1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
{-# LANGUAGE FlexibleContexts
, FlexibleInstances
, UndecidableInstances
, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Free
-- Copyright : (C) 2008-2011 Edward Kmett
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : MPTCs, fundeps
--
-- Free monads
--
----------------------------------------------------------------------------
module Control.Monad.Free
( MonadFree(..)
, Free(..)
, retract
, liftF
, iter
) where
import Control.Applicative
import Control.Monad (liftM, MonadPlus(..))
import Control.Monad.Trans.Class
import Control.Monad.Free.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.Error.Class
import Control.Monad.Cont.Class
import Data.Functor.Bind
import Data.Foldable
import Data.Traversable
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
data Free f a = Pure a | Free (f (Free f a))
instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where
Pure a == Pure b = a == b
Free fa == Free fb = fa == fb
_ == _ = False
instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where
Pure a `compare` Pure b = a `compare` b
Pure _ `compare` Free _ = LT
Free _ `compare` Pure _ = GT
Free fa `compare` Free fb = fa `compare` fb
instance (Show (f (Free f a)), Show a) => Show (Free f a) where
showsPrec d (Pure a) = showParen (d > 10) $
showString "Pure " . showsPrec 11 a
showsPrec d (Free m) = showParen (d > 10) $
showString "Free " . showsPrec 11 m
instance (Read (f (Free f a)), Read a) => Read (Free f a) where
readsPrec d r = readParen (d > 10)
(\r' -> [ (Pure m, t)
| ("Pure", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
++ readParen (d > 10)
(\r' -> [ (Free m, t)
| ("Free", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
instance Functor f => Functor (Free f) where
fmap f (Pure a) = Pure (f a)
fmap f (Free fa) = Free (fmap f <$> fa)
instance Functor f => Apply (Free f) where
Pure a <.> Pure b = Pure (a b)
Pure a <.> Free fb = Free $ fmap a <$> fb
Free fa <.> b = Free $ (<.> b) <$> fa
instance Functor f => Applicative (Free f) where
pure = Pure
Pure a <*> Pure b = Pure $ a b
Pure a <*> Free mb = Free $ fmap a <$> mb
Free ma <*> b = Free $ (<*> b) <$> ma
instance Functor f => Bind (Free f) where
Pure a >>- f = f a
Free m >>- f = Free ((>>- f) <$> m)
instance Functor f => Monad (Free f) where
return = Pure
Pure a >>= f = f a
Free m >>= f = Free ((>>= f) <$> m)
instance Alternative v => Alternative (Free v) where
empty = Free empty
a <|> b = Free (pure a <|> pure b)
instance (Functor v, MonadPlus v) => MonadPlus (Free v) where
mzero = Free mzero
a `mplus` b = Free (return a `mplus` return b)
instance MonadTrans Free where
lift = Free . liftM Pure
instance Foldable f => Foldable (Free f) where
foldMap f (Pure a) = f a
foldMap f (Free fa) = foldMap (foldMap f) fa
instance Foldable1 f => Foldable1 (Free f) where
foldMap1 f (Pure a) = f a
foldMap1 f (Free fa) = foldMap1 (foldMap1 f) fa
instance Traversable f => Traversable (Free f) where
traverse f (Pure a) = Pure <$> f a
traverse f (Free fa) = Free <$> traverse (traverse f) fa
instance Traversable1 f => Traversable1 (Free f) where
traverse1 f (Pure a) = Pure <$> f a
traverse1 f (Free fa) = Free <$> traverse1 (traverse1 f) fa
instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where
tell = lift . tell
listen = lift . listen . retract
pass = lift . pass . retract
instance (Functor m, MonadReader e m) => MonadReader e (Free m) where
ask = lift ask
local f = lift . local f . retract
instance (Functor m, MonadState s m) => MonadState s (Free m) where
get = lift get
put s = lift (put s)
instance (Functor m, MonadError e m) => MonadError e (Free m) where
throwError = lift . throwError
catchError as f = lift (catchError (retract as) (retract . f))
instance (Functor m, MonadCont m) => MonadCont (Free m) where
callCC f = lift (callCC (retract . f . liftM lift))
liftF :: Functor f => f a -> Free f a
liftF = Free . fmap Pure
instance Functor f => MonadFree f (Free f) where
wrap = Free
-- |
--
-- > retract . lift = id
-- > retract . liftF = id
retract :: Monad f => Free f a -> f a
retract (Pure a) = return a
retract (Free as) = as >>= retract
iter :: Functor f => (f a -> a) -> Free f a -> a
iter _ (Pure a) = a
iter phi (Free m) = phi (iter phi <$> m)
|
