diff --git a/26-monad-transformers/26-monad-transformers.md b/26-monad-transformers/26-monad-transformers.md new file mode 100644 index 0000000..fb1b018 --- /dev/null +++ b/26-monad-transformers/26-monad-transformers.md @@ -0,0 +1,46 @@ +# 26 Monad Transformers + +## 26.3 EitherT + +see [src/EitherT.hs](./src/EitherT.hs) + +## 26.5 StateT + +see [src/StateT.hs](./src/StateT.hs) + +## 26.8 Wrap it up + +see [src/WrapItUp.hs](./src/WrapItUp.hs) + +## 26.9 Exercises: Lift More + +1. see [src/EitherT.hs](./src/EitherT.hs) +2. see [src/StateT.hs](./src/StateT.hs) + +## 26.10 Exercises: Some Instances + +1. see [src/MaybeT.hs](./src/MaybeT.hs) +2. see [src/ReaderT.hs](./src/ReaderT.hs) +3. see [src/StateT.hs](./src/StateT.hs) + +## 26.12 Hypothetical Exercise + +see [src/Hypo.hs](./src/Hypo.hs) + +## 26.14 Chapter Exercises + +### Write the code + +see [src/WriteTheCode.hs](./src/WriteTheCode.hs) + +### Fix the code + +see [src/FixTheCode.hs](./src/FixTheCode.hs) + +### Hit counter + +see [hit-counter/Main.hs](./hit-counter/Main.hs) + +### Morra + +see [morra/src/Morra.hs](./morra/src/Morra.hs) \ No newline at end of file diff --git a/26-monad-transformers/hit-counter/Main.hs b/26-monad-transformers/hit-counter/Main.hs new file mode 100644 index 0000000..2b18883 --- /dev/null +++ b/26-monad-transformers/hit-counter/Main.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main 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 Control.Monad.IO.Class + +data Config = + Config { + counts :: IORef (M.Map Text Integer) + , prefix :: Text + } + +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 = let m' = M.insertWith (+) k 1 m + in (m', (M.!) m' k) + +updateHitCounter :: Text -> ReaderT Config IO Integer +updateHitCounter t = do + c <- ask + m <- liftIO $ readIORef (counts c) + let (m', n) = bumpBoomp t m + liftIO $ writeIORef (counts c) m' + return n + +app :: Scotty () +app = + get "/:key" $ do + unprefixed <- param "key" + config <- lift ask + let key' = mappend (prefix config) unprefixed + newInteger <- lift $ updateHitCounter key' + html $ + mconcat [ "

Success! Count was: " + , TL.pack $ show newInteger + , "

" + ] + +main :: IO () +main = do + [prefixArg] <- getArgs + counter <- newIORef M.empty + let config = Config { counts = counter, prefix = TL.pack prefixArg } + runR = flip runReaderT config + scottyT 3000 runR app diff --git a/26-monad-transformers/hit-counter/hit-counter.cabal b/26-monad-transformers/hit-counter/hit-counter.cabal new file mode 100644 index 0000000..af204fe --- /dev/null +++ b/26-monad-transformers/hit-counter/hit-counter.cabal @@ -0,0 +1,15 @@ +name: hit-counter +version: 0.0.0 +cabal-version: >= 1.8 +build-type: Simple + +executable hit-counter + hs-source-dirs: . + main-is: Main.hs + ghc-options: -Wall -threaded -O2 -rtsopts -with-rtsopts=-N + extensions: OverloadedStrings + build-depends: base >= 4 && < 5 + , scotty + , transformers + , containers + , text diff --git a/26-monad-transformers/hit-counter/stack.yaml b/26-monad-transformers/hit-counter/stack.yaml new file mode 100644 index 0000000..a9e6a04 --- /dev/null +++ b/26-monad-transformers/hit-counter/stack.yaml @@ -0,0 +1,65 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-11.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/26-monad-transformers/morra/LICENSE b/26-monad-transformers/morra/LICENSE new file mode 100644 index 0000000..e69de29 diff --git a/26-monad-transformers/morra/README.md b/26-monad-transformers/morra/README.md new file mode 100644 index 0000000..e69de29 diff --git a/26-monad-transformers/morra/Setup.hs b/26-monad-transformers/morra/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/26-monad-transformers/morra/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/26-monad-transformers/morra/lib/Morra.hs b/26-monad-transformers/morra/lib/Morra.hs new file mode 100644 index 0000000..0aebbd2 --- /dev/null +++ b/26-monad-transformers/morra/lib/Morra.hs @@ -0,0 +1,154 @@ +module Morra + (runGame, Game(..), Player(..), PlayerType(..)) + where + +import Data.Maybe (listToMaybe) +import qualified Data.Map as M + +import Control.Monad (forever) +import Control.Monad.Trans.State +import Control.Monad.IO.Class +import Control.Monad.Trans.Class + +import System.Exit (exitSuccess) +import System.Random (randomRIO) +import System.Console.ANSI +import System.IO (hFlush, stdout) + +-- Two player game +-- Player chooses 0-5 and number +-- AI chooses 0-5 and number + +type Source = (Integer, Integer) +type Table = M.Map Source Integer +type Guesses = (Integer, Integer) + +data PlayerType = Human | AI Guesses Table deriving (Show, Eq) + +data Player = Player { + pType :: PlayerType, + score :: Integer +} deriving (Show, Eq) + +data Game = Game { + playerA :: Player, + playerB :: Player, + pointsToWin :: Integer +} deriving (Show, Eq) + +-- type Score = (Integer, Integer) + +type GameState = StateT Game IO + +isPlayerWinner :: (Game -> Player) -> Game -> Bool +isPlayerWinner p g = (score . p) g >= pointsToWin g + +endGameMsg :: Bool -> Bool -> IO () +endGameMsg True True = putStrLn "Everybody is a winner!" >> exitSuccess +endGameMsg True False = putStrLn "Player A is a winner!" >> exitSuccess +endGameMsg False True = putStrLn "Player B is a winner!" >> exitSuccess +endGameMsg _ _ = return () + +gameEnd :: GameState () +gameEnd = do + g <- get + let pA = isPlayerWinner playerA g + pB = isPlayerWinner playerB g + liftIO $ endGameMsg pA pB + return () + +handleHumanPlayer :: IO (Integer, Integer) +handleHumanPlayer = do + putStr "Fingers and total (f, t): " + hFlush stdout + s <- getLine + clearScreen + case fmap fst . listToMaybe . reads $ s of + Nothing -> do + putStrLn "Incorrect format." + handleHumanPlayer + Just a -> return a + +handleAIPlayer :: Guesses -> Table -> IO (Integer, Integer) +handleAIPlayer g t = do + f <- randomRIO (0,5) + g <- case M.lookup g t of + Nothing -> randomRIO (0, 5) + Just n -> return n + return (f, f + g) + +updateAI :: Player -> Integer -> Player +updateAI p n = case pType p of + Human -> p + AI g@(g1, g2) t -> p { pType = AI g' t' } + where g' = (g2, n) + t' = M.insert g n t + +updateAIs :: (Integer, Integer) -> GameState () +updateAIs (gA, gB) = do + g <- get + let pA = playerA g + pB = playerB g + pA' = updateAI pA gB + pB' = updateAI pB gA + g' = g { playerA = pA' } + put $ g' { playerB = pB' } + +handlePlayer :: (Game -> Player) -> GameState (Integer, Integer) +handlePlayer p = do + g <- get + let player = p g + case pType player of + Human -> liftIO handleHumanPlayer + AI g t -> liftIO $ handleAIPlayer g t + +handleGuessPlayerA :: Integer -> Integer -> GameState () +handleGuessPlayerA guess total = + if (guess == total) + then do + g <- get + let p = playerA g + s = score p + put $ g { playerA = (p { score = s + 1 })} + liftIO $ putStrLn $ "PlayerA guessed correctly!" + else return () + +handleGuessPlayerB :: Integer -> Integer -> GameState () +handleGuessPlayerB guess total = + if (guess == total) + then do + g <- get + let p = playerB g + s = score p + put $ g { playerB = (p { score = s + 1 })} + liftIO $ putStrLn $ "PlayerB guessed correctly!" + else return () + +runGame :: GameState () +runGame = forever $ do + gameEnd + liftIO $ putStrLn "Turn PlayerA" + (f, g) <- handlePlayer playerA + liftIO $ putStrLn "Turn PlayerB" + (f', g') <- handlePlayer playerB + let total = f + f' + liftIO $ do + putStrLn "==========================" + putStr $ "PlayerA showed: " ++ show f + putStrLn $ " and guessed: " ++ show g + putStr $ "PlayerB showed: " ++ show f' + putStrLn $ " and guessed: " ++ show g' + putStrLn $ "Total was: " ++ show total + putStrLn "==========================" + handleGuessPlayerA g total + handleGuessPlayerB g' total + liftIO $ putStrLn "==========================" + -- update any ai + updateAIs (f, f') + -- print the player status + g <- get + let pA = playerA g + pB = playerB g + liftIO $ do + putStrLn $ "PlayerA: " ++ show pA + putStrLn $ "PlayerB: " ++ show pB \ No newline at end of file diff --git a/26-monad-transformers/morra/morra.cabal b/26-monad-transformers/morra/morra.cabal new file mode 100644 index 0000000..97a66b5 --- /dev/null +++ b/26-monad-transformers/morra/morra.cabal @@ -0,0 +1,33 @@ +name: morra +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/githubuser/morra#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2018 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + hs-source-dirs: lib + exposed-modules: Morra + build-depends: base >= 4.7 && < 5 + , transformers + , random + , ansi-terminal + , containers + default-language: Haskell2010 + +executable morra + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , transformers + , morra + , containers diff --git a/26-monad-transformers/morra/src/Main.hs b/26-monad-transformers/morra/src/Main.hs new file mode 100644 index 0000000..1a33f58 --- /dev/null +++ b/26-monad-transformers/morra/src/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Morra +import Control.Monad.Trans.State +import qualified Data.Map as M + +initialGame :: Game +initialGame = Game { + playerA = Player { pType = Human, score = 0 }, + playerB = Player { pType = AI (0,0) M.empty, score = 0 }, + pointsToWin = 3 +} + +main :: IO () +main = do + -- putStrLn "Woop" + evalStateT runGame initialGame diff --git a/26-monad-transformers/morra/stack.yaml b/26-monad-transformers/morra/stack.yaml new file mode 100644 index 0000000..a9e6a04 --- /dev/null +++ b/26-monad-transformers/morra/stack.yaml @@ -0,0 +1,65 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-11.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/26-monad-transformers/src/EitherT.hs b/26-monad-transformers/src/EitherT.hs new file mode 100644 index 0000000..e6c28a3 --- /dev/null +++ b/26-monad-transformers/src/EitherT.hs @@ -0,0 +1,38 @@ +module EitherT where + +import Control.Monad.Trans.Class + +newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) } + + +instance Functor m => Functor (EitherT e m) where + fmap f (EitherT ma) = EitherT $ (fmap . fmap) f ma + +instance Applicative m => Applicative (EitherT e m) where + pure a = EitherT $ pure . pure $ a + (EitherT mf) <*> (EitherT ma) = EitherT $ (fmap (<*>) mf) <*> ma + +instance Monad m => Monad (EitherT e m) where + return = pure + (EitherT ma) >>= k = EitherT $ do + a <- ma + case a of + Right a' -> runEitherT $ k a' + Left e -> return $ Left e + +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 ma) = EitherT $ fmap swapEither ma + +eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c +eitherT f g (EitherT ma) = do + a <- ma + case a of + Left e -> f e + Right a' -> g a' + +instance MonadTrans (EitherT e) where + lift m = EitherT $ fmap Right m \ No newline at end of file diff --git a/26-monad-transformers/src/FixTheCode.hs b/26-monad-transformers/src/FixTheCode.hs new file mode 100644 index 0000000..323d37d --- /dev/null +++ b/26-monad-transformers/src/FixTheCode.hs @@ -0,0 +1,23 @@ +module FixTheCode where + +import Control.Monad.Trans.Maybe +import Control.Monad + +import Control.Monad.IO.Class + +isValid :: String -> Bool +isValid v = '!' `elem` v + +maybeExcite :: MaybeT IO String +maybeExcite = do + v <- liftIO getLine -- added liftIO + guard $ isValid v + return v + +doExcite :: IO () +doExcite = do + putStrLn "say something excite!" + excite <- runMaybeT maybeExcite -- added runMaybeT + case excite of + Nothing -> putStrLn "MOAR EXCITE" + Just e -> putStrLn $ "Good, was very excite: " ++ e diff --git a/26-monad-transformers/src/Hypo.hs b/26-monad-transformers/src/Hypo.hs new file mode 100644 index 0000000..6b9b9bd --- /dev/null +++ b/26-monad-transformers/src/Hypo.hs @@ -0,0 +1,20 @@ +module Hypo where + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Maybe + +-- r -> Maybe a +foo :: Int -> ReaderT Int Maybe Int +foo a = return a + + +-- (Reader r) (Maybe a) +-- r -> Maybe a +bar :: Int -> MaybeT (Reader Int) Int +bar a = return a + +-- looks pretty much the same to me... +main :: IO () +main = do + print $ runReaderT (foo 1) 5 + print $ runReader (runMaybeT (bar 1)) 5 \ No newline at end of file diff --git a/26-monad-transformers/src/MaybeT.hs b/26-monad-transformers/src/MaybeT.hs new file mode 100644 index 0000000..c1c5f4f --- /dev/null +++ b/26-monad-transformers/src/MaybeT.hs @@ -0,0 +1,30 @@ +module MaybeT where + +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +data MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } + +instance Functor m => Functor (MaybeT m) where + fmap f (MaybeT ma) = MaybeT $ (fmap . fmap) f ma + +instance Applicative m => Applicative (MaybeT m) where + pure = MaybeT . pure . Just + + (MaybeT mf) <*> (MaybeT ma) = MaybeT $ + (fmap (<*>) mf) <*> ma + +instance Monad m => Monad (MaybeT m) where + return = pure + + (MaybeT ma) >>= k = MaybeT $ do + a <- ma + case a of + Nothing -> return Nothing + Just a' -> runMaybeT $ k a' + +instance MonadTrans (MaybeT) where + lift m = MaybeT $ fmap Just m + +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = lift . liftIO \ No newline at end of file diff --git a/26-monad-transformers/src/Morra.hs b/26-monad-transformers/src/Morra.hs new file mode 100644 index 0000000..dd85016 --- /dev/null +++ b/26-monad-transformers/src/Morra.hs @@ -0,0 +1,102 @@ +module Morra where + +import Control.Monad (forever) +import Control.Monad.Trans.State +import Control.Monad.IO.Class + + +import System.Exit (exitSuccess) +import System.Random (randomRIO) + +-- Player chooses 0-5 and number +-- AI chooses 0-5 and number + +pointsToWin :: Integer +pointsToWin = 3 + +type Score = (Integer, Integer) +type GameState = StateT Score IO + +iWin :: Score -> Bool +iWin = (>= pointsToWin) . fst + +aiWin :: Score -> Bool +aiWin = (>= pointsToWin) . snd + +gameWin :: GameState () +gameWin = do + s <- get + if iWin s then + liftIO $ do + putStrLn "You win!" + exitSuccess + else return () + +gameLose :: GameState () +gameLose = do + s <- get + if aiWin s then + liftIO $ do + putStrLn "AI wins!" + exitSuccess + else return () + +getFingers :: IO Integer +getFingers = do + putStrLn "How many fingers will you show (0-5)?" + response <- getLine + if response `elem` (map show [0..5]) + then return $ read response + else getFingers + +getGuess :: IO Integer +getGuess = do + putStrLn "How many fingers will be shown in total (0-10)?" + response <- getLine + if response `elem` (map show [0..10]) + then return $ read response + else getGuess + +getAIData :: IO (Integer, Integer) +getAIData = do + f <- randomRIO (0,5) + g <- randomRIO (0,5) + return (f, f + g) + +handleCorrectGuess :: GameState () +handleCorrectGuess = do + (hs,as) <- get + put (hs + 1, as) + +handleAICorrectGuess :: GameState () +handleAICorrectGuess = do + (hs, as) <- get + put (hs, as + 1) + +runGame :: GameState () +runGame = forever $ do + gameWin + gameLose + (f,g) <- liftIO $ do + f <- getFingers + g <- getGuess + return (f,g) + (f', g') <- liftIO getAIData + if f == g + g' then handleCorrectGuess else return () + if f' == g + g' then handleAICorrectGuess else return () + s <- get + liftIO $ do + putStrLn $ "==================" + putStrLn $ "AI showed: " ++ show f' + putStrLn $ "AI guessed: " ++ show g' + putStrLn $ "Total was: " ++ show (f + f') + putStrLn $ "------------------" + putStrLn $ "Score is: " ++ show s + putStrLn $ "==================" + + +initialState :: Score +initialState = (0, 0) + +main :: IO () +main = evalStateT runGame initialState \ No newline at end of file diff --git a/26-monad-transformers/src/ReaderT.hs b/26-monad-transformers/src/ReaderT.hs new file mode 100644 index 0000000..72752e2 --- /dev/null +++ b/26-monad-transformers/src/ReaderT.hs @@ -0,0 +1,28 @@ +module ReaderT where + +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +data ReaderT r m a = ReaderT { runReaderT :: r -> m a } + +instance Functor m => Functor (ReaderT r m) where + fmap f (ReaderT rma) = ReaderT $ \r -> fmap f (rma r) + +instance Applicative m => Applicative (ReaderT r m) where + pure = ReaderT . const . pure + + (ReaderT rmf) <*> (ReaderT rma) = ReaderT $ \r -> + (rmf r) <*> (rma r) + +instance Monad m => Monad (ReaderT r m) where + return = pure + + (ReaderT rma) >>= k = ReaderT $ \r -> do + a <- rma r + runReaderT (k a) r + +instance MonadTrans (ReaderT r) where + lift = ReaderT . const + +instance MonadIO m => MonadIO (ReaderT r m) where + liftIO = lift . liftIO diff --git a/26-monad-transformers/src/StateT.hs b/26-monad-transformers/src/StateT.hs new file mode 100644 index 0000000..523ce22 --- /dev/null +++ b/26-monad-transformers/src/StateT.hs @@ -0,0 +1,29 @@ +module StateT where + +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +data StateT s m a = StateT { runStateT :: s -> m (a, s) } + +instance Functor m => Functor (StateT s m) where + fmap f st = StateT $ \s -> + fmap (\(a, s') -> (f a, s')) $ runStateT st s + +instance Monad m => Applicative (StateT s m) where + pure a = StateT $ \s -> pure (a, s) + stf <*> sta = StateT $ \s -> do + (f, s') <- runStateT stf s + (a, s'') <- runStateT sta s' + return (f a, s'') + +instance Monad m => Monad (StateT s m) where + return = pure + st >>= k = StateT $ \s -> do + (a, s') <- runStateT st s + runStateT (k a) s' + +instance MonadTrans (StateT s) where + lift m = StateT $ \s -> fmap (flip (,) s) m + +instance MonadIO m => MonadIO (StateT s m) where + liftIO = lift . liftIO \ No newline at end of file diff --git a/26-monad-transformers/src/WrapItUp.hs b/26-monad-transformers/src/WrapItUp.hs new file mode 100644 index 0000000..d4fc412 --- /dev/null +++ b/26-monad-transformers/src/WrapItUp.hs @@ -0,0 +1,9 @@ +module WrapItUp where + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader + +embedded :: MaybeT (ExceptT String (ReaderT () IO)) Int +embedded = + MaybeT (ExceptT (ReaderT (const $ return (Right (Just 1))))) \ No newline at end of file diff --git a/26-monad-transformers/src/WriteTheCode.hs b/26-monad-transformers/src/WriteTheCode.hs new file mode 100644 index 0000000..b4191b7 --- /dev/null +++ b/26-monad-transformers/src/WriteTheCode.hs @@ -0,0 +1,44 @@ +module WriteTheCode where + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Identity + +import Control.Monad.IO.Class + +-- 1 +rDec :: Num a => Reader a a +rDec = do + a <- ask + return $ a - 1 + +-- 2 +rDec' :: Num a => Reader a a +rDec' = ask >>= return . flip (-) 1 + +-- 3 +rShow :: Show a => ReaderT a Identity String +rShow = do + a <- ask + return $ show a + +-- 4 +rShow' :: Show a => ReaderT a Identity String +rShow' = ask >>= return . show + +-- 5 +rPrintAndInc :: (Num a, Show a) => ReaderT a IO a +rPrintAndInc = do + a <- ask + liftIO $ putStr "Hi: " + liftIO $ print a + return $ a + 1 + +-- 6 +sPrintIncAccum :: (Num a, Show a) => StateT a IO String +sPrintIncAccum = do + a <- get + liftIO $ putStr "Hi: " + liftIO $ print a + put (a + 1) + return $ show a \ No newline at end of file