Skip to content

Commit fd5837e

Browse files
ethulethul
committed
Merge branch 'topic/free-revival'
2 parents 02d49df + 935dffe commit fd5837e

File tree

9 files changed

+216
-92
lines changed

9 files changed

+216
-92
lines changed

‎.gitignore

Lines changed: 1 addition & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,4 @@
1-
.DS_Store
2-
*.log
1+
.psci
32
node_modules
43
bower_components
5-
js
6-
externs
74
dist
8-
output

‎MODULE.md

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
# Module Documentation
2+
3+
## Module Control.Monad.Free
4+
5+
### Types
6+
7+
data Free f a where
8+
Pure :: a -> Free f a
9+
Free :: f (Free f a) -> Free f a
10+
Gosub :: forall s. (forall r. (Unit -> Free f r) -> (r -> Free f a) -> s) -> s -> Free f a
11+
12+
13+
### Type Classes
14+
15+
class MonadFree f m where
16+
wrap :: forall a. f (m a) -> m a
17+
18+
19+
### Type Class Instances
20+
21+
instance applicativeFree :: (Functor f) => Applicative (Free f)
22+
23+
instance applyFree :: (Functor f) => Apply (Free f)
24+
25+
instance bindFree :: (Functor f) => Bind (Free f)
26+
27+
instance functorFree :: (Functor f) => Functor (Free f)
28+
29+
instance monadFree :: (Functor f) => Monad (Free f)
30+
31+
instance monadFreeFree :: (Functor f) => MonadFree f (Free f)
32+
33+
instance monadTransFree :: MonadTrans Free
34+
35+
36+
### Values
37+
38+
go :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
39+
40+
goEff :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a
41+
42+
goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
43+
44+
iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
45+
46+
liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
47+
48+
pureF :: forall f a. (Applicative f) => a -> Free f a
49+
50+
51+
## Module Control.Monad.Trampoline
52+
53+
### Types
54+
55+
newtype Delay a where
56+
Delay :: Unit -> a -> Delay a
57+
58+
type Trampoline a = Free Delay a
59+
60+
61+
### Type Class Instances
62+
63+
instance delayApplicative :: Applicative Delay
64+
65+
instance delayApply :: Apply Delay
66+
67+
instance delayFunctor :: Functor Delay
68+
69+
70+
### Values
71+
72+
delay :: forall a. (Unit -> a) -> Trampoline a
73+
74+
done :: forall a. a -> Trampoline a
75+
76+
runTrampoline :: forall a. Trampoline a -> a
77+
78+
suspend :: forall a. Trampoline a -> Trampoline a
79+
80+
81+

‎README.md

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,3 @@
11
# Deprecation Notice
22

33
Please note that this library has been merged into [purescript-transformers](https://github.com/purescript-contrib/purescript-transformers).
4-
5-
Development will be continued there.

‎bower.json

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -10,12 +10,10 @@
1010
"node_modules",
1111
"bower_components",
1212
"examples",
13-
"externs",
14-
"js",
1513
"dist"
1614
],
1715
"dependencies": {
18-
"purescript-transformers": "0.0.1",
19-
"purescript-either": "0.1.2"
16+
"purescript-transformers": "0.1.2",
17+
"purescript-either": "0.1.3"
2018
}
2119
}

‎examples/Teletype.purs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,8 @@ instance teletypeFFunctor :: Functor TeletypeF where
1212

1313
type Teletype = Free TeletypeF
1414

15-
putStrLn :: String -> Teletype {}
16-
putStrLn s = liftF $ PutStrLn s {}
15+
putStrLn :: String -> Teletype Unit
16+
putStrLn s = liftF $ PutStrLn s unit
1717

1818
getLine :: Teletype String
1919
getLine = liftF $ GetLine (\a -> a)
@@ -29,5 +29,8 @@ echo = do
2929
a <- getLine
3030
putStrLn a
3131
putStrLn "Finished"
32+
return $ a ++ a
3233

33-
main = run $ echo
34+
main = do
35+
a <- run $ echo
36+
trace a

‎gulpfile.js

Lines changed: 24 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,15 +3,17 @@ var gulp = require('gulp')
33
, gutil = require('gulp-util')
44
, plumber = require('gulp-plumber')
55
, purescript = require('gulp-purescript')
6+
, sequence = require('run-sequence')
67
, config = {
7-
clean: ['dist', 'js', 'externs'],
8+
clean: ['dist'],
89
purescript: {
910
src: [
1011
'bower_components/purescript-*/src/**/*.purs*',
1112
'src/**/*.purs'
1213
],
1314
examples: 'examples/**/*.purs',
1415
dest: 'dist',
16+
docgen: 'MODULE.md',
1517
options: {
1618
main: 'Teletype'
1719
}
@@ -50,9 +52,29 @@ gulp.task('make', function(){
5052
);
5153
});
5254

55+
gulp.task('psci', function(){
56+
return (
57+
gulp.src(config.purescript.src).
58+
pipe(plumber()).
59+
pipe(purescript.dotPsci()).
60+
on('error', error)
61+
);
62+
});
63+
64+
gulp.task('docgen', function(){
65+
return (
66+
gulp.src(config.purescript.src[1]).
67+
pipe(plumber()).
68+
pipe(purescript.docgen()).
69+
on('error', error).
70+
pipe(gulp.dest(config.purescript.docgen))
71+
);
72+
});
5373

5474
gulp.task('watch', function(cb){
5575
gulp.watch(config.purescript.src, ['make']);
5676
});
5777

58-
gulp.task('default', ['clean', 'make'], function(){});
78+
gulp.task('default', function(){
79+
sequence('clean', 'make', ['psci', 'docgen']);
80+
});

‎package.json

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,10 +2,11 @@
22
"name": "purescript-free",
33
"private": true,
44
"devDependencies": {
5-
"gulp": "^3.5.5",
6-
"gulp-clean": "^0.2.4",
7-
"gulp-util": "^2.2.14",
8-
"gulp-plumber": "^0.5.6",
9-
"gulp-purescript": "^0.0.4"
5+
"gulp": "3.8.7",
6+
"gulp-clean": "0.2.4",
7+
"gulp-util": "2.2.14",
8+
"gulp-plumber": "0.5.6",
9+
"gulp-purescript": "0.0.10",
10+
"run-sequence": "0.3.6"
1011
}
1112
}

‎src/Control/Monad/Free.purs

Lines changed: 89 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,22 @@
1-
module Control.Monad.Free where
1+
module Control.Monad.Free
2+
( Free(..)
3+
, MonadFree, wrap
4+
, liftF
5+
, pureF
6+
, iterM
7+
, goM
8+
, go
9+
, goEff
10+
) where
211

312
import Control.Monad.Trans
413
import Control.Monad.Eff
514
import Data.Either
15+
import Data.Function
616

717
data Free f a = Pure a
818
| Free (f (Free f a))
9-
| Gosub (forall s. (forall r. ({} -> Free f r) -> (r -> Free f a) -> s) -> s)
19+
| Gosub (forall s. (forall r. (Unit -> Free f r) -> (r -> Free f a) -> s) -> s)
1020

1121
class MonadFree f m where
1222
wrap :: forall a. f (m a) -> m a
@@ -45,77 +55,92 @@ pureF a = Free (pure (Pure a))
4555
iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
4656
iterM _ (Pure a) = return a
4757
iterM k (Free f) = k $ iterM k <$> f
48-
iterM k (Gosub f) = f (\req recv -> iterM k (req {}) >>= (iterM k <<< recv))
58+
iterM k (Gosub f) = f (\req recv -> iterM k (req unit) >>= (iterM k <<< recv))
4959

5060
-- Note: can blow the stack!
5161
goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
5262
goM k f = case resume f of
5363
Left s -> k s >>= goM k
5464
Right a -> return a
5565

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
66+
resumeGosub :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) (Free f a)
67+
resumeGosub (Gosub f) = f (\a g ->
68+
case a unit of
5969
Pure a -> Right (g a)
6070
Free t -> Left ((\h -> h >>= g) <$> t)
61-
Gosub h -> Right (h (\b i -> b {} >>= (\x -> i x >>= g)))
71+
Gosub h -> Right (h (\b i -> b unit >>= (\x -> i x >>= g)))
6272
)
6373

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-
\ }\
74+
isGosub :: forall f a. Free f a -> Boolean
75+
isGosub (Gosub _) = true
76+
isGosub _ = false
77+
78+
unsafeFreeToEither :: forall f a. Free f a -> Either (f (Free f a)) a
79+
unsafeFreeToEither (Pure x) = Right x
80+
unsafeFreeToEither (Free x) = Left x
81+
82+
unsafeLeft :: forall a b. Either a b -> a
83+
unsafeLeft (Left x) = x
84+
85+
unsafeRight :: forall a b. Either a b -> b
86+
unsafeRight (Right x) = x
87+
88+
foreign import resumeImpl
89+
"function resumeImpl(isGosub, isLeft, toEither, fromRight, resumeGosub, value) {\
90+
\ while (true) {\
91+
\ if (!isGosub(value)) return toEither(value);\
92+
\ var x = resumeGosub(value);\
93+
\ if (isLeft(x)) return x;\
94+
\ else value = fromRight(x);\
95+
\ }\
96+
\}" :: forall f a. Fn6
97+
(Free f a -> Boolean)
98+
(Either (f (Free f a)) a -> Boolean)
99+
(Free f a -> Either (f (Free f a)) a)
100+
(Either (f (Free f a)) a -> a)
101+
(Free f a -> Either (f (Free f a)) (Free f a))
102+
(Free f a)
103+
(Either (f (Free f a)) a)
104+
105+
resume :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
106+
resume f = runFn6 resumeImpl isGosub isLeft unsafeFreeToEither unsafeRight resumeGosub f
107+
108+
foreign import goImpl
109+
"function goImpl(resume, isRight, fromLeft, fromRight, fn, value) {\
110+
\ while (true) {\
111+
\ var r = resume(value);\
112+
\ if (isRight(r)) return fromRight(r);\
113+
\ value = fn(fromLeft(r));\
114+
\ }\
115+
\}" :: forall f a. Fn6
116+
(Free f a -> Either (f (Free f a)) a)
117+
(Either (f (Free f a)) a -> Boolean)
118+
(Either (f (Free f a)) a -> (f (Free f a)))
119+
(Either (f (Free f a)) a -> a)
120+
(f (Free f a) -> Free f a)
121+
(Free f a)
122+
a
123+
124+
go :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
125+
go fn f = runFn6 goImpl resume isRight unsafeLeft unsafeRight fn f
126+
127+
foreign import goEffImpl
128+
"function goEffImpl(resume, isRight, fromLeft, fromRight, fn, value) {\
129+
\ return function(){\
130+
\ while (true) {\
131+
\ var r = resume(value);\
132+
\ if (isRight(r)) return fromRight(r);\
133+
\ value = fn(fromLeft(r))();\
134+
\ }\
82135
\ };\
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
136+
\}" :: forall e f a. Fn6
137+
(Free f a -> Either (f (Free f a)) a)
138+
(Either (f (Free f a)) a -> Boolean)
139+
(Either (f (Free f a)) a -> (f (Free f a)))
140+
(Either (f (Free f a)) a -> a)
141+
(f (Free f a) -> Eff e (Free f a))
142+
(Free f a)
143+
(Eff e a)
144+
145+
goEff :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a
146+
goEff fn f = runFn6 goEffImpl resume isRight unsafeLeft unsafeRight fn f

0 commit comments

Comments
 (0)