Merge pull request #19 from ethul/topic/coproduct-and-inject

Topic/coproduct and inject

Author: garyb

Gruntfile.js

@@ -13,26 +13,36 @@ module.exports = function(grunt) {
 
     pscMake: ["<%=libFiles%>"],
     dotPsci: ["<%=libFiles%>"],
-    docgen: {
+    pscDocs: {
         readme: {
             src: "src/**/*.purs",
             dest: "README.md"
         }
     },
 
     psc: {
-      options: {
-        main: "Teletype"
-      },
-      example: {
+      teletypeExample: {
+        options: {
+          main: "Teletype"
+        },
         src: ["examples/Teletype.purs", "<%=libFiles%>"],
         dest: "tmp/Teletype.js"
+      },
+      teletypeCoproductExample: {
+        options: {
+          main: "TeletypeCoproduct"
+        },
+        src: ["examples/TeletypeCoproduct.purs", "<%=libFiles%>"],
+        dest: "tmp/TeletypeCoproduct.js"
       }
     },
 
     execute: {
-      example: {
+      teletypeExample: {
         src: "tmp/Teletype.js"
+      },
+      teletypeCoproductExample: {
+        src: "tmp/TeletypeCoproduct.js"
       }
     }
 
@@ -43,6 +53,6 @@ module.exports = function(grunt) {
   grunt.loadNpmTasks("grunt-contrib-clean");
 
   grunt.registerTask("example", ["psc", "execute"]);
-  grunt.registerTask("make", ["pscMake", "dotPsci", "docgen"]);
+  grunt.registerTask("make", ["pscMake", "dotPsci", "pscDocs"]);
   grunt.registerTask("default", ["make"]);
 };

README.md

@@ -84,12 +84,16 @@
 
     goMC :: forall f m a. (Monad m) => Natural f m -> FreeC f a -> m a
 
+    injC :: forall f g a. (Inject f g) => FreeC f a -> FreeC g 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
 
     liftFC :: forall f a. f a -> FreeC f a
 
+    mapF :: forall f g a. (Functor f, Functor g) => Natural f g -> Free f a -> Free g a
+
     pureF :: forall f a. (Applicative f) => a -> Free f a
 
     pureFC :: forall f a. (Applicative f) => a -> FreeC f a

bower.json

@@ -29,6 +29,8 @@
     "purescript-exists": "~0.1.0",
     "purescript-transformers": "~0.3.0",
     "purescript-lazy": "~0.1.1",
-    "purescript-foldable-traversable": "~0.1.4"
+    "purescript-foldable-traversable": "~0.1.4",
+    "purescript-coproducts": "~0.1.0",
+    "purescript-inject": "~0.0.2"
   }
 }

examples/TeletypeCoproduct.purs

@@ -0,0 +1,67 @@
+module TeletypeCoproduct where
+
+import Control.Apply ((*>))
+import Control.Alt ((<|>))
+import Control.Monad.Eff (Eff())
+import Control.Monad.Free (FreeC(), liftFC, injC, goEffC)
+import Data.Coyoneda (Natural())
+import Data.Inject (prj)
+import Data.Functor.Coproduct (Coproduct())
+import Data.Maybe.Unsafe (fromJust)
+import Debug.Trace (Trace(), trace)
+
+data Teletype1F a = Print1 String a
+
+type Teletype1 a = FreeC Teletype1F a
+
+print1 :: String -> Teletype1 Unit
+print1 a = liftFC $ Print1 a unit
+
+data Teletype2F a = Print2 String a
+
+type Teletype2 a = FreeC Teletype2F a
+
+print2 :: String -> Teletype2 Unit
+print2 a = liftFC $ Print2 a unit
+
+data Teletype3F a = Print3 String a
+
+type Teletype3 a = FreeC Teletype3F a
+
+print3 :: String -> Teletype3 Unit
+print3 a = liftFC $ Print3 a unit
+
+type TF = Coproduct Teletype1F (Coproduct Teletype2F Teletype3F)
+
+type T a = FreeC TF a
+
+r :: T Unit
+r = injC $ print1 "1"
+
+s :: T Unit
+s = injC $ print2 "2"
+
+t :: T Unit
+t = injC $ print3 "3"
+
+u :: T Unit
+u =  r *> s *> t
+
+teletype1N :: forall e. Natural Teletype1F (Eff (trace :: Trace | e))
+teletype1N (Print1 s a) = const a <$> trace ("teletype1: " ++ s)
+
+teletype2N :: forall e. Natural Teletype2F (Eff (trace :: Trace | e))
+teletype2N (Print2 s a) = const a <$> trace ("teletype2: " ++ s)
+
+teletype3N :: forall e. Natural Teletype3F (Eff (trace :: Trace | e))
+teletype3N (Print3 s a) = const a <$> trace ("teletype3: " ++ s)
+
+tN :: forall e. Natural TF (Eff (trace :: Trace | e))
+tN fa = fromJust$ (teletype1N <$> prj fa) <|>
+                  (teletype2N <$> prj fa) <|>
+                  (teletype3N <$> prj fa)
+
+run :: forall a. T a -> Eff (trace :: Trace) a
+run = goEffC tN
+
+main = run u

src/Control/Monad/Free.purs

@@ -4,6 +4,7 @@ module Control.Monad.Free
   , MonadFree, wrap
   , liftF, liftFC
   , pureF, pureFC
+  , mapF, injC
   , iterM
   , goM, goMC
   , go
@@ -15,6 +16,7 @@ import Control.Monad.Eff
 import Data.Coyoneda
 import Data.Either
 import Data.Function
+import Data.Inject (Inject, inj)
 
 data Free f a = Pure a
               | Free (f (Free f a))
@@ -61,6 +63,12 @@ liftFC = liftF <<< liftCoyoneda
 pureFC :: forall f a. (Applicative f) => a -> FreeC f a
 pureFC = liftFC <<< pure
 
+mapF :: forall f g a. (Functor f, Functor g) => Natural f g -> Free f a -> Free g a
+mapF t fa = either (\s -> Free <<< t $ mapF t <$> s) Pure (resume fa)
+
+injC :: forall f g a. (Inject f g) => FreeC f a -> FreeC g a
+injC = mapF (liftCoyonedaT inj)
+
 -- 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
@@ -100,23 +108,23 @@ go fn f = case resume f of
   Left l -> go fn (fn l)
   Right r -> r
 
-foreign import goEffImpl
-  "function goEffImpl(resume, isRight, fromLeft, fromRight, fn, value) {\
-  \  return function(){\
-  \    while (true) {\
-  \      var r = resume(value);\
-  \      if (isRight(r)) return fromRight(r);\
-  \      value = fn(fromLeft(r))();\
-  \    }\
-  \  };\
-  \}" :: forall e f a. Fn6
-         (Free f a -> Either (f (Free f a)) a)
-         (Either (f (Free f a)) a -> Boolean)
-         (Either (f (Free f a)) a -> (f (Free f a)))
-         (Either (f (Free f a)) a -> a)
-         (f (Free f a) -> Eff e (Free f a))
-         (Free f a)
-         (Eff e a)
+foreign import goEffImpl """
+  function goEffImpl(resume, isRight, fromLeft, fromRight, fn, value) {
+    return function(){
+      while (true) {
+        var r = resume(value);
+        if (isRight(r)) return fromRight(r);
+        value = fn(fromLeft(r))();
+      }
+    };
+  }""" :: forall e f a. Fn6
+          (Free f a -> Either (f (Free f a)) a)
+          (Either (f (Free f a)) a -> Boolean)
+          (Either (f (Free f a)) a -> (f (Free f a)))
+          (Either (f (Free f a)) a -> a)
+          (f (Free f a) -> Eff e (Free f a))
+          (Free f a)
+          (Eff e a)
 
 goEff :: forall e f a. (Functor f) => (f (Free f a) -> Eff e (Free f a)) -> Free f a -> Eff e a
 goEff fn f = runFn6 goEffImpl resume isRight unsafeLeft unsafeRight fn f