Skip to content

Commit f4bf6bd

Browse files
thomashoneymanthomashoneyman
committed
Add Cofree and Free class
1 parent e32ed83 commit f4bf6bd

File tree

4 files changed

+111
-178
lines changed

4 files changed

+111
-178
lines changed

‎src/Control/Comonad/Cofree.purs

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
-- | The _cofree comonad_ for a `Functor`.
2+
3+
module Control.Comonad.Cofree
4+
( module Control.Comonad.Cofree.Compat
5+
, explore
6+
, exploreM
7+
) where
8+
9+
import Control.Comonad.Cofree.Compat hiding (explore, exploreM)
10+
11+
import Prelude (class Functor, map, (<$>))
12+
import Control.Comonad (extract)
13+
import Control.Monad.Free (Free, runRec)
14+
import Control.Monad.Rec.Class (class MonadRec)
15+
import Control.Monad.State (State, StateT(..), runState, runStateT, state)
16+
import Data.Tuple (Tuple(..))
17+
18+
-- | Explore a value in the cofree comonad by using an expression in a
19+
-- | corresponding free monad.
20+
-- |
21+
-- | The free monad should be built from a functor which pairs with the
22+
-- | functor underlying the cofree comonad.
23+
explore
24+
:: forall f g a b
25+
. Functor f
26+
=> Functor g
27+
=> (forall x y. f (x -> y) -> g x -> y)
28+
-> Free f (a -> b)
29+
-> Cofree g a
30+
-> b
31+
explore pair m w =
32+
case runState (runRec step m) w of
33+
Tuple f cof -> f (extract cof)
34+
where
35+
step :: f (Free f (a -> b)) -> State (Cofree g a) (Free f (a -> b))
36+
step ff = state \cof -> pair (map Tuple ff) (tail cof)
37+
38+
exploreM
39+
:: forall f g a b m
40+
. Functor f
41+
=> Functor g
42+
=> MonadRec m
43+
=> (forall x y. f (x -> y) -> g x -> m y)
44+
-> Free f (a -> b)
45+
-> Cofree g a
46+
-> m b
47+
exploreM pair m w =
48+
eval <$> runStateT (runRec step m) w
49+
where
50+
step :: f (Free f (a -> b)) -> StateT (Cofree g a) m (Free f (a -> b))
51+
step ff = StateT \cof -> pair (map Tuple ff) (tail cof)
52+
53+
eval :: forall x y. Tuple (x -> y) (Cofree g x) -> y
54+
eval (Tuple f cof) = f (extract cof)

‎src/Control/Comonad/Cofree/Class/Compat.purs renamed to ‎src/Control/Comonad/Cofree/Class.purs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
1-
module Control.Comonad.Cofree.Class.Compat
1+
module Control.Comonad.Cofree.Class
22
( class ComonadCofree
33
, unwrapCofree
44
) where
55

66
import Prelude
77

88
import Control.Comonad (class Comonad)
9-
import Control.Comonad.Cofree.Compat (Cofree, tail)
9+
import Control.Comonad.Cofree (Cofree, tail)
1010
import Control.Comonad.Env.Trans (EnvT(..))
1111
import Control.Comonad.Store.Trans (StoreT(..))
1212
import Control.Comonad.Traced.Trans (TracedT(..))

‎src/Control/Comonad/Cofree/Compat.purs

Lines changed: 20 additions & 176 deletions
Original file line numberDiff line numberDiff line change
@@ -1,185 +1,29 @@
1-
-- | The _cofree comonad_ for a `Functor`.
2-
3-
module Control.Comonad.Cofree.Compat
4-
( Cofree
5-
, deferCofree
6-
, mkCofree, (:<)
7-
, head
8-
, tail
9-
, hoistCofree
10-
, unfoldCofree
11-
, buildCofree
12-
, explore
13-
, exploreM
1+
module Control.Comonad.Cofree.Class.Compat
2+
( class ComonadCofree
3+
, unwrapCofree
144
) where
155

166
import Prelude
17-
import Control.Alternative (class Alternative, (<|>), empty)
18-
import Control.Comonad (class Comonad, extract)
19-
import Control.Extend (class Extend)
20-
import Control.Lazy as Z
21-
import Control.Monad.Free.Compat (Free, runFreeM)
22-
import Control.Monad.Rec.Class (class MonadRec)
23-
import Control.Monad.State (State, StateT(..), runState, runStateT, state)
24-
import Data.Eq (class Eq1, eq1)
25-
import Data.Foldable (class Foldable, foldr, foldl, foldMap)
26-
import Data.Lazy (Lazy, force, defer)
27-
import Data.Ord (class Ord1, compare1)
28-
import Data.Traversable (class Traversable, traverse)
29-
import Data.Tuple (Tuple(..), fst, snd)
30-
31-
-- | The `Cofree` `Comonad` for a functor.
32-
-- |
33-
-- | A value of type `Cofree f a` consists of an `f`-branching
34-
-- | tree, annotated with labels of type `a`.
35-
-- |
36-
-- | The `Comonad` instance supports _redecoration_, recomputing
37-
-- | labels from the local context.
38-
newtype Cofree f a = Cofree (Lazy (Tuple a (f (Cofree f a))))
39-
40-
-- | Lazily creates a value of type `Cofree f a` from a label and a
41-
-- | functor-full of "subtrees".
42-
deferCofree :: forall f a. (Unit -> Tuple a (f (Cofree f a))) -> Cofree f a
43-
deferCofree = Cofree <<< defer
44-
45-
-- | Create a value of type `Cofree f a` from a label and a
46-
-- | functor-full of "subtrees".
47-
mkCofree :: forall f a. a -> f (Cofree f a) -> Cofree f a
48-
mkCofree a t = Cofree (defer \_ -> Tuple a t)
49-
50-
infixr 5 mkCofree as :<
51-
52-
-- | Returns the label for a tree.
53-
head :: forall f a. Cofree f a -> a
54-
head (Cofree c) = fst (force c)
55-
56-
-- | Returns the "subtrees" of a tree.
57-
tail :: forall f a. Cofree f a -> f (Cofree f a)
58-
tail (Cofree c) = snd (force c)
59-
60-
hoistCofree :: forall f g. Functor f => (f ~> g) -> Cofree f ~> Cofree g
61-
hoistCofree nat (Cofree c) = Cofree (map (nat <<< map (hoistCofree nat)) <$> c)
62-
63-
-- | This signature is deprecated and will be replaced by `buildCofree` in a
64-
-- | future release.
65-
unfoldCofree
66-
:: forall f s a
67-
. Functor f
68-
=> (s -> a)
69-
-> (s -> f s)
70-
-> s
71-
-> Cofree f a
72-
unfoldCofree e n = buildCofree (\s -> Tuple (e s) (n s))
73-
74-
-- | Recursively unfolds a `Cofree` structure given a seed.
75-
buildCofree
76-
:: forall f s a
77-
. Functor f
78-
=> (s -> Tuple a (f s))
79-
-> s
80-
-> Cofree f a
81-
buildCofree k s =
82-
Cofree (defer \_ -> map (buildCofree k) <$> k s)
83-
84-
-- | Explore a value in the cofree comonad by using an expression in a
85-
-- | corresponding free monad.
86-
-- |
87-
-- | The free monad should be built from a functor which pairs with the
88-
-- | functor underlying the cofree comonad.
89-
explore
90-
:: forall f g a b
91-
. Functor f
92-
=> Functor g
93-
=> (forall x y. f (x -> y) -> g x -> y)
94-
-> Free f (a -> b)
95-
-> Cofree g a
96-
-> b
97-
explore pair m w =
98-
case runState (runFreeM step m) w of
99-
Tuple f cof -> f (extract cof)
100-
where
101-
step :: f (Free f (a -> b)) -> State (Cofree g a) (Free f (a -> b))
102-
step ff = state \cof -> pair (map Tuple ff) (tail cof)
103-
104-
exploreM
105-
:: forall f g a b m
106-
. Functor f
107-
=> Functor g
108-
=> MonadRec m
109-
=> (forall x y. f (x -> y) -> g x -> m y)
110-
-> Free f (a -> b)
111-
-> Cofree g a
112-
-> m b
113-
exploreM pair m w =
114-
eval <$> runStateT (runFreeM step m) w
115-
where
116-
step :: f (Free f (a -> b)) -> StateT (Cofree g a) m (Free f (a -> b))
117-
step ff = StateT \cof -> pair (map Tuple ff) (tail cof)
118-
119-
eval :: forall x y. Tuple (x -> y) (Cofree g x) -> y
120-
eval (Tuple f cof) = f (extract cof)
121-
122-
instance eqCofree :: (Eq1 f, Eq a) => Eq (Cofree f a) where
123-
eq x y = head x == head y && tail x `eq1` tail y
124-
125-
instance eq1Cofree :: Eq1 f => Eq1 (Cofree f) where
126-
eq1 = eq
127-
128-
instance ordCofree :: (Ord1 f, Ord a) => Ord (Cofree f a) where
129-
compare x y =
130-
case compare (head x) (head y) of
131-
EQ -> compare1 (tail x) (tail y)
132-
r -> r
133-
134-
instance ord1Cofree :: Ord1 f => Ord1 (Cofree f) where
135-
compare1 = compare
136-
137-
instance functorCofree :: Functor f => Functor (Cofree f) where
138-
map f = loop
139-
where
140-
loop (Cofree fa) = Cofree ((\(Tuple a b) -> Tuple (f a) (loop <$> b)) <$> fa)
141-
142-
instance foldableCofree :: Foldable f => Foldable (Cofree f) where
143-
foldr f = flip go
144-
where
145-
go fa b = f (head fa) (foldr go b (tail fa))
146-
147-
foldl f = go
148-
where
149-
go b fa = foldl go (f b (head fa)) (tail fa)
150-
151-
foldMap f = go
152-
where
153-
go fa = f (head fa) <> (foldMap go (tail fa))
154-
155-
instance traversableCofree :: Traversable f => Traversable (Cofree f) where
156-
sequence = traverse identity
157-
traverse f = loop
158-
where
159-
loop ta = mkCofree <$> f (head ta) <*> (traverse loop (tail ta))
160-
161-
instance extendCofree :: Functor f => Extend (Cofree f) where
162-
extend f = loop
163-
where
164-
loop (Cofree fa) = Cofree ((\(Tuple a b) -> Tuple (f (Cofree fa)) (loop <$> b)) <$> fa)
1657

166-
instance comonadCofree :: Functor f => Comonad (Cofree f) where
167-
extract = head
8+
import Control.Comonad (class Comonad)
9+
import Control.Comonad.Cofree.Compat (Cofree, tail)
10+
import Control.Comonad.Env.Trans (EnvT(..))
11+
import Control.Comonad.Store.Trans (StoreT(..))
12+
import Control.Comonad.Traced.Trans (TracedT(..))
13+
import Data.Tuple (Tuple(..))
16814

169-
instance applyCofree :: Alternative f => Apply (Cofree f) where
170-
apply = ap
15+
-- | Based on <http://hackage.haskell.org/package/free/docs/Control-Comonad-Cofree-Class.html>
16+
class (Functor f, Comonad w) <= ComonadCofree f w | w -> f where
17+
unwrapCofree :: forall a. w a -> f (w a)
17118

172-
instance applicativeCofree :: Alternative f => Applicative (Cofree f) where
173-
pure a = mkCofree a empty
19+
instance comonadCofreeCofree :: Functor f => ComonadCofree f (Cofree f) where
20+
unwrapCofree = tail
17421

175-
instance bindCofree :: Alternative f => Bind (Cofree f) where
176-
bind fa f = loop fa
177-
where
178-
loop fa' =
179-
let fh = f (head fa')
180-
in mkCofree (head fh) ((tail fh) <|> (loop <$> tail fa'))
22+
instance comonadCofreeEnvT :: (Functor f, ComonadCofree f w) => ComonadCofree f (EnvT e w) where
23+
unwrapCofree (EnvT (Tuple e wa)) = map (\x -> EnvT (Tuple e x)) (unwrapCofree wa)
18124

182-
instance monadCofree :: Alternative f => Monad (Cofree f)
25+
instance comonadCofreeStoreT :: (Functor f, ComonadCofree f w) => ComonadCofree f (StoreT s w) where
26+
unwrapCofree (StoreT (Tuple wsa s)) = map (\x -> StoreT (Tuple x s)) (unwrapCofree wsa)
18327

184-
instance lazyCofree :: Z.Lazy (Cofree f a) where
185-
defer k = Cofree (defer \_ -> let (Cofree t) = k unit in force t)
28+
instance comonadCofreeTracedT :: (Functor f, ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where
29+
unwrapCofree (TracedT wma) = map TracedT (unwrapCofree wma)

‎src/Control/Monad/Free/Class.purs

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
module Control.Monad.Free.Class
2+
( class MonadFree
3+
, wrapFree
4+
) where
5+
6+
import Prelude
7+
8+
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
9+
import Control.Monad.Free (Free, lift)
10+
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
11+
import Control.Monad.Reader.Trans (ReaderT(..), runReaderT)
12+
import Control.Monad.State.Trans (StateT(..), runStateT)
13+
import Control.Monad.Writer.Trans (WriterT(..), runWriterT)
14+
15+
-- | Based on <http://hackage.haskell.org/package/free/docs/Control-Monad-Free-Class.html>
16+
class Monad m <= MonadFree f m | m -> f where
17+
wrapFree :: forall a. f (m a) -> m a
18+
19+
instance monadFreeFree :: MonadFree f (Free f) where
20+
wrapFree = join <<< lift
21+
22+
instance monadFreeReaderT :: (Functor f, MonadFree f m) => MonadFree f (ReaderT r m) where
23+
wrapFree f = ReaderT \r -> wrapFree (map (\rt -> runReaderT rt r) f)
24+
25+
instance monadFreeStateT :: (Functor f, MonadFree f m) => MonadFree f (StateT s m) where
26+
wrapFree f = StateT \s -> wrapFree (map (\st -> runStateT st s) f)
27+
28+
instance monadFreeWriterT :: (Functor f, MonadFree f m, Monoid w) => MonadFree f (WriterT w m) where
29+
wrapFree f = WriterT (wrapFree (map runWriterT f))
30+
31+
instance monadFreeMaybeT :: (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where
32+
wrapFree f = MaybeT (wrapFree (map runMaybeT f))
33+
34+
instance monadFreeExceptT :: (Functor f, MonadFree f m) => MonadFree f (ExceptT e m) where
35+
wrapFree f = ExceptT (wrapFree (map runExceptT f))

0 commit comments

Comments
 (0)