Week 2 Lecture 2

1
import Control.Monad (ap, liftM)
2
import Data.Traversable (fmapDefault, foldMapDefault)
3
4
-- Pretend this file is much larger and complicated...
5
6
data Tree a
7
  = Leaf a
8
  | Node (Tree a) (Tree a)
9
  deriving (Show)
10
11
someTree :: Tree Int
12
someTree =
13
  Node (Leaf 2) (Node (Node (Leaf 1) (Leaf 0)) (Leaf 5))
14
15
--                 *
16
--                / \
17
--               2   *
18
--                  / \
19
--                 *  5
20
--                / \
21
--               1  0
22
23
-- instance Foldable Tree where
24
--   foldMap :: (Monoid m) => (a -> m) -> Tree a -> m
25
--   foldMap f (Leaf a) = f a
26
--   foldMap f (Node lc rc) = mappend (foldMap f lc) (foldMap f rc)
27
28
transformTree :: Int -> Tree Int -> Tree Bool
29
transformTree x (Leaf y) = Leaf (y >= x)
30
transformTree x (Node lc rc) = Node (transformTree x lc) (transformTree x rc)
31
32
newtype Reader r a = Reader (r -> a)
33
34
instance Functor (Reader r) where
35
  fmap f (Reader r) = Reader (f . r)
36
37
instance Applicative (Reader r) where
38
  pure = Reader . const
39
  (Reader r1) <*> (Reader r2) = Reader $ \r -> let a = r2 r in r1 r a
40
41
instance Monad (Reader r) where
42
  (Reader ra) >>= arb = Reader $ \r ->
43
    let a = ra r
44
     in case arb a of
45
          (Reader rb) -> rb r
46
47
ask :: Reader r r
48
ask = Reader id
49
50
runReader :: Reader r a -> r -> a
51
runReader (Reader f) r = f r
52
53
-- transformTreeM :: Tree Int -> Reader Int (Tree Bool)
54
-- transformTreeM (Leaf v) = (Leaf . (v >=)) <$> ask
55
-- transformTreeM (Node lhs rhs) = Node <$> transformTreeM lhs <*> transformTreeM rhs
56
transformTreeM :: Tree Int -> Reader Int (Tree Bool)
57
transformTreeM (Leaf v) = do
58
  t <- ask
59
  pure $ Leaf $ v >= t
60
transformTreeM (Node lhs rhs) = do
61
  lhs' <- transformTreeM lhs
62
  rhs' <- transformTreeM rhs
63
  pure $ Node lhs' rhs'
64
65
-- newtype Writer w a = Writer (w, a)
66
--
67
-- instance Functor (Writer w) where
68
--   fmap f (Writer (w, a)) = Writer (w, f a)
69
--
70
-- instance (Monoid w) => Applicative (Writer w) where
71
--   pure :: (Monoid w) => a -> Writer w a
72
--   pure a = Writer (mempty, a)
73
--   (<*>) :: (Monoid w) => Writer w (a -> b) -> Writer w a -> Writer w b
74
--   (<*>) (Writer (w1, f)) (Writer (w2, a)) = Writer (mappend w1 w2, f a)
75
--
76
-- instance (Monoid w) => Monad (Writer w) where
77
--   (>>=) :: Writer w a -> (a -> Writer w b) -> Writer w b
78
--   (>>=) (Writer (w1, a)) f =
79
--     let (Writer (w2, b)) = f a
80
--      in (Writer (mappend w1 w2, b))
81
--
82
-- tell :: w -> Writer w ()
83
-- tell x = Writer (x, ())
84
--
85
-- tellOne :: w -> Writer [w] ()
86
-- tellOne x = Writer ([x], ())
87
--
88
-- runWriter :: Writer w a -> (w, a)
89
-- runWriter (Writer x) = x
90
91
-- liftM -- Defines fmap by only using Monad's implementation
92
fmapMonad :: (Monad m) => (a -> b) -> m a -> m b
93
fmapMonad f a = a >>= \a' -> pure (f a')
94
95
-- ap -- Defined (<*>) by only using Monad's implementation
96
applyMonad :: (Monad m) => m (a -> b) -> m a -> m b
97
applyMonad f x = f >>= \f' -> x >>= \a' -> pure (f' a')
98
99
newtype State s a = State (s -> (s, a))
100
101
instance Functor (State s) where
102
  -- fmap f (State g) = State $ \x -> let (s, a) = g x in (s, f a)
103
  fmap = liftM
104
105
instance Applicative (State s) where
106
  pure :: a -> State s a
107
  pure a = State $ \s -> (s, a)
108
109
  -- (<*>) :: State s (a -> b) -> State s a -> State s b
110
  -- (<*>) (State f) (State g) = State $ \y ->
111
  --   let
112
  --     (s1, f1) = f y
113
  --     (s2, a) = g s1
114
  --     in (s2, f1 a)
115
  (<*>) = ap
116
117
instance Monad (State s) where
118
  (State sa) >>= asb = State $ \s ->
119
    let (s', a) = sa s
120
        State sb = asb a
121
     in sb s'
122
123
put :: s -> State s ()
124
put s = State $ const (s, ())
125
126
get :: State s s
127
get = State (\s -> (s, s))
128
129
frobTreeM :: Tree Int -> State Int (Tree Int)
130
frobTreeM (Leaf x) = do
131
  s <- get
132
  put (s + 1)
133
  pure (Leaf (x + s))
134
frobTreeM (Node lhs rhs) = do
135
  lhs' <- frobTreeM lhs
136
  rhs' <- frobTreeM rhs
137
  pure (Node lhs' rhs')
138
139
runState :: State s a -> s -> (s, a)
140
runState (State x) = x
141
142
instance Functor Tree where
143
  fmap = fmapDefault
144
145
instance Foldable Tree where
146
  foldMap = foldMapDefault
147
148
instance Traversable Tree where
149
  traverse :: (Applicative f) => (a -> f b) -> Tree a -> f (Tree b)
150
  traverse f (Leaf a) = let fb = f a in Leaf <$> fb
151
  -- traverse f (Node lc rc) = Node <$> (traverse f lc) <*> (traverse f rc)
152
  -- traverse f (Node lc rc) = liftA2 Node (traverse f lc) (traverse f rc)
153
  traverse f (Node lc rc) = pure Node <*> (traverse f lc) <*> (traverse f rc)
154
155
-- let lb = traverse f lc
156
--     rb = traverse f rc
157
-- in Node <$> lb <*> rb
158
159
-- Traversable
160
161
-- Spaaaaace :pea_pod: . :coconut: =  :peanuts: