Week 4 Lecture 1

1
import Control.Monad (ap, liftM, void, (<=<), (>=>))
2
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3
4
-- What do I owe you?
5
-- Nothing, it's for free!
6
-- Monads? For freee????!
7
8
-- I guess I'm forced to write haskell the old fashioned way now -- Writing with a bat? A butterfly
9
10
newtype FState s a = FState {runFState :: s -> (a, s)}
11
12
instance Functor (FState s) where
13
  fmap = liftM
14
15
instance Applicative (FState s) where
16
  -- pure x = FState $ \s -> (x, s)
17
  -- pure x = FState $ (x,)
18
  pure = FState . (,)
19
  (<*>) = ap
20
21
instance Monad (FState s) where
22
  c >>= f = FState $ \s ->
23
    let (a, s') = runFState c s
24
     in runFState (f a) s'
25
26
get :: FState s s
27
get = FState (\s -> (s, s))
28
29
put :: s -> FState s ()
30
-- put s = FState (\_ -> ((), s))
31
-- put s = FState (const ((), s))
32
put = FState . const . ((),) -- ~~Pointless!~~ Pointfree! -.-
33
34
-- The get, put and runState functions define the State monad
35
-- Alongside the following rules:
36
-- put s >> get = put s >> return s
37
-- put s >> put s' = put s'
38
-- get >>= put = return ()
39
40
-- type Monad :: (* -> *) -> Constraint
41
-- class Applicative m => Monad m where
42
--   ...
43
--   (>>) :: m a -> m b -> m b
44
--   ...
45
--         -- Defined in ‘GHC.Internal.Base’
46
-- infixl 1 >>
47
48
-- yee 🦕 Dino nuggies, omg i want dino nuggies
49
50
class (Monad m) => StateMonad m s where
51
  getm :: m s
52
  putm :: s -> m ()
53
54
modify :: (StateMonad m s) => (s -> s) -> m ()
55
-- modify f = getm >>= (putm . f)
56
modify f = f <$> getm >>= putm
57
58
tick :: (StateMonad m Int) => m Int
59
-- tick = do{n <- getm; putm (n+1); return n}
60
tick = do n <- getm; n <$ putm (n + 1)
61
62
push :: (StateMonad m [a]) => a -> m ()
63
push x = modify (x :)
64
65
pop :: (StateMonad m [a]) => m (Maybe a)
66
pop =
67
  do
68
    xs <- getm
69
    case xs of
70
      [] -> return Nothing
71
      (x : xs') -> do putm xs'; return $ Just x
72
73
newtype IState s a = IState {runIState :: IORef s -> IO a}
74
75
evalIState :: s -> IState s a -> IO a
76
evalIState def m = newIORef def >>= runIState m
77
78
instance Functor (IState s) where
79
  fmap = liftM
80
81
instance Applicative (IState s) where
82
  pure = IState . const . pure
83
  (<*>) = ap
84
85
instance Monad (IState s) where
86
  c >>= f = IState $ \ref -> do
87
    val <- runIState c ref
88
    runIState (f val) ref
89
90
instance StateMonad (IState s) s where
91
  getm = IState $ readIORef
92
  putm = IState . flip writeIORef
93
94
-- A `continuation` is passed into the function
95
-- Continuation passing style!
96
putk :: (StateMonad m s) => s -> (() -> m a) -> m a
97
putk s = (putm s >>=)
98
99
data FSM s a where
100
  Return :: a -> FSM s a
101
  Getk :: (s -> FSM s a) -> FSM s a
102
  Putk :: s -> FSM s a -> FSM s a
103
104
instance Functor (FSM s) where
105
  fmap = liftM
106
107
instance Applicative (FSM s) where
108
  pure = Return
109
  (<*>) = ap
110
111
instance Monad (FSM s) where
112
  Return x >>= f = f x
113
  Getk n >>= f = Getk $ \s -> n s >>= f -- GetK (n >=> f)
114
  Putk v n >>= f = Putk v $ n >>= f -- PutK ()
115
116
instance StateMonad (FSM s) s where
117
  getm = Getk return
118
  putm state' = Putk state' (return ())
119
120
-- This function allows FSM to be evaluated under any other StateMonad
121
evalFSM :: (StateMonad m s) => FSM s a -> m a
122
evalFSM (Return x) = return x
123
evalFSM (Getk next) = getm >>= \state -> evalFSM (next state)
124
evalFSM (Putk state' next) = putm state' *> evalFSM next
125
126
runFSM :: s -> FSM s a -> (a, s)
127
runFSM s (Return a) = (a, s)
128
runFSM s (Getk n) = runFSM s (n s)
129
runFSM s (Putk s' n) = runFSM s' n
130
131
-- I'm not sure I get why these constructors are needed. Which one?
132
-- FSM itself, there are just the functions as constructors
133
-- Exactly! FSM is a Free State Monad that encodes what a state typeclass would have, but inside a datatype
134
-- So you can have a type that models state, but in the end you can evaluate it however you actually want
135
136
data StateOp s a where
137
  StateGet :: (s -> a) -> StateOp s a
138
  StatePut :: s -> a -> StateOp s a
139
140
data Free e a where
141
  Pure :: a -> Free e a
142
  Free :: e (Free e a) -> Free e a
143
144
instance (Functor e) => Functor (Free e) where
145
  fmap = liftM
146
147
instance (Functor e) => Applicative (Free e) where
148
  pure = Pure
149
  (<*>) = ap
150
151
instance (Functor e) => Monad (Free e) where
152
  (Pure a) >>= f = f a
153
  (Free c) >>= f = Free $ fmap (>>= f) c
154
155
type FreeState s a = Free (StateOp s) a
156
157
-- Space