Topic/free

Gruntfile.js

@@ -2,15 +2,15 @@ module.exports = function(grunt) {
 
   "use strict";
 
-  grunt.initConfig({ 
-  
+  grunt.initConfig({
+
     libFiles: [
       "src/**/*.purs",
       "bower_components/purescript-*/src/**/*.purs*"
     ],
-  
+
     clean: ["output", "tmp"],
-    
+
     pscMake: ["<%=libFiles%>"],
     dotPsci: ["<%=libFiles%>"],
     docgen: {
@@ -19,7 +19,7 @@ module.exports = function(grunt) {
             dest: "README.md"
         }
     },
-  
+
     psc: {
       options: {
         main: true
@@ -39,9 +39,13 @@ module.exports = function(grunt) {
       exampleCont: {
         src: ["examples/Cont.purs", "<%=libFiles%>"],
         dest: "tmp/Cont.js"
+      },
+      exampleFree: {
+        src: ["examples/Free.purs", "<%=libFiles%>"],
+        dest: "tmp/Free.js"
       }
     },
-    
+
     execute: {
       exampleReader: {
         src: "tmp/Reader.js"
@@ -54,9 +58,12 @@ module.exports = function(grunt) {
       },
       exampleCont: {
         src: "tmp/Cont.js"
+      },
+      exampleFree: {
+        src: "tmp/Free.js"
       }
     }
-    
+
   });
 
   grunt.loadNpmTasks("grunt-purescript");
@@ -67,6 +74,7 @@ module.exports = function(grunt) {
   grunt.registerTask("exampleState", ["psc:exampleState", "execute:exampleState"]);
   grunt.registerTask("exampleWriter", ["psc:exampleWriter", "execute:exampleWriter"]);
   grunt.registerTask("exampleCont", ["psc:exampleCont", "execute:exampleCont"]);
+  grunt.registerTask("exampleFree", ["psc:exampleFree", "execute:exampleFree"]);
   grunt.registerTask("examples", ["psc", "execute"]);
   grunt.registerTask("make", ["pscMake", "dotPsci", "docgen"]);
   grunt.registerTask("default", ["make"]);

README.md

@@ -135,6 +135,58 @@
     runErrorT :: forall e m a. ErrorT e m a -> m (Either e a)
 
 
+## Module Control.Monad.Free
+
+### Types
+
+    data Free f a where
+      Pure :: a -> Free f a
+      Free :: f (Free f a) -> Free f a
+      Gosub :: forall s. (forall r. ({  } -> Free f r) -> (r -> Free f a) -> s) -> s -> Free f a
+
+
+### Type Classes
+
+    class MonadFree f m where
+      wrap :: forall a. f (m a) -> m a
+
+
+### Type Class Instances
+
+    instance applicativeFree :: (Functor f) => Applicative (Free f)
+
+    instance applyFree :: (Functor f) => Apply (Free f)
+
+    instance bindFree :: (Functor f) => Bind (Free f)
+
+    instance functorFree :: (Functor f) => Functor (Free f)
+
+    instance monadFree :: (Functor f) => Monad (Free f)
+
+    instance monadFreeFree :: (Functor f) => MonadFree f (Free f)
+
+    instance monadTransFree :: MonadTrans Free
+
+
+### Values
+
+    go :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
+
+    goEff :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a
+
+    goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
+
+    iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
+
+    liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
+
+    pureF :: forall f a. (Applicative f) => a -> Free f a
+
+    resume :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
+
+    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)
+
+
 ## Module Control.Monad.Identity
 
 ### Types
@@ -386,6 +438,36 @@
     withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
 
 
+## Module Control.Monad.Trampoline
+
+### Types
+
+    data Delay a where
+      Delay :: {  } -> a -> Delay a
+
+    type Trampoline a = Free Delay a
+
+
+### Type Class Instances
+
+    instance delayApplicative :: Applicative Delay
+
+    instance delayApply :: Apply Delay
+
+    instance delayFunctor :: Functor Delay
+
+
+### Values
+
+    delay :: forall a. ({  } -> a) -> Trampoline a
+
+    done :: forall a. a -> Trampoline a
+
+    runTrampoline :: forall a. Trampoline a -> a
+
+    suspend :: forall a. Trampoline a -> Trampoline a
+
+
 ## Module Control.Monad.Trans
 
 ### Type Classes

examples/Free.purs

@@ -0,0 +1,33 @@
+module Main where
+
+import Control.Monad.Eff
+import Control.Monad.Free
+import Debug.Trace
+
+data TeletypeF a = PutStrLn String a | GetLine (String -> a)
+
+instance teletypeFFunctor :: Functor TeletypeF where
+  (<$>) f (PutStrLn s a) = PutStrLn s (f a)
+  (<$>) f (GetLine k) = GetLine (\s -> f (k s))
+
+type Teletype = Free TeletypeF
+
+putStrLn :: String -> Teletype {}
+putStrLn s = liftF $ PutStrLn s {}
+
+getLine :: Teletype String
+getLine = liftF $ GetLine (\a -> a)
+
+runF :: forall a. TeletypeF a -> Eff (trace :: Trace) a
+runF (PutStrLn s a) = (\_ -> a) <$> trace s
+runF (GetLine k) = return $ k "fake input"
+
+run :: forall a. Teletype a -> Eff (trace :: Trace) a
+run = goEff runF
+
+echo = do
+  a <- getLine
+  putStrLn a
+  putStrLn "Finished"
+
+main = run $ echo

src/Control/Monad/Free.purs

@@ -0,0 +1,121 @@
+module Control.Monad.Free where
+
+import Control.Monad.Trans
+import Control.Monad.Eff
+import Data.Either
+
+data Free f a = Pure a
+              | Free (f (Free f a))
+              | Gosub (forall s. (forall r. ({} -> Free f r) -> (r -> Free f a) -> s) -> s)
+
+class MonadFree f m where
+  wrap :: forall a. f (m a) -> m a
+
+instance functorFree :: (Functor f) => Functor (Free f) where
+  (<$>) f (Pure a) = Pure (f a)
+  (<$>) f g = liftA1 f g
+
+instance applyFree :: (Functor f) => Apply (Free f) where
+  (<*>) = ap
+
+instance applicativeFree :: (Functor f) => Applicative (Free f) where
+  pure = Pure
+
+instance bindFree :: (Functor f) => Bind (Free f) where
+  (>>=) (Gosub g) f = Gosub (\h -> g (\a i -> h a (\x -> Gosub (\j -> j (const (i x)) f))))
+  (>>=) a         f = Gosub (\h -> h (const a) f)
+
+instance monadFree :: (Functor f) => Monad (Free f)
+
+instance monadTransFree :: MonadTrans Free where
+  lift f = Free $ do
+    a <- f
+    return (Pure a)
+
+instance monadFreeFree :: (Functor f) => MonadFree f (Free f) where
+  wrap = Free
+
+liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
+liftF fa = wrap $ return <$> fa
+
+pureF :: forall f a. (Applicative f) => a -> Free f a
+pureF a = Free (pure (Pure  a))
+
+-- Note: can blow the stack!
+iterM :: forall f m a. (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Free f a -> m a
+iterM _ (Pure a) = return a
+iterM k (Free f) = k $ iterM k <$> f
+iterM k (Gosub f) = f (\req recv -> iterM k (req {}) >>= (iterM k <<< recv))
+
+-- Note: can blow the stack!
+goM :: forall f m a. (Functor f, Monad m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
+goM k f = case resume f of
+            Left s -> k s >>= goM k
+            Right a -> return a
+
+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)
+resumeGosub f = f (\a g ->
+  case a {} of
+    Pure a -> Right (g a)
+    Free t -> Left ((\h -> h >>= g) <$> t)
+    Gosub h -> Right (h (\b i -> b {} >>= (\x -> i x >>= g)))
+  )
+
+foreign import resume
+  "function resume(__dict_Functor) {\
+  \  return function(__copy__1) {\
+  \    var _1 = __copy__1;\
+  \    tco: while (true)\
+  \      if (_1.ctor === 'Control.Monad.Free.Pure')\
+  \        return Data_Either.Right(_1.values[0]);\
+  \      else if (_1.ctor === 'Control.Monad.Free.Free')\
+  \        return Data_Either.Left(_1.values[0]);\
+  \      else {\
+  \        var x = resumeGosub(__dict_Functor)(_1.values[0]);\
+  \        if (x.ctor === 'Data.Either.Left')\
+  \          return x;\
+  \        else {\
+  \          _1 = x.values[0];\
+  \          continue tco;\
+  \        }\
+  \      }\
+  \  };\
+  \}" :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
+
+foreign import go
+  "function go(__dict_Functor) {\
+  \  return function(f) {\
+  \    return function(__copy__1) {\
+  \      var _1 = __copy__1;\
+  \      var r;\
+  \      tco: while (true) {\
+  \        r = resume(__dict_Functor)(_1);\
+  \        if (r.ctor === 'Data.Either.Left') {\
+  \          _1 = f(r.values[0]);\
+  \          continue tco;\
+  \        } else\
+  \          return r.values[0];\
+  \      }\
+  \    };\
+  \  };\
+  \}" :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
+
+foreign import goEff
+  "function goEff(__dict_Functor) {\
+  \  return function(f) {\
+  \    return function(__copy__1) {\
+  \      return function(){\
+  \        var _1 = __copy__1;\
+  \        var r;\
+  \        tco: while (true) {\
+  \          r = resume(__dict_Functor)(_1);\
+  \          if (r.ctor === 'Data.Either.Left') {\
+  \            _1 = f(r.values[0])();\
+  \            continue tco;\
+  \          } else\
+  \            return function(){return r.values[0];};\
+  \        }\
+  \      };\
+  \    };\
+  \  };\
+  \}" :: 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

@@ -0,0 +1,28 @@
+module Control.Monad.Trampoline where
+
+import Control.Monad.Free
+
+data Delay a = Delay ({} -> a)
+
+instance delayFunctor :: Functor Delay where
+  (<$>) f (Delay g) = Delay (const (f (g {})))
+
+instance delayApply :: Apply Delay where
+  (<*>) (Delay f) (Delay a) = Delay (\{} -> (f {}) (a {}))
+
+instance delayApplicative :: Applicative Delay where
+  pure a = Delay (\{} -> a)
+
+type Trampoline a = Free Delay a
+
+done :: forall a. a -> Trampoline a
+done = Pure
+
+suspend :: forall a. Trampoline a -> Trampoline a
+suspend a = Free (Delay (\{} -> a))
+
+delay :: forall a. ({} -> a) -> Trampoline a
+delay a = Free (done <$> Delay a)
+
+runTrampoline :: forall a. Trampoline a -> a
+runTrampoline = go (\(Delay f) -> f {})