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 | ||||
| 
 | ||||
| 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 ((&)) | ||||
| -------------------------------------------------------------------------------- | ||||
| 
 | ||||
|  | @ -71,9 +75,109 @@ instance (Applicative m) => Applicative (ReaderT r m) where | |||
|   pure x = x & pure & pure & ReaderT | ||||
|   ReaderT f <*> ReaderT x = ReaderT $ fmap (<*>) f <*> x | ||||
| 
 | ||||
| instance (Monad m) => Monad (ReaderT r m) where | ||||
|   return = pure | ||||
|   ReaderT rma >>= f = | ||||
|     ReaderT $ \r -> do | ||||
|       a <- rma r | ||||
|       runReaderT (f a) r | ||||
| -- instance (Monad m) => Monad (ReaderT r m) where | ||||
| --   return = pure | ||||
| --   ReaderT rma >>= f = | ||||
| --     ReaderT $ \r -> do | ||||
| --       a <- rma 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…
	
	Add table
		Add a link
		
	
		Reference in a new issue