Implementing PromiseEC based on ErrorT and ContT

ethul · ethul · commit b716713b4e5d · 2014-11-16T17:20:53.000-05:00
Based on discussions in issue #18 and pull request #20
diff --git a/MODULE.md b/MODULE.md
@@ -381,7 +381,7 @@
 
     data Http :: *
 
-    type HttpResponse e r a b c d = HttpEff e (Promise (Response r a b c d) (Response r a b c d))
+    type HttpResponse e r a b c d = HttpEff e (Promise I.ForeignResponse (Response r a b c d))
 
     type Response r a b c d = { statusText :: String, config :: Config a b c d, headers :: [String] -> String, status :: Status, "data" :: D.HttpData r }
 
@@ -681,13 +681,19 @@
 
     data Promise :: * -> * -> *
 
+    type PromiseEC e a b = ErrorT a (ContT Unit (Eff e)) b
+
 
 ### Values
 
     catch :: forall a b c d. (a -> Promise c d) -> Promise a b -> Promise c d
 
     finally :: forall e r a b. Eff e r -> Promise a b -> Promise a b
 
+    liftPromiseEC :: forall e a b. (Error a) => Eff e (Promise a b) -> PromiseEC e a b
+
+    runPromiseEC :: forall e a b. PromiseEC e a b -> (Either a b -> Eff e Unit) -> Eff e Unit
+
     then1 :: forall a b c. (b -> Promise a c) -> Promise a b -> Promise a c
 
     then1' :: forall a b c. (b -> c) -> Promise a b -> Promise a c
@@ -884,6 +890,11 @@
     data ForeignResponse :: *
 
 
+### Type Class Instances
+
+    instance errorForeignResponse :: Error ForeignResponse
+
+
 ### Values
 
     foreignConfig :: forall e. HttpEff e ForeignConfig
diff --git a/bower.json b/bower.json
@@ -21,6 +21,7 @@
     "purescript-exceptions": "0.2.1",
     "purescript-foldable-traversable": "0.1.4",
     "purescript-maybe": "0.2.1",
+    "purescript-transformers": "0.3.0",
     "purescript-tuples": "0.2.1",
     "purescript-simple-dom": "git://github.com/aktowns/purescript-simple-dom.git"
   },
diff --git a/examples/Backend/Main.purs b/examples/Backend/Main.purs
@@ -0,0 +1,30 @@
+module Backend.Main where
+
+import Control.Monad.Eff
+import Data.Either (either)
+
+import Angular.Http (Http(), get)
+import Angular.Module (controller, ngmodule')
+import Angular.Promise (liftPromiseEC, runPromiseEC)
+import Angular.This (extendThis)
+
+mainctrl http this = extendThis { text: ""
+                                , submit: submit } this
+  where
+    url = "http://localhost:9501/examples/Backend/main.html"
+    submit a = runPromiseEC (do p <- liftPromiseEC $ get url http
+                                q <- liftPromiseEC $ get url http
+                                return q) (either (\e -> extendThis { value: "Failed to get" ++ url } this)
+                                                  (\a -> extendThis { value: a."data" } this))
+
+main = do
+  m <- ngmodule' "backend" []
+  controller "Main" mainctrl' m
+
+foreign import mainctrl'
+  """
+  /*@ngInject*/function mainctrl$prime($http) {
+    var impl = mainctrl($http)(this);
+    return impl.apply(this, []);
+  }
+  """ :: forall e a. Http -> Eff e Unit
diff --git a/examples/Backend/main.html b/examples/Backend/main.html
@@ -0,0 +1,30 @@
+<!doctype html>
+<html class="no-js"
+      lang=""
+      ng-app="backend">
+  <head>
+    <meta charset="utf-8">
+    <meta http-equiv="X-UA-Compatible"
+          content="IE=edge">
+    <title>Backend</title>
+    <meta name="description"
+          content="">
+    <meta name="viewport"
+          content="width=device-width, initial-scale=1">
+    <link rel="stylesheet"
+          href="../../bower_components/angular/angular-csp.css">
+  </head>
+  <body ng-controller="Main as mainctrl">
+    <form ng-submit="mainctrl.submit(mainctrl.text)()"
+          novalidate>
+      <button type="submit">
+        Submit
+      </button>
+    </form>
+    <code ng-cloak>
+      {{mainctrl.value.value0}}
+    </code>
+    <script src="../../bower_components/angular/angular.js"></script>
+    <script src="../../dist/backend.js"></script>
+  </body>
+</html>
diff --git a/gulpfile.js b/gulpfile.js
@@ -13,14 +13,23 @@ var gulp = require('gulp')
           'src/**/*.purs'
         ],
         examples: {
-          todomvc: 'examples/Todomvc/**/*.purs'
+          todomvc: {
+            src: 'examples/Todomvc/**/*.purs',
+            options: {
+              main: 'Todomvc.Main',
+              output: 'todomvc.js'
+            }
+          },
+          backend: {
+            src: 'examples/Backend/**/*.purs',
+            options: {
+              main: 'Backend.Main',
+              output: 'backend.js'
+            }
+          }
         },
         dest: 'dist',
-        docs: 'MODULE.md',
-        options: {
-          main: 'Todomvc.Main',
-          output: 'todomvc.js'
-        }
+        docs: 'MODULE.md'
       },
       nstatic: {
         root: '.',
@@ -55,9 +64,19 @@ gulp.task('clean', function(){
 
 gulp.task('todomvc', ['clean'], function(){
   return (
-    gulp.src([config.purescript.examples.todomvc].concat(config.purescript.src)).
+    gulp.src([config.purescript.examples.todomvc.src].concat(config.purescript.src)).
     pipe(plumber()).
-    pipe(purescript.psc(config.purescript.options)).
+    pipe(purescript.psc(config.purescript.examples.todomvc.options)).
+    on('error', error).
+    pipe(gulp.dest(config.purescript.dest))
+  );
+});
+
+gulp.task('backend', ['clean'], function(){
+  return (
+    gulp.src([config.purescript.examples.backend.src].concat(config.purescript.src)).
+    pipe(plumber()).
+    pipe(purescript.psc(config.purescript.examples.backend.options)).
     on('error', error).
     pipe(gulp.dest(config.purescript.dest))
   );
@@ -96,7 +115,12 @@ gulp.task('watch', function(cb){
 });
 
 gulp.task('watch.todomvc', function(cb){
-  gulp.watch([config.purescript.examples.todomvc].concat(config.purescript.src), ['todomvc']);
+  gulp.watch([config.purescript.examples.todomvc.src].concat(config.purescript.src), ['todomvc']);
+  server(cb);
+});
+
+gulp.task('watch.backend', function(cb){
+  gulp.watch([config.purescript.examples.backend.src].concat(config.purescript.src), ['backend']);
   server(cb);
 });
 
diff --git a/src/Angular/Http.purs b/src/Angular/Http.purs
@@ -29,11 +29,11 @@ import qualified Data.DOM.Simple.Ajax as D
 import Angular.Cache (Cache())
 import qualified Angular.Http.Internal as I
 import Angular.Http.Types
-import Angular.Promise (Promise(), then2')
+import Angular.Promise (Promise(), then1')
 
 foreign import data Http :: *
 
-type HttpResponse e r a b c d = HttpEff e (Promise (Response r a b c d) (Response r a b c d))
+type HttpResponse e r a b c d = HttpEff e (Promise I.ForeignResponse (Response r a b c d))
 
 type ForeignHttpResponse e = HttpEff e (Promise I.ForeignResponse I.ForeignResponse)
 
@@ -77,7 +77,7 @@ config = { method: D.GET
          , responseType: D.Default }
 
 http :: forall e r a b c d. Config a b c d -> Http -> HttpResponse e r a b c d
-http c h = (then2' foreignResponse foreignResponse) <$> (foreignConfig c >>= runFn2 httpFn h)
+http c h = (then1' foreignResponse) <$> (foreignConfig c >>= runFn2 httpFn h)
 
 get :: forall e r a b c d. D.Url -> Http -> HttpResponse e r a b c d
 get u = runHttpFn' D.GET u config
@@ -119,13 +119,13 @@ runHttpFn' :: forall e r a b c d. D.HttpMethod -> D.Url -> Config a b c d -> Htt
 runHttpFn' m u c h = do
   conf <- foreignConfig c
   res <- runFn4 httpFn' (show m) u conf h
-  return $ then2' foreignResponse foreignResponse res
+  return $ then1' foreignResponse res
 
 runHttpFn'' :: forall e r a b c d. D.HttpMethod -> D.Url -> RequestData b -> Config a b c d -> Http -> HttpResponse e r a b c d
 runHttpFn'' m u d c h = do
   conf <- foreignConfig c
   res <- runFn5 httpFn'' (show m) u (writeRequestData d) conf h
-  return $ then2' foreignResponse foreignResponse res
+  return $ then1' foreignResponse res
 
 foreignConfig :: forall e a b c d. Config a b c d -> HttpEff e I.ForeignConfig
 foreignConfig conf = do
diff --git a/src/Angular/Http/Internal.purs b/src/Angular/Http/Internal.purs
@@ -32,6 +32,7 @@ module Angular.Http.Internal
   ) where
 
 import Control.Monad.Eff
+import Control.Monad.Error
 import Data.Either
 import Data.Foldable (for_)
 import Data.Function
@@ -47,6 +48,18 @@ foreign import data ForeignConfig :: *
 
 foreign import data ForeignResponse :: *
 
+foreign import unimplementedForeignResponse
+  """
+    function foreignResponse(){
+      return {
+      };
+    }
+  """ :: ForeignResponse
+
+instance errorForeignResponse :: Error ForeignResponse where
+  noMsg = unimplementedForeignResponse
+  strMsg = \_ -> unimplementedForeignResponse
+
 setConfigMethod :: forall e. D.HttpMethod -> ForeignConfig -> HttpEff e Unit
 setConfigMethod m = runFn3 setConfigPropFn "method" (show m)
 
diff --git a/src/Angular/Promise.purs b/src/Angular/Promise.purs
@@ -1,5 +1,6 @@
 module Angular.Promise
   ( Promise()
+  , PromiseEC()
   , then1
   , then1'
   , then2
@@ -8,18 +9,28 @@ module Angular.Promise
   , then3'
   , catch
   , finally
+  , liftPromiseEC
+  , runPromiseEC
   ) where
 
+import Control.Monad.Cont.Trans (ContT(..), runContT)
 import Control.Monad.Eff
+import Control.Monad.Error (Error)
+import Control.Monad.Error.Trans (ErrorT(..), runErrorT)
+import Control.Monad.Trans (lift)
+
+import Data.Either (Either(Right, Left))
 import Data.Function
 
 foreign import data Promise :: * -> * -> *
 
+type PromiseEC e a b = ErrorT a (ContT Unit (Eff e)) b
+
 foreign import then1Fn
   """
-  function then1Fn(f, fa){
-    return fa['then'](f);
-  }
+    function then1Fn(f, fa){
+      return fa['then'](f);
+    }
   """ :: forall a b c d. Fn2 (b -> c) (Promise a b) (Promise a d)
 
 then1 :: forall a b c. (b -> Promise a c) -> Promise a b -> Promise a c
@@ -30,9 +41,9 @@ then1' = runFn2 then1Fn
 
 foreign import then2Fn
   """
-  function then2Fn(f, g, fa){
-    return fa['then'](f, g);
-  }
+    function then2Fn(f, g, fa){
+      return fa['then'](f, g);
+    }
   """ :: forall s t a b c d. Fn3 (b -> d) (a -> c) (Promise a b) (Promise s t)
 
 then2 :: forall a b c d. (b -> Promise c d) -> (a -> Promise c d) -> Promise a b -> Promise c d
@@ -43,11 +54,11 @@ then2' = runFn3 then2Fn
 
 foreign import then3Fn
   """
-  function then3Fn(f, g, h, fa){
-    return fa['then'](f, g, function(a){
-      return h(a)();
-    });
-  }
+    function then3Fn(f, g, h, fa){
+      return fa['then'](f, g, function(a){
+        return h(a)();
+      });
+    }
   """ :: forall e q r s t a b c d. Fn4 (b -> d)
                                        (a -> c)
                                        (s -> Eff e t)
@@ -62,20 +73,45 @@ then3' = runFn4 then3Fn
 
 foreign import catchFn
   """
-  function catchFn(f, fa){ \
-    return fa['catch'](f); \
-  }
+    function catchFn(f, fa){
+      return fa['catch'](f);
+    }
   """ :: forall a b c d. Fn2 (a -> Promise c d) (Promise a b) (Promise c d)
 
 catch :: forall a b c d. (a -> Promise c d) -> Promise a b -> Promise c d
 catch = runFn2 catchFn
 
 foreign import finallyFn
   """
-  function finallyFn(f, fa){
-    return fa['finally'](f);
-  }
+    function finallyFn(f, fa){
+      return fa['finally'](f);
+    }
   """ :: forall e r a b. Fn2 (Eff e r) (Promise a b) (Promise a b)
 
 finally :: forall e r a b. Eff e r -> Promise a b -> Promise a b
 finally = runFn2 finallyFn
+
+foreign import then2ECFn
+  """
+    function then2ECFn(f, g, fa){
+      return function(){
+        var run = function(k){
+          return function(a){
+            return k(a)();
+          };
+        };
+        fa['then'](run(f), run(g));
+      };
+    }
+  """ :: forall e a b c d. Fn3 (b -> d) (a -> c) (Promise a b) (Eff e Unit)
+
+promiseEC :: forall e a b. Promise a b -> PromiseEC e a b
+promiseEC = ErrorT <<< ContT <<< cb
+  where
+    cb fa k = runFn3 then2ECFn (k <<< Right) (k <<< Left) fa
+
+liftPromiseEC :: forall e a b. (Error a) => Eff e (Promise a b) -> PromiseEC e a b
+liftPromiseEC fa = (lift $ lift fa) >>= promiseEC
+
+runPromiseEC :: forall e a b. PromiseEC e a b -> (Either a b -> Eff e Unit) -> Eff e Unit
+runPromiseEC = runContT <<< runErrorT
