Return Canceler from runAff/launchAff

Author: sardonicpresence

src/Control/Monad/Aff.purs

@@ -46,15 +46,15 @@ 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
 -- | successfully canceled. The flag should not be used for communication.
 newtype Canceler e = Canceler (Error -> Aff e Boolean)
 
 -- | Unwraps the canceler function from the newtype that wraps it.
-cancel :: forall e. Canceler e -> Error ->  Aff e Boolean
+cancel :: forall e. Canceler e -> Error -> Aff e Boolean
 cancel (Canceler f) = f
 
 -- | This function allows you to attach a custom canceler to an asynchronous
@@ -73,15 +73,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
@@ -194,7 +199,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)
@@ -224,7 +229,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

@@ -4,14 +4,15 @@ import Prelude
 
 import Control.Alt ((<|>))
 import Control.Apply ((*>))
-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.Aff.Par (Par(..), runPar)
 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_cancelPar :: TestAVar Unit
 test_cancelPar = do
   c  <- forkAff <<< runPar $ Par (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 Par (*>)"
-  test_parError
+    log "Test Par (*>)"
+    test_parError
 
-  log "Testing Par (<|>)"
-  test_parRace
+    log "Testing Par (<|>)"
+    test_parRace
 
-  log "Testing Par (<|>) - kill one"
-  test_parRaceKill1
+    log "Testing Par (<|>) - kill one"
+    test_parRaceKill1
 
-  log "Testing Par (<|>) - kill two"
-  test_parRaceKill2
+    log "Testing Par (<|>) - kill two"
+    test_parRaceKill2
 
-  log "Testing cancel of Par (<|>)"
-  test_cancelPar
+    log "Testing cancel of Par (<|>)"
+    test_cancelPar
 
-  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"