{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GADTs #-}
import Control.Arrow (first)
import Control.Monad (ap, when)
-- Monads!!
-- Intuition:
-- - structure of Applicative computations is fixed
-- - Monad allows choosing future computations
-- based on intermediate results
-- 3 views on Monad:
-- - Monad = fmap + pure + ?
-- 1. join. Collapse multiple levels into one.
fmap2 :: (a -> b -> c) -> f a -> f b -> f c
fmap2 g fa fb = undefined
-- fmap g fa :: f (b -> c)
-- fb :: f b
-- we could stop here and come up with Applicative
-- or, if we try a little harder:
-- fmap (\h -> fmap h fb) (fmap g fa) :: f (f c)
--
-- all we would need now is f (f c) -> f c
-- i.e. collapse two levels of f into one.
-- this is called 'join'.
class Applicative f => Joinable f where
joiny :: f (f a) -> f a
-- Examples.
instance Joinable [] where
-- join :: [[a]] -> [a]
joiny = concat
instance Joinable Maybe where
-- join :: Maybe (Maybe a) -> Maybe a
joiny (Just (Just a)) = Just a
joiny _ = Nothing
-- join Nothing = Nothing
-- join (Just Nothing) = Nothing
-- instance Joinable ((,) e) where
-- -- join :: (e,(e,a)) -> (e,a)
-- join = snd
-- actually it turns out we want to combine the e's
instance Joinable ((->) e) where
-- join :: (e -> (e -> a)) -> e -> a
joiny g e = g e e
newtype Parser a = P (String -> Maybe (a, String))
deriving Functor
instance Applicative Parser where
pure a = P $ \s -> Just (a,s)
-- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
p <*> q = joiny ((\g -> g <$> q) <$> p)
instance Joinable Parser where
-- join :: Parser (Parser a) -> Parser a
joiny (P p) = P $ \s ->
case p s of
Nothing -> Nothing
Just (P q, s') -> q s'
-- 2. "bind" (>>=)
-- More directly encodes idea of choosing what to do next based on
-- previous results.
-- implementing bind in terms of join
(>>==) :: Joinable m => m a -> (a -> m b) -> m b
ma >>== k = joiny (fmap k ma)
-- k stands for "continuation"
-- implementing join in terms of bind
joiny' :: Joinable m => m (m c) -> m c
joiny' mma = mma >>== id
-- Using the Monad IO instance:
sayHello :: IO ()
sayHello =
putStr "What is your name? " *>
getLine >>= (\name -> putStrLn ("Hello, " ++ name ++ "!"))
sayHelloChecked :: IO ()
sayHelloChecked =
putStr "What is your name? " *>
getLine >>= (\name ->
if length name < 4
then (putStrLn ("No it isn't.") *> sayHelloChecked)
else (putStrLn ("Hello, " ++ name ++ "!"))
)
sayHello3 :: IO ()
sayHello3 =
putStr "What is your name? " *>
getLine >>= \name ->
putStr "What is your favorite color? " *>
getLine >>= \color ->
putStr "What is the airspeed velocity of a unladen swallow? " *>
getLine >>= \vel ->
putStrLn (name ++ color ++ vel)
-- The above style is historical, now we can use "do-notation"
sayHello3Do :: IO ()
sayHello3Do = do
putStr "What is your name? "
name <- getLine
putStr "What is your favorite color? "
color <- getLine
putStr "What is the airspeed velocity of a unladen swallow? "
vel <- getLine
putStrLn (name ++ color ++ vel)
listExample = do
a <- [1..100]
b <- [1..100]
c <- [1..100]
if (a^2 + b^2 == c^2)
then [(a,b,c)]
else []
--------------------------------------------------------
-- State monad
-- State s a represents a computation that produces a value of type a
-- and has access to a read/write state of type s.
data State s a where
State :: (s -> (a,s)) -> State s a
-- Take an initial state and produce a result along with an updated
-- state.
runState :: State s a -> s -> (a,s)
runState (State k) = k
evalState :: State s a -> s -> a
evalState (State k) = fst . k
instance Functor (State s) where
-- fmap :: (a -> b) -> State s a -> State s b
fmap g (State k) = State $ \s -> first g (k s)
-- fmap g (State k) = State $ first g . k
ap' :: Monad m => m (a -> b) -> m a -> m b
ap' mab ma = mab >>= \g -> fmap g ma
instance Applicative (State s) where
pure = return
(<*>) = ap
instance Monad (State s) where
return a = State $ \s -> (a,s)
(State k) >>= m = State $ \s ->
case k s of
(a, s') -> runState (m a) s'
-- k :: s -> (a,s)
-- m :: a -> State b
-- we need: State b
get :: State s s
get = State $ \s -> (s,s)
put :: s -> State s ()
put s' = State $ \s -> ((), s')
tick :: State Int ()
tick = get >>= (\n -> put (n+1))
tick' :: State Int ()
tick' = do
n <- get
put (n+1)
-- Increment everything in a list, count the even elements
mapCount :: [Int] -> State Int [Int]
mapCount [] = return []
mapCount (n:ns) = do
when (even n) tick
numEvens <- get
ns' <- mapCount ns
return (n+numEvens : ns')
--------------------------------------------------------
-- 3rd view on monads: effectful function composition
-- "fish"
(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
g <=< h = \a -> h a >>= g
-- write bind in terms of fish
(>>===) :: Monad m => m a -> (a -> m b) -> m b
ma >>=== k = (k <=< (\_ -> ma)) ()
-------------------------------------------------------
data AST v where
Var :: v -> AST v
Add :: AST v -> AST v -> AST v
Lit :: Int -> AST v
deriving (Functor, Foldable, Traversable, Show)
-- parse :: Parser (AST String) where
example :: AST String
example = Add (Add (Lit 3) (Var "x")) (Add (Var "y") (Var "x"))
uniqify :: String -> State Int (String, Int)
uniqify var = do
i <- get
put (i+1)
return (var, i)