Finish exercises for Monad Transformer chapter
I expect to look back on this code and cringe, but... it compiles!
This commit is contained in:
parent
5116cc3463
commit
e5abc3d675
1 changed files with 110 additions and 6 deletions
|
@ -1,5 +1,9 @@
|
||||||
module MonadTransformersScratch where
|
module MonadTransformersScratch where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import qualified Control.Monad.Trans.Maybe as M
|
||||||
|
import qualified Control.Monad.Trans.Reader as R
|
||||||
|
import qualified Control.Monad.Trans.State as S
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -71,9 +75,109 @@ instance (Applicative m) => Applicative (ReaderT r m) where
|
||||||
pure x = x & pure & pure & ReaderT
|
pure x = x & pure & pure & ReaderT
|
||||||
ReaderT f <*> ReaderT x = ReaderT $ fmap (<*>) f <*> x
|
ReaderT f <*> ReaderT x = ReaderT $ fmap (<*>) f <*> x
|
||||||
|
|
||||||
instance (Monad m) => Monad (ReaderT r m) where
|
-- instance (Monad m) => Monad (ReaderT r m) where
|
||||||
return = pure
|
-- return = pure
|
||||||
ReaderT rma >>= f =
|
-- ReaderT rma >>= f =
|
||||||
ReaderT $ \r -> do
|
-- ReaderT $ \r -> do
|
||||||
a <- rma r
|
-- a <- rma r
|
||||||
runReaderT (f a) r
|
-- runReaderT (f a) r
|
||||||
|
-- --------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
rDec :: Num a => R.Reader a a
|
||||||
|
rDec = R.ReaderT $ \x -> pure $ x + 1
|
||||||
|
|
||||||
|
rShow :: Show a => R.Reader a String
|
||||||
|
rShow = R.ReaderT $ \x -> pure $ show x
|
||||||
|
|
||||||
|
rPrintAndInc :: (Num a, Show a) => R.ReaderT a IO a
|
||||||
|
rPrintAndInc = R.ReaderT $ \x ->
|
||||||
|
putStrLn ("Hi: " ++ show x) >> pure (x + 1)
|
||||||
|
|
||||||
|
sPrintIncAccum :: (Num a, Show a) => S.StateT a IO String
|
||||||
|
sPrintIncAccum = S.StateT $ \x -> do
|
||||||
|
putStrLn ("Hi: " ++ show x)
|
||||||
|
pure (show x, x + 1)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
isValid :: String -> Bool
|
||||||
|
isValid v = '!' `elem` v
|
||||||
|
|
||||||
|
maybeExcite :: M.MaybeT IO String
|
||||||
|
maybeExcite = M.MaybeT $ do
|
||||||
|
x <- getLine
|
||||||
|
putStrLn ""
|
||||||
|
case isValid x of
|
||||||
|
False -> pure Nothing
|
||||||
|
True -> pure $ Just x
|
||||||
|
|
||||||
|
doExcite :: IO ()
|
||||||
|
doExcite = do
|
||||||
|
putStr "Say something *exciting*: "
|
||||||
|
excite <- M.runMaybeT maybeExcite
|
||||||
|
case excite of
|
||||||
|
Nothing -> putStrLn "Gonna need some more excitement..."
|
||||||
|
Just x -> putStrLn "Now THAT'S exciting...nice!"
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
data Participant
|
||||||
|
= Man
|
||||||
|
| Machine
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
newtype Hand = Hand (Integer, Integer) deriving (Show, Eq)
|
||||||
|
|
||||||
|
newtype Score = Score (Integer, Integer) deriving (Show, Eq)
|
||||||
|
|
||||||
|
getLineLn :: String -> IO String
|
||||||
|
getLineLn prompt = do
|
||||||
|
putStr prompt
|
||||||
|
x <- getLine
|
||||||
|
putStrLn ""
|
||||||
|
pure x
|
||||||
|
|
||||||
|
promptGuess :: IO Hand
|
||||||
|
promptGuess = do
|
||||||
|
fingers <- getLineLn "How many fingers (0-5): "
|
||||||
|
guess <- getLineLn "Guess: "
|
||||||
|
pure $ Hand (read guess, read fingers)
|
||||||
|
|
||||||
|
aiGuess :: IO Hand
|
||||||
|
aiGuess = pure $ Hand (2, 3)
|
||||||
|
|
||||||
|
whoWon :: Hand -> Hand -> Maybe Participant
|
||||||
|
whoWon (Hand (guessA, fingersA)) (Hand (guessB, fingersB))
|
||||||
|
| guessA == guessB && guessA == (fingersA + fingersB) = Nothing
|
||||||
|
| guessA == (fingersA + fingersB) = Just Man
|
||||||
|
| guessB == (fingersA + fingersB) = Just Machine
|
||||||
|
| otherwise = Nothing
|
||||||
|
|
||||||
|
initScore :: Score
|
||||||
|
initScore = Score (0, 0)
|
||||||
|
|
||||||
|
printScore :: Score -> IO ()
|
||||||
|
printScore (Score (man, machine)) =
|
||||||
|
putStrLn $ "Man: " ++ show man ++ " Machine: " ++ show machine
|
||||||
|
|
||||||
|
startMorra :: S.StateT Score IO ()
|
||||||
|
startMorra = S.StateT $ \(Score (man, machine)) -> do
|
||||||
|
Hand (guessA, fingersA) <- promptGuess
|
||||||
|
Hand (guessB, fingersB) <- aiGuess
|
||||||
|
putStrLn $ "P: " ++ show fingersA ++ "," ++ show guessA
|
||||||
|
putStrLn $ "C: " ++ show fingersB ++ "," ++ show guessB
|
||||||
|
case whoWon (Hand (guessA, fingersA)) (Hand (guessB, fingersB)) of
|
||||||
|
Nothing -> do
|
||||||
|
putStrLn "Nobody won..."
|
||||||
|
printScore (Score (man, machine))
|
||||||
|
pure ((), Score (man, machine))
|
||||||
|
Just Man -> do
|
||||||
|
putStrLn "Man won!"
|
||||||
|
printScore (Score (man + 1, machine))
|
||||||
|
pure ((), Score (man + 1, machine))
|
||||||
|
Just Machine -> do
|
||||||
|
putStrLn "Oh no... Machine won..."
|
||||||
|
printScore (Score (man, machine + 1))
|
||||||
|
pure ((), Score (man, machine + 1))
|
||||||
|
|
||||||
|
playMorra = S.runStateT (forever startMorra) initScore
|
||||||
|
|
Loading…
Reference in a new issue