Use catchError primitive instead of attempt

Author: natefaubion

src/Control/Monad/Aff.purs

@@ -1,5 +1,6 @@
 module Control.Monad.Aff
   ( module Internal
+  , module Control.Monad.Error.Class
   , liftEff'
   , forkAff
   , runAff
@@ -8,19 +9,20 @@ module Control.Monad.Aff
   ) where
 
 import Prelude
-import Control.Monad.Aff.Internal (ASYNC, Aff, Thread(..), attempt, launchAff, unsafeLaunchAff)
-import Control.Monad.Aff.Internal (Aff, ParAff, Thread, Canceler(..), ASYNC, attempt, bracket, delay, launchAff, makeAff, nonCanceler) as Internal
+import Control.Monad.Aff.Internal (ASYNC, Aff, Thread(..), launchAff, unsafeLaunchAff)
+import Control.Monad.Aff.Internal (Aff, ParAff, Thread, Canceler(..), ASYNC, bracket, delay, launchAff, makeAff, nonCanceler) as Internal
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Class (liftEff)
 import Control.Monad.Eff.Exception (Error, EXCEPTION)
 import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
+import Control.Monad.Error.Class (try)
 import Data.Either (Either)
 
 liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
 liftEff' = liftEff <<< unsafeCoerceEff
 
 runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff (async ∷ ASYNC | eff) Unit
-runAff k aff = void $ launchAff $ liftEff <<< k =<< attempt aff
+runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff
 
 forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a)
 forkAff = liftEff <<< unsafeLaunchAff

src/Control/Monad/Aff/Internal.js

@@ -10,17 +10,17 @@ data Aff eff a
   | Throw Error
   | Sync (Eff eff a)
   | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff))
-  | forall b. Attempt (Aff eff b) ?(Either Error b -> a)
+  | forall b. Catch (Error -> a) (Aff eff b) ?(b -> a)
   | forall b. Bracket (Aff eff b) (b -> Aff eff Unit) (b -> Aff eff a)
 
 */
-var PURE      = "Pure";
-var THROW     = "Throw";
-var SYNC      = "Sync";
-var ASYNC     = "Async";
-var BIND      = "Bind";
-var ATTEMPT   = "Attempt";
-var BRACKET   = "Bracket";
+var PURE    = "Pure";
+var THROW   = "Throw";
+var SYNC    = "Sync";
+var ASYNC   = "Async";
+var BIND    = "Bind";
+var CATCH   = "Catch";
+var BRACKET = "Bracket";
 
 // These are constructors used to implement the recover stack. We still use the
 // Aff constructor so that property offsets can always inline.
@@ -48,6 +48,12 @@ exports._throwError = function (error) {
   return new Aff(THROW, error);
 };
 
+exports._catchError = function (aff) {
+  return function (k) {
+    return new Aff(CATCH, aff, k);
+  };
+};
+
 exports._map = function (f) {
   return function (aff) {
     if (aff.tag === PURE) {
@@ -74,10 +80,6 @@ exports.makeAff = function (k) {
   return new Aff(ASYNC, k);
 };
 
-exports.attempt = function (aff) {
-  return new Aff(ATTEMPT, aff);
-};
-
 exports.bracket = function (acquire) {
   return function (release) {
     return function (k) {
@@ -257,8 +259,8 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) {
             break;
 
           // Enqueue the current stack of binds and continue
-          case ATTEMPT:
-            attempts = new Aff(CONS, new Aff(RECOVER, bhead, btail), attempts);
+          case CATCH:
+            attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts);
             bhead    = null;
             btail    = null;
             status   = CONTINUE;
@@ -293,16 +295,22 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) {
           } else {
             attempt = attempts._1;
             switch (attempt.tag) {
-            // We cannot recover from an interrupt. If we are able to recover
-            // we should step directly (since the return value is an Either).
+            // We cannot recover from an interrupt. Otherwise we should
+            // continue stepping, or run the exception handler if an exception
+            // was raised.
             case RECOVER:
               attempts = attempts._2;
               if (interrupt === null) {
-                bhead  = attempt._1;
-                btail  = attempt._2;
-                status = BINDSTEP;
-                step   = fail || step;
-                fail   = null;
+                bhead  = attempt._2;
+                btail  = attempt._3;
+                if (fail === null) {
+                  status = BINDSTEP;
+                  step   = fromRight(step);
+                } else {
+                  status = CONTINUE;
+                  step   = attempt._1(fromLeft(fail));
+                  fail   = null;
+                }
               }
               break;
 
@@ -356,7 +364,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) {
           tmp = false;
           for (var k in joins) {
             tmp = true;
-            runJoin(step, joins[k]);
+            runEff(joins[k](step));
           }
           joins = tmp;
           // If we have an unhandled exception, and no other thread has joined
@@ -462,21 +470,21 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) {
   };
 };
 
-function runJoin (result, cb) {
+function runEff (eff) {
   try {
-    cb(result)();
+    eff();
   } catch (error) {
     setTimeout(function () {
       throw error;
-    }, 0)
+    }, 0);
   }
 }
 
 function runSync (left, right, eff) {
   try {
     return right(eff());
   } catch (error) {
-    return left(error)
+    return left(error);
   }
 }
 

src/Control/Monad/Aff/Internal.purs

@@ -7,7 +7,6 @@ module Control.Monad.Aff.Internal
   , nonCanceler
   , makeAff
   , launchAff
-  , attempt
   , bracket
   , delay
   , unsafeLaunchAff
@@ -22,7 +21,7 @@ import Control.Monad.Eff.Class (class MonadEff, liftEff)
 import Control.Monad.Eff.Exception (Error, error)
 import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
 import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
-import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
 import Control.Monad.Rec.Class (class MonadRec, Step(..))
 import Control.MonadPlus (class MonadPlus)
 import Control.MonadZero (class MonadZero)
@@ -55,11 +54,7 @@ instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
   mempty = pure mempty
 
 instance altAff ∷ Alt (Aff eff) where
-  alt a1 a2 = do
-    res ← attempt a1
-    case res of
-      Left err → a2
-      Right r  → pure r
+  alt a1 a2 = catchError a1 (const a2)
 
 instance plusAff ∷ Plus (Aff eff) where
   empty = throwError (error "Always fails")
@@ -83,11 +78,7 @@ instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
   throwError = _throwError
 
 instance monadErrorAff ∷ MonadError Error (Aff eff) where
-  catchError aff k = do
-    res ← attempt aff
-    case res of
-      Left err → k err
-      Right r  → pure r
+  catchError = _catchError
 
 instance monadEffAff ∷ MonadEff eff (Aff eff) where
   liftEff = _liftEff
@@ -104,8 +95,8 @@ instance applyParAff ∷ Apply (ParAff eff) where
       Thread t1 ← unsafeLaunchAff ff
       Thread t2 ← unsafeLaunchAff fa
       Thread t3 ← unsafeLaunchAff do
-        f ← attempt t1.join
-        a ← attempt t2.join
+        f ← try t1.join
+        a ← try t2.join
         liftEff (k (f <*> a))
       pure $ Canceler \err →
         parSequence_
@@ -142,8 +133,8 @@ instance altParAff ∷ Alt (ParAff eff) where
             Nothing, Right _ → t.kill earlyError *> liftEff (k r)
             Just r', _ → t.kill earlyError *> liftEff (k r')
 
-      Thread t3 ← unsafeLaunchAff $ runK t2 =<< attempt t1.join
-      Thread t4 ← unsafeLaunchAff $ runK t1 =<< attempt t2.join
+      Thread t3 ← unsafeLaunchAff $ runK t2 =<< try t1.join
+      Thread t4 ← unsafeLaunchAff $ runK t1 =<< try t2.join
 
       pure $ Canceler \err →
         parSequence_
@@ -195,11 +186,11 @@ delay (Milliseconds n) = Fn.runFn2 _delay Right n
 
 foreign import _pure ∷ ∀ eff a. a → Aff eff a
 foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
+foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
 foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
 foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
 foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
 foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
-foreign import attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
 foreign import bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
 foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a
 

test/Test/Main.purs

@@ -1,7 +1,7 @@
 module Test.Main where
 
 import Prelude
-import Control.Monad.Aff (Aff, Canceler(..), ASYNC, nonCanceler, runAff, launchAff, makeAff, attempt, bracket, delay, forkAff, joinThread, killThread)
+import Control.Monad.Aff (Aff, Canceler(..), ASYNC, nonCanceler, runAff, launchAff, makeAff, try, bracket, delay, forkAff, joinThread, killThread)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Class (class MonadEff, liftEff)
 import Control.Monad.Eff.Console (CONSOLE)
@@ -50,10 +50,10 @@ runAssertEq ∷ ∀ eff a. Eq a ⇒ String → a → TestAff eff a → TestEff e
 runAssertEq s a = runAff (assertEff s <<< map (eq a))
 
 assertEq ∷ ∀ eff a. Eq a ⇒ String → a → TestAff eff a → TestAff eff Unit
-assertEq s a aff = liftEff <<< assertEff s <<< map (eq a) =<< attempt aff
+assertEq s a aff = liftEff <<< assertEff s <<< map (eq a) =<< try aff
 
 assert ∷ ∀ eff. String → TestAff eff Boolean → TestAff eff Unit
-assert s aff = liftEff <<< assertEff s =<< attempt aff
+assert s aff = liftEff <<< assertEff s =<< try aff
 
 test_pure ∷ ∀ eff. TestEff eff Unit
 test_pure = runAssertEq "pure" 42 (pure 42)
@@ -65,16 +65,16 @@ test_bind = runAssertEq "bind" 44 do
   n3 ← pure (n2 + 1)
   pure n3
 
-test_attempt ∷ ∀ eff. TestEff eff Unit
-test_attempt = runAssert "attempt" do
-  n ← attempt (pure 42)
+test_try ∷ ∀ eff. TestEff eff Unit
+test_try = runAssert "try" do
+  n ← try (pure 42)
   case n of
     Right 42 → pure true
     _ → pure false
 
 test_throw ∷ ∀ eff. TestEff eff Unit
-test_throw = runAssert "attempt/throw" do
-  n ← attempt (throwError (error "Nope."))
+test_throw = runAssert "try/throw" do
+  n ← try (throwError (error "Nope."))
   pure (isLeft n)
 
 test_liftEff ∷ ∀ eff. TestEff eff Unit
@@ -115,12 +115,12 @@ test_join_throw = assert "join/throw" do
   thread ← forkAff do
     delay (Milliseconds 10.0)
     throwError (error "Nope.")
-  isLeft <$> attempt (joinThread thread)
+  isLeft <$> try (joinThread thread)
 
 test_join_throw_sync ∷ ∀ eff. TestAff eff Unit
 test_join_throw_sync = assert "join/throw/sync" do
   thread ← forkAff (throwError (error "Nope."))
-  isLeft <$> attempt (joinThread thread)
+  isLeft <$> try (joinThread thread)
 
 test_multi_join ∷ ∀ eff. TestAff eff Unit
 test_multi_join = assert "join/multi" do
@@ -212,7 +212,7 @@ test_kill ∷ ∀ eff. TestAff eff Unit
 test_kill = assert "kill" do
   thread ← forkAff $ makeAff \_ → pure nonCanceler
   killThread (error "Nope") thread
-  isLeft <$> attempt (joinThread thread)
+  isLeft <$> try (joinThread thread)
 
 test_kill_canceler ∷ ∀ eff. TestAff eff Unit
 test_kill_canceler = assert "kill/canceler" do
@@ -221,7 +221,7 @@ test_kill_canceler = assert "kill/canceler" do
     n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref 42))
     writeRef ref 2
   killThread (error "Nope") thread
-  res ← attempt (joinThread thread)
+  res ← try (joinThread thread)
   n ← readRef ref
   pure (n == 42 && (lmap message res) == Left "Nope")
 
@@ -238,7 +238,7 @@ test_kill_bracket = assert "kill/bracket" do
       (\_ → action "b")
       (\_ → action "c")
   killThread (error "Nope") thread
-  _ ← attempt (joinThread thread)
+  _ ← try (joinThread thread)
   eq "ab" <$> readRef ref
 
 test_kill_bracket_nested ∷ ∀ eff. TestAff eff Unit
@@ -260,7 +260,7 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do
       (\s → void $ bracketAction (s <> "/release"))
       (\s → bracketAction (s <> "/run"))
   killThread (error "Nope") thread
-  _ ← attempt (joinThread thread)
+  _ ← try (joinThread thread)
   readRef ref <#> eq
     [ "foo/bar"
     , "foo/bar/run"
@@ -274,7 +274,7 @@ main ∷ TestEff () Unit
 main = do
   test_pure
   test_bind
-  test_attempt
+  test_try
   test_throw
   test_liftEff