Merge pull request #52 from sardonicpresence/master

Allow cancellation of computations forked with `runAff`

Author: jdegoes

src/Control/Monad/Aff.purs

@@ -52,7 +52,7 @@ foreign import data Aff :: # ! -> * -> *
 -- | asynchronous computation.
 type PureAff a = forall e. Aff e a
 
--- | A canceler is asynchronous function that can be used to attempt the
+-- | A canceler is an asynchronous function that can be used to attempt the
 -- | cancelation of a computation. Returns a boolean flag indicating whether
 -- | or not the cancellation was successful. Many computations may be composite,
 -- | in such cases the flag indicates whether any part of the computation was
@@ -79,15 +79,20 @@ cancelWith aff c = runFn3 _cancelWith nonCanceler aff c
 -- | If you do need to handle exceptions, you can use `runAff` instead, or
 -- | you can handle the exception within the Aff computation, using
 -- | `catchError` (or any of the other mechanisms).
-launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) Unit
-launchAff = runAff throwException (const (pure unit)) <<< liftEx
+launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) (Canceler e)
+launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx
   where
   liftEx :: Aff e a -> Aff (err :: EXCEPTION | e) a
   liftEx = _unsafeInterleaveAff
+  lowerEx :: Eff (err :: EXCEPTION | e) (Canceler (err :: EXCEPTION | e)) -> Eff (err :: EXCEPTION | e) (Canceler e)
+  lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel)
 
 -- | Runs the asynchronous computation. You must supply an error callback and a
 -- | success callback.
-runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e Unit
+-- |
+-- | Returns a canceler that can be used to attempt cancellation of the
+-- | asynchronous computation.
+runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e (Canceler e)
 runAff ex f aff = runFn3 _runAff ex f aff
 
 -- | Creates an asynchronous effect from a function that accepts error and
@@ -200,7 +205,7 @@ instance monadRecAff :: MonadRec (Aff e) where
   tailRecM f a = runFn3 _tailRecM isLeft f a
 
 instance monadContAff :: MonadCont (Aff e) where
-  callCC f = makeAff (\eb cb -> runAff eb cb (f \a -> makeAff (\_ _ -> cb a)))
+  callCC f = makeAff (\eb cb -> void $ runAff eb cb (f \a -> makeAff (\_ _ -> cb a)))
 
 instance semigroupCanceler :: Semigroup (Canceler e) where
   append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)
@@ -272,7 +277,7 @@ foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b)
 
 foreign import _attempt :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))
 
-foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e Unit)
+foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e (Canceler e))
 
 foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)
 

test/Test/Main.purs

@@ -5,13 +5,14 @@ import Prelude
 import Control.Alt ((<|>))
 import Control.Apply ((*>))
 import Control.Parallel.Class (parallel, runParallel)
-import Control.Monad.Aff (Aff, runAff, makeAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
+import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
 import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, killVar)
 import Control.Monad.Aff.Console (log)
 import Control.Monad.Cont.Class (callCC)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE)
-import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message)
+import Control.Monad.Eff.Console (log) as Eff
+import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message, try)
 import Control.Monad.Error.Class (throwError)
 import Control.Monad.Rec.Class (tailRecM)
 import Data.Either (Either(..), either, fromLeft, fromRight)
@@ -137,6 +138,18 @@ test_cancelLater = do
   v <- cancel c (error "Cause")
   log (if v then "Success: Canceled later" else "Failure: Did not cancel later")
 
+test_cancelLaunchLater :: forall e. Eff (console :: CONSOLE, err :: EXCEPTION | e) Unit
+test_cancelLaunchLater = do
+  c <- launchAff $ later' 100 $ log ("Failure: Later was not canceled!")
+  void $ launchAff $ (do v <- cancel c (error "Cause")
+                         log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))
+
+test_cancelRunLater :: forall e. Eff (console :: CONSOLE | e) Unit
+test_cancelRunLater = do
+  c <- runAff (const (pure unit)) (const (pure unit)) $ later' 100 $ log ("Failure: Later was not canceled!")
+  void $ try $ launchAff $ (do v <- cancel c (error "Cause")
+                               log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))
+
 test_cancelParallel :: TestAVar Unit
 test_cancelParallel = do
   c  <- forkAff <<< runParallel $ parallel (later' 100 $ log "Failure: #1 should not get through") <|>
@@ -187,69 +200,76 @@ delay n = callCC \cont ->
   later' n (cont unit)
 
 main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
-main = runAff throwException (const (pure unit)) $ do
-  log "Testing sequencing"
-  test_sequencing 3
+main = do
+  Eff.log "Testing kill of later launched in separate Aff"
+  test_cancelLaunchLater
+
+  Eff.log "Testing kill of later run in separate Aff"
+  test_cancelRunLater
+
+  void $ runAff throwException (const (pure unit)) $ do
+    log "Testing sequencing"
+    test_sequencing 3
 
-  log "Testing pure"
-  test_pure
+    log "Testing pure"
+    test_pure
 
-  log "Testing makeAff"
-  test_makeAff
+    log "Testing makeAff"
+    test_makeAff
 
-  log "Testing attempt"
-  test_attempt
+    log "Testing attempt"
+    test_attempt
 
-  log "Testing later"
-  later $ log "Success: It happened later"
+    log "Testing later"
+    later $ log "Success: It happened later"
 
-  log "Testing kill of later"
-  test_cancelLater
+    log "Testing kill of later"
+    test_cancelLater
 
-  log "Testing kill of first forked"
-  test_killFirstForked
+    log "Testing kill of first forked"
+    test_killFirstForked
 
-  log "Testing apathize"
-  test_apathize
+    log "Testing apathize"
+    test_apathize
 
-  log "Testing semigroup canceler"
-  test_semigroupCanceler
+    log "Testing semigroup canceler"
+    test_semigroupCanceler
 
-  log "Testing AVar - putVar, takeVar"
-  test_putTakeVar
+    log "Testing AVar - putVar, takeVar"
+    test_putTakeVar
 
-  log "Testing AVar killVar"
-  test_killVar
+    log "Testing AVar killVar"
+    test_killVar
 
-  log "Testing finally"
-  test_finally
+    log "Testing finally"
+    test_finally
 
-  log "Test Parallel (*>)"
-  test_parError
+    log "Test Parallel (*>)"
+    test_parError
 
-  log "Testing Parallel (<|>)"
-  test_parRace
+    log "Testing Parallel (<|>)"
+    test_parRace
 
-  log "Testing Parallel (<|>) - kill one"
-  test_parRaceKill1
+    log "Testing Parallel (<|>) - kill one"
+    test_parRaceKill1
 
-  log "Testing Parallel (<|>) - kill two"
-  test_parRaceKill2
+    log "Testing Parallel (<|>) - kill two"
+    test_parRaceKill2
 
-  log "Testing cancel of Parallel (<|>)"
-  test_cancelParallel
+    log "Testing cancel of Parallel (<|>)"
+    test_cancelParallel
 
-  log "Testing synchronous tailRecM"
-  test_syncTailRecM
+    log "Testing synchronous tailRecM"
+    test_syncTailRecM
 
-  log "pre-delay"
-  delay 1000
-  log "post-delay"
+    log "pre-delay"
+    delay 1000
+    log "post-delay"
 
-  loopAndBounce 1000000
+    loopAndBounce 1000000
 
-  all 100000
+    all 100000
 
-  cancelAll 100000
+    cancelAll 100000
 
-  log "Done testing"
+    log "Done testing"