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…
	
	Add table
		Add a link
		
	
		Reference in a new issue