Merge pull request #87 from garyb/cancelling-alt

Cancel the other branch when there's succeess in a race

Author: garyb

src/Control/Monad/Aff.purs

@@ -39,6 +39,7 @@ import Data.Foldable (class Foldable, foldl)
 import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
 import Data.Monoid (class Monoid, mempty)
 import Data.Newtype (class Newtype)
+import Data.Tuple (Tuple(..), fst, snd)
 
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -244,11 +245,18 @@ instance altParAff :: Alt (ParAff e) where
   alt (ParAff a1) (ParAff a2) = ParAff do
     va <- makeVar -- the `a` value
     ve <- makeVar -- the error count (starts at 0)
+    cs <- makeVar -- the cancelers
     putVar ve 0
-    c1 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a1
-    c2 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a2
+    c1 <- forkAff $ either (maybeKill va ve) (done cs snd va) =<< attempt a1
+    c2 <- forkAff $ either (maybeKill va ve) (done cs fst va) =<< attempt a2
+    putVar cs (Tuple c1 c2)
     takeVar va `cancelWith` (c1 <> c2)
     where
+    done :: forall a. AVar (Tuple (Canceler e) (Canceler e)) -> (forall x. Tuple x x -> x) -> AVar a -> a -> Aff e Unit
+    done cs get va x = do
+      putVar va x
+      c <- get <$> takeVar cs
+      void $ cancel c (error "Alt early exit")
     maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
     maybeKill va ve err = do
       e <- takeVar ve

test/Test/Main.purs

@@ -202,6 +202,26 @@ test_cancelParallel = do
   log (if v then "Success: Canceling composite of two Parallel succeeded"
                    else "Failure: Canceling composite of two Parallel failed")
 
+test_cancelRaceLeft :: TestAVar Unit
+test_cancelRaceLeft = do
+  var <- makeVar
+  c  <- sequential
+    $ parallel (later' 250 $ putVar var true)
+    <|> parallel (later' 100 $ pure unit)
+  later' 500 $ putVar var false
+  l <- takeVar var
+  when l $ throwError (error "Failure: left side ran even though it lost the race")
+
+test_cancelRaceRight :: TestAVar Unit
+test_cancelRaceRight = do
+  var <- makeVar
+  c  <- sequential
+    $ parallel (later' 100 $ pure unit)
+    <|> parallel (later' 250 $ putVar var true)
+  later' 500 $ putVar var false
+  l <- takeVar var
+  when l $ throwError (error "Failure: right side ran even though it lost the race")
+
 test_syncTailRecM :: TestAVar Unit
 test_syncTailRecM = do
   v <- makeVar' false
@@ -305,6 +325,12 @@ main = do
     log "Testing cancel of Parallel (<|>)"
     test_cancelParallel
 
+    log "Testing cancel of left branch in parallel (<|>)"
+    test_cancelRaceLeft
+
+    log "Testing cancel of right branch in parallel (<|>)"
+    test_cancelRaceRight
+
     log "Testing synchronous tailRecM"
     test_syncTailRecM