Add solutions to the monad transformers chapter

Author: BoeingX

package.yaml

@@ -34,6 +34,8 @@ dependencies:
 - checkers
 - hspec-checkers
 - split
+- scotty
+- wai
 
 library:
   source-dirs: src

src/MonadTransformers/ChapterExercises/FixTheCode.hs

@@ -0,0 +1,29 @@
+module MonadTransformers.ChapterExercises.FixTheCode where
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+import Control.Monad
+
+isValid :: String -> Bool
+isValid v = '!' `elem` v
+
+maybeExcite :: MaybeT IO String
+maybeExcite = do
+    -- v :: String because MaybeT IO String is a monad
+    --                     |_______| |____|
+    --                         m       a
+    -- thus v :: a, i.e. v :: String
+    v <- (lift :: IO String -> MaybeT IO String) getLine
+    guard $ isValid (v :: String)
+    return v
+
+doExcite :: IO ()
+doExcite = do
+    putStrLn "say something excite!"
+    -- excite :: Maybe String because (runMaybeT maybeExcite) :: IO (Maybe String)
+    --                                                          |__| |___________|
+    --                                                            m       a
+    excite <- runMaybeT (maybeExcite :: MaybeT IO String)
+    case excite of
+        Nothing -> putStrLn "MOAR EXCITE"
+        Just e -> putStrLn ("Good, was very excite: " ++ e)

src/MonadTransformers/ChapterExercises/HitCounter.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+module MonadTransformers.ChapterExercises.HitCounter where
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Data.IORef
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as TL
+import System.Environment (getArgs)
+import Web.Scotty.Trans
+import Network.Wai.Internal
+
+data Config =
+    Config {
+        -- that's one, one click!
+        -- two...two clicks!
+        -- Three BEAUTIFUL clicks! ah ah ahhhh
+        counts :: IORef (M.Map Text Integer)
+      , prefix :: Text
+    }
+
+-- Stuff inside ScottyT is, except for things that escape
+-- via IO, effectively read-only so we can't use StateT.
+-- It would overcomplicate things to attempt to do so and
+-- you should be using a proper database for production
+-- applications.
+type Scotty = ScottyT Text (ReaderT Config IO)
+type Handler = ActionT Text (ReaderT Config IO)
+
+bumpBoomp :: Text
+          -> M.Map Text Integer
+          -> (M.Map Text Integer, Integer)
+bumpBoomp k m = (newM, n)
+    where n = M.findWithDefault 1 k m
+          newM = M.insert k (n + 1) m
+
+updateAndGet :: Text -> Config -> IO Integer
+updateAndGet key config = do
+    let counter = counts config :: IORef (M.Map Text Integer)
+    (m, n) <- bumpBoomp key <$> (readIORef counter :: IO (M.Map Text Integer))
+    -- Very important to use writeIORef or something equivalent
+    -- otherwise the counter will not be updated
+    writeIORef counter m
+    return n
+
+app :: Scotty ()
+app = get "/:key" $ do
+    unprefixed <- param "key"
+    p <- lift $ ReaderT (return . prefix)
+    let key' = mappend p unprefixed
+    newInteger <- lift $ ReaderT $ updateAndGet key'
+    html $ mconcat [ "<h1>Success! Count was: "
+                   , TL.pack $ show newInteger
+                   , "</h1>"
+                   ]
+
+main :: IO ()
+main = do
+    [prefixArg] <- getArgs
+    counter <- newIORef M.empty
+    let config = Config counter (TL.pack prefixArg)
+        runR = flip runReaderT config :: ReaderT Config IO Response -> IO Response
+    scottyT 3000 runR app

src/MonadTransformers/ChapterExercises/Morra.hs

@@ -0,0 +1,67 @@
+module MonadTransformers.ChapterExercises.Morra where
+
+import Control.Monad
+import Control.Monad.Trans.State
+import System.Exit
+import System.Random
+
+data GameState = GameState {
+                             score1 :: Int
+                           , score2 :: Int
+                           , trigram :: [Int]
+                           }
+    deriving (Eq, Show)
+
+gameOver :: GameState -> IO ()
+gameOver (GameState s1 s2 _)
+  | s1 < 3 && s2 < 3 = return ()
+  | otherwise = do
+      putStrLn "- Game over"
+      putStrLn $ "- Player got " ++ show s1 ++ " points"
+      putStrLn $ "- Computer got " ++ show s2 ++ " points"
+      if s1 == 3 then
+        putStrLn "- Player wins the game"
+      else
+        putStrLn "- Computer wins the game"
+      exitSuccess
+
+makeMove :: GameState -> IO Int
+makeMove s = do
+    let t = trigram s
+        c1 = length $ filter (==1) t
+        c2 = length $ filter (==2) t
+    case compare c1 c2 of
+      GT -> return 1
+      LT -> return 2
+      EQ -> randomRIO (1, 2)
+
+updateTrigram :: Int -> [Int] -> [Int]
+updateTrigram x xs = take 3 (x : xs)
+
+game :: StateT GameState IO Int
+game = forever $ StateT $ \s -> do
+    p1 <- (read <$> getLine) :: IO Int
+    putStrLn $ "P: " ++ show p1
+    p2 <- makeMove s
+    putStrLn $ "C: " ++ show p2
+    let p = p1 + p2
+    if odd p then
+      putStrLn "- P wins"
+    else
+      putStrLn "- C wins"
+    let (s1, s2) = if odd p then
+                            (score1 s +1, score2 s)
+                            else
+                            (score1 s, score2 s + 1)
+        t = updateTrigram p1 $ trigram s
+        newGameState = GameState s1 s2 t
+    gameOver newGameState
+    return (p, newGameState)
+
+main :: IO ()
+main = do
+    putStrLn "-- p is Player"
+    putStrLn "-- c is Computer"
+    putStrLn "-- Player is odds, computer is evens."
+    (a, s) <- runStateT game (GameState 0 0 [])
+    return ()

src/MonadTransformers/ChapterExercises/WriteTheCode.hs

@@ -0,0 +1,33 @@
+module MonadTransformers.ChapterExercises.WriteTheCode where
+
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Data.Functor.Identity
+
+-- Question 1
+rDec :: Num a => Reader a a
+rDec = ReaderT $ \r -> Identity (r - 1)
+
+-- Question 2
+rDec' :: Num a => Reader a a
+rDec' = ReaderT $ fmap Identity ((-1) + )
+
+-- Question 3
+rShow :: Show a => ReaderT a Identity String
+rShow = ReaderT $ \a -> Identity (show a)
+
+-- Question 4
+rShow' :: Show a => ReaderT a Identity String
+rShow' = ReaderT (fmap Identity show)
+
+-- Question 5
+rPrintAndInc :: (Num a, Show a) => ReaderT a IO a
+rPrintAndInc = ReaderT $ \r -> do
+                            putStrLn $ "Hi: " ++ show r
+                            return $ r + 1
+
+-- Question 6
+sPrintIncAccum :: (Num a, Show a) => StateT a IO String
+sPrintIncAccum = StateT $ \s -> do
+                            putStrLn $ "Hi: " ++ show s
+                            return (show s, s + 1)

src/MonadTransformers/EitherT/Exercises.hs

@@ -0,0 +1,39 @@
+module MonadTransformers.EitherT.Exercises where
+
+import Control.Applicative (liftA2)
+
+newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }
+
+-- Question 1
+instance (Functor m) => Functor (EitherT e m) where
+    fmap f (EitherT mea) = EitherT $ (fmap . fmap) f mea
+
+-- Question 2
+instance (Applicative m) => Applicative (EitherT e m) where
+    pure = EitherT . pure . pure
+    EitherT fmeab <*> EitherT mea = EitherT $ liftA2 (<*>) fmeab mea
+
+-- Question 3
+instance (Monad m) => Monad (EitherT e m) where
+    return = pure
+    EitherT mea >>= f = EitherT $ do
+        ea <- mea
+        case ea of
+          Left e -> return (Left e)
+          Right a -> (runEitherT . f) a
+
+-- Question 4
+swapEither :: Either e a -> Either a e
+swapEither (Left e) = Right e
+swapEither (Right a) = Left a
+
+swapEitherT :: (Functor m) => EitherT e m a -> EitherT a m e
+swapEitherT (EitherT mea) = EitherT (fmap swapEither mea)
+
+-- Question 5
+eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c
+eitherT f g (EitherT mab) = do
+    ab <- mab
+    case ab of
+      Left a -> f a
+      Right b -> g b

src/MonadTransformers/LexicallyInnerIsStructurallyOuter/Exercise.hs

@@ -0,0 +1,18 @@
+module MonadTransformers.LexicallyInnerIsStructurallyOuter.Exercise where
+
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+
+embedded :: MaybeT (ExceptT String (ReaderT () IO)) Int
+embedded = MaybeT $ ExceptT $ ReaderT $ return <$> const (Right (Just 1))
+
+-- Or more explicitely
+embedded' :: MaybeT (ExceptT String (ReaderT () IO)) Int
+embedded' = MaybeT ma
+    where ma :: (ExceptT String (ReaderT () IO)) (Maybe Int)
+          ma = ExceptT mb
+            where mb :: (ReaderT () IO) (Either String (Maybe Int))
+                  mb = ReaderT mc
+                    where mc :: () -> IO (Either String (Maybe Int))
+                          mc = return <$> const (Right (Just 1))

src/MonadTransformers/MonadIO/Exercises.hs

@@ -0,0 +1,66 @@
+module MonadTransformers.MonadIO.Exercises where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+
+-- MaybeT
+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
+
+instance (Functor m) => Functor (MaybeT m) where
+    fmap = undefined
+
+instance (Applicative m) => Applicative (MaybeT m) where
+    pure = undefined
+    (<*>) = undefined
+
+instance (Monad m) => Monad (MaybeT m) where
+    return = pure
+    (>>=) = undefined
+
+instance MonadTrans MaybeT where
+    lift = MaybeT . fmap Just
+
+instance (MonadIO m) => MonadIO (MaybeT m) where
+    liftIO = lift . liftIO
+
+-- ReaderT
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+instance (Functor m) => Functor (ReaderT r m) where
+    fmap = undefined
+
+instance (Applicative m) => Applicative (ReaderT r m) where
+    pure = undefined
+    (<*>) = undefined
+
+instance (Monad m) => Monad (ReaderT r m) where
+    return = pure
+    (>>=) = undefined
+
+instance MonadTrans (ReaderT r) where
+    lift = ReaderT . const
+
+instance (MonadIO m) => MonadIO (ReaderT r m) where
+    liftIO = lift . liftIO
+
+-- StateT
+newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }
+
+instance (Functor m) => Functor (StateT s m) where
+    fmap = undefined
+
+instance (Monad m) => Applicative (StateT s m) where
+    pure = undefined
+    (<*>) = undefined
+
+instance (Monad m) => Monad (StateT s m) where
+    return = pure
+    (>>=) = undefined
+
+instance MonadTrans (StateT s) where
+    lift ma = StateT $ \s -> do
+                                a <- ma
+                                return (a, s)
+
+instance (MonadIO m ) => MonadIO (StateT s m) where
+    liftIO = lift . liftIO

src/MonadTransformers/MonadTrans/Exercises.hs

@@ -0,0 +1,15 @@
+module MonadTransformers.MonadTrans.Exercises where
+
+import Control.Monad.Trans.Class
+
+newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }
+
+instance MonadTrans (EitherT e) where
+    lift = EitherT . (fmap Right)
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }
+
+instance MonadTrans (StateT s) where
+    lift ma = StateT $ \s -> do
+                            a <- ma
+                            return (a, s)

src/MonadTransformers/StateT/Exercises.hs

@@ -0,0 +1,24 @@
+module MonadTransformers.StateT.Exercises where
+
+import Control.Applicative
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a, s)}
+
+instance (Functor m) => Functor (StateT s m) where
+    fmap f (StateT sma) = StateT $ \s -> fmap f' (sma s)
+        where f' (a, s) = (f a, s)
+
+-- See this Stackoverflow post the reason why we need a Monad instance of m
+-- https://stackoverflow.com/questions/18673525/is-it-possible-to-implement-applicative-m-applicative-statet-s-m
+instance (Monad m) => Applicative (StateT s m) where
+    pure a = StateT $ \s -> pure (a, s)
+    StateT smab <*> StateT sma = StateT $ \s -> do
+        (ab, s') <- smab s
+        (a, s'') <- sma s'
+        return (ab a, s'')
+
+instance (Monad m) => Monad (StateT s m) where
+    return = pure
+    StateT sma >>= asmb = StateT $ \s -> do
+        (a, s') <- sma s
+        runStateT (asmb a) s'