Skip to content

Allow cancellation of computations forked with runAff #52

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Jun 9, 2016
Merged

Allow cancellation of computations forked with runAff #52

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 11 additions & 6 deletions src/Control/Monad/Aff.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)

Expand Down
112 changes: 66 additions & 46 deletions test/Test/Main.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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") <|>
Expand Down Expand Up @@ -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"