Rework compat

Author: natefaubion

README.md

@@ -75,11 +75,9 @@ exports._ajaxGet = function (request) { // accepts a request
     });
 
     // Return a canceler, which is just another Aff effect.
-    return function (cancelError) {
-      return function (cancelerError, cancelerSuccess) {
-        req.cancel(); // cancel the request
-        cancelerSuccess(); // invoke the success callback for the canceler
-      };
+    return function (cancelError, cancelerError, cancelerSuccess) {
+      req.cancel(); // cancel the request
+      cancelerSuccess(); // invoke the success callback for the canceler
     };
   };
 };

bower.json

@@ -32,6 +32,7 @@
   "devDependencies": {
     "purescript-partial": "^1.2.0",
     "purescript-minibench": "^1.0.0",
-    "purescript-assert": "^3.0.0"
+    "purescript-assert": "^3.0.0",
+    "purescript-js-timers": "^3.0.0"
   }
 }

src/Control/Monad/Aff/Compat.purs

@@ -3,19 +3,22 @@
 module Control.Monad.Aff.Compat
   ( EffFnAff(..)
   , EffFnCanceler(..)
-  , fromEffFnAff
+  , EffFnCb
+  , toAff
+  , module Control.Monad.Eff.Uncurried
   ) where
 
 import Prelude
-import Control.Monad.Aff (Aff, Canceler(..), makeAff)
-import Control.Monad.Eff.Class (liftEff)
+import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler)
 import Control.Monad.Eff.Exception (Error)
-import Control.Monad.Eff.Uncurried as Fn
+import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, EffFn3, mkEffFn1, mkEffFn2, mkEffFn3, runEffFn1, runEffFn2, runEffFn3)
 import Data.Either (Either(..))
 
-newtype EffFnAff eff a = EffFnAff (Fn.EffFn2 eff (Fn.EffFn1 eff Error Unit) (Fn.EffFn1 eff a Unit) (EffFnCanceler eff))
+type EffFnCb eff a = EffFn1 eff a Unit
 
-newtype EffFnCanceler eff = EffFnCanceler (Fn.EffFn1 eff Error (EffFnAff eff Unit))
+newtype EffFnAff eff a = EffFnAff (EffFn2 eff (EffFnCb eff Error) (EffFnCb eff a) (EffFnCanceler eff))
+
+newtype EffFnCanceler eff = EffFnCanceler (EffFn3 eff Error (EffFnCb eff Error) (EffFnCb eff Unit) Unit)
 
 -- | Lift a FFI definition into an `Aff`. `EffFnAff` makes use of `EffFn` so
 -- | `Eff` thunks are unnecessary. A definition might follow this example:
@@ -29,11 +32,9 @@ newtype EffFnCanceler eff = EffFnCanceler (Fn.EffFn1 eff Error (EffFnAff eff Uni
 -- |       onSuccess(res);
 -- |     }
 -- |   });
--- |   return function (cancelError) {
--- |     return function (onCancelerError, onCancelerSuccess) {
--- |       cancel();
--- |       onCancelerSuccess();
--- |     };
+-- |   return function (cancelError, onCancelerError, onCancelerSuccess) {
+-- |     cancel();
+-- |     onCancelerSuccess();
 -- |   };
 -- | };
 -- | ```
@@ -44,7 +45,9 @@ newtype EffFnCanceler eff = EffFnCanceler (Fn.EffFn1 eff Error (EffFnAff eff Uni
 -- | myAff :: forall eff. Aff (myeffect :: MYEFFECT | eff) String
 -- | myAff = fromEffFnAff _myAff
 -- | ````
-fromEffFnAff ∷ ∀ eff a. EffFnAff eff a → Aff eff a
-fromEffFnAff (EffFnAff eff) = makeAff \k → do
-  EffFnCanceler canceler ← Fn.runEffFn2 eff (Fn.mkEffFn1 (k <<< Left)) (Fn.mkEffFn1 (k <<< Right))
-  pure $ Canceler \e → fromEffFnAff =<< liftEff (Fn.runEffFn1 canceler e)
+toAff ∷ ∀ eff a. EffFnAff eff a → Aff eff a
+toAff (EffFnAff eff) = makeAff \k → do
+  EffFnCanceler canceler ← runEffFn2 eff (mkEffFn1 (k <<< Left)) (mkEffFn1 (k <<< Right))
+  pure $ Canceler \e → makeAff \k2 → do
+    runEffFn3 canceler e (mkEffFn1 (k2 <<< Left)) (mkEffFn1 (k2 <<< Right))
+    pure nonCanceler

test/Test/Main.purs

@@ -5,6 +5,7 @@ import Prelude
 import Control.Alt ((<|>))
 import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never, supervise, Error, error, message)
 import Control.Monad.Aff.AVar (AVAR, makeEmptyVar, takeVar, putVar)
+import Control.Monad.Aff.Compat as AC
 import Control.Monad.Eff (Eff, runPure)
 import Control.Monad.Eff.Class (class MonadEff, liftEff)
 import Control.Monad.Eff.Console (CONSOLE)
@@ -13,6 +14,7 @@ import Control.Monad.Eff.Exception (throwException, EXCEPTION)
 import Control.Monad.Eff.Ref (REF, Ref)
 import Control.Monad.Eff.Ref as Ref
 import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
+import Control.Monad.Eff.Timer (TIMER, setTimeout, clearTimeout)
 import Control.Monad.Error.Class (throwError, catchError)
 import Control.Parallel (parallel, sequential, parTraverse_)
 import Data.Array as Array
@@ -25,7 +27,7 @@ import Data.Time.Duration (Milliseconds(..))
 import Data.Traversable (traverse)
 import Test.Assert (assert', ASSERT)
 
-type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION, avar ∷ AVAR | eff)
+type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION, avar ∷ AVAR, timer ∷ TIMER | eff)
 type TestEff eff = Eff (TestEffects eff)
 type TestAff eff = Aff (TestEffects eff)
 
@@ -561,6 +563,24 @@ test_avar_order = assert "avar/order" do
   joinFiber f1
   eq "takenfoo" <$> readRef ref
 
+test_efffn ∷ ∀ eff. TestAff eff Unit
+test_efffn = assert "efffn" do
+  ref ← newRef ""
+  let
+    jsDelay ms = AC.toAff $ AC.EffFnAff $ AC.mkEffFn2 \ke kc → do
+      tid ← setTimeout ms (AC.runEffFn1 kc unit)
+      pure $ AC.EffFnCanceler $ AC.mkEffFn3 \e cke ckc → do
+        clearTimeout tid
+        AC.runEffFn1 ckc unit
+    action = do
+      jsDelay 10
+      modifyRef ref (_ <> "done")
+  f1 ← forkAff action
+  f2 ← forkAff action
+  killFiber (error "Nope.") f2
+  delay (Milliseconds 20.0)
+  eq "done" <$> readRef ref
+
 test_parallel_stack ∷ ∀ eff. TestAff eff Unit
 test_parallel_stack = assert "parallel/stack" do
   ref ← newRef 0
@@ -609,6 +629,7 @@ main = do
     test_parallel_mixed
     test_kill_parallel_alt
     test_avar_order
+    test_efffn
     test_fiber_map
     test_fiber_apply
     -- Turn on if we decide to schedule forks