Merge branch 'puffnfresh-trampoline'

Author: ethul

README.md

@@ -1,3 +1,81 @@
-# purescript-free
+# Module Documentation
 
-Free monads based on the Haskell [implementation](https://github.com/ekmett/free).
+## Module Control.Monad.Free
+
+### Types
+
+    data Free f a where
+      Return :: a -> Free f a
+      Suspend :: 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 monadTransFree :: MonadTrans Free
+
+    instance monadFreeFree :: (Functor f) => MonadFree f (Free f)
+
+
+### Values
+
+    bindFree :: forall f a b. (a -> Free f b) -> Free f a -> Free f b
+
+    go :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
+
+    liftF :: forall f a. (Functor f) => f a -> Free f a
+
+    pureF :: forall f a. (Applicative f) => a -> Free f a
+
+    -- Note: can blow the stack!
+    iterM :: forall f m a. (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m 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.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

bower.json

@@ -15,6 +15,7 @@
     "dist"
   ],
   "dependencies": {
-    "purescript-transformers": "64fa7200dc328fc79090426cddb64ed6e4ccffc9"
+    "purescript-transformers": "64fa7200dc328fc79090426cddb64ed6e4ccffc9",
+    "purescript-either": "*"
   }
 }

src/Control/Monad/Free.purs

@@ -1,17 +1,19 @@
 module Control.Monad.Free where
 
 import Prelude
+import Data.Either
 import Control.Monad.Trans
 
-data Free f a = Pure a | Free (f (Free f a))
+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 = go where
-    go (Pure a)  = Pure (f a)
-    go (Free fa) = Free (go <$> fa)
+  (<$>) f (Pure a) = Pure (f a)
+  (<$>) f g = liftA1 f g
 
 instance applyFree :: (Functor f) => Apply (Free f) where
   (<*>) = ap
@@ -20,8 +22,8 @@ instance applicativeFree :: (Functor f) => Applicative (Free f) where
   pure = Pure
 
 instance bindFree :: (Functor f) => Bind (Free f) where
-  (>>=) (Pure a) f = f a
-  (>>=) (Free m) f = Free ((<$>) (\a -> a >>= f) m)
+  (>>=) (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)
 
@@ -36,6 +38,58 @@ instance monadFreeFree :: (Functor f) => MonadFree f (Free f) where
 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) => (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 (Free f) = k $ iterM k <$> f
+iterM k (Gosub f) = iterM k $ f (\req recv -> req {} >>= recv)
+
+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

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 {})