Skip to content

Commit aaa86da

Browse files
paf31paf31
committed
Merge pull request #4 from ethul/topic/free
Topic/free
2 parents 2306375 + 7e9caf9 commit aaa86da

File tree

5 files changed

+279
-7
lines changed

5 files changed

+279
-7
lines changed

‎Gruntfile.js

Lines changed: 15 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2,15 +2,15 @@ module.exports = function(grunt) {
22

33
"use strict";
44

5-
grunt.initConfig({
6-
5+
grunt.initConfig({
6+
77
libFiles: [
88
"src/**/*.purs",
99
"bower_components/purescript-*/src/**/*.purs*"
1010
],
11-
11+
1212
clean: ["output", "tmp"],
13-
13+
1414
pscMake: ["<%=libFiles%>"],
1515
dotPsci: ["<%=libFiles%>"],
1616
docgen: {
@@ -19,7 +19,7 @@ module.exports = function(grunt) {
1919
dest: "README.md"
2020
}
2121
},
22-
22+
2323
psc: {
2424
options: {
2525
main: true
@@ -39,9 +39,13 @@ module.exports = function(grunt) {
3939
exampleCont: {
4040
src: ["examples/Cont.purs", "<%=libFiles%>"],
4141
dest: "tmp/Cont.js"
42+
},
43+
exampleFree: {
44+
src: ["examples/Free.purs", "<%=libFiles%>"],
45+
dest: "tmp/Free.js"
4246
}
4347
},
44-
48+
4549
execute: {
4650
exampleReader: {
4751
src: "tmp/Reader.js"
@@ -54,9 +58,12 @@ module.exports = function(grunt) {
5458
},
5559
exampleCont: {
5660
src: "tmp/Cont.js"
61+
},
62+
exampleFree: {
63+
src: "tmp/Free.js"
5764
}
5865
}
59-
66+
6067
});
6168

6269
grunt.loadNpmTasks("grunt-purescript");
@@ -67,6 +74,7 @@ module.exports = function(grunt) {
6774
grunt.registerTask("exampleState", ["psc:exampleState", "execute:exampleState"]);
6875
grunt.registerTask("exampleWriter", ["psc:exampleWriter", "execute:exampleWriter"]);
6976
grunt.registerTask("exampleCont", ["psc:exampleCont", "execute:exampleCont"]);
77+
grunt.registerTask("exampleFree", ["psc:exampleFree", "execute:exampleFree"]);
7078
grunt.registerTask("examples", ["psc", "execute"]);
7179
grunt.registerTask("make", ["pscMake", "dotPsci", "docgen"]);
7280
grunt.registerTask("default", ["make"]);

‎README.md

Lines changed: 82 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -135,6 +135,58 @@
135135
runErrorT :: forall e m a. ErrorT e m a -> m (Either e a)
136136

137137

138+
## Module Control.Monad.Free
139+
140+
### Types
141+
142+
data Free f a where
143+
Pure :: a -> Free f a
144+
Free :: f (Free f a) -> Free f a
145+
Gosub :: forall s. (forall r. ({ } -> Free f r) -> (r -> Free f a) -> s) -> s -> Free f a
146+
147+
148+
### Type Classes
149+
150+
class MonadFree f m where
151+
wrap :: forall a. f (m a) -> m a
152+
153+
154+
### Type Class Instances
155+
156+
instance applicativeFree :: (Functor f) => Applicative (Free f)
157+
158+
instance applyFree :: (Functor f) => Apply (Free f)
159+
160+
instance bindFree :: (Functor f) => Bind (Free f)
161+
162+
instance functorFree :: (Functor f) => Functor (Free f)
163+
164+
instance monadFree :: (Functor f) => Monad (Free f)
165+
166+
instance monadFreeFree :: (Functor f) => MonadFree f (Free f)
167+
168+
instance monadTransFree :: MonadTrans Free
169+
170+
171+
### Values
172+
173+
go :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
174+
175+
goEff :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a
176+
177+
goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
178+
179+
iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
180+
181+
liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
182+
183+
pureF :: forall f a. (Applicative f) => a -> Free f a
184+
185+
resume :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
186+
187+
resumeGosub :: forall f a. (Functor f) => (forall s. (forall r. ({ } -> Free f r) -> (r -> Free f a) -> s) -> s) -> Either (f (Free f a)) (Free f a)
188+
189+
138190
## Module Control.Monad.Identity
139191

140192
### Types
@@ -386,6 +438,36 @@
386438
withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
387439

388440

441+
## Module Control.Monad.Trampoline
442+
443+
### Types
444+
445+
data Delay a where
446+
Delay :: { } -> a -> Delay a
447+
448+
type Trampoline a = Free Delay a
449+
450+
451+
### Type Class Instances
452+
453+
instance delayApplicative :: Applicative Delay
454+
455+
instance delayApply :: Apply Delay
456+
457+
instance delayFunctor :: Functor Delay
458+
459+
460+
### Values
461+
462+
delay :: forall a. ({ } -> a) -> Trampoline a
463+
464+
done :: forall a. a -> Trampoline a
465+
466+
runTrampoline :: forall a. Trampoline a -> a
467+
468+
suspend :: forall a. Trampoline a -> Trampoline a
469+
470+
389471
## Module Control.Monad.Trans
390472

391473
### Type Classes

‎examples/Free.purs

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
module Main where
2+
3+
import Control.Monad.Eff
4+
import Control.Monad.Free
5+
import Debug.Trace
6+
7+
data TeletypeF a = PutStrLn String a | GetLine (String -> a)
8+
9+
instance teletypeFFunctor :: Functor TeletypeF where
10+
(<$>) f (PutStrLn s a) = PutStrLn s (f a)
11+
(<$>) f (GetLine k) = GetLine (\s -> f (k s))
12+
13+
type Teletype = Free TeletypeF
14+
15+
putStrLn :: String -> Teletype {}
16+
putStrLn s = liftF $ PutStrLn s {}
17+
18+
getLine :: Teletype String
19+
getLine = liftF $ GetLine (\a -> a)
20+
21+
runF :: forall a. TeletypeF a -> Eff (trace :: Trace) a
22+
runF (PutStrLn s a) = (\_ -> a) <$> trace s
23+
runF (GetLine k) = return $ k "fake input"
24+
25+
run :: forall a. Teletype a -> Eff (trace :: Trace) a
26+
run = goEff runF
27+
28+
echo = do
29+
a <- getLine
30+
putStrLn a
31+
putStrLn "Finished"
32+
33+
main = run $ echo

‎src/Control/Monad/Free.purs

Lines changed: 121 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,121 @@
1+
module Control.Monad.Free where
2+
3+
import Control.Monad.Trans
4+
import Control.Monad.Eff
5+
import Data.Either
6+
7+
data Free f a = Pure a
8+
| Free (f (Free f a))
9+
| Gosub (forall s. (forall r. ({} -> Free f r) -> (r -> Free f a) -> s) -> s)
10+
11+
class MonadFree f m where
12+
wrap :: forall a. f (m a) -> m a
13+
14+
instance functorFree :: (Functor f) => Functor (Free f) where
15+
(<$>) f (Pure a) = Pure (f a)
16+
(<$>) f g = liftA1 f g
17+
18+
instance applyFree :: (Functor f) => Apply (Free f) where
19+
(<*>) = ap
20+
21+
instance applicativeFree :: (Functor f) => Applicative (Free f) where
22+
pure = Pure
23+
24+
instance bindFree :: (Functor f) => Bind (Free f) where
25+
(>>=) (Gosub g) f = Gosub (\h -> g (\a i -> h a (\x -> Gosub (\j -> j (const (i x)) f))))
26+
(>>=) a f = Gosub (\h -> h (const a) f)
27+
28+
instance monadFree :: (Functor f) => Monad (Free f)
29+
30+
instance monadTransFree :: MonadTrans Free where
31+
lift f = Free $ do
32+
a <- f
33+
return (Pure a)
34+
35+
instance monadFreeFree :: (Functor f) => MonadFree f (Free f) where
36+
wrap = Free
37+
38+
liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
39+
liftF fa = wrap $ return <$> fa
40+
41+
pureF :: forall f a. (Applicative f) => a -> Free f a
42+
pureF a = Free (pure (Pure a))
43+
44+
-- Note: can blow the stack!
45+
iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
46+
iterM _ (Pure a) = return a
47+
iterM k (Free f) = k $ iterM k <$> f
48+
iterM k (Gosub f) = f (\req recv -> iterM k (req {}) >>= (iterM k <<< recv))
49+
50+
-- Note: can blow the stack!
51+
goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
52+
goM k f = case resume f of
53+
Left s -> k s >>= goM k
54+
Right a -> return a
55+
56+
resumeGosub :: forall f a. (Functor f) => (forall s. (forall r. ({} -> Free f r) -> (r -> Free f a) -> s) -> s) -> Either (f (Free f a)) (Free f a)
57+
resumeGosub f = f (\a g ->
58+
case a {} of
59+
Pure a -> Right (g a)
60+
Free t -> Left ((\h -> h >>= g) <$> t)
61+
Gosub h -> Right (h (\b i -> b {} >>= (\x -> i x >>= g)))
62+
)
63+
64+
foreign import resume
65+
"function resume(__dict_Functor) {\
66+
\ return function(__copy__1) {\
67+
\ var _1 = __copy__1;\
68+
\ tco: while (true)\
69+
\ if (_1.ctor === 'Control.Monad.Free.Pure')\
70+
\ return Data_Either.Right(_1.values[0]);\
71+
\ else if (_1.ctor === 'Control.Monad.Free.Free')\
72+
\ return Data_Either.Left(_1.values[0]);\
73+
\ else {\
74+
\ var x = resumeGosub(__dict_Functor)(_1.values[0]);\
75+
\ if (x.ctor === 'Data.Either.Left')\
76+
\ return x;\
77+
\ else {\
78+
\ _1 = x.values[0];\
79+
\ continue tco;\
80+
\ }\
81+
\ }\
82+
\ };\
83+
\}" :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
84+
85+
foreign import go
86+
"function go(__dict_Functor) {\
87+
\ return function(f) {\
88+
\ return function(__copy__1) {\
89+
\ var _1 = __copy__1;\
90+
\ var r;\
91+
\ tco: while (true) {\
92+
\ r = resume(__dict_Functor)(_1);\
93+
\ if (r.ctor === 'Data.Either.Left') {\
94+
\ _1 = f(r.values[0]);\
95+
\ continue tco;\
96+
\ } else\
97+
\ return r.values[0];\
98+
\ }\
99+
\ };\
100+
\ };\
101+
\}" :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
102+
103+
foreign import goEff
104+
"function goEff(__dict_Functor) {\
105+
\ return function(f) {\
106+
\ return function(__copy__1) {\
107+
\ return function(){\
108+
\ var _1 = __copy__1;\
109+
\ var r;\
110+
\ tco: while (true) {\
111+
\ r = resume(__dict_Functor)(_1);\
112+
\ if (r.ctor === 'Data.Either.Left') {\
113+
\ _1 = f(r.values[0])();\
114+
\ continue tco;\
115+
\ } else\
116+
\ return function(){return r.values[0];};\
117+
\ }\
118+
\ };\
119+
\ };\
120+
\ };\
121+
\}" :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a

‎src/Control/Monad/Trampoline.purs

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
module Control.Monad.Trampoline where
2+
3+
import Control.Monad.Free
4+
5+
data Delay a = Delay ({} -> a)
6+
7+
instance delayFunctor :: Functor Delay where
8+
(<$>) f (Delay g) = Delay (const (f (g {})))
9+
10+
instance delayApply :: Apply Delay where
11+
(<*>) (Delay f) (Delay a) = Delay (\{} -> (f {}) (a {}))
12+
13+
instance delayApplicative :: Applicative Delay where
14+
pure a = Delay (\{} -> a)
15+
16+
type Trampoline a = Free Delay a
17+
18+
done :: forall a. a -> Trampoline a
19+
done = Pure
20+
21+
suspend :: forall a. Trampoline a -> Trampoline a
22+
suspend a = Free (Delay (\{} -> a))
23+
24+
delay :: forall a. ({} -> a) -> Trampoline a
25+
delay a = Free (done <$> Delay a)
26+
27+
runTrampoline :: forall a. Trampoline a -> a
28+
runTrampoline = go (\(Delay f) -> f {})

0 commit comments

Comments
 (0)