From 9fe5a0b9bf4ead9a5677bd8ddc9128ea172a0768 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 29 Jun 2017 16:31:15 -0700 Subject: [PATCH 01/35] WIP --- bower.json | 9 +- src/Control/Monad/Aff.js | 691 ++++++++++++++++++------------- src/Control/Monad/Aff.purs | 397 +++++------------- src/Control/Monad/Aff/AVar.purs | 78 +--- src/Control/Monad/Aff/Class.purs | 3 +- test/Test/Bench.purs | 62 +++ test/Test/Main.js | 5 - test/Test/Main.purs | 403 +----------------- 8 files changed, 599 insertions(+), 1049 deletions(-) create mode 100644 test/Test/Bench.purs delete mode 100644 test/Test/Main.js diff --git a/bower.json b/bower.json index a6299d3..c44e996 100644 --- a/bower.json +++ b/bower.json @@ -23,9 +23,14 @@ "purescript-parallel": "^3.0.0", "purescript-transformers": "^3.0.0", "purescript-unsafe-coerce": "^3.0.0", - "purescript-datetime": "^3.0.0" + "purescript-datetime": "^3.0.0", + "purescript-free": "^4.0.1", + "purescript-st": "^3.0.0", + "purescript-type-equality": "^2.1.0" }, "devDependencies": { - "purescript-partial": "^1.2.0" + "purescript-partial": "^1.2.0", + "purescript-minibench": "^1.0.0", + "purescript-assert": "^3.0.0" } } diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 9e7d22f..227dfc2 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -1,334 +1,441 @@ -/* globals setTimeout, clearTimeout, setImmediate, clearImmediate */ "use strict"; -exports._cancelWith = function (nonCanceler, aff, canceler1) { - return function (success, error) { - var canceler2 = aff(success, error); - - return function (e) { - return function (success, error) { - var cancellations = 0; - var result = false; - var errored = false; - - var s = function (bool) { - cancellations = cancellations + 1; - result = result || bool; - - if (cancellations === 2 && !errored) { - success(result); - } - }; - - var f = function (err) { - if (!errored) { - errored = true; - error(err); - } - }; - - canceler2(e)(s, f); - canceler1(e)(s, f); - - return nonCanceler; - }; - }; - }; +/* + +An awkward approximation. We elide evidence we would otherwise need in PS for +efficiency sake. + +data Aff eff a + = Pure a + | Throw Error + | Sync (Eff eff (Either Error a)) + | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) + | forall b. Attempt (Aff eff b) ?(Either Error 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"; + +// These are constructors used to implement the recover stack. We still use the +// Aff constructor so that property offsets can always inline. +var CONS = "Cons"; // Cons-list +var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) +var RESUME = "Resume"; // Continue indiscriminately +var FINALIZED = "Finalized"; // Marker for finalization + +function Aff (tag, _1, _2, _3) { + this.tag = tag; + this._1 = _1; + this._2 = _2; + this._3 = _3; +} + +var finalized = new Aff(FINALIZED); + +exports._pure = function (a) { + return new Aff(PURE, a); }; -exports._delay = function (nonCanceler, millis) { - var set = setTimeout; - var clear = clearTimeout; - if (millis <= 0 && typeof setImmediate === "function") { - set = setImmediate; - clear = clearImmediate; - } - return function (success) { - var timedOut = false; - var timer = set(function () { - timedOut = true; - success(); - }, millis); - - return function () { - return function (s) { - if (timedOut) { - s(false); - } else { - clear(timer); - s(true); - } - return nonCanceler; - }; - }; - }; +exports._throwError = function (error) { + return new Aff(THROW, error); }; -exports._unsafeInterleaveAff = function (aff) { - return aff; +exports._unsafeSync = function (eff) { + return new Aff(SYNC, eff); }; -exports._forkAff = function (nonCanceler, aff) { - var voidF = function () {}; - - return function (success) { - var canceler = aff(voidF, voidF); - success(canceler); - return nonCanceler; - }; -}; - -exports._forkAll = function (nonCanceler, foldl, affs) { - var voidF = function () {}; - - return function (success) { - var cancelers = foldl(function (acc) { - return function (aff) { - acc.push(aff(voidF, voidF)); - return acc; - }; - })([])(affs); - - var canceler = function (e) { - return function (success, error) { - var cancellations = 0; - var result = false; - var errored = false; - - var s = function (bool) { - cancellations = cancellations + 1; - result = result || bool; - - if (cancellations === cancelers.length && !errored) { - success(result); - } - }; - - var f = function (err) { - if (!errored) { - errored = true; - error(err); - } - }; - - for (var i = 0; i < cancelers.length; i++) { - cancelers[i](e)(s, f); - } - - return nonCanceler; - }; - }; - - success(canceler); - return nonCanceler; - }; +exports._unsafeAsync = function (k) { + return new Aff(ASYNC, k); }; -exports._makeAff = function (cb) { - return function (success, error) { - try { - return cb(function (e) { - return function () { - error(e); - }; - })(function (v) { - return function () { - success(v); - }; - })(); - } catch (err) { - error(err); +exports._map = function (f) { + return function (aff) { + if (aff.tag === PURE) { + return new Aff(PURE, f(aff._1)); + } else { + return new Aff(BIND, aff, function (value) { + return new Aff(PURE, f(value)); + }); } }; }; -exports._pure = function (nonCanceler, v) { - return function (success) { - success(v); - return nonCanceler; +exports._bind = function (aff) { + return function (k) { + return new Aff(BIND, aff, k); }; }; -exports._throwError = function (nonCanceler, e) { - return function (success, error) { - error(e); - return nonCanceler; - }; +exports._attempt = function (aff) { + return new Aff(ATTEMPT, aff); }; -exports._fmap = function (f, aff) { - return function (success, error) { - return aff(function (v) { - success(f(v)); - }, error); +exports._bracket = function (acquire) { + return function (release) { + return function (k) { + return new Aff(BRACKET, acquire, release, k); + }; }; }; -exports._bind = function (alwaysCanceler, aff, f) { - return function (success, error) { - var canceler1, canceler2; - - var isCanceled = false; - var requestCancel = false; - - var onCanceler = function () {}; - - canceler1 = aff(function (v) { - if (requestCancel) { - isCanceled = true; +exports._liftEff = function (left, right, eff) { + return new Aff(SYNC, function () { + try { + return right(eff()); + } catch (error) { + return left(error); + } + }); +}; - return alwaysCanceler; - } else { - canceler2 = f(v)(success, error); +// Thread state machine +var BLOCKED = 0; // No effect is running. +var PENDING = 1; // An async effect is running. +var RETURN = 2; // The current stack has returned. +var CONTINUE = 3; // Run the next effect. +var BINDSTEP = 4; // +var COMPLETED = 5; // The entire thread has completed. - onCanceler(canceler2); +exports._drainAff = function (isLeft, fromLeft, fromRight, left, right, aff) { + return function () { + // Monotonically increasing tick, increased on each asynchronous turn. + var runTick = 0; + + // The current branch of the state machine. + var status = CONTINUE; + + // The current point of interest for the state machine branch. + var step = aff; // Successful step + var fail = null; // Failure step + var interrupt = null; // Asynchronous interrupt + + // Stack of continuations for the current thread. + var bhead = null; + var btail = null; + + // Stack of attempts and finalizers for error recovery. This holds a union + // of an arbitrary Aff finalizer or a Cons list of bind continuations. + var attempts = null; + + // A special state is needed for Bracket, because it cannot be killed. When + // we enter a bracket acquisition or finalizer, we increment the counter, + // and then decrement once complete. + var bracket = 0; + + // Each join gets a new id so they can be revoked. + var joinId = 0; + var joins = {}; + + // Temporary bindings for the various branches. + var tmp, result, attempt, canceler; + + // Each invocation of `run` requires a tick. When an asynchronous effect is + // resolved, we must check that the local tick coincides with the thread + // tick before resuming. This prevents multiple async continuations from + // accidentally resuming the same thread. A common example may be invoking + // the provided callback in `makeAff` more than once, but it may also be an + // async effect resuming after the thread was already cancelled. + function run (localRunTick) { + while (1) { + tmp = status; + status = BLOCKED; + + switch (tmp) { + case BINDSTEP: + status = CONTINUE; + step = bhead(step); + if (btail === null) { + bhead = null; + } else { + bhead = btail._1; + btail = btail._2; + } + break; - return canceler2; - } - }, error); - - return function (e) { - return function (s, f) { - requestCancel = true; - - if (canceler2 !== undefined) { - return canceler2(e)(s, f); - } else { - return canceler1(e)(function (bool) { - if (bool || isCanceled) { - s(true); + case CONTINUE: + switch (step.tag) { + case BIND: + if (bhead) { + btail = new Aff(CONS, bhead, btail); + } + bhead = step._2; + status = CONTINUE; + step = step._1; + break; + + case PURE: + if (bhead === null) { + status = RETURN; + step = right(step._1); } else { - onCanceler = function (canceler) { - canceler(e)(s, f); + status = BINDSTEP; + step = step._1; + } + break; + + case THROW: + bhead = null; + btail = null; + status = RETURN; + fail = left(step._1); + break; + + case SYNC: + result = step._1(); + if (isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = fromRight(result); + } + break; + + case ASYNC: + canceler = step._1(function (result) { + return function () { + if (runTick !== localRunTick) { + return; + } + tmp = status; + if (isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = fromRight(result); + } + // We only need to invoke `run` if the subsequent block has + // switch the status to PENDING. Otherwise the callback was + // resolved synchronously, and the current loop can continue + // normally. + if (tmp === PENDING) { + run(++runTick); + } else { + localRunTick = ++runTick; + } }; + })(); + // If the callback was resolved synchronously, the status will have + // switched to CONTINUE, and we should not move on to PENDING. + if (status === BLOCKED) { + status = PENDING; + step = canceler; } - }, f); + break; + + // Enqueue the current stack of binds and continue + case ATTEMPT: + attempts = new Aff(CONS, new Aff(RECOVER, bhead, btail), attempts); + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + } + break; + + // When we evaluate a Bracket, we also enqueue the instruction so we + // can fullfill it later once we return from the acquisition. + case BRACKET: + bracket++; + attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + + case RETURN: + // If the current stack has returned, and we have no other stacks to + // resume or finalizers to run, the thread has halted and we can + // invoke all join callbacks. Otherwise we need to resume. + if (attempts === null) { + runTick++; // Increment the counter to prevent reentry after completion. + status = COMPLETED; + step = interrupt || fail || step; + for (var k in joins) { + runJoin(step, joins[k]); + } + joins = null; + } 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). + case RECOVER: + attempts = attempts._2; + if (interrupt === null) { + bhead = attempt._1; + btail = attempt._2; + status = BINDSTEP; + step = fail || step; + fail = null; + } + break; + + // We cannot resume from an interrupt or exception. + case RESUME: + attempts = attempts._2; + if (interrupt === null && fail === null) { + bhead = attempt._1; + btail = attempt._2; + status = BINDSTEP; + step = fromRight(step); + } + break; + + // If we have a bracket, we should enqueue the finalizer branch, + // and continue with the success branch only if the thread has + // not been interrupted. If the bracket acquisition failed, we + // should not run either. + case BRACKET: + bracket--; + if (fail === null) { + result = fromRight(step); + attempts = new Aff(CONS, attempt._2(result), attempts._2); + if (interrupt === null) { + status = CONTINUE; + step = attempt._3(result); + } + } else { + attempts = attempts._2; + } + break; + + case FINALIZED: + bracket--; + attempts = attempts._2; + break; + + // Otherwise we need to run a finalizer, which cannot be interrupted. + // We insert a FINALIZED marker to know when we can release it. + default: + bracket++; + attempts._1 = finalized; + status = CONTINUE; + step = attempt; + } + } + break; + + case COMPLETED: + status = COMPLETED; + // If we have an unhandled exception, we need to throw it in + // a fresh stack. + if (isLeft(step)) { + setTimeout(function() { + throw fromLeft(step); + }, 0); + } + return; + case BLOCKED: return; + case PENDING: return; } - }; - }; - }; -}; -exports._attempt = function (Left, Right, aff) { - return function (success) { - return aff(function (v) { - success(Right(v)); - }, function (e) { - success(Left(e)); - }); - }; -}; - -exports._runAff = function (errorT, successT, aff) { - // If errorT or successT throw, and an Aff is comprised only of synchronous - // effects, then it's possible for makeAff/liftEff to accidentally catch - // it, which may end up rerunning the Aff depending on error recovery - // behavior. To mitigate this, we observe synchronicity using mutation. If - // an Aff is observed to be synchronous, we let the stack reset and run the - // handlers outside of the normal callback flow. - return function () { - var status = 0; - var result, success; - - var canceler = aff(function (v) { - if (status === 2) { - successT(v)(); - } else { - status = 1; - result = v; - success = true; + tmp = null; + result = null; + attempt = null; + canceler = null; } - }, function (e) { - if (status === 2) { - errorT(e)(); - } else { - status = 1; - result = e; - success = false; - } - }); - - if (status === 1) { - if (success) { - successT(result)(); - } else { - errorT(result)(); - } - } else { - status = 2; } - return canceler; - }; -}; - -exports._liftEff = function (nonCanceler, e) { - return function (success, error) { - var result; - try { - result = e(); - } catch (err) { - error(err); - return nonCanceler; + function addJoinCallback (cb) { + var jid = joinId++; + joins[jid] = cb; + return function (error) { + return new Aff(SYNC, function () { + delete joins[jid]; + return right({}); + }); + }; } - success(result); - return nonCanceler; - }; -}; + function pureCanceler (error) { + return new Aff(PURE, {}); + } -exports._tailRecM = function (isLeft, f, a) { - return function (success, error) { - return function go (acc) { - var result, status, canceler; - - // Observes synchronous effects using a flag. - // status = 0 (unresolved status) - // status = 1 (synchronous effect) - // status = 2 (asynchronous effect) - - var csuccess = function (v) { - // If the status is still unresolved, we have observed a - // synchronous effect. Otherwise, the status will be `2`. - if (status === 0) { - // Store the result for further synchronous processing. - result = v; - status = 1; - } else { - // When we have observed an asynchronous effect, we use normal - // recursion. This is safe because we will be on a new stack. - if (isLeft(v)) { - go(v.value0); - } else { - success(v.value0); + function kill (error) { + return new Aff(ASYNC, function (cb) { + return function () { + // Shadow the canceler binding because it can potentially be + // clobbered if we call `run`. + var canceler; + switch (status) { + case COMPLETED: + canceler = pureCanceler; + cb(right({}))(); + break; + case PENDING: + canceler = addJoinCallback(cb); + if (interrupt === null) { + interrupt = left(error); + } + // If we can interrupt the pending action, enqueue the canceler as + // a non-interruptible finalizer. + if (bracket === 0) { + attempts = new Aff(CONS, step(error), attempts); + bhead = null; + btail = null; + status = RETURN; + run(runTick++); + } + break; + default: + canceler = addJoinCallback(cb); + if (interrupt === null) { + interrupt = left(error); + } + if (bracket === 0) { + bhead = null; + btail = null; + status = RETURN; + } } - } - }; + return canceler; + }; + }); + } - while (true) { - status = 0; - canceler = f(acc)(csuccess, error); - - // If the status has already resolved to `1` by our Aff handler, then - // we have observed a synchronous effect. Otherwise it will still be - // `0`. - if (status === 1) { - // When we have observed a synchronous effect, we merely swap out the - // accumulator and continue the loop, preserving stack. - if (isLeft(result)) { - acc = result.value0; - continue; - } else { - success(result.value0); + function join () { + return new Aff(ASYNC, function (cb) { + return function () { + if (status === COMPLETED) { + cb(step)(); + return pureCanceler; } - } else { - // If the status has not resolved yet, then we have observed an - // asynchronous effect. - status = 2; - } - return canceler; - } + return addJoinCallback(cb); + }; + }); + } + + run(runTick); - }(a); + return { + kill: kill, + join: join() + }; }; }; + +function runJoin (result, cb) { + try { + cb(result)(); + } catch (error) { + setTimeout(function () { + throw error; + }, 0) + } +} diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index dfc6739..9088c38 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -1,314 +1,131 @@ module Control.Monad.Aff ( Aff + , Thread , Canceler(..) - , PureAff(..) - , apathize , attempt - , cancel - , cancelWith - , finally - , forkAff - , forkAll - , delay - , launchAff - , liftEff' - , makeAff - , makeAff' - , nonCanceler + , bracket , runAff - , ParAff(..) + , launchAff + , forkAff + , killThread + , joinThread + , onComplete ) where import Prelude - -import Control.Alt (class Alt) -import Control.Alternative (class Alternative) -import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _makeVar) +import Data.Function.Uncurried as Fn import Control.Monad.Eff (Eff, kind Effect) -import Control.Monad.Eff.Class (class MonadEff) -import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error) -import Control.Monad.Error.Class (class MonadThrow, class MonadError, throwError) +import Control.Monad.Eff.Class (class MonadEff, liftEff) +import Control.Monad.Eff.Exception (EXCEPTION, Error) +import Control.Monad.Error.Class (class MonadError, class MonadThrow) import Control.Monad.Rec.Class (class MonadRec, Step(..)) -import Control.MonadPlus (class MonadZero, class MonadPlus) -import Control.Parallel (class Parallel) -import Control.Plus (class Plus, empty) - -import Data.Either (Either(..), either) -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.Time.Duration (Milliseconds(..)) -import Data.Tuple (Tuple(..), fst, snd) - -import Unsafe.Coerce (unsafeCoerce) - --- | An asynchronous computation with effects `e`. The computation either --- | errors or produces a value of type `a`. --- | --- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`. -foreign import data Aff :: # Effect -> Type -> Type - --- | A pure asynchronous computation, having no effects other than --- | asynchronous computation. -type PureAff a = forall e. Aff e a - --- | 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 (Canceler f) = f - --- | This function allows you to attach a custom canceler to an asynchronous --- | computation. If the computation is canceled, then the custom canceler --- | will be run along side the computation's own canceler. -cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a -cancelWith aff c = runFn3 _cancelWith nonCanceler aff c - --- | Converts the asynchronous computation into a synchronous one. All values --- | are ignored, and if the computation produces an error, it is thrown. --- | --- | Catching exceptions by using `catchException` with the resulting Eff --- | computation is not recommended, as exceptions may end up being thrown --- | asynchronously, in which case they cannot be caught. --- | --- | 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 (exception :: EXCEPTION | e) (Canceler e) -launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx - where - liftEx :: Aff e a -> Aff (exception :: EXCEPTION | e) a - liftEx = _unsafeInterleaveAff - lowerEx :: Eff (exception :: EXCEPTION | e) (Canceler (exception :: EXCEPTION | e)) -> Eff (exception :: EXCEPTION | e) (Canceler e) - lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel) - --- | Runs the asynchronous computation. You must supply an error callback and a --- | success callback. --- | --- | 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 --- | success callbacks. This function can be used for asynchronous computations --- | that cannot be canceled. -makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a -makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a) - --- | Creates an asynchronous effect from a function that accepts error and --- | success callbacks, and returns a canceler for the computation. This --- | function can be used for asynchronous computations that can be canceled. -makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a -makeAff' h = _makeAff h - --- | Pauses execuation of the current computation for the specified number of milliseconds. -delay :: forall e. Milliseconds -> Aff e Unit -delay (Milliseconds n) = runFn2 _delay nonCanceler n - --- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully. -finally :: forall e a b. Aff e a -> Aff e b -> Aff e a -finally aff1 aff2 = do - x <- attempt aff1 - _ <- aff2 - either throwError pure x - --- | Forks the specified asynchronous computation so subsequent computations --- | will not block on the result of the computation. --- | --- | Returns a canceler that can be used to attempt cancellation of the --- | forked computation. -forkAff :: forall e a. Aff e a -> Aff e (Canceler e) -forkAff aff = runFn2 _forkAff nonCanceler aff - --- | Forks many asynchronous computation in a synchronous manner while being --- | stack-safe up to the selected Foldable instance. --- | --- | Returns a canceler that can be used to attempt cancellation of all --- | forked computations. -forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e) -forkAll affs = runFn3 _forkAll nonCanceler foldl affs - --- | Promotes any error to the value level of the asynchronous monad. -attempt :: forall e a. Aff e a -> Aff e (Either Error a) -attempt aff = runFn3 _attempt Left Right aff - --- | Ignores any errors. -apathize :: forall e a. Aff e a -> Aff e Unit -apathize a = const unit <$> attempt a - --- | Lifts a synchronous computation and makes explicit any failure from exceptions. -liftEff' :: forall e a. Eff (exception :: EXCEPTION | e) a -> Aff e (Either Error a) -liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff)) - --- | A constant canceller that always returns false. -nonCanceler :: forall e. Canceler e -nonCanceler = Canceler (const (pure false)) - --- | A constant canceller that always returns true. -alwaysCanceler :: forall e. Canceler e -alwaysCanceler = Canceler (const (pure true)) - -instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where - append a b = (<>) <$> a <*> b - -instance monoidAff :: (Monoid a) => Monoid (Aff e a) where - mempty = pure mempty - -instance functorAff :: Functor (Aff e) where - map f fa = runFn2 _fmap f fa - -instance applyAff :: Apply (Aff e) where - apply ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa) - -instance applicativeAff :: Applicative (Aff e) where - pure v = runFn2 _pure nonCanceler v - -instance bindAff :: Bind (Aff e) where - bind fa f = runFn3 _bind alwaysCanceler fa f +import Data.Either (Either(..), isLeft) +import Partial.Unsafe (unsafeCrashWith) +import Type.Row.Effect.Equality (class EffectRowEquals, effTo) -instance monadAff :: Monad (Aff e) +foreign import data Aff :: # Effect → Type → Type -instance monadEffAff :: MonadEff e (Aff e) where - liftEff eff = runFn2 _liftEff nonCanceler eff +instance functorAff ∷ Functor (Aff eff) where map = _map +instance applyAff ∷ Apply (Aff eff) where apply = ap +instance applicativeAff ∷ Applicative (Aff eff) where pure = _pure +instance bindAff ∷ Bind (Aff eff) where bind = _bind +instance monadAff ∷ Monad (Aff eff) --- | Allows users to throw errors on the error channel of the --- | asynchronous computation. See documentation in `purescript-transformers`. -instance monadThrowAff :: MonadThrow Error (Aff e) where - throwError e = runFn2 _throwError nonCanceler e - --- | Allows users to catch errors on the error channel of the --- | asynchronous computation. See documentation in `purescript-transformers`. -instance monadErrorAff :: MonadError Error (Aff e) where - catchError aff ex = attempt aff >>= either ex pure - -instance altAff :: Alt (Aff e) where - alt a1 a2 = attempt a1 >>= either (const a2) pure - -instance plusAff :: Plus (Aff e) where - empty = throwError $ error "Always fails" - -instance alternativeAff :: Alternative (Aff e) - -instance monadZero :: MonadZero (Aff e) - -instance monadPlusAff :: MonadPlus (Aff e) - -instance monadRecAff :: MonadRec (Aff e) where - tailRecM f a = runFn3 _tailRecM isLoop f a - where - isLoop (Loop _) = true - isLoop _ = false - -instance semigroupCanceler :: Semigroup (Canceler e) where - append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e) - -instance monoidCanceler :: Monoid (Canceler e) where - mempty = Canceler (const (pure true)) - -newtype ParAff e a = ParAff (Aff e a) - -derive instance newtypeParAff :: Newtype (ParAff e a) _ - -instance semigroupParAff :: (Semigroup a) => Semigroup (ParAff e a) where - append a b = append <$> a <*> b - -instance monoidParAff :: (Monoid a) => Monoid (ParAff e a) where - mempty = pure mempty - -derive newtype instance functorParAff :: Functor (ParAff e) - -instance applyParAff :: Apply (ParAff e) where - apply (ParAff ff) (ParAff fa) = ParAff do - va <- makeVar - vb <- makeVar - c1 <- forkAff (putOrKill va =<< attempt ff) - c2 <- forkAff (putOrKill vb =<< attempt fa) - (takeVar va <*> takeVar vb) `cancelWith` (c1 <> c2) +instance monadRecAff ∷ MonadRec (Aff eff) where + tailRecM k = go where - putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit - putOrKill v = either (killVar v) (putVar v) + go a = do + res ← k a + case res of + Done r → pure r + Loop b → go b -instance applicativeParAff :: Applicative (ParAff e) where - pure = ParAff <<< pure +instance monadThrowAff ∷ MonadThrow Error (Aff eff) where + throwError = _throwError --- | Returns the first value, or the first error if both error. -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) (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 - when (e == 1) $ killVar va err - putVar ve (e + 1) - -instance plusParAff :: Plus (ParAff e) where - empty = ParAff empty - -instance alternativeParAff :: Alternative (ParAff e) - -instance parallelParAff :: Parallel (ParAff e) (Aff e) where - parallel = ParAff - sequential (ParAff ma) = ma - -makeVar :: forall e a. Aff e (AVar a) -makeVar = fromAVBox $ _makeVar nonCanceler - -takeVar :: forall e a. AVar a -> Aff e a -takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q - -putVar :: forall e a. AVar a -> a -> Aff e Unit -putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a - -killVar :: forall e a. AVar a -> Error -> Aff e Unit -killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e +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 -fromAVBox :: forall a e. AVBox a -> Aff e a -fromAVBox = unsafeCoerce +instance monadEffAff ∷ EffectRowEquals eff1 (exception ∷ EXCEPTION | eff2) ⇒ MonadEff eff1 (Aff eff2) where + liftEff eff = Fn.runFn3 _liftEff Left Right (effTo eff) -foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a) +newtype Thread eff a = Thread + { kill ∷ Error → Aff eff Unit + , join ∷ Aff eff a + } -foreign import _delay :: forall e a. Fn2 (Canceler e) Number (Aff e a) +instance functorThread ∷ Functor (Thread eff) where + map f (Thread { kill, join }) = Thread { kill, join: f <$> join } -foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a +newtype Canceler eff = Canceler (Error → Aff eff Unit) -foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e)) +attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a) +attempt = _attempt -foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e)) +bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b +bracket = _bracket -foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a - -foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a) - -foreign import _throwError :: forall e a. Fn2 (Canceler e) Error (Aff e a) - -foreign import _fmap :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b) - -foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (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 (Canceler e)) - -foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a) +launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) +launchAff aff = Fn.runFn6 _drainAff isLeft unsafeFromLeft unsafeFromRight Left Right aff + where + unsafeFromLeft ∷ ∀ x y. Either x y → x + unsafeFromLeft = case _ of + Left a → a + Right _ → unsafeCrashWith "unsafeFromLeft: Right" + + unsafeFromRight ∷ ∀ x y. Either x y → y + unsafeFromRight = case _ of + Right a → a + Left _ → unsafeCrashWith "unsafeFromRight: Left" + +runAff ∷ ∀ eff a. (Either Error a → Eff (exception ∷ EXCEPTION | eff) Unit) → Aff eff a → Eff eff Unit +runAff k aff = do + thread ← launchAff aff + onComplete k thread + +forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) +forkAff = _unsafeSync <<< map Right <<< launchAff + +killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit +killThread e (Thread t) = t.kill e + +joinThread ∷ ∀ eff a. Thread eff a → Aff eff a +joinThread (Thread t) = t.join + +onComplete ∷ ∀ eff a. (Either Error a → Eff (exception ∷ EXCEPTION | eff) Unit) → Thread eff a → Eff eff Unit +onComplete k t = void $ launchAff do + res ← attempt (joinThread t) + liftEff (k res) + +foreign import _pure ∷ ∀ eff a. a → Aff eff a +foreign import _throwError ∷ ∀ eff a. Error → Aff eff a +foreign import _unsafeSync ∷ ∀ eff a. Eff eff (Either Error a) → Aff eff a +foreign import _unsafeAsync ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → 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 _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 _liftEff + ∷ forall eff1 eff2 a + . Fn.Fn3 + (Error → Either Error a) + (a → Either Error a) + (Eff (exception ∷ EXCEPTION | eff1) a) + (Aff eff2 a) + +foreign import _drainAff + ∷ ∀ eff a + . Fn.Fn6 + (Either Error a → Boolean) + (Either Error a → Error) + (Either Error a → a) + (Error → Either Error a) + (a → Either Error a) + (Aff eff a) + (Eff eff (Thread eff a)) -foreign import _tailRecM :: forall e a b. Fn3 (Step a b -> Boolean) (a -> Aff e (Step a b)) a (Aff e b) diff --git a/src/Control/Monad/Aff/AVar.purs b/src/Control/Monad/Aff/AVar.purs index c8f20c4..3bc313e 100644 --- a/src/Control/Monad/Aff/AVar.purs +++ b/src/Control/Monad/Aff/AVar.purs @@ -1,77 +1,3 @@ --- | A low-level primitive for building asynchronous code. -module Control.Monad.Aff.AVar - ( AffAVar - , AVAR - , makeVar - , makeVar' - , takeVar - , peekVar - , putVar - , modifyVar - , killVar - , tryTakeVar - , tryPeekVar - , module Exports - ) where +module Control.Monad.Aff.AVar where -import Prelude - -import Control.Monad.Aff (Aff, nonCanceler) -import Control.Monad.Aff.Internal (AVar) as Exports -import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _peekVar, _makeVar, _tryTakeVar, _tryPeekVar) -import Control.Monad.Eff (kind Effect) -import Control.Monad.Eff.Exception (Error()) - -import Data.Function.Uncurried (runFn4, runFn3, runFn2) -import Data.Maybe (Maybe(..)) - -import Unsafe.Coerce (unsafeCoerce) - -foreign import data AVAR :: Effect - -type AffAVar e a = Aff (avar :: AVAR | e) a - --- | Makes a new asynchronous avar. -makeVar :: forall e a. AffAVar e (AVar a) -makeVar = fromAVBox $ _makeVar nonCanceler - --- | Makes a avar and sets it to some value. -makeVar' :: forall e a. a -> AffAVar e (AVar a) -makeVar' a = do - v <- makeVar - putVar v a - pure v - --- | Takes the next value from the asynchronous avar. -takeVar :: forall e a. AVar a -> AffAVar e a -takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q - --- | A variant of `takeVar` which return immediately if the asynchronous avar --- | was empty. Nothing if the avar empty and `Just a` if the avar have contents `a`. -tryTakeVar :: forall e a. AVar a -> AffAVar e (Maybe a) -tryTakeVar q = fromAVBox $ runFn4 _tryTakeVar Nothing Just nonCanceler q - --- | Reads a value from the asynchronous var but does not consume it. -peekVar :: forall e a. AVar a -> AffAVar e a -peekVar q = fromAVBox $ runFn2 _peekVar nonCanceler q - --- | A variant of `peekVar` which return immediately when the asynchronous avar --- | was empty. Nothing if the avar empty and `Just a` if the avar have contents `a`. -tryPeekVar :: forall e a. AVar a -> AffAVar e (Maybe a) -tryPeekVar q = fromAVBox $ runFn4 _tryPeekVar Nothing Just nonCanceler q - --- | Puts a new value into the asynchronous avar. If the avar has --- | been killed, this will result in an error. -putVar :: forall e a. AVar a -> a -> AffAVar e Unit -putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a - --- | Modifies the value at the head of the avar (will suspend until one is available). -modifyVar :: forall e a. (a -> a) -> AVar a -> AffAVar e Unit -modifyVar f v = takeVar v >>= (f >>> putVar v) - --- | Kills an asynchronous avar. -killVar :: forall e a. AVar a -> Error -> AffAVar e Unit -killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e - -fromAVBox :: forall a e. AVBox a -> AffAVar e a -fromAVBox = unsafeCoerce +-- TODO diff --git a/src/Control/Monad/Aff/Class.purs b/src/Control/Monad/Aff/Class.purs index 483e4ab..20bae3f 100644 --- a/src/Control/Monad/Aff/Class.purs +++ b/src/Control/Monad/Aff/Class.purs @@ -5,6 +5,7 @@ import Prelude import Control.Monad.Aff (Aff) import Control.Monad.Cont.Trans (ContT) import Control.Monad.Eff.Class (class MonadEff) +import Control.Monad.Eff.Exception (EXCEPTION) import Control.Monad.Except.Trans (ExceptT) import Control.Monad.List.Trans (ListT) import Control.Monad.Maybe.Trans (MaybeT) @@ -16,7 +17,7 @@ import Control.Monad.Writer.Trans (WriterT) import Data.Monoid (class Monoid) -class MonadEff eff m <= MonadAff eff m | m -> eff where +class MonadEff (exception ∷ EXCEPTION | eff) m <= MonadAff eff m | m -> eff where liftAff :: forall a. Aff eff a -> m a instance monadAffAff :: MonadAff e (Aff e) where diff --git a/test/Test/Bench.purs b/test/Test/Bench.purs new file mode 100644 index 0000000..1e34fb9 --- /dev/null +++ b/test/Test/Bench.purs @@ -0,0 +1,62 @@ +module Test.Bench where + +import Prelude +import Control.Monad.Aff as Aff +import Control.Monad.Eff (Eff, runPure) +import Control.Monad.Eff.Console as Console +import Control.Monad.Rec.Class (Step(..), tailRecM) +import Performance.Minibench (bench) + +loop1 ∷ ∀ eff. Int → Aff.Aff eff Int +loop1 = tailRecM go + where + go n + | n <= 0 = pure $ Done n + | otherwise = do + _ ← do + _ ← do + _ ← pure n + _ ← pure n + _ ← pure n + pure n + _ ← pure n + _ ← pure n + _ ← pure n + pure n + pure $ Loop (n - 1) + +loop2 ∷ ∀ eff. Int → Aff.Aff eff Int +loop2 = go + where + go n + | n <= 0 = pure n + | otherwise = do + _ ← do + _ ← do + _ ← pure n + _ ← pure n + _ ← pure n + pure n + _ ← pure n + _ ← pure n + _ ← pure n + pure n + loop2 (n - 1) + +fib1 ∷ ∀ e. Int → Aff.Aff e Int +fib1 n = if n <= 1 then pure n else do + a ← fib1 (n - 1) + b ← fib1 (n - 2) + pure (a + b) + +main ∷ Eff (console ∷ Console.CONSOLE) Unit +main = do + Console.log "\nAff tailRecM:" + bench \_ → runPure (void $ Aff.launchAff $ loop1 10000) + + Console.log "\nAff loop:" + bench \_ → runPure (void $ Aff.launchAff $ loop2 10000) + + Console.log "\nAff fib:" + bench \_ → runPure (void $ Aff.launchAff $ fib1 100) + diff --git a/test/Test/Main.js b/test/Test/Main.js deleted file mode 100644 index 27e23a0..0000000 --- a/test/Test/Main.js +++ /dev/null @@ -1,5 +0,0 @@ -"use strict"; - -exports.synchronousUnexpectedThrowError = function () { - throw new Error("ok"); -}; diff --git a/test/Test/Main.purs b/test/Test/Main.purs index a25b24e..dd2db5b 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -1,393 +1,30 @@ module Test.Main where import Prelude - -import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, delay, forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize) -import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, peekVar, killVar, tryTakeVar, tryPeekVar) -import Control.Monad.Aff.Console (CONSOLE, log) +import Control.Monad.Aff (Aff, runAff) import Control.Monad.Eff (Eff) -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 (Step(..), tailRecM) -import Control.Parallel (parallel, sequential) -import Data.Either (either, fromLeft, fromRight) -import Data.Maybe (Maybe(..)) -import Data.Time.Duration (Milliseconds(..)) -import Data.Unfoldable (replicate) -import Partial.Unsafe (unsafePartial) - -type Test a = forall e. Aff (console :: CONSOLE | e) a -type TestAVar a = forall e. Aff (console :: CONSOLE, avar :: AVAR | e) a - -timeout :: Milliseconds → TestAVar Unit → TestAVar Unit -timeout ms aff = do - exn <- makeVar - clr1 <- forkAff (delay ms *> putVar exn (Just "Timed out")) - clr2 <- forkAff (aff *> putVar exn Nothing) - res ← takeVar exn - log (show res) - case res of - Nothing -> void (clr1 `cancel` error "Done") - Just e -> void (clr2 `cancel` error "Done") *> throwError (error e) - -replicateArray :: forall a. Int -> a -> Array a -replicateArray = replicate - -test_sequencing :: Int -> Test Unit -test_sequencing 0 = log "Done" -test_sequencing n = do - delay $ Milliseconds 100.0 - log (show (n / 10) <> " seconds left") - test_sequencing (n - 1) - -foreign import synchronousUnexpectedThrowError :: forall e. Eff e Unit - -test_makeAff :: Test Unit -test_makeAff = unsafePartial do - s <- attempt $ makeAff \reject resolve -> resolve "ok" - log $ "makeAff success is " <> fromRight s - - asyncF <- attempt $ makeAff \reject resolve -> reject (error "ok") - log $ "makeAff asynchronous failure is " <> message (fromLeft asyncF) - - asyncF' <- attempt $ makeAff \reject resolve -> synchronousUnexpectedThrowError - log $ "makeAff synchronous failure is " <> message (fromLeft asyncF') - - log "Success: makeAff is ok" - -test_pure :: Test Unit -test_pure = do - pure unit - pure unit - pure unit - log "Success: Got all the way past 4 pures" - -test_attempt :: Test Unit -test_attempt = do - e <- attempt (throwError (error "Oh noes!")) - either (const $ log "Success: Exception caught") (const $ log "Failure: Exception NOT caught!!!") e - -test_apathize :: Test Unit -test_apathize = do - apathize $ throwError (error "Oh noes!") - log "Success: Exceptions don't stop the apathetic" - -test_putTakeVar :: TestAVar Unit -test_putTakeVar = do - v <- makeVar - _ <- forkAff (delay (Milliseconds 0.0) *> putVar v 1.0) - a <- takeVar v - log ("Success: Value " <> show a) - -test_peekVar :: TestAVar Unit -test_peekVar = do - timeout (Milliseconds 1000.0) do - v <- makeVar - _ <- forkAff (delay (Milliseconds 0.0) *> putVar v 1.0) - a1 <- peekVar v - a2 <- takeVar v - when (a1 /= a2) do - throwError (error "Something horrible went wrong - peeked var is not equal to taken var") - log ("Success: Peeked value not consumed") - - timeout (Milliseconds 1000.0) do - w <- makeVar - putVar w true - b <- peekVar w - when (not b) do - throwError (error "Something horrible went wrong - peeked var is not true") - log ("Success: Peeked value read from written var") - - timeout (Milliseconds 1000.0) do - x <- makeVar - res <- makeVar' 1 - _ <- forkAff do - c <- peekVar x - putVar x 1000 - d <- peekVar x - modifyVar (_ + (c + d)) res - putVar x 10 - count <- takeVar res - e <- takeVar x - f <- takeVar x - when (not (count == 21 && e == 10 && f == 1000)) do - throwError (error "Something horrible went wrong - peeked consumers/producer ordering") - log "Success: peekVar consumer/producer order maintained" - -test_killFirstForked :: Test Unit -test_killFirstForked = do - c <- forkAff (delay (Milliseconds 100.0) $> "Failure: This should have been killed!") - b <- c `cancel` (error "Just die") - log (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked") - -test_killVar :: TestAVar Unit -test_killVar = do - v <- makeVar - killVar v (error "DOA") - e <- attempt $ takeVar v - either (const $ log "Success: Killed queue dead") (const $ log "Failure: Oh noes, queue survived!") e - -test_tryTakeVar :: TestAVar Unit -test_tryTakeVar = do - timeout (Milliseconds 1000.0) do - v <- makeVar - x <- tryTakeVar v - case x of - Nothing -> log $ "Success: trying take an empty var" - Just _ -> throwError $ error $ "Failure: Oh noes, take an empty var should return Nothing" - - timeout (Milliseconds 1000.0) do - v <- makeVar - b <- tryTakeVar v - putVar v 1.0 - a <- tryTakeVar v - when (a /= Just 1.0 || a == b) do - throwError $ error ("Failure: Oh noes, tryTakeVar should take var if it available, value: " <> show a) - log $ "Success: value taken by tryTakeVar " <> show a - -test_tryPeekVar :: TestAVar Unit -test_tryPeekVar = do - timeout (Milliseconds 1000.0) do - v <- makeVar - x <- tryPeekVar v - case x of - Nothing -> log $ "Success: try peek var return immediately" - Just _ -> throwError $ error $ "Failure: tryPeekVar return Just when peek an empty var" - - timeout (Milliseconds 1000.0) do - v <- makeVar - putVar v 100.0 - a <- tryPeekVar v - b <- takeVar v - when (a /= Just b) do - throwError (error "Something horrible went wrong - peeked var is not equal to taken var") - log ("Success: Try Peeked value not consumed") - -test_finally :: TestAVar Unit -test_finally = do - v <- makeVar - finally - (putVar v 0) - (putVar v 2) - apathize $ finally - (throwError (error "poof!") *> putVar v 666) -- this putVar should not get executed - (putVar v 40) - n1 <- takeVar v - n2 <- takeVar v - n3 <- takeVar v - log $ if n1 + n2 + n3 == 42 then "Success: effects amount to 42." - else "Failure: Expected 42." - -test_parRace :: TestAVar Unit -test_parRace = do - s <- sequential (parallel (delay (Milliseconds 100.0) $> "Success: Early bird got the worm") <|> - parallel (delay (Milliseconds 200.0) $> "Failure: Late bird got the worm")) - log s - -test_parError :: TestAVar Unit -test_parError = do - e <- attempt $ sequential (parallel (throwError (error ("Oh noes!"))) *> pure unit) - either (const $ log "Success: Exception propagated") (const $ log "Failure: Exception missing") e - -test_parRaceKill1 :: TestAVar Unit -test_parRaceKill1 = do - s <- sequential (parallel (delay (Milliseconds 100.0) *> throwError (error ("Oh noes!"))) <|> - parallel (delay (Milliseconds 200.0) $> "Success: Early error was ignored in favor of late success")) - log s - -test_parRaceKill2 :: TestAVar Unit -test_parRaceKill2 = do - e <- attempt $ sequential (parallel (delay (Milliseconds 100.0) *> throwError (error ("Oh noes!"))) <|> - parallel (delay (Milliseconds 200.0) *> throwError (error ("Oh noes!")))) - either (const $ log "Success: Killing both kills it dead") (const $ log "Failure: It's alive!!!") e - -test_semigroupCanceler :: Test Unit -test_semigroupCanceler = - let - c = Canceler (const (pure true)) <> Canceler (const (pure true)) - in do - v <- cancel c (error "CANCEL") - log (if v then "Success: Canceled semigroup composite canceler" - else "Failure: Could not cancel semigroup composite canceler") - -test_cancelDelay :: TestAVar Unit -test_cancelDelay = do - c <- forkAff do - _ <- pure "Binding" - delay (Milliseconds 100.0) - log $ "Failure: Delay was not canceled!" - pure "Binding" - v <- cancel c (error "Cause") - log (if v then "Success: Canceled delay" else "Failure: Did not cancel delay") - -test_cancelLaunchDelay :: forall e. Eff (console :: CONSOLE, exception :: EXCEPTION | e) Unit -test_cancelLaunchDelay = do - c <- launchAff $ delay (Milliseconds 100.0) *> log ("Failure: Delay was not canceled!") - void $ launchAff $ (do v <- cancel c (error "Cause") - log (if v then "Success: Canceled delay" else "Failure: Did not cancel delay")) - -test_cancelRunDelay :: forall e. Eff (console :: CONSOLE | e) Unit -test_cancelRunDelay = do - c <- runAff (const (pure unit)) (const (pure unit)) $ delay (Milliseconds 100.0) *> log ("Failure: Delay was not canceled!") - void $ try $ launchAff $ (do v <- cancel c (error "Cause") - log (if v then "Success: Canceled delay" else "Failure: Did not cancel delay")) - -test_cancelParallel :: TestAVar Unit -test_cancelParallel = do - c <- forkAff <<< sequential $ parallel (delay (Milliseconds 100.0) *> log "Failure: #1 should not get through") <|> - parallel (delay (Milliseconds 100.0) *> log "Failure: #2 should not get through") - v <- c `cancel` (error "Must cancel") - log (if v then "Success: Canceling composite of two Parallel succeeded" - else "Failure: Canceling composite of two Parallel failed") +import Control.Monad.Eff.Console (CONSOLE) +import Control.Monad.Eff.Console as Console +import Data.Either (Either(..)) +import Test.Assert (assert', ASSERT) -test_cancelRaceLeft :: TestAVar Unit -test_cancelRaceLeft = do - var <- makeVar - c <- sequential - $ parallel (delay (Milliseconds 250.0) *> putVar var true) - <|> parallel (delay (Milliseconds 100.0)) - delay (Milliseconds 500.0) - putVar var false - l <- takeVar var - when l $ throwError (error "Failure: left side ran even though it lost the race") +type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE | eff) +type TestEff eff = Eff (TestEffects eff) +type TestAff eff = Aff (TestEffects eff) -test_cancelRaceRight :: TestAVar Unit -test_cancelRaceRight = do - var <- makeVar - c <- sequential - $ parallel (delay (Milliseconds 100.0)) - <|> parallel (delay (Milliseconds 250.0) *> putVar var true) - delay (Milliseconds 500.0) - 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 - _ <- forkAff $ tailRecM go { n: 1000000, v } - b <- takeVar v - log (if b then "Success: Synchronous tailRecM resolved synchronously" - else "Failure: Synchronous tailRecM resolved asynchronously") - where - go { n: 0, v } = do - modifyVar (const true) v - pure (Done 0) - go { n, v } = pure (Loop { n: n - 1, v }) - -loopAndBounce :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit -loopAndBounce n = do - res <- tailRecM go n - log $ "Done: " <> show res +runAssertEq ∷ ∀ eff a. Show a ⇒ Eq a ⇒ String → a → TestAff eff a → TestEff eff Unit +runAssertEq s a = runAff go where - go 0 = pure (Done 0) - go k | mod k 30000 == 0 = do - delay (Milliseconds 10.0) - pure (Loop (k - 1)) - go k = pure (Loop (k - 1)) + go (Left err) = do + Console.error ("[Error] " <> s) + assert' s false + go (Right r) = do + assert' s (r == a) + Console.log ("[OK] " <> s) -all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit -all n = do - var <- makeVar' 0 - _ <- forkAll $ replicateArray n (modifyVar (_ + 1) var) - count <- takeVar var - log ("Forked " <> show count) +test_pure ∷ ∀ eff. TestEff eff Unit +test_pure = runAssertEq "pure" 42 (pure 42) -cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit -cancelAll n = do - canceler <- forkAll $ replicateArray n (delay (Milliseconds 100000.0) *> log "oops") - canceled <- cancel canceler (error "bye") - log ("Cancelled all: " <> show canceled) - -main :: Eff (console :: CONSOLE, avar :: AVAR, exception :: EXCEPTION) Unit +main ∷ TestEff () Unit main = do - Eff.log "Testing kill of delay launched in separate Aff" - test_cancelLaunchDelay - - Eff.log "Testing kill of delay run in separate Aff" - test_cancelRunDelay - - void $ runAff throwException (const (pure unit)) $ do - log "Testing sequencing" - test_sequencing 3 - - log "Testing pure" - test_pure - - log "Testing makeAff" - test_makeAff - - log "Testing attempt" - test_attempt - - log "Testing delay" - delay (Milliseconds 0.0) - log "Success: It happened later" - - log "Testing kill of delay" - test_cancelDelay - - log "Testing kill of first forked" - test_killFirstForked - - log "Testing apathize" - test_apathize - - log "Testing semigroup canceler" - test_semigroupCanceler - - log "Testing AVar - putVar, takeVar" - test_putTakeVar - - log "Testing AVar - peekVar" - test_peekVar - - log "Testing AVar killVar" - test_killVar - - log "Testing AVar - tryTakeVar" - test_tryTakeVar - - log "Testing AVar - tryPeekVar" - test_tryPeekVar - - log "Testing finally" - test_finally - - log "Test Parallel (*>)" - test_parError - - log "Testing Parallel (<|>)" - test_parRace - - log "Testing Parallel (<|>) - kill one" - test_parRaceKill1 - - log "Testing Parallel (<|>) - kill two" - test_parRaceKill2 - - 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 - - log "pre-delay" - delay (Milliseconds 1000.0) - log "post-delay" - - loopAndBounce 1000000 - - all 100000 - - cancelAll 100000 - - log "Done testing" + test_pure From c7f2c4f547c05166e4f0ba0ec07162ebf0cde913 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 3 Jul 2017 08:16:49 -0700 Subject: [PATCH 02/35] Move things around, add a bunch of tests and instances --- src/Control/Monad/Aff.js | 441 ---------------------- src/Control/Monad/Aff.purs | 126 +------ src/Control/Monad/Aff/Class.purs | 22 +- src/Control/Monad/Aff/Internal.js | 555 +++++++++++++++++++++++----- src/Control/Monad/Aff/Internal.purs | 263 +++++++++++-- src/Control/Monad/Aff/Unsafe.purs | 8 +- test/Test/Bench.purs | 7 +- test/Test/Main.purs | 286 +++++++++++++- 8 files changed, 1012 insertions(+), 696 deletions(-) delete mode 100644 src/Control/Monad/Aff.js diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js deleted file mode 100644 index 227dfc2..0000000 --- a/src/Control/Monad/Aff.js +++ /dev/null @@ -1,441 +0,0 @@ -"use strict"; - -/* - -An awkward approximation. We elide evidence we would otherwise need in PS for -efficiency sake. - -data Aff eff a - = Pure a - | Throw Error - | Sync (Eff eff (Either Error a)) - | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) - | forall b. Attempt (Aff eff b) ?(Either Error 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"; - -// These are constructors used to implement the recover stack. We still use the -// Aff constructor so that property offsets can always inline. -var CONS = "Cons"; // Cons-list -var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) -var RESUME = "Resume"; // Continue indiscriminately -var FINALIZED = "Finalized"; // Marker for finalization - -function Aff (tag, _1, _2, _3) { - this.tag = tag; - this._1 = _1; - this._2 = _2; - this._3 = _3; -} - -var finalized = new Aff(FINALIZED); - -exports._pure = function (a) { - return new Aff(PURE, a); -}; - -exports._throwError = function (error) { - return new Aff(THROW, error); -}; - -exports._unsafeSync = function (eff) { - return new Aff(SYNC, eff); -}; - -exports._unsafeAsync = function (k) { - return new Aff(ASYNC, k); -}; - -exports._map = function (f) { - return function (aff) { - if (aff.tag === PURE) { - return new Aff(PURE, f(aff._1)); - } else { - return new Aff(BIND, aff, function (value) { - return new Aff(PURE, f(value)); - }); - } - }; -}; - -exports._bind = function (aff) { - return function (k) { - return new Aff(BIND, aff, k); - }; -}; - -exports._attempt = function (aff) { - return new Aff(ATTEMPT, aff); -}; - -exports._bracket = function (acquire) { - return function (release) { - return function (k) { - return new Aff(BRACKET, acquire, release, k); - }; - }; -}; - -exports._liftEff = function (left, right, eff) { - return new Aff(SYNC, function () { - try { - return right(eff()); - } catch (error) { - return left(error); - } - }); -}; - -// Thread state machine -var BLOCKED = 0; // No effect is running. -var PENDING = 1; // An async effect is running. -var RETURN = 2; // The current stack has returned. -var CONTINUE = 3; // Run the next effect. -var BINDSTEP = 4; // -var COMPLETED = 5; // The entire thread has completed. - -exports._drainAff = function (isLeft, fromLeft, fromRight, left, right, aff) { - return function () { - // Monotonically increasing tick, increased on each asynchronous turn. - var runTick = 0; - - // The current branch of the state machine. - var status = CONTINUE; - - // The current point of interest for the state machine branch. - var step = aff; // Successful step - var fail = null; // Failure step - var interrupt = null; // Asynchronous interrupt - - // Stack of continuations for the current thread. - var bhead = null; - var btail = null; - - // Stack of attempts and finalizers for error recovery. This holds a union - // of an arbitrary Aff finalizer or a Cons list of bind continuations. - var attempts = null; - - // A special state is needed for Bracket, because it cannot be killed. When - // we enter a bracket acquisition or finalizer, we increment the counter, - // and then decrement once complete. - var bracket = 0; - - // Each join gets a new id so they can be revoked. - var joinId = 0; - var joins = {}; - - // Temporary bindings for the various branches. - var tmp, result, attempt, canceler; - - // Each invocation of `run` requires a tick. When an asynchronous effect is - // resolved, we must check that the local tick coincides with the thread - // tick before resuming. This prevents multiple async continuations from - // accidentally resuming the same thread. A common example may be invoking - // the provided callback in `makeAff` more than once, but it may also be an - // async effect resuming after the thread was already cancelled. - function run (localRunTick) { - while (1) { - tmp = status; - status = BLOCKED; - - switch (tmp) { - case BINDSTEP: - status = CONTINUE; - step = bhead(step); - if (btail === null) { - bhead = null; - } else { - bhead = btail._1; - btail = btail._2; - } - break; - - case CONTINUE: - switch (step.tag) { - case BIND: - if (bhead) { - btail = new Aff(CONS, bhead, btail); - } - bhead = step._2; - status = CONTINUE; - step = step._1; - break; - - case PURE: - if (bhead === null) { - status = RETURN; - step = right(step._1); - } else { - status = BINDSTEP; - step = step._1; - } - break; - - case THROW: - bhead = null; - btail = null; - status = RETURN; - fail = left(step._1); - break; - - case SYNC: - result = step._1(); - if (isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = fromRight(result); - } - break; - - case ASYNC: - canceler = step._1(function (result) { - return function () { - if (runTick !== localRunTick) { - return; - } - tmp = status; - if (isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = fromRight(result); - } - // We only need to invoke `run` if the subsequent block has - // switch the status to PENDING. Otherwise the callback was - // resolved synchronously, and the current loop can continue - // normally. - if (tmp === PENDING) { - run(++runTick); - } else { - localRunTick = ++runTick; - } - }; - })(); - // If the callback was resolved synchronously, the status will have - // switched to CONTINUE, and we should not move on to PENDING. - if (status === BLOCKED) { - status = PENDING; - step = canceler; - } - break; - - // Enqueue the current stack of binds and continue - case ATTEMPT: - attempts = new Aff(CONS, new Aff(RECOVER, bhead, btail), attempts); - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; - break; - } - break; - - // When we evaluate a Bracket, we also enqueue the instruction so we - // can fullfill it later once we return from the acquisition. - case BRACKET: - bracket++; - attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; - break; - - case RETURN: - // If the current stack has returned, and we have no other stacks to - // resume or finalizers to run, the thread has halted and we can - // invoke all join callbacks. Otherwise we need to resume. - if (attempts === null) { - runTick++; // Increment the counter to prevent reentry after completion. - status = COMPLETED; - step = interrupt || fail || step; - for (var k in joins) { - runJoin(step, joins[k]); - } - joins = null; - } 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). - case RECOVER: - attempts = attempts._2; - if (interrupt === null) { - bhead = attempt._1; - btail = attempt._2; - status = BINDSTEP; - step = fail || step; - fail = null; - } - break; - - // We cannot resume from an interrupt or exception. - case RESUME: - attempts = attempts._2; - if (interrupt === null && fail === null) { - bhead = attempt._1; - btail = attempt._2; - status = BINDSTEP; - step = fromRight(step); - } - break; - - // If we have a bracket, we should enqueue the finalizer branch, - // and continue with the success branch only if the thread has - // not been interrupted. If the bracket acquisition failed, we - // should not run either. - case BRACKET: - bracket--; - if (fail === null) { - result = fromRight(step); - attempts = new Aff(CONS, attempt._2(result), attempts._2); - if (interrupt === null) { - status = CONTINUE; - step = attempt._3(result); - } - } else { - attempts = attempts._2; - } - break; - - case FINALIZED: - bracket--; - attempts = attempts._2; - break; - - // Otherwise we need to run a finalizer, which cannot be interrupted. - // We insert a FINALIZED marker to know when we can release it. - default: - bracket++; - attempts._1 = finalized; - status = CONTINUE; - step = attempt; - } - } - break; - - case COMPLETED: - status = COMPLETED; - // If we have an unhandled exception, we need to throw it in - // a fresh stack. - if (isLeft(step)) { - setTimeout(function() { - throw fromLeft(step); - }, 0); - } - return; - case BLOCKED: return; - case PENDING: return; - } - - tmp = null; - result = null; - attempt = null; - canceler = null; - } - } - - function addJoinCallback (cb) { - var jid = joinId++; - joins[jid] = cb; - return function (error) { - return new Aff(SYNC, function () { - delete joins[jid]; - return right({}); - }); - }; - } - - function pureCanceler (error) { - return new Aff(PURE, {}); - } - - function kill (error) { - return new Aff(ASYNC, function (cb) { - return function () { - // Shadow the canceler binding because it can potentially be - // clobbered if we call `run`. - var canceler; - switch (status) { - case COMPLETED: - canceler = pureCanceler; - cb(right({}))(); - break; - case PENDING: - canceler = addJoinCallback(cb); - if (interrupt === null) { - interrupt = left(error); - } - // If we can interrupt the pending action, enqueue the canceler as - // a non-interruptible finalizer. - if (bracket === 0) { - attempts = new Aff(CONS, step(error), attempts); - bhead = null; - btail = null; - status = RETURN; - run(runTick++); - } - break; - default: - canceler = addJoinCallback(cb); - if (interrupt === null) { - interrupt = left(error); - } - if (bracket === 0) { - bhead = null; - btail = null; - status = RETURN; - } - } - return canceler; - }; - }); - } - - function join () { - return new Aff(ASYNC, function (cb) { - return function () { - if (status === COMPLETED) { - cb(step)(); - return pureCanceler; - } - return addJoinCallback(cb); - }; - }); - } - - run(runTick); - - return { - kill: kill, - join: join() - }; - }; -}; - -function runJoin (result, cb) { - try { - cb(result)(); - } catch (error) { - setTimeout(function () { - throw error; - }, 0) - } -} diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 9088c38..e48fb58 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -1,131 +1,27 @@ module Control.Monad.Aff - ( Aff - , Thread - , Canceler(..) - , attempt - , bracket - , runAff - , launchAff + ( module Internal , forkAff + , runAff , killThread , joinThread - , onComplete ) where import Prelude -import Data.Function.Uncurried as Fn -import Control.Monad.Eff (Eff, kind Effect) -import Control.Monad.Eff.Class (class MonadEff, liftEff) -import Control.Monad.Eff.Exception (EXCEPTION, Error) -import Control.Monad.Error.Class (class MonadError, class MonadThrow) -import Control.Monad.Rec.Class (class MonadRec, Step(..)) -import Data.Either (Either(..), isLeft) -import Partial.Unsafe (unsafeCrashWith) -import Type.Row.Effect.Equality (class EffectRowEquals, effTo) - -foreign import data Aff :: # Effect → Type → Type - -instance functorAff ∷ Functor (Aff eff) where map = _map -instance applyAff ∷ Apply (Aff eff) where apply = ap -instance applicativeAff ∷ Applicative (Aff eff) where pure = _pure -instance bindAff ∷ Bind (Aff eff) where bind = _bind -instance monadAff ∷ Monad (Aff eff) - -instance monadRecAff ∷ MonadRec (Aff eff) where - tailRecM k = go - where - go a = do - res ← k a - case res of - Done r → pure r - Loop b → go b - -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 - -instance monadEffAff ∷ EffectRowEquals eff1 (exception ∷ EXCEPTION | eff2) ⇒ MonadEff eff1 (Aff eff2) where - liftEff eff = Fn.runFn3 _liftEff Left Right (effTo eff) - -newtype Thread eff a = Thread - { kill ∷ Error → Aff eff Unit - , join ∷ Aff eff a - } - -instance functorThread ∷ Functor (Thread eff) where - map f (Thread { kill, join }) = Thread { kill, join: f <$> join } +import Control.Monad.Aff.Internal (ASYNC, Aff, AffModality, Thread(..), attempt, launchAff, unsafeLaunchAff, unsafeLiftEff) +import Control.Monad.Aff.Internal (Aff, AffModality, ParAff, Thread, Canceler(..), ASYNC, attempt, bracket, delay, launchAff, makeAff, nonCanceler) as Internal +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Class (liftEff) +import Control.Monad.Eff.Exception (Error) +import Data.Either (Either(..)) -newtype Canceler eff = Canceler (Error → Aff eff Unit) - -attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a) -attempt = _attempt - -bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b -bracket = _bracket - -launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) -launchAff aff = Fn.runFn6 _drainAff isLeft unsafeFromLeft unsafeFromRight Left Right aff - where - unsafeFromLeft ∷ ∀ x y. Either x y → x - unsafeFromLeft = case _ of - Left a → a - Right _ → unsafeCrashWith "unsafeFromLeft: Right" - - unsafeFromRight ∷ ∀ x y. Either x y → y - unsafeFromRight = case _ of - Right a → a - Left _ → unsafeCrashWith "unsafeFromRight: Left" - -runAff ∷ ∀ eff a. (Either Error a → Eff (exception ∷ EXCEPTION | eff) Unit) → Aff eff a → Eff eff Unit -runAff k aff = do - thread ← launchAff aff - onComplete k thread +runAff ∷ ∀ eff a. (Either Error a → Eff (AffModality eff) Unit) → Aff eff a → Eff (async ∷ ASYNC | eff) Unit +runAff k aff = void $ launchAff $ liftEff <<< k =<< attempt aff forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) -forkAff = _unsafeSync <<< map Right <<< launchAff +forkAff = unsafeLiftEff <<< map Right <<< unsafeLaunchAff killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit killThread e (Thread t) = t.kill e joinThread ∷ ∀ eff a. Thread eff a → Aff eff a joinThread (Thread t) = t.join - -onComplete ∷ ∀ eff a. (Either Error a → Eff (exception ∷ EXCEPTION | eff) Unit) → Thread eff a → Eff eff Unit -onComplete k t = void $ launchAff do - res ← attempt (joinThread t) - liftEff (k res) - -foreign import _pure ∷ ∀ eff a. a → Aff eff a -foreign import _throwError ∷ ∀ eff a. Error → Aff eff a -foreign import _unsafeSync ∷ ∀ eff a. Eff eff (Either Error a) → Aff eff a -foreign import _unsafeAsync ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → 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 _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 _liftEff - ∷ forall eff1 eff2 a - . Fn.Fn3 - (Error → Either Error a) - (a → Either Error a) - (Eff (exception ∷ EXCEPTION | eff1) a) - (Aff eff2 a) - -foreign import _drainAff - ∷ ∀ eff a - . Fn.Fn6 - (Either Error a → Boolean) - (Either Error a → Error) - (Either Error a → a) - (Error → Either Error a) - (a → Either Error a) - (Aff eff a) - (Eff eff (Thread eff a)) - diff --git a/src/Control/Monad/Aff/Class.purs b/src/Control/Monad/Aff/Class.purs index 20bae3f..44ac02f 100644 --- a/src/Control/Monad/Aff/Class.purs +++ b/src/Control/Monad/Aff/Class.purs @@ -2,7 +2,7 @@ module Control.Monad.Aff.Class where import Prelude -import Control.Monad.Aff (Aff) +import Control.Monad.Aff (Aff, ASYNC) import Control.Monad.Cont.Trans (ContT) import Control.Monad.Eff.Class (class MonadEff) import Control.Monad.Eff.Exception (EXCEPTION) @@ -17,32 +17,32 @@ import Control.Monad.Writer.Trans (WriterT) import Data.Monoid (class Monoid) -class MonadEff (exception ∷ EXCEPTION | eff) m <= MonadAff eff m | m -> eff where +class MonadEff (exception ∷ EXCEPTION, async ∷ ASYNC | eff) m ⇐ MonadAff eff m | m → eff where liftAff :: forall a. Aff eff a -> m a -instance monadAffAff :: MonadAff e (Aff e) where +instance monadAffAff ∷ MonadAff e (Aff e) where liftAff = id -instance monadAffContT :: MonadAff eff m => MonadAff eff (ContT r m) where +instance monadAffContT ∷ MonadAff eff m ⇒ MonadAff eff (ContT r m) where liftAff = lift <<< liftAff -instance monadAffExceptT :: MonadAff eff m => MonadAff eff (ExceptT e m) where +instance monadAffExceptT ∷ MonadAff eff m ⇒ MonadAff eff (ExceptT e m) where liftAff = lift <<< liftAff -instance monadAffListT :: MonadAff eff m => MonadAff eff (ListT m) where +instance monadAffListT ∷ MonadAff eff m ⇒ MonadAff eff (ListT m) where liftAff = lift <<< liftAff -instance monadAffMaybe :: MonadAff eff m => MonadAff eff (MaybeT m) where +instance monadAffMaybe ∷ MonadAff eff m ⇒ MonadAff eff (MaybeT m) where liftAff = lift <<< liftAff -instance monadAffReader :: MonadAff eff m => MonadAff eff (ReaderT r m) where +instance monadAffReader ∷ MonadAff eff m ⇒ MonadAff eff (ReaderT r m) where liftAff = lift <<< liftAff -instance monadAffRWS :: (MonadAff eff m, Monoid w) => MonadAff eff (RWST r w s m) where +instance monadAffRWS ∷ (MonadAff eff m, Monoid w) ⇒ MonadAff eff (RWST r w s m) where liftAff = lift <<< liftAff -instance monadAffState :: MonadAff eff m => MonadAff eff (StateT s m) where +instance monadAffState ∷ MonadAff eff m ⇒ MonadAff eff (StateT s m) where liftAff = lift <<< liftAff -instance monadAffWriter :: (MonadAff eff m, Monoid w) => MonadAff eff (WriterT w m) where +instance monadAffWriter ∷ (MonadAff eff m, Monoid w) ⇒ MonadAff eff (WriterT w m) where liftAff = lift <<< liftAff diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index 49bf6bf..138109d 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/src/Control/Monad/Aff/Internal.js @@ -1,125 +1,496 @@ "use strict"; -exports._makeVar = function (nonCanceler) { - return function (success) { - success({ - consumers: [], - producers: [], - error: undefined - }); - return nonCanceler; - }; +/* + +An awkward approximation. We elide evidence we would otherwise need in PS for +efficiency sake. + +data Aff eff a + = Pure a + | Throw Error + | Sync (Eff eff (Either Error a)) + | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) + | forall b. Attempt (Aff eff b) ?(Either Error 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"; + +// These are constructors used to implement the recover stack. We still use the +// Aff constructor so that property offsets can always inline. +var CONS = "Cons"; // Cons-list +var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) +var RESUME = "Resume"; // Continue indiscriminately +var FINALIZED = "Finalized"; // Marker for finalization + +function Aff (tag, _1, _2, _3) { + this.tag = tag; + this._1 = _1; + this._2 = _2; + this._3 = _3; +} + +var nonCanceler = function (error) { + return new Aff(PURE, void 0); +}; + +exports._pure = function (a) { + return new Aff(PURE, a); }; -exports._takeVar = function (nonCanceler, avar) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); - } else if (avar.producers.length > 0) { - avar.producers.shift()(success, error); +exports._throwError = function (error) { + return new Aff(THROW, error); +}; + +exports._map = function (f) { + return function (aff) { + if (aff.tag === PURE) { + return new Aff(PURE, f(aff._1)); } else { - avar.consumers.push({ peek: false, success: success, error: error }); + return new Aff(BIND, aff, function (value) { + return new Aff(PURE, f(value)); + }); } + }; +}; - return nonCanceler; +exports._bind = function (aff) { + return function (k) { + return new Aff(BIND, aff, k); }; }; -exports._tryTakeVar = function (nothing, just, nonCanceler, avar) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); - } else if (avar.producers.length > 0) { - avar.producers.shift()(function (x) { - return success(just(x)); - }, error); - } else { - success(nothing); - } - return nonCanceler; +exports.unsafeLiftEff = function (eff) { + return new Aff(SYNC, eff); +}; + +exports.unsafeMakeAff = 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) { + return new Aff(BRACKET, acquire, release, k); + }; }; }; -exports._peekVar = function (nonCanceler, avar) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); - } else if (avar.producers.length > 0) { - avar.producers[0](success, error); - } else { - avar.consumers.push({ peek: true, success: success, error: error }); +exports._liftEff = function (left, right, eff) { + return new Aff(SYNC, function () { + try { + return right(eff()); + } catch (error) { + return left(error); } - return nonCanceler; - }; + }); }; -exports._tryPeekVar = function (nothing, just, nonCanceler, avar) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); - } else if (avar.producers.length > 0) { - avar.producers[0](function (x) { - return success(just(x)); - }, error); +exports._makeAff = function (left, right, aff) { + return new Aff(ASYNC, function (k) { + return function () { + try { + return aff(k)(); + } catch (error) { + k(left(error))(); + return nonCanceler; + } + }; + }); +}; + +exports._delay = function () { + var setDelay = function (n, k) { + if (n === 0 && typeof setImmediate !== "undefined") { + return setImmediate(k); } else { - success(nothing); + return setTimeout(k, n); } - return nonCanceler; }; -}; - -exports._putVar = function (nonCanceler, avar, a) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); + var clearDelay = function (n, t) { + if (n === 0 && typeof clearImmediate !== "undefined") { + return clearImmediate(t); } else { - var shouldQueue = true; - var consumers = []; - var consumer; - - while (true) { - consumer = avar.consumers.shift(); - if (consumer) { - consumers.push(consumer); - if (consumer.peek) { - continue; + return clearTimeout(t); + } + }; + return function (right, ms) { + return new Aff(ASYNC, function (cb) { + return function () { + var timer = setDelay(ms, cb(right())); + return function () { + return new Aff(SYNC, function () { + return right(clearDelay(ms, timer)); + }); + }; + }; + }); + }; +}(); + +// Thread state machine +var BLOCKED = 0; // No effect is running. +var PENDING = 1; // An async effect is running. +var RETURN = 2; // The current stack has returned. +var CONTINUE = 3; // Run the next effect. +var BINDSTEP = 4; // Apply the next bind. +var COMPLETED = 5; // The entire thread has completed. + +exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { + return function () { + // Monotonically increasing tick, increased on each asynchronous turn. + var runTick = 0; + + // The current branch of the state machine. + var status = CONTINUE; + + // The current point of interest for the state machine branch. + var step = aff; // Successful step + var fail = null; // Failure step + var interrupt = null; // Asynchronous interrupt + + // Stack of continuations for the current thread. + var bhead = null; + var btail = null; + + // Stack of attempts and finalizers for error recovery. This holds a union + // of an arbitrary Aff finalizer or a Cons list of bind continuations. + var attempts = null; + + // A special state is needed for Bracket, because it cannot be killed. When + // we enter a bracket acquisition or finalizer, we increment the counter, + // and then decrement once complete. + var bracket = 0; + + // Each join gets a new id so they can be revoked. + var joinId = 0; + var joins = {}; + + // Temporary bindings for the various branches. + var tmp, result, attempt, canceler; + + // Each invocation of `run` requires a tick. When an asynchronous effect is + // resolved, we must check that the local tick coincides with the thread + // tick before resuming. This prevents multiple async continuations from + // accidentally resuming the same thread. A common example may be invoking + // the provided callback in `makeAff` more than once, but it may also be an + // async effect resuming after the thread was already cancelled. + function run (localRunTick) { + while (1) { + switch (status) { + case BINDSTEP: + status = CONTINUE; + step = bhead(step); + if (btail === null) { + bhead = null; } else { - shouldQueue = false; + bhead = btail._1; + btail = btail._2; } - } - break; - } + break; - if (shouldQueue) { - avar.producers.push(function (success) { - success(a); - return nonCanceler; - }); - } + case CONTINUE: + switch (step.tag) { + case BIND: + if (bhead) { + btail = new Aff(CONS, bhead, btail); + } + bhead = step._2; + status = CONTINUE; + step = step._1; + break; + + case PURE: + if (bhead === null) { + status = RETURN; + step = right(step._1); + } else { + status = BINDSTEP; + step = step._1; + } + break; + + case THROW: + bhead = null; + btail = null; + status = RETURN; + fail = left(step._1); + break; + + case SYNC: + status = BLOCKED; + result = step._1(); + if (isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = fromRight(result); + } + break; + + case ASYNC: + status = BLOCKED; + canceler = step._1(function (result) { + return function () { + if (runTick !== localRunTick) { + return; + } + tmp = status; + if (isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = fromRight(result); + } + // We only need to invoke `run` if the subsequent block has + // switch the status to PENDING. Otherwise the callback was + // resolved synchronously, and the current loop can continue + // normally. + if (tmp === PENDING) { + run(++runTick); + } else { + localRunTick = ++runTick; + } + }; + })(); + // If the callback was resolved synchronously, the status will have + // switched to CONTINUE, and we should not move on to PENDING. + if (status === BLOCKED) { + status = PENDING; + step = canceler; + } + break; + + // Enqueue the current stack of binds and continue + case ATTEMPT: + attempts = new Aff(CONS, new Aff(RECOVER, bhead, btail), attempts); + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + + // When we evaluate a Bracket, we also enqueue the instruction so we + // can fullfill it later once we return from the acquisition. + case BRACKET: + bracket++; + if (bhead === null) { + attempts = new Aff(CONS, step, attempts); + } else { + attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); + } + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + } + break; + + case RETURN: + // If the current stack has returned, and we have no other stacks to + // resume or finalizers to run, the thread has halted and we can + // invoke all join callbacks. Otherwise we need to resume. + if (attempts === null) { + runTick++; // Increment the counter to prevent reentry after completion. + status = COMPLETED; + step = interrupt || fail || step; + } 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). + case RECOVER: + attempts = attempts._2; + if (interrupt === null) { + bhead = attempt._1; + btail = attempt._2; + status = BINDSTEP; + step = fail || step; + fail = null; + } + break; + + // We cannot resume from an interrupt or exception. + case RESUME: + attempts = attempts._2; + if (interrupt === null && fail === null) { + bhead = attempt._1; + btail = attempt._2; + status = BINDSTEP; + step = fromRight(step); + } + break; - for (var i = 0; i < consumers.length; i++) { - consumers[i].success(a); + // If we have a bracket, we should enqueue the finalizer branch, + // and continue with the success branch only if the thread has + // not been interrupted. If the bracket acquisition failed, we + // should not run either. + case BRACKET: + bracket--; + if (fail === null) { + result = fromRight(step); + attempts = new Aff(CONS, attempt._2(result), attempts._2); + if (interrupt === null || bracket > 0) { + status = CONTINUE; + step = attempt._3(result); + } + } else { + attempts = attempts._2; + } + break; + + case FINALIZED: + bracket--; + attempts = attempts._2; + step = attempt._1; + break; + + // Otherwise we need to run a finalizer, which cannot be interrupted. + // We insert a FINALIZED marker to know when we can release it. + default: + bracket++; + attempts._1 = new Aff(FINALIZED, step); + status = CONTINUE; + step = attempt; + } + } + break; + + case COMPLETED: + tmp = false; + for (var k in joins) { + tmp = true; + runJoin(step, joins[k]); + } + joins = tmp; + // If we have an unhandled exception, and no other thread has joined + // then we need to throw the exception in a fresh stack. + if (isLeft(step) && !joins) { + setTimeout(function() { + // Guard on joins because a completely synchronous thread can + // still have an observer. + if (!joins) { + throw fromLeft(step); + } + }, 0); + } + return; + case BLOCKED: return; + case PENDING: return; + } + + tmp = null; + result = null; + attempt = null; + canceler = null; } + } - success({}); + function addJoinCallback (cb) { + var jid = joinId++; + joins[jid] = cb; + return function (error) { + return new Aff(SYNC, function () { + delete joins[jid]; + return right(); + }); + }; } - return nonCanceler; - }; -}; + function kill (error) { + return new Aff(ASYNC, function (cb) { + return function () { + // Shadow the canceler binding because it can potentially be + // clobbered if we call `run`. + var canceler; + var killCb = function () { + return cb(right(void 0)); + }; + switch (status) { + case COMPLETED: + canceler = nonCanceler; + killCb()(); + break; + case PENDING: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = left(error); + } + // If we can interrupt the pending action, enqueue the canceler as + // a non-interruptible finalizer. + if (bracket === 0) { + attempts = new Aff(CONS, step(error), attempts); + bhead = null; + btail = null; + status = RETURN; + step = null; + fail = null; + run(runTick++); + } + break; + default: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = left(error); + } + if (bracket === 0) { + bhead = null; + btail = null; + status = RETURN; + } + } + return canceler; + }; + }); + } -exports._killVar = function (nonCanceler, avar, e) { - return function (success, error) { - if (avar.error !== undefined) { - error(avar.error); - } else { - avar.error = e; - while (avar.consumers.length) { - avar.consumers.shift().error(e); - } - success({}); + function join () { + return new Aff(ASYNC, function (cb) { + return function () { + if (status === COMPLETED) { + joins = true; + cb(step)(); + return nonCanceler; + } + return addJoinCallback(cb); + }; + }); } - return nonCanceler; + run(runTick); + + return { + kill: kill, + join: join() + }; }; }; + +function runJoin (result, cb) { + try { + cb(result)(); + } catch (error) { + setTimeout(function () { + throw error; + }, 0) + } +} diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs index 0ff681d..fd2d91b 100644 --- a/src/Control/Monad/Aff/Internal.purs +++ b/src/Control/Monad/Aff/Internal.purs @@ -1,36 +1,257 @@ module Control.Monad.Aff.Internal - ( AVBox - , AVar - , _makeVar - , _takeVar - , _tryTakeVar - , _peekVar - , _tryPeekVar - , _putVar - , _killVar + ( Aff + , AffModality + , ParAff(..) + , Thread(..) + , Canceler(..) + , ASYNC + , nonCanceler + , makeAff + , launchAff + , attempt + , bracket + , delay + , unsafeLaunchAff + , unsafeLiftEff + , unsafeMakeAff ) where import Prelude +import Control.Alt (class Alt) +import Control.Alternative (class Alternative) +import Control.Apply (lift2) +import Control.Monad.Eff (Eff, kind Effect) +import Control.Monad.Eff.Class (class MonadEff) +import Control.Monad.Eff.Exception (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.Rec.Class (class MonadRec, Step(..)) +import Control.MonadPlus (class MonadPlus) +import Control.MonadZero (class MonadZero) +import Control.Parallel (parSequence_) +import Control.Parallel.Class (class Parallel) +import Control.Plus (class Plus, empty) +import Data.Either (Either(..), isLeft) +import Data.Function.Uncurried as Fn +import Data.Maybe (Maybe(..)) +import Data.Monoid (class Monoid, mempty) +import Data.Newtype (class Newtype) +import Data.Time.Duration (Milliseconds(..)) +import Partial.Unsafe (unsafeCrashWith) +import Type.Row.Effect.Equality (class EffectRowEquals, effTo) +import Unsafe.Coerce (unsafeCoerce) -import Control.Monad.Eff.Exception (Error) +foreign import data Aff ∷ # Effect → Type → Type -import Data.Maybe (Maybe) -import Data.Function.Uncurried (Fn2, Fn3, Fn4) +foreign import data ASYNC ∷ Effect -foreign import data AVar :: Type -> Type +type AffModality eff = + ( exception ∷ EXCEPTION + , async ∷ ASYNC + | eff + ) -foreign import data AVBox :: Type -> Type +instance functorAff ∷ Functor (Aff eff) where map = _map +instance applyAff ∷ Apply (Aff eff) where apply = ap +instance applicativeAff ∷ Applicative (Aff eff) where pure = _pure +instance bindAff ∷ Bind (Aff eff) where bind = _bind +instance monadAff ∷ Monad (Aff eff) -foreign import _makeVar :: forall c a. c -> AVBox (AVar a) +instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where + append = lift2 append -foreign import _takeVar :: forall c a. Fn2 c (AVar a) (AVBox a) +instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where + mempty = pure mempty -foreign import _tryTakeVar :: forall c a. Fn4 (forall x. Maybe x) (forall x. x -> Maybe x) c (AVar a) (AVBox (Maybe a)) +instance altAff ∷ Alt (Aff eff) where + alt a1 a2 = do + res ← attempt a1 + case res of + Left err → a2 + Right r → pure r -foreign import _peekVar :: forall c a. Fn2 c (AVar a) (AVBox a) +instance plusAff ∷ Plus (Aff eff) where + empty = throwError (error "Always fails") -foreign import _tryPeekVar :: forall c a. Fn4 (forall x. Maybe x) (forall x. x -> Maybe x) c (AVar a) (AVBox (Maybe a)) +instance alternativeAff ∷ Alternative (Aff eff) -foreign import _putVar :: forall c a. Fn3 c (AVar a) a (AVBox Unit) +instance monadZeroAff ∷ MonadZero (Aff eff) -foreign import _killVar :: forall c a. Fn3 c (AVar a) Error (AVBox Unit) +instance monadPlusAff ∷ MonadPlus (Aff eff) + +instance monadRecAff ∷ MonadRec (Aff eff) where + tailRecM k = go + where + go a = do + res ← k a + case res of + Done r → pure r + Loop b → go b + +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 + +instance monadEffAff ∷ EffectRowEquals eff1 (exception ∷ EXCEPTION, async ∷ ASYNC | eff2) ⇒ MonadEff eff1 (Aff eff2) where + liftEff eff = Fn.runFn3 _liftEff Left Right (effTo eff) + +newtype ParAff eff a = ParAff (Aff eff a) + +derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ +derive newtype instance functorParAff ∷ Functor (ParAff eff) + +instance applyParAff ∷ Apply (ParAff eff) where + apply (ParAff ff) (ParAff fa) = ParAff (unsafeMakeAff go) + where + go k = do + Thread t1 ← unsafeLaunchAff ff + Thread t2 ← unsafeLaunchAff fa + Thread t3 ← unsafeLaunchAff do + f ← attempt t1.join + a ← attempt t2.join + unsafeLiftEff (Right <$> k (f <*> a)) + pure $ Canceler \err → + parSequence_ + [ t3.kill err + , t1.kill err + , t2.kill err + ] + +instance applicativeParAff ∷ Applicative (ParAff eff) where + pure = ParAff <<< pure + +instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where + append = lift2 append + +instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where + mempty = pure mempty + +instance altParAff ∷ Alt (ParAff eff) where + alt (ParAff a1) (ParAff a2) = ParAff (unsafeMakeAff go) + where + go k = do + ref ← unsafeRunRef $ newRef Nothing + Thread t1 ← unsafeLaunchAff a1 + Thread t2 ← unsafeLaunchAff a2 + + let + lift ∷ ∀ a. Eff eff a → Aff eff a + lift = unsafeLiftEff <<< map Right + + earlyError = + error "Alt ParAff: early exit" + + runK t r = do + res ← lift $ unsafeRunRef $ readRef ref + case res, r of + Nothing, Left _ → lift $ unsafeRunRef $ writeRef ref (Just r) + Nothing, Right _ → t.kill earlyError *> lift (k r) + Just r', _ → t.kill earlyError *> lift (k r') + + Thread t3 ← unsafeLaunchAff $ runK t2 =<< attempt t1.join + Thread t4 ← unsafeLaunchAff $ runK t1 =<< attempt t2.join + + pure $ Canceler \err → + parSequence_ + [ t3.kill earlyError + , t4.kill earlyError + , t1.kill earlyError + , t2.kill earlyError + ] + +instance plusParAff ∷ Plus (ParAff e) where + empty = ParAff empty + +instance alternativeParAff ∷ Alternative (ParAff e) + +instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where + parallel = ParAff + sequential (ParAff aff) = aff + +newtype Thread eff a = Thread + { kill ∷ Error → Aff eff Unit + , join ∷ Aff eff a + } + +instance functorThread ∷ Functor (Thread eff) where + map f (Thread { kill, join }) = Thread { kill, join: f <$> join } + +newtype Canceler eff = Canceler (Error → Aff eff Unit) + +derive instance newtypeCanceler ∷ Newtype (Canceler eff) _ + +instance semigroupCanceler ∷ Semigroup (Canceler eff) where + append (Canceler c1) (Canceler c2) = + Canceler \err → parSequence_ [ c1 err, c2 err ] + +instance monoidCanceler ∷ Monoid (Canceler eff) where + mempty = nonCanceler + +nonCanceler ∷ ∀ eff. Canceler eff +nonCanceler = Canceler k where k _ = pure unit + +launchAff ∷ ∀ eff a. Aff eff a → Eff (async ∷ ASYNC | eff) (Thread eff a) +launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff + +unsafeLaunchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) +unsafeLaunchAff = unsafeCoerce launchAff + +makeAff ∷ ∀ eff a. ((Either Error a → Eff (AffModality eff) Unit) → Eff (AffModality eff) (Canceler eff)) → Aff eff a +makeAff k = Fn.runFn3 _makeAff Left Right k + +delay ∷ ∀ eff. Milliseconds → Aff eff Unit +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 _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 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 unsafeLiftEff ∷ ∀ eff a. Eff eff (Either Error a) → Aff eff a +foreign import unsafeMakeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a + +foreign import _liftEff + ∷ ∀ eff a + . Fn.Fn3 + (Error → Either Error a) + (a → Either Error a) + (Eff (AffModality eff) a) + (Aff eff a) + +foreign import _makeAff + ∷ ∀ eff a + . Fn.Fn3 + (Error → Either Error a) + (a → Either Error a) + ((Either Error a → Eff (AffModality eff) Unit) → Eff (AffModality eff) (Canceler eff)) + (Aff eff a) + +foreign import _launchAff + ∷ ∀ eff a + . Fn.Fn6 + (Either Error a → Boolean) + (Either Error a → Error) + (Either Error a → a) + (Error → Either Error a) + (a → Either Error a) + (Aff eff a) + (Eff (async ∷ ASYNC | eff) (Thread eff a)) + +unsafeFromLeft ∷ ∀ x y. Either x y → x +unsafeFromLeft = case _ of + Left a → a + Right _ → unsafeCrashWith "unsafeFromLeft: Right" + +unsafeFromRight ∷ ∀ x y. Either x y → y +unsafeFromRight = case _ of + Right a → a + Left _ → unsafeCrashWith "unsafeFromRight: Left" diff --git a/src/Control/Monad/Aff/Unsafe.purs b/src/Control/Monad/Aff/Unsafe.purs index 349662f..7860525 100644 --- a/src/Control/Monad/Aff/Unsafe.purs +++ b/src/Control/Monad/Aff/Unsafe.purs @@ -1,7 +1,11 @@ -module Control.Monad.Aff.Unsafe where +module Control.Monad.Aff.Unsafe + ( unsafeCoerceAff + , module Internal + ) where import Control.Monad.Aff (Aff) +import Control.Monad.Aff.Internal (unsafeLaunchAff, unsafeLiftEff, unsafeMakeAff) as Internal import Unsafe.Coerce (unsafeCoerce) -unsafeCoerceAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a +unsafeCoerceAff ∷ ∀ eff1 eff2 a. Aff eff1 a -> Aff eff2 a unsafeCoerceAff = unsafeCoerce diff --git a/test/Test/Bench.purs b/test/Test/Bench.purs index 1e34fb9..8bcdc59 100644 --- a/test/Test/Bench.purs +++ b/test/Test/Bench.purs @@ -3,6 +3,7 @@ module Test.Bench where import Prelude import Control.Monad.Aff as Aff import Control.Monad.Eff (Eff, runPure) +import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Control.Monad.Eff.Console as Console import Control.Monad.Rec.Class (Step(..), tailRecM) import Performance.Minibench (bench) @@ -52,11 +53,11 @@ fib1 n = if n <= 1 then pure n else do main ∷ Eff (console ∷ Console.CONSOLE) Unit main = do Console.log "\nAff tailRecM:" - bench \_ → runPure (void $ Aff.launchAff $ loop1 10000) + bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ loop1 10000 Console.log "\nAff loop:" - bench \_ → runPure (void $ Aff.launchAff $ loop2 10000) + bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ loop2 10000 Console.log "\nAff fib:" - bench \_ → runPure (void $ Aff.launchAff $ fib1 100) + bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ fib1 100 diff --git a/test/Test/Main.purs b/test/Test/Main.purs index dd2db5b..55483d7 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -1,30 +1,294 @@ module Test.Main where import Prelude -import Control.Monad.Aff (Aff, runAff) +import Control.Monad.Aff (Aff, Canceler(..), ASYNC, nonCanceler, runAff, launchAff, makeAff, attempt, bracket, delay, forkAff, joinThread, killThread) import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) import Control.Monad.Eff.Console as Console -import Data.Either (Either(..)) +import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error, message) +import Control.Monad.Eff.Ref (REF, Ref) +import Control.Monad.Eff.Ref as Ref +import Control.Monad.Error.Class (throwError) +import Data.Bifunctor (lmap) +import Data.Either (Either(..), isLeft) +import Data.Foldable (sum) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Data.Time.Duration (Milliseconds(..)) import Test.Assert (assert', ASSERT) -type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE | eff) -type TestEff eff = Eff (TestEffects eff) +type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF | eff) +type TestEff eff = Eff (TestEffects (async ∷ ASYNC | eff)) type TestAff eff = Aff (TestEffects eff) -runAssertEq ∷ ∀ eff a. Show a ⇒ Eq a ⇒ String → a → TestAff eff a → TestEff eff Unit -runAssertEq s a = runAff go - where - go (Left err) = do +newRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ a → m (Ref a) +newRef = liftEff <<< Ref.newRef + +readRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ Ref a → m a +readRef = liftEff <<< Ref.readRef + +writeRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ Ref a → a → m Unit +writeRef r = liftEff <<< Ref.writeRef r + +modifyRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ Ref a → (a → a) → m Unit +modifyRef r = liftEff <<< Ref.modifyRef r + +assertEff ∷ ∀ eff. String → Either Error Boolean → TestEff (exception ∷ EXCEPTION | eff) Unit +assertEff s = case _ of + Left err → do Console.error ("[Error] " <> s) - assert' s false - go (Right r) = do - assert' s (r == a) + throwException err + Right r → do + assert' s r Console.log ("[OK] " <> s) +runAssert ∷ ∀ eff. String → TestAff eff Boolean → TestEff eff Unit +runAssert s = runAff (assertEff s) + +runAssertEq ∷ ∀ eff a. Eq a ⇒ String → a → TestAff eff a → TestEff eff Unit +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 + +assert ∷ ∀ eff. String → TestAff eff Boolean → TestAff eff Unit +assert s aff = liftEff <<< assertEff s =<< attempt aff + test_pure ∷ ∀ eff. TestEff eff Unit test_pure = runAssertEq "pure" 42 (pure 42) +test_bind ∷ ∀ eff. TestEff eff Unit +test_bind = runAssertEq "bind" 44 do + n1 ← pure 42 + n2 ← pure (n1 + 1) + n3 ← pure (n2 + 1) + pure n3 + +test_attempt ∷ ∀ eff. TestEff eff Unit +test_attempt = runAssert "attempt" do + n ← attempt (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.")) + pure (isLeft n) + +test_liftEff ∷ ∀ eff. TestEff eff Unit +test_liftEff = runAssertEq "liftEff" 42 do + ref ← newRef 0 + liftEff do + writeRef ref 42 + readRef ref + +test_delay ∷ ∀ eff. TestAff eff Unit +test_delay = assert "delay" do + delay (Milliseconds 1000.0) + pure true + +test_fork ∷ ∀ eff. TestAff eff Unit +test_fork = assert "fork" do + ref ← newRef 0 + thread ← forkAff do + delay (Milliseconds 10.0) + modifyRef ref (_ + 1) + writeRef ref 42 + delay (Milliseconds 20.0) + modifyRef ref (_ - 3) + eq 40 <$> readRef ref + +test_join ∷ ∀ eff. TestAff eff Unit +test_join = assert "join" do + ref ← newRef 1 + thread ← forkAff do + delay (Milliseconds 10.0) + modifyRef ref (_ - 2) + readRef ref + writeRef ref 42 + eq 40 <$> joinThread thread + +test_join_throw ∷ ∀ eff. TestAff eff Unit +test_join_throw = assert "join/throw" do + thread ← forkAff do + delay (Milliseconds 10.0) + throwError (error "Nope.") + isLeft <$> attempt (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) + +test_multi_join ∷ ∀ eff. TestAff eff Unit +test_multi_join = assert "join/multi" do + ref ← newRef 1 + thread1 ← forkAff do + delay (Milliseconds 10.0) + modifyRef ref (_ + 1) + pure 10 + thread2 ← forkAff do + delay (Milliseconds 20.0) + modifyRef ref (_ + 1) + pure 20 + n1 ← sum <$> traverse joinThread + [ thread1 + , thread1 + , thread1 + , thread2 + ] + n2 ← readRef ref + pure (n1 == 50 && n2 == 3) + +test_makeAff ∷ ∀ eff. TestAff eff Unit +test_makeAff = assert "makeAff" do + ref1 ← newRef Nothing + ref2 ← newRef 0 + thread ← forkAff do + n ← makeAff \cb → do + writeRef ref1 (Just cb) + pure nonCanceler + writeRef ref2 n + cb ← readRef ref1 + case cb of + Just k → do + liftEff $ k (Right 42) + eq 42 <$> readRef ref2 + Nothing → pure false + +test_bracket ∷ ∀ eff. TestAff eff Unit +test_bracket = assert "bracket" do + ref ← newRef [] + let + action s = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> [ s ]) + pure s + thread ← forkAff do + delay (Milliseconds 40.0) + readRef ref + _ ← bracket + (action "foo") + (\s → void $ action (s <> "/release")) + (\s → action (s <> "/run")) + joinThread thread <#> eq + [ "foo" + , "foo/run" + , "foo/release" + ] + +test_bracket_nested ∷ ∀ eff. TestAff eff Unit +test_bracket_nested = assert "bracket/nested" do + ref ← newRef [] + let + action s = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> [ s ]) + pure s + bracketAction s = + bracket + (action (s <> "/bar")) + (\s' → void $ action (s' <> "/release")) + (\s' → action (s' <> "/run")) + _ ← bracket + (bracketAction "foo") + (\s → void $ bracketAction (s <> "/release")) + (\s → bracketAction (s <> "/run")) + readRef ref <#> eq + [ "foo/bar" + , "foo/bar/run" + , "foo/bar/release" + , "foo/bar/run/run/bar" + , "foo/bar/run/run/bar/run" + , "foo/bar/run/run/bar/release" + , "foo/bar/run/release/bar" + , "foo/bar/run/release/bar/run" + , "foo/bar/run/release/bar/release" + ] + +test_kill ∷ ∀ eff. TestAff eff Unit +test_kill = assert "kill" do + thread ← forkAff $ makeAff \_ → pure nonCanceler + killThread (error "Nope") thread + isLeft <$> attempt (joinThread thread) + +test_kill_canceler ∷ ∀ eff. TestAff eff Unit +test_kill_canceler = assert "kill/canceler" do + ref ← newRef 0 + thread ← forkAff do + n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref 42)) + writeRef ref 2 + killThread (error "Nope") thread + res ← attempt (joinThread thread) + n ← readRef ref + pure (n == 42 && (lmap message res) == Left "Nope") + +test_kill_bracket ∷ ∀ eff. TestAff eff Unit +test_kill_bracket = assert "kill/bracket" do + ref ← newRef "" + let + action n = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> n) + thread ← + forkAff $ bracket + (action "a") + (\_ → action "b") + (\_ → action "c") + killThread (error "Nope") thread + _ ← attempt (joinThread thread) + eq "ab" <$> readRef ref + +test_kill_bracket_nested ∷ ∀ eff. TestAff eff Unit +test_kill_bracket_nested = assert "kill/bracket/nested" do + ref ← newRef [] + let + action s = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> [ s ]) + pure s + bracketAction s = + bracket + (action (s <> "/bar")) + (\s' → void $ action (s' <> "/release")) + (\s' → action (s' <> "/run")) + thread ← + forkAff $ bracket + (bracketAction "foo") + (\s → void $ bracketAction (s <> "/release")) + (\s → bracketAction (s <> "/run")) + killThread (error "Nope") thread + _ ← attempt (joinThread thread) + readRef ref <#> eq + [ "foo/bar" + , "foo/bar/run" + , "foo/bar/release" + , "foo/bar/run/release/bar" + , "foo/bar/run/release/bar/run" + , "foo/bar/run/release/bar/release" + ] + main ∷ TestEff () Unit main = do test_pure + test_bind + test_attempt + test_throw + test_liftEff + + void $ launchAff do + test_delay + test_fork + test_join + test_join_throw + test_join_throw_sync + test_multi_join + test_makeAff + test_bracket + test_bracket_nested + test_kill + test_kill_canceler + test_kill_bracket + test_kill_bracket_nested From 1eff561ad1c8189288f219af9adcba63e11bc782 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 3 Jul 2017 09:13:28 -0700 Subject: [PATCH 03/35] Remove Either from Sync constructor --- src/Control/Monad/Aff.purs | 4 ++-- src/Control/Monad/Aff/Internal.js | 22 ++++++++++----------- src/Control/Monad/Aff/Internal.purs | 30 +++++++++++------------------ 3 files changed, 23 insertions(+), 33 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index e48fb58..d72b23b 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -12,13 +12,13 @@ import Control.Monad.Aff.Internal (Aff, AffModality, ParAff, Thread, Canceler(.. import Control.Monad.Eff (Eff) import Control.Monad.Eff.Class (liftEff) import Control.Monad.Eff.Exception (Error) -import Data.Either (Either(..)) +import Data.Either (Either) runAff ∷ ∀ eff a. (Either Error a → Eff (AffModality eff) Unit) → Aff eff a → Eff (async ∷ ASYNC | eff) Unit runAff k aff = void $ launchAff $ liftEff <<< k =<< attempt aff forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) -forkAff = unsafeLiftEff <<< map Right <<< unsafeLaunchAff +forkAff = unsafeLiftEff <<< unsafeLaunchAff killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit killThread e (Thread t) = t.kill e diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index 138109d..14278e6 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/src/Control/Monad/Aff/Internal.js @@ -8,7 +8,7 @@ efficiency sake. data Aff eff a = Pure a | Throw Error - | Sync (Eff eff (Either Error a)) + | 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. Bracket (Aff eff b) (b -> Aff eff Unit) (b -> Aff eff a) @@ -86,16 +86,6 @@ exports.bracket = function (acquire) { }; }; -exports._liftEff = function (left, right, eff) { - return new Aff(SYNC, function () { - try { - return right(eff()); - } catch (error) { - return left(error); - } - }); -}; - exports._makeAff = function (left, right, aff) { return new Aff(ASYNC, function (k) { return function () { @@ -229,7 +219,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case SYNC: status = BLOCKED; - result = step._1(); + result = runSync(step._1); if (isLeft(result)) { status = RETURN; fail = result; @@ -405,6 +395,14 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { } } + function runSync (eff) { + try { + return right(eff()); + } catch (error) { + return left(error) + } + } + function addJoinCallback (cb) { var jid = joinId++; joins[jid] = cb; diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs index fd2d91b..b265b81 100644 --- a/src/Control/Monad/Aff/Internal.purs +++ b/src/Control/Monad/Aff/Internal.purs @@ -39,7 +39,7 @@ import Data.Monoid (class Monoid, mempty) import Data.Newtype (class Newtype) import Data.Time.Duration (Milliseconds(..)) import Partial.Unsafe (unsafeCrashWith) -import Type.Row.Effect.Equality (class EffectRowEquals, effTo) +import Type.Row.Effect.Equality (class EffectRowEquals) import Unsafe.Coerce (unsafeCoerce) foreign import data Aff ∷ # Effect → Type → Type @@ -100,7 +100,10 @@ instance monadErrorAff ∷ MonadError Error (Aff eff) where Right r → pure r instance monadEffAff ∷ EffectRowEquals eff1 (exception ∷ EXCEPTION, async ∷ ASYNC | eff2) ⇒ MonadEff eff1 (Aff eff2) where - liftEff eff = Fn.runFn3 _liftEff Left Right (effTo eff) + liftEff eff = unsafeLiftEff (coerceEff eff) + where + coerceEff ∷ Eff eff1 ~> Eff eff2 + coerceEff = unsafeCoerce newtype ParAff eff a = ParAff (Aff eff a) @@ -116,7 +119,7 @@ instance applyParAff ∷ Apply (ParAff eff) where Thread t3 ← unsafeLaunchAff do f ← attempt t1.join a ← attempt t2.join - unsafeLiftEff (Right <$> k (f <*> a)) + unsafeLiftEff (k (f <*> a)) pure $ Canceler \err → parSequence_ [ t3.kill err @@ -142,18 +145,15 @@ instance altParAff ∷ Alt (ParAff eff) where Thread t2 ← unsafeLaunchAff a2 let - lift ∷ ∀ a. Eff eff a → Aff eff a - lift = unsafeLiftEff <<< map Right - earlyError = error "Alt ParAff: early exit" runK t r = do - res ← lift $ unsafeRunRef $ readRef ref + res ← unsafeLiftEff $ unsafeRunRef $ readRef ref case res, r of - Nothing, Left _ → lift $ unsafeRunRef $ writeRef ref (Just r) - Nothing, Right _ → t.kill earlyError *> lift (k r) - Just r', _ → t.kill earlyError *> lift (k r') + Nothing, Left _ → unsafeLiftEff $ unsafeRunRef $ writeRef ref (Just r) + Nothing, Right _ → t.kill earlyError *> unsafeLiftEff (k r) + Just r', _ → t.kill earlyError *> unsafeLiftEff (k r') Thread t3 ← unsafeLaunchAff $ runK t2 =<< attempt t1.join Thread t4 ← unsafeLaunchAff $ runK t1 =<< attempt t2.join @@ -216,17 +216,9 @@ foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff ef foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit) 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 unsafeLiftEff ∷ ∀ eff a. Eff eff (Either Error a) → Aff eff a +foreign import unsafeLiftEff ∷ ∀ eff a. Eff eff a → Aff eff a foreign import unsafeMakeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a -foreign import _liftEff - ∷ ∀ eff a - . Fn.Fn3 - (Error → Either Error a) - (a → Either Error a) - (Eff (AffModality eff) a) - (Aff eff a) - foreign import _makeAff ∷ ∀ eff a . Fn.Fn3 From 51169ff62b00f03e35178bfb98df9b1946c8a453 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 3 Jul 2017 15:17:15 -0700 Subject: [PATCH 04/35] Revert fancy rows in instances. Simplify liftEff/makeAff wrappers. --- src/Control/Monad/Aff.purs | 15 ++++++--- src/Control/Monad/Aff/Class.purs | 7 ++-- src/Control/Monad/Aff/Internal.js | 48 +++++++++++++-------------- src/Control/Monad/Aff/Internal.purs | 50 ++++++++--------------------- src/Control/Monad/Aff/Unsafe.purs | 4 +-- test/Test/Bench.purs | 2 +- test/Test/Main.purs | 6 ++-- 7 files changed, 54 insertions(+), 78 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index d72b23b..0afd666 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -1,5 +1,6 @@ module Control.Monad.Aff ( module Internal + , liftEff' , forkAff , runAff , killThread @@ -7,18 +8,22 @@ module Control.Monad.Aff ) where import Prelude -import Control.Monad.Aff.Internal (ASYNC, Aff, AffModality, Thread(..), attempt, launchAff, unsafeLaunchAff, unsafeLiftEff) -import Control.Monad.Aff.Internal (Aff, AffModality, ParAff, Thread, Canceler(..), ASYNC, attempt, bracket, delay, launchAff, makeAff, nonCanceler) as Internal +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.Eff (Eff) import Control.Monad.Eff.Class (liftEff) -import Control.Monad.Eff.Exception (Error) +import Control.Monad.Eff.Exception (Error, EXCEPTION) +import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Data.Either (Either) -runAff ∷ ∀ eff a. (Either Error a → Eff (AffModality eff) Unit) → Aff eff a → Eff (async ∷ ASYNC | eff) Unit +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 forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) -forkAff = unsafeLiftEff <<< unsafeLaunchAff +forkAff = liftEff <<< unsafeLaunchAff killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit killThread e (Thread t) = t.kill e diff --git a/src/Control/Monad/Aff/Class.purs b/src/Control/Monad/Aff/Class.purs index 44ac02f..262071c 100644 --- a/src/Control/Monad/Aff/Class.purs +++ b/src/Control/Monad/Aff/Class.purs @@ -2,10 +2,9 @@ module Control.Monad.Aff.Class where import Prelude -import Control.Monad.Aff (Aff, ASYNC) +import Control.Monad.Aff (Aff) import Control.Monad.Cont.Trans (ContT) import Control.Monad.Eff.Class (class MonadEff) -import Control.Monad.Eff.Exception (EXCEPTION) import Control.Monad.Except.Trans (ExceptT) import Control.Monad.List.Trans (ListT) import Control.Monad.Maybe.Trans (MaybeT) @@ -17,8 +16,8 @@ import Control.Monad.Writer.Trans (WriterT) import Data.Monoid (class Monoid) -class MonadEff (exception ∷ EXCEPTION, async ∷ ASYNC | eff) m ⇐ MonadAff eff m | m → eff where - liftAff :: forall a. Aff eff a -> m a +class MonadEff eff m ⇐ MonadAff eff m | m → eff where + liftAff ∷ ∀ a. Aff eff a → m a instance monadAffAff ∷ MonadAff e (Aff e) where liftAff = id diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index 14278e6..d12f89a 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/src/Control/Monad/Aff/Internal.js @@ -66,11 +66,11 @@ exports._bind = function (aff) { }; }; -exports.unsafeLiftEff = function (eff) { +exports._liftEff = function (eff) { return new Aff(SYNC, eff); }; -exports.unsafeMakeAff = function (k) { +exports.makeAff = function (k) { return new Aff(ASYNC, k); }; @@ -86,19 +86,6 @@ exports.bracket = function (acquire) { }; }; -exports._makeAff = function (left, right, aff) { - return new Aff(ASYNC, function (k) { - return function () { - try { - return aff(k)(); - } catch (error) { - k(left(error))(); - return nonCanceler; - } - }; - }); -}; - exports._delay = function () { var setDelay = function (n, k) { if (n === 0 && typeof setImmediate !== "undefined") { @@ -219,7 +206,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case SYNC: status = BLOCKED; - result = runSync(step._1); + result = runSync(left, right, step._1); if (isLeft(result)) { status = RETURN; fail = result; @@ -234,7 +221,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case ASYNC: status = BLOCKED; - canceler = step._1(function (result) { + canceler = runAsync(left, step._1, function (result) { return function () { if (runTick !== localRunTick) { return; @@ -260,7 +247,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { localRunTick = ++runTick; } }; - })(); + }); // If the callback was resolved synchronously, the status will have // switched to CONTINUE, and we should not move on to PENDING. if (status === BLOCKED) { @@ -395,14 +382,6 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { } } - function runSync (eff) { - try { - return right(eff()); - } catch (error) { - return left(error) - } - } - function addJoinCallback (cb) { var jid = joinId++; joins[jid] = cb; @@ -492,3 +471,20 @@ function runJoin (result, cb) { }, 0) } } + +function runSync (left, right, eff) { + try { + return right(eff()); + } catch (error) { + return left(error) + } +} + +function runAsync (left, eff, k) { + try { + return eff(k)(); + } catch (error) { + k(left(error))(); + return nonCanceler; + } +} diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs index b265b81..87c4b5f 100644 --- a/src/Control/Monad/Aff/Internal.purs +++ b/src/Control/Monad/Aff/Internal.purs @@ -1,6 +1,5 @@ module Control.Monad.Aff.Internal ( Aff - , AffModality , ParAff(..) , Thread(..) , Canceler(..) @@ -12,8 +11,6 @@ module Control.Monad.Aff.Internal , bracket , delay , unsafeLaunchAff - , unsafeLiftEff - , unsafeMakeAff ) where import Prelude @@ -21,8 +18,8 @@ import Control.Alt (class Alt) import Control.Alternative (class Alternative) import Control.Apply (lift2) import Control.Monad.Eff (Eff, kind Effect) -import Control.Monad.Eff.Class (class MonadEff) -import Control.Monad.Eff.Exception (EXCEPTION, Error, error) +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) @@ -39,19 +36,12 @@ import Data.Monoid (class Monoid, mempty) import Data.Newtype (class Newtype) import Data.Time.Duration (Milliseconds(..)) import Partial.Unsafe (unsafeCrashWith) -import Type.Row.Effect.Equality (class EffectRowEquals) import Unsafe.Coerce (unsafeCoerce) foreign import data Aff ∷ # Effect → Type → Type foreign import data ASYNC ∷ Effect -type AffModality eff = - ( exception ∷ EXCEPTION - , async ∷ ASYNC - | eff - ) - instance functorAff ∷ Functor (Aff eff) where map = _map instance applyAff ∷ Apply (Aff eff) where apply = ap instance applicativeAff ∷ Applicative (Aff eff) where pure = _pure @@ -99,11 +89,8 @@ instance monadErrorAff ∷ MonadError Error (Aff eff) where Left err → k err Right r → pure r -instance monadEffAff ∷ EffectRowEquals eff1 (exception ∷ EXCEPTION, async ∷ ASYNC | eff2) ⇒ MonadEff eff1 (Aff eff2) where - liftEff eff = unsafeLiftEff (coerceEff eff) - where - coerceEff ∷ Eff eff1 ~> Eff eff2 - coerceEff = unsafeCoerce +instance monadEffAff ∷ MonadEff eff (Aff eff) where + liftEff = _liftEff newtype ParAff eff a = ParAff (Aff eff a) @@ -111,7 +98,7 @@ derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ derive newtype instance functorParAff ∷ Functor (ParAff eff) instance applyParAff ∷ Apply (ParAff eff) where - apply (ParAff ff) (ParAff fa) = ParAff (unsafeMakeAff go) + apply (ParAff ff) (ParAff fa) = ParAff (makeAff go) where go k = do Thread t1 ← unsafeLaunchAff ff @@ -119,7 +106,7 @@ instance applyParAff ∷ Apply (ParAff eff) where Thread t3 ← unsafeLaunchAff do f ← attempt t1.join a ← attempt t2.join - unsafeLiftEff (k (f <*> a)) + liftEff (k (f <*> a)) pure $ Canceler \err → parSequence_ [ t3.kill err @@ -137,7 +124,7 @@ instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where mempty = pure mempty instance altParAff ∷ Alt (ParAff eff) where - alt (ParAff a1) (ParAff a2) = ParAff (unsafeMakeAff go) + alt (ParAff a1) (ParAff a2) = ParAff (makeAff go) where go k = do ref ← unsafeRunRef $ newRef Nothing @@ -149,11 +136,11 @@ instance altParAff ∷ Alt (ParAff eff) where error "Alt ParAff: early exit" runK t r = do - res ← unsafeLiftEff $ unsafeRunRef $ readRef ref + res ← liftEff $ unsafeRunRef $ readRef ref case res, r of - Nothing, Left _ → unsafeLiftEff $ unsafeRunRef $ writeRef ref (Just r) - Nothing, Right _ → t.kill earlyError *> unsafeLiftEff (k r) - Just r', _ → t.kill earlyError *> unsafeLiftEff (k r') + Nothing, Left _ → liftEff $ unsafeRunRef $ writeRef ref (Just r) + 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 @@ -203,9 +190,6 @@ launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left unsafeLaunchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) unsafeLaunchAff = unsafeCoerce launchAff -makeAff ∷ ∀ eff a. ((Either Error a → Eff (AffModality eff) Unit) → Eff (AffModality eff) (Canceler eff)) → Aff eff a -makeAff k = Fn.runFn3 _makeAff Left Right k - delay ∷ ∀ eff. Milliseconds → Aff eff Unit delay (Milliseconds n) = Fn.runFn2 _delay Right n @@ -214,18 +198,10 @@ foreign import _throwError ∷ ∀ eff a. Error → 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 unsafeLiftEff ∷ ∀ eff a. Eff eff a → Aff eff a -foreign import unsafeMakeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a - -foreign import _makeAff - ∷ ∀ eff a - . Fn.Fn3 - (Error → Either Error a) - (a → Either Error a) - ((Either Error a → Eff (AffModality eff) Unit) → Eff (AffModality eff) (Canceler eff)) - (Aff eff a) +foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a foreign import _launchAff ∷ ∀ eff a diff --git a/src/Control/Monad/Aff/Unsafe.purs b/src/Control/Monad/Aff/Unsafe.purs index 7860525..29dd4bc 100644 --- a/src/Control/Monad/Aff/Unsafe.purs +++ b/src/Control/Monad/Aff/Unsafe.purs @@ -1,10 +1,10 @@ module Control.Monad.Aff.Unsafe ( unsafeCoerceAff - , module Internal + , module Control.Monad.Aff.Internal ) where import Control.Monad.Aff (Aff) -import Control.Monad.Aff.Internal (unsafeLaunchAff, unsafeLiftEff, unsafeMakeAff) as Internal +import Control.Monad.Aff.Internal (unsafeLaunchAff) import Unsafe.Coerce (unsafeCoerce) unsafeCoerceAff ∷ ∀ eff1 eff2 a. Aff eff1 a -> Aff eff2 a diff --git a/test/Test/Bench.purs b/test/Test/Bench.purs index 8bcdc59..1bf49bb 100644 --- a/test/Test/Bench.purs +++ b/test/Test/Bench.purs @@ -59,5 +59,5 @@ main = do bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ loop2 10000 Console.log "\nAff fib:" - bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ fib1 100 + bench \_ → runPure $ unsafeCoerceEff $ void $ Aff.launchAff $ fib1 20 diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 55483d7..e5c3586 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -18,7 +18,7 @@ import Data.Traversable (traverse) import Data.Time.Duration (Milliseconds(..)) import Test.Assert (assert', ASSERT) -type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF | eff) +type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION | eff) type TestEff eff = Eff (TestEffects (async ∷ ASYNC | eff)) type TestAff eff = Aff (TestEffects eff) @@ -34,10 +34,10 @@ writeRef r = liftEff <<< Ref.writeRef r modifyRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ Ref a → (a → a) → m Unit modifyRef r = liftEff <<< Ref.modifyRef r -assertEff ∷ ∀ eff. String → Either Error Boolean → TestEff (exception ∷ EXCEPTION | eff) Unit +assertEff ∷ ∀ eff. String → Either Error Boolean → Eff (TestEffects eff) Unit assertEff s = case _ of Left err → do - Console.error ("[Error] " <> s) + Console.log ("[Error] " <> s) throwException err Right r → do assert' s r From b53ec1e4866499ae32fc6af5680e809f50ab11e2 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 17 Jul 2017 20:34:14 -0700 Subject: [PATCH 05/35] Add AVar bindings --- src/Control/Monad/Aff/AVar.purs | 62 +++++++++++++++++++++++++++++++-- 1 file changed, 60 insertions(+), 2 deletions(-) diff --git a/src/Control/Monad/Aff/AVar.purs b/src/Control/Monad/Aff/AVar.purs index 3bc313e..3b2b6da 100644 --- a/src/Control/Monad/Aff/AVar.purs +++ b/src/Control/Monad/Aff/AVar.purs @@ -1,3 +1,61 @@ -module Control.Monad.Aff.AVar where +module Control.Monad.Aff.AVar + ( module Control.Monad.Eff.AVar + , makeVar + , makeEmptyVar + , isEmptyVar + , takeVar + , tryTakeVar + , putVar + , tryPutVar + , readVar + , tryReadVar + , killVar + ) where --- TODO +import Prelude +import Control.Monad.Aff (Aff, Canceler(..), makeAff) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.AVar (AVar, AVAR) +import Control.Monad.Eff.AVar as AVar +import Control.Monad.Eff.Class (liftEff) +import Control.Monad.Eff.Exception (Error) +import Data.Maybe (Maybe) + +toCanceler ∷ ∀ eff. Eff eff Unit → Canceler eff +toCanceler = Canceler <<< const <<< liftEff + +makeVar ∷ ∀ eff a. a → Aff (avar ∷ AVAR | eff) (AVar a) +makeVar = liftEff <<< AVar.makeVar + +makeEmptyVar ∷ ∀ eff a. Aff (avar ∷ AVAR | eff) (AVar a) +makeEmptyVar = liftEff AVar.makeEmptyVar + +isEmptyVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) Boolean +isEmptyVar = liftEff <<< AVar.isEmptyVar + +takeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a +takeVar avar = makeAff \k → do + c ← AVar.takeVar avar k + pure (toCanceler c) + +tryTakeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a) +tryTakeVar = liftEff <<< AVar.tryTakeVar + +putVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Unit +putVar avar value = makeAff \k → do + c ← AVar.putVar avar value k + pure (toCanceler c) + +tryPutVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Boolean +tryPutVar avar = liftEff <<< AVar.tryPutVar avar + +readVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a +readVar avar = makeAff \k → do + c ← AVar.readVar avar k + pure (toCanceler c) + +tryReadVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a) +tryReadVar = liftEff <<< AVar.tryReadVar + +killVar ∷ ∀ eff a. AVar a → Error → Aff (avar ∷ AVAR | eff) Unit +killVar avar = liftEff <<< AVar.killVar avar From 6e23d0aaf8e5c4f8cbb3de20763316770af9c2d4 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 18 Jul 2017 12:00:18 -0700 Subject: [PATCH 06/35] Use catchError primitive instead of attempt --- src/Control/Monad/Aff.purs | 8 ++-- src/Control/Monad/Aff/Internal.js | 60 ++++++++++++++++------------- src/Control/Monad/Aff/Internal.purs | 25 ++++-------- test/Test/Main.purs | 30 +++++++-------- 4 files changed, 62 insertions(+), 61 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 0afd666..c0cc8ec 100644 --- a/src/Control/Monad/Aff.purs +++ b/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 diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index d12f89a..b3466f8 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/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,13 +470,13 @@ 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); } } @@ -476,7 +484,7 @@ function runSync (left, right, eff) { try { return right(eff()); } catch (error) { - return left(error) + return left(error); } } diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs index 87c4b5f..e177ef7 100644 --- a/src/Control/Monad/Aff/Internal.purs +++ b/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 diff --git a/test/Test/Main.purs b/test/Test/Main.purs index e5c3586..b6fc72b 100644 --- a/test/Test/Main.purs +++ b/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 From 60fc908e63013f53e5ecad68b173d9bba8720482 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 19 Jul 2017 21:27:50 -0700 Subject: [PATCH 07/35] Rework ParAff --- src/Control/Monad/Aff.purs | 12 +--- src/Control/Monad/Aff/Internal.js | 3 +- src/Control/Monad/Aff/Internal.purs | 101 +++++++++++++++++----------- test/Test/Main.purs | 82 +++++++++++++++++++++- 4 files changed, 147 insertions(+), 51 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index c0cc8ec..14436e5 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -4,13 +4,11 @@ module Control.Monad.Aff , liftEff' , forkAff , runAff - , killThread - , joinThread ) where import Prelude -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.Aff.Internal (ASYNC, Aff, Thread, launchAff, unsafeLaunchAff) +import Control.Monad.Aff.Internal (Aff, ParAff, Thread, Canceler(..), ASYNC, bracket, delay, launchAff, makeAff, nonCanceler, joinThread, killThread) as Internal import Control.Monad.Eff (Eff) import Control.Monad.Eff.Class (liftEff) import Control.Monad.Eff.Exception (Error, EXCEPTION) @@ -26,9 +24,3 @@ runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) forkAff = liftEff <<< unsafeLaunchAff - -killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit -killThread e (Thread t) = t.kill e - -joinThread ∷ ∀ eff a. Thread eff a → Aff eff a -joinThread (Thread t) = t.join diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index b3466f8..d975cc4 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/src/Control/Monad/Aff/Internal.js @@ -396,7 +396,6 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { return function (error) { return new Aff(SYNC, function () { delete joins[jid]; - return right(); }); }; } @@ -429,7 +428,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { status = RETURN; step = null; fail = null; - run(runTick++); + run(++runTick); } break; default: diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs index e177ef7..666511a 100644 --- a/src/Control/Monad/Aff/Internal.purs +++ b/src/Control/Monad/Aff/Internal.purs @@ -10,6 +10,8 @@ module Control.Monad.Aff.Internal , bracket , delay , unsafeLaunchAff + , killThread + , joinThread ) where import Prelude @@ -89,21 +91,31 @@ derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ derive newtype instance functorParAff ∷ Functor (ParAff eff) instance applyParAff ∷ Apply (ParAff eff) where - apply (ParAff ff) (ParAff fa) = ParAff (makeAff go) - where - go k = do - Thread t1 ← unsafeLaunchAff ff - Thread t2 ← unsafeLaunchAff fa - Thread t3 ← unsafeLaunchAff do - f ← try t1.join - a ← try t2.join - liftEff (k (f <*> a)) - pure $ Canceler \err → - parSequence_ - [ t3.kill err - , t1.kill err - , t2.kill err - ] + apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do + ref1 ← unsafeRunRef $ newRef Nothing + ref2 ← unsafeRunRef $ newRef Nothing + + t1 ← unsafeLaunchAff do + f ← try ff + liftEff do + ma ← unsafeRunRef $ readRef ref2 + case ma of + Nothing → unsafeRunRef $ writeRef ref1 (Just f) + Just a → k (f <*> a) + + t2 ← unsafeLaunchAff do + a ← try fa + liftEff do + mf ← unsafeRunRef $ readRef ref1 + case mf of + Nothing → unsafeRunRef $ writeRef ref2 (Just a) + Just f → k (f <*> a) + + pure $ Canceler \err → + parSequence_ + [ killThread err t1 + , killThread err t2 + ] instance applicativeParAff ∷ Applicative (ParAff eff) where pure = ParAff <<< pure @@ -114,34 +126,41 @@ instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where mempty = pure mempty +data AltStatus a + = Pending + | Completed a + instance altParAff ∷ Alt (ParAff eff) where - alt (ParAff a1) (ParAff a2) = ParAff (makeAff go) + alt = runAlt where - go k = do + runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a + runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do ref ← unsafeRunRef $ newRef Nothing - Thread t1 ← unsafeLaunchAff a1 - Thread t2 ← unsafeLaunchAff a2 + t1 ← unsafeLaunchAff a1 + t2 ← unsafeLaunchAff a2 let - earlyError = - error "Alt ParAff: early exit" - - runK t r = do - res ← liftEff $ unsafeRunRef $ readRef ref - case res, r of - Nothing, Left _ → liftEff $ unsafeRunRef $ writeRef ref (Just r) - Nothing, Right _ → t.kill earlyError *> liftEff (k r) - Just r', _ → t.kill earlyError *> liftEff (k r') - - Thread t3 ← unsafeLaunchAff $ runK t2 =<< try t1.join - Thread t4 ← unsafeLaunchAff $ runK t1 =<< try t2.join + completed ∷ Thread eff a → Either Error a → Aff eff Unit + completed t res = do + val ← liftEff $ unsafeRunRef $ readRef ref + case val, res of + _, Right _ → do + killThread (error "Alt ParAff: early exit") t + liftEff (k res) + Nothing, _ → + liftEff $ unsafeRunRef $ writeRef ref (Just res) + Just res', _ → + liftEff (k res') + + t3 ← unsafeLaunchAff $ completed t2 =<< try (joinThread t1) + t4 ← unsafeLaunchAff $ completed t1 =<< try (joinThread t2) pure $ Canceler \err → parSequence_ - [ t3.kill earlyError - , t4.kill earlyError - , t1.kill earlyError - , t2.kill earlyError + [ killThread err t3 + , killThread err t4 + , killThread err t1 + , killThread err t2 ] instance plusParAff ∷ Plus (ParAff e) where @@ -161,6 +180,12 @@ newtype Thread eff a = Thread instance functorThread ∷ Functor (Thread eff) where map f (Thread { kill, join }) = Thread { kill, join: f <$> join } +killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit +killThread e (Thread t) = t.kill e + +joinThread ∷ ∀ eff a. Thread eff a → Aff eff a +joinThread (Thread t) = t.join + newtype Canceler eff = Canceler (Error → Aff eff Unit) derive instance newtypeCanceler ∷ Newtype (Canceler eff) _ @@ -173,7 +198,7 @@ instance monoidCanceler ∷ Monoid (Canceler eff) where mempty = nonCanceler nonCanceler ∷ ∀ eff. Canceler eff -nonCanceler = Canceler k where k _ = pure unit +nonCanceler = Canceler (const (pure unit)) launchAff ∷ ∀ eff a. Aff eff a → Eff (async ∷ ASYNC | eff) (Thread eff a) launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff @@ -207,8 +232,8 @@ foreign import _launchAff unsafeFromLeft ∷ ∀ x y. Either x y → x unsafeFromLeft = case _ of - Left a → a - Right _ → unsafeCrashWith "unsafeFromLeft: Right" + Left a → a + Right _ → unsafeCrashWith "unsafeFromLeft: Right" unsafeFromRight ∷ ∀ x y. Either x y → y unsafeFromRight = case _ of diff --git a/test/Test/Main.purs b/test/Test/Main.purs index b6fc72b..2f400b4 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -1,6 +1,7 @@ module Test.Main where import Prelude +import Control.Alt ((<|>)) 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) @@ -10,6 +11,7 @@ import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error, mes import Control.Monad.Eff.Ref (REF, Ref) import Control.Monad.Eff.Ref as Ref import Control.Monad.Error.Class (throwError) +import Control.Parallel (parallel, sequential) import Data.Bifunctor (lmap) import Data.Either (Either(..), isLeft) import Data.Foldable (sum) @@ -40,7 +42,7 @@ assertEff s = case _ of Console.log ("[Error] " <> s) throwException err Right r → do - assert' s r + assert' ("Assertion failure " <> s) r Console.log ("[OK] " <> s) runAssert ∷ ∀ eff. String → TestAff eff Boolean → TestEff eff Unit @@ -270,6 +272,80 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do , "foo/bar/run/release/bar/release" ] +test_parallel ∷ ∀ eff. TestAff eff Unit +test_parallel = assert "parallel" do + ref ← newRef "" + let + action s = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> s) + pure s + t1 ← forkAff $ sequential $ + { a: _, b: _ } + <$> parallel (action "foo") + <*> parallel (action "bar") + delay (Milliseconds 10.0) + r1 ← readRef ref + r2 ← joinThread t1 + pure (r1 == "foobar" && r2.a == "foo" && r2.b == "bar") + +test_kill_parallel ∷ ∀ eff. TestAff eff Unit +test_kill_parallel = assert "kill/parallel" do + ref ← newRef "" + let + action s = do + bracket + (pure unit) + (\_ → modifyRef ref (_ <> "killed" <> s)) + (\_ → do + delay (Milliseconds 10.0) + modifyRef ref (_ <> s)) + t1 ← forkAff $ sequential $ + parallel (action "foo") *> parallel (action "bar") + t2 ← forkAff do + delay (Milliseconds 5.0) + killThread (error "Nope") t1 + modifyRef ref (_ <> "done") + _ ← try $ joinThread t1 + _ ← try $ joinThread t2 + eq "killedfookilledbardone" <$> readRef ref + +test_parallel_alt ∷ ∀ eff. TestAff eff Unit +test_parallel_alt = assert "parallel/alt" do + ref ← newRef "" + let + action n s = do + delay (Milliseconds n) + modifyRef ref (_ <> s) + pure s + t1 ← forkAff $ sequential $ + parallel (action 10.0 "foo") <|> parallel (action 5.0 "bar") + delay (Milliseconds 10.0) + r1 ← readRef ref + r2 ← joinThread t1 + pure (r1 == "bar" && r2 == "bar") + +test_kill_parallel_alt ∷ ∀ eff. TestAff eff Unit +test_kill_parallel_alt = assert "kill/parallel/alt" do + ref ← newRef "" + let + action n s = do + bracket + (pure unit) + (\_ → modifyRef ref (_ <> "killed" <> s)) + (\_ → do + delay (Milliseconds n) + modifyRef ref (_ <> s)) + t1 ← forkAff $ sequential $ + parallel (action 10.0 "foo") <|> parallel (action 20.0 "bar") + t2 ← forkAff do + delay (Milliseconds 5.0) + killThread (error "Nope") t1 + modifyRef ref (_ <> "done") + _ ← try $ joinThread t1 + _ ← try $ joinThread t2 + eq "killedfookilledbardone" <$> readRef ref + main ∷ TestEff () Unit main = do test_pure @@ -292,3 +368,7 @@ main = do test_kill_canceler test_kill_bracket test_kill_bracket_nested + test_parallel + test_kill_parallel + test_parallel_alt + test_kill_parallel_alt From d68d117b18599d9b038d7f8d9cdc19af2a15b6f1 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 09:54:27 -0700 Subject: [PATCH 08/35] Add avar dep --- bower.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/bower.json b/bower.json index c44e996..b93fb82 100644 --- a/bower.json +++ b/bower.json @@ -26,7 +26,8 @@ "purescript-datetime": "^3.0.0", "purescript-free": "^4.0.1", "purescript-st": "^3.0.0", - "purescript-type-equality": "^2.1.0" + "purescript-type-equality": "^2.1.0", + "purescript-avar": "^1.0.1" }, "devDependencies": { "purescript-partial": "^1.2.0", From f2d67a1a27c734c5ee311350ab78f2907238129a Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 13:24:38 -0700 Subject: [PATCH 09/35] Satisfy linters --- package.json | 5 ++- src/Control/Monad/Aff/Internal.js | 74 ++++++++++++++++--------------- 2 files changed, 43 insertions(+), 36 deletions(-) diff --git a/package.json b/package.json index c4fe1e6..3c9f7e7 100644 --- a/package.json +++ b/package.json @@ -2,7 +2,7 @@ "private": true, "scripts": { "clean": "rimraf output && rimraf .pulp-cache", - "build": "jshint src && jscs src && pulp build -- --censor-lib --strict", + "build": "jshint src --verbose && jscs src && pulp build -- --censor-lib --strict", "test": "pulp test" }, "devDependencies": { @@ -12,5 +12,8 @@ "purescript-psa": "^0.5.0", "purescript": "^0.11.0", "rimraf": "^2.5.4" + }, + "jscsConfig": { + "validateIndentation": false } } diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff/Internal.js index d975cc4..ff2a230 100644 --- a/src/Control/Monad/Aff/Internal.js +++ b/src/Control/Monad/Aff/Internal.js @@ -1,3 +1,5 @@ +/* globals setImmediate, clearImmediate, setTimeout, clearTimeout */ +/* jshint -W083, -W098 */ "use strict"; /* @@ -29,7 +31,7 @@ var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) var RESUME = "Resume"; // Continue indiscriminately var FINALIZED = "Finalized"; // Marker for finalization -function Aff (tag, _1, _2, _3) { +function Aff(tag, _1, _2, _3) { this.tag = tag; this._1 = _1; this._2 = _2; @@ -117,6 +119,33 @@ exports._delay = function () { }; }(); +function runEff(eff) { + try { + eff(); + } catch (error) { + setTimeout(function () { + throw error; + }, 0); + } +} + +function runSync(left, right, eff) { + try { + return right(eff()); + } catch (error) { + return left(error); + } +} + +function runAsync(left, eff, k) { + try { + return eff(k)(); + } catch (error) { + k(left(error))(); + return nonCanceler; + } +} + // Thread state machine var BLOCKED = 0; // No effect is running. var PENDING = 1; // An async effect is running. @@ -164,7 +193,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { // accidentally resuming the same thread. A common example may be invoking // the provided callback in `makeAff` more than once, but it may also be an // async effect resuming after the thread was already cancelled. - function run (localRunTick) { + function run(localRunTick) { while (1) { switch (status) { case BINDSTEP: @@ -363,14 +392,16 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case COMPLETED: tmp = false; for (var k in joins) { - tmp = true; - runEff(joins[k](step)); + if ({}.hasOwnProperty.call(joins, k)) { + tmp = true; + runEff(joins[k](step)); + } } joins = tmp; // If we have an unhandled exception, and no other thread has joined // then we need to throw the exception in a fresh stack. if (isLeft(step) && !joins) { - setTimeout(function() { + setTimeout(function () { // Guard on joins because a completely synchronous thread can // still have an observer. if (!joins) { @@ -390,7 +421,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { } } - function addJoinCallback (cb) { + function addJoinCallback(cb) { var jid = joinId++; joins[jid] = cb; return function (error) { @@ -400,7 +431,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { }; } - function kill (error) { + function kill(error) { return new Aff(ASYNC, function (cb) { return function () { // Shadow the canceler binding because it can potentially be @@ -447,7 +478,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { }); } - function join () { + function join() { return new Aff(ASYNC, function (cb) { return function () { if (status === COMPLETED) { @@ -468,30 +499,3 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { }; }; }; - -function runEff (eff) { - try { - eff(); - } catch (error) { - setTimeout(function () { - throw error; - }, 0); - } -} - -function runSync (left, right, eff) { - try { - return right(eff()); - } catch (error) { - return left(error); - } -} - -function runAsync (left, eff, k) { - try { - return eff(k)(); - } catch (error) { - k(left(error))(); - return nonCanceler; - } -} From 7d71cba6d51e64f3e331485ec3f166f53bc228e0 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 13:53:08 -0700 Subject: [PATCH 10/35] Move unnecessary Internal module, cleanup --- src/Control/Monad/{Aff/Internal.js => Aff.js} | 0 src/Control/Monad/Aff.purs | 267 +++++++++++++++++- src/Control/Monad/Aff/Class.purs | 2 - src/Control/Monad/Aff/Console.purs | 5 +- src/Control/Monad/Aff/Internal.purs | 241 ---------------- src/Control/Monad/Aff/Unsafe.purs | 2 - 6 files changed, 254 insertions(+), 263 deletions(-) rename src/Control/Monad/{Aff/Internal.js => Aff.js} (100%) delete mode 100644 src/Control/Monad/Aff/Internal.purs diff --git a/src/Control/Monad/Aff/Internal.js b/src/Control/Monad/Aff.js similarity index 100% rename from src/Control/Monad/Aff/Internal.js rename to src/Control/Monad/Aff.js diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 14436e5..b5fb31c 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -1,26 +1,263 @@ module Control.Monad.Aff - ( module Internal - , module Control.Monad.Error.Class - , liftEff' - , forkAff + ( Aff + , Thread + , ParAff(..) + , Canceler(..) + , nonCanceler + , makeAff + , launchAff , runAff + , forkAff + , liftEff' + , bracket + , delay + , finally + , atomically + , killThread + , joinThread ) where import Prelude -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, joinThread, killThread) as Internal -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Class (liftEff) -import Control.Monad.Eff.Exception (Error, EXCEPTION) +import Control.Alt (class Alt) +import Control.Alternative (class Alternative) +import Control.Apply (lift2) +import Control.Monad.Eff (Eff, kind Effect) +import Control.Monad.Eff.Class (class MonadEff, liftEff) +import Control.Monad.Eff.Exception (Error, EXCEPTION, error) +import Control.Monad.Eff.Ref (newRef, readRef, writeRef) +import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef) import Control.Monad.Eff.Unsafe (unsafeCoerceEff) -import Control.Monad.Error.Class (try) -import Data.Either (Either) +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) +import Control.Parallel (parSequence_) +import Control.Parallel.Class (class Parallel) +import Control.Plus (class Plus, empty) +import Data.Either (Either(..), isLeft) +import Data.Function.Uncurried as Fn +import Data.Maybe (Maybe(..)) +import Data.Monoid (class Monoid, mempty) +import Data.Newtype (class Newtype) +import Data.Time.Duration (Milliseconds(..)) +import Partial.Unsafe (unsafeCrashWith) -liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a -liftEff' = liftEff <<< unsafeCoerceEff +foreign import data Aff ∷ # Effect → Type → Type + +instance functorAff ∷ Functor (Aff eff) where + map = _map + +instance applyAff ∷ Apply (Aff eff) where + apply = ap + +instance applicativeAff ∷ Applicative (Aff eff) where + pure = _pure + +instance bindAff ∷ Bind (Aff eff) where + bind = _bind + +instance monadAff ∷ Monad (Aff eff) + +instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where + append = lift2 append + +instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where + mempty = pure mempty + +instance altAff ∷ Alt (Aff eff) where + alt a1 a2 = catchError a1 (const a2) + +instance plusAff ∷ Plus (Aff eff) where + empty = throwError (error "Always fails") + +instance alternativeAff ∷ Alternative (Aff eff) + +instance monadZeroAff ∷ MonadZero (Aff eff) + +instance monadPlusAff ∷ MonadPlus (Aff eff) + +instance monadRecAff ∷ MonadRec (Aff eff) where + tailRecM k = go + where + go a = do + res ← k a + case res of + Done r → pure r + Loop b → go b + +instance monadThrowAff ∷ MonadThrow Error (Aff eff) where + throwError = _throwError + +instance monadErrorAff ∷ MonadError Error (Aff eff) where + catchError = _catchError + +instance monadEffAff ∷ MonadEff eff (Aff eff) where + liftEff = _liftEff + +newtype ParAff eff a = ParAff (Aff eff a) + +derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ + +derive newtype instance functorParAff ∷ Functor (ParAff eff) + +instance applyParAff ∷ Apply (ParAff eff) where + apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do + ref1 ← unsafeRunRef $ newRef Nothing + ref2 ← unsafeRunRef $ newRef Nothing + + t1 ← launchAff do + f ← try ff + liftEff do + ma ← unsafeRunRef $ readRef ref2 + case ma of + Nothing → unsafeRunRef $ writeRef ref1 (Just f) + Just a → k (f <*> a) + + t2 ← launchAff do + a ← try fa + liftEff do + mf ← unsafeRunRef $ readRef ref1 + case mf of + Nothing → unsafeRunRef $ writeRef ref2 (Just a) + Just f → k (f <*> a) + + pure $ Canceler \err → + parSequence_ + [ killThread err t1 + , killThread err t2 + ] + +instance applicativeParAff ∷ Applicative (ParAff eff) where + pure = ParAff <<< pure -runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff (async ∷ ASYNC | eff) Unit +instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where + append = lift2 append + +instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where + mempty = pure mempty + +data AltStatus a + = Pending + | Completed a + +instance altParAff ∷ Alt (ParAff eff) where + alt = runAlt + where + runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a + runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do + ref ← unsafeRunRef $ newRef Nothing + t1 ← launchAff a1 + t2 ← launchAff a2 + + let + completed ∷ Thread eff a → Either Error a → Aff eff Unit + completed t res = do + val ← liftEff $ unsafeRunRef $ readRef ref + case val, res of + _, Right _ → do + killThread (error "Alt ParAff: early exit") t + liftEff (k res) + Nothing, _ → + liftEff $ unsafeRunRef $ writeRef ref (Just res) + Just res', _ → + liftEff (k res') + + t3 ← launchAff $ completed t2 =<< try (joinThread t1) + t4 ← launchAff $ completed t1 =<< try (joinThread t2) + + pure $ Canceler \err → + parSequence_ + [ killThread err t3 + , killThread err t4 + , killThread err t1 + , killThread err t2 + ] + +instance plusParAff ∷ Plus (ParAff e) where + empty = ParAff empty + +instance alternativeParAff ∷ Alternative (ParAff e) + +instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where + parallel = ParAff + sequential (ParAff aff) = aff + +newtype Thread eff a = Thread + { kill ∷ Error → Aff eff Unit + , join ∷ Aff eff a + } + +instance functorThread ∷ Functor (Thread eff) where + map f (Thread { kill, join }) = Thread { kill, join: f <$> join } + +killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit +killThread e (Thread t) = t.kill e + +joinThread ∷ ∀ eff a. Thread eff a → Aff eff a +joinThread (Thread t) = t.join + +newtype Canceler eff = Canceler (Error → Aff eff Unit) + +derive instance newtypeCanceler ∷ Newtype (Canceler eff) _ + +instance semigroupCanceler ∷ Semigroup (Canceler eff) where + append (Canceler c1) (Canceler c2) = + Canceler \err → parSequence_ [ c1 err, c2 err ] + +instance monoidCanceler ∷ Monoid (Canceler eff) where + mempty = nonCanceler + +nonCanceler ∷ ∀ eff. Canceler eff +nonCanceler = Canceler (const (pure unit)) + +launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) +launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff + +runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) -forkAff = liftEff <<< unsafeLaunchAff +forkAff = liftEff <<< launchAff + +delay ∷ ∀ eff. Milliseconds → Aff eff Unit +delay (Milliseconds n) = Fn.runFn2 _delay Right n + +liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a +liftEff' = liftEff <<< unsafeCoerceEff + +finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a +finally fin a = bracket (pure unit) (const fin) (const a) + +atomically ∷ ∀ eff a. Aff eff a → Aff eff a +atomically a = bracket a (const (pure unit)) pure + +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 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 + +foreign import _launchAff + ∷ ∀ eff a + . Fn.Fn6 + (Either Error a → Boolean) + (Either Error a → Error) + (Either Error a → a) + (Error → Either Error a) + (a → Either Error a) + (Aff eff a) + (Eff eff (Thread eff a)) + +unsafeFromLeft ∷ ∀ x y. Either x y → x +unsafeFromLeft = case _ of + Left a → a + Right _ → unsafeCrashWith "unsafeFromLeft: Right" + +unsafeFromRight ∷ ∀ x y. Either x y → y +unsafeFromRight = case _ of + Right a → a + Left _ → unsafeCrashWith "unsafeFromRight: Left" diff --git a/src/Control/Monad/Aff/Class.purs b/src/Control/Monad/Aff/Class.purs index 262071c..dd6c0c5 100644 --- a/src/Control/Monad/Aff/Class.purs +++ b/src/Control/Monad/Aff/Class.purs @@ -1,7 +1,6 @@ module Control.Monad.Aff.Class where import Prelude - import Control.Monad.Aff (Aff) import Control.Monad.Cont.Trans (ContT) import Control.Monad.Eff.Class (class MonadEff) @@ -13,7 +12,6 @@ import Control.Monad.RWS.Trans (RWST) import Control.Monad.State.Trans (StateT) import Control.Monad.Trans.Class (lift) import Control.Monad.Writer.Trans (WriterT) - import Data.Monoid (class Monoid) class MonadEff eff m ⇐ MonadAff eff m | m → eff where diff --git a/src/Control/Monad/Aff/Console.purs b/src/Control/Monad/Aff/Console.purs index ab3b970..379a12c 100644 --- a/src/Control/Monad/Aff/Console.purs +++ b/src/Control/Monad/Aff/Console.purs @@ -11,11 +11,10 @@ module Control.Monad.Aff.Console ) where import Prelude -import Control.Monad.Eff.Console (CONSOLE) as Exports -import Control.Monad.Eff.Console as C - import Control.Monad.Aff (Aff) import Control.Monad.Eff.Class (liftEff) +import Control.Monad.Eff.Console (CONSOLE) as Exports +import Control.Monad.Eff.Console as C -- | Write a message to the console. Shorthand for `liftEff $ log x`. log :: forall eff. String -> Aff (console :: C.CONSOLE | eff) Unit diff --git a/src/Control/Monad/Aff/Internal.purs b/src/Control/Monad/Aff/Internal.purs deleted file mode 100644 index 666511a..0000000 --- a/src/Control/Monad/Aff/Internal.purs +++ /dev/null @@ -1,241 +0,0 @@ -module Control.Monad.Aff.Internal - ( Aff - , ParAff(..) - , Thread(..) - , Canceler(..) - , ASYNC - , nonCanceler - , makeAff - , launchAff - , bracket - , delay - , unsafeLaunchAff - , killThread - , joinThread - ) where - -import Prelude -import Control.Alt (class Alt) -import Control.Alternative (class Alternative) -import Control.Apply (lift2) -import Control.Monad.Eff (Eff, kind Effect) -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, catchError, try) -import Control.Monad.Rec.Class (class MonadRec, Step(..)) -import Control.MonadPlus (class MonadPlus) -import Control.MonadZero (class MonadZero) -import Control.Parallel (parSequence_) -import Control.Parallel.Class (class Parallel) -import Control.Plus (class Plus, empty) -import Data.Either (Either(..), isLeft) -import Data.Function.Uncurried as Fn -import Data.Maybe (Maybe(..)) -import Data.Monoid (class Monoid, mempty) -import Data.Newtype (class Newtype) -import Data.Time.Duration (Milliseconds(..)) -import Partial.Unsafe (unsafeCrashWith) -import Unsafe.Coerce (unsafeCoerce) - -foreign import data Aff ∷ # Effect → Type → Type - -foreign import data ASYNC ∷ Effect - -instance functorAff ∷ Functor (Aff eff) where map = _map -instance applyAff ∷ Apply (Aff eff) where apply = ap -instance applicativeAff ∷ Applicative (Aff eff) where pure = _pure -instance bindAff ∷ Bind (Aff eff) where bind = _bind -instance monadAff ∷ Monad (Aff eff) - -instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where - append = lift2 append - -instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where - mempty = pure mempty - -instance altAff ∷ Alt (Aff eff) where - alt a1 a2 = catchError a1 (const a2) - -instance plusAff ∷ Plus (Aff eff) where - empty = throwError (error "Always fails") - -instance alternativeAff ∷ Alternative (Aff eff) - -instance monadZeroAff ∷ MonadZero (Aff eff) - -instance monadPlusAff ∷ MonadPlus (Aff eff) - -instance monadRecAff ∷ MonadRec (Aff eff) where - tailRecM k = go - where - go a = do - res ← k a - case res of - Done r → pure r - Loop b → go b - -instance monadThrowAff ∷ MonadThrow Error (Aff eff) where - throwError = _throwError - -instance monadErrorAff ∷ MonadError Error (Aff eff) where - catchError = _catchError - -instance monadEffAff ∷ MonadEff eff (Aff eff) where - liftEff = _liftEff - -newtype ParAff eff a = ParAff (Aff eff a) - -derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ -derive newtype instance functorParAff ∷ Functor (ParAff eff) - -instance applyParAff ∷ Apply (ParAff eff) where - apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do - ref1 ← unsafeRunRef $ newRef Nothing - ref2 ← unsafeRunRef $ newRef Nothing - - t1 ← unsafeLaunchAff do - f ← try ff - liftEff do - ma ← unsafeRunRef $ readRef ref2 - case ma of - Nothing → unsafeRunRef $ writeRef ref1 (Just f) - Just a → k (f <*> a) - - t2 ← unsafeLaunchAff do - a ← try fa - liftEff do - mf ← unsafeRunRef $ readRef ref1 - case mf of - Nothing → unsafeRunRef $ writeRef ref2 (Just a) - Just f → k (f <*> a) - - pure $ Canceler \err → - parSequence_ - [ killThread err t1 - , killThread err t2 - ] - -instance applicativeParAff ∷ Applicative (ParAff eff) where - pure = ParAff <<< pure - -instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where - append = lift2 append - -instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where - mempty = pure mempty - -data AltStatus a - = Pending - | Completed a - -instance altParAff ∷ Alt (ParAff eff) where - alt = runAlt - where - runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a - runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do - ref ← unsafeRunRef $ newRef Nothing - t1 ← unsafeLaunchAff a1 - t2 ← unsafeLaunchAff a2 - - let - completed ∷ Thread eff a → Either Error a → Aff eff Unit - completed t res = do - val ← liftEff $ unsafeRunRef $ readRef ref - case val, res of - _, Right _ → do - killThread (error "Alt ParAff: early exit") t - liftEff (k res) - Nothing, _ → - liftEff $ unsafeRunRef $ writeRef ref (Just res) - Just res', _ → - liftEff (k res') - - t3 ← unsafeLaunchAff $ completed t2 =<< try (joinThread t1) - t4 ← unsafeLaunchAff $ completed t1 =<< try (joinThread t2) - - pure $ Canceler \err → - parSequence_ - [ killThread err t3 - , killThread err t4 - , killThread err t1 - , killThread err t2 - ] - -instance plusParAff ∷ Plus (ParAff e) where - empty = ParAff empty - -instance alternativeParAff ∷ Alternative (ParAff e) - -instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where - parallel = ParAff - sequential (ParAff aff) = aff - -newtype Thread eff a = Thread - { kill ∷ Error → Aff eff Unit - , join ∷ Aff eff a - } - -instance functorThread ∷ Functor (Thread eff) where - map f (Thread { kill, join }) = Thread { kill, join: f <$> join } - -killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit -killThread e (Thread t) = t.kill e - -joinThread ∷ ∀ eff a. Thread eff a → Aff eff a -joinThread (Thread t) = t.join - -newtype Canceler eff = Canceler (Error → Aff eff Unit) - -derive instance newtypeCanceler ∷ Newtype (Canceler eff) _ - -instance semigroupCanceler ∷ Semigroup (Canceler eff) where - append (Canceler c1) (Canceler c2) = - Canceler \err → parSequence_ [ c1 err, c2 err ] - -instance monoidCanceler ∷ Monoid (Canceler eff) where - mempty = nonCanceler - -nonCanceler ∷ ∀ eff. Canceler eff -nonCanceler = Canceler (const (pure unit)) - -launchAff ∷ ∀ eff a. Aff eff a → Eff (async ∷ ASYNC | eff) (Thread eff a) -launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff - -unsafeLaunchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) -unsafeLaunchAff = unsafeCoerce launchAff - -delay ∷ ∀ eff. Milliseconds → Aff eff Unit -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 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 - -foreign import _launchAff - ∷ ∀ eff a - . Fn.Fn6 - (Either Error a → Boolean) - (Either Error a → Error) - (Either Error a → a) - (Error → Either Error a) - (a → Either Error a) - (Aff eff a) - (Eff (async ∷ ASYNC | eff) (Thread eff a)) - -unsafeFromLeft ∷ ∀ x y. Either x y → x -unsafeFromLeft = case _ of - Left a → a - Right _ → unsafeCrashWith "unsafeFromLeft: Right" - -unsafeFromRight ∷ ∀ x y. Either x y → y -unsafeFromRight = case _ of - Right a → a - Left _ → unsafeCrashWith "unsafeFromRight: Left" diff --git a/src/Control/Monad/Aff/Unsafe.purs b/src/Control/Monad/Aff/Unsafe.purs index 29dd4bc..0d05e0d 100644 --- a/src/Control/Monad/Aff/Unsafe.purs +++ b/src/Control/Monad/Aff/Unsafe.purs @@ -1,10 +1,8 @@ module Control.Monad.Aff.Unsafe ( unsafeCoerceAff - , module Control.Monad.Aff.Internal ) where import Control.Monad.Aff (Aff) -import Control.Monad.Aff.Internal (unsafeLaunchAff) import Unsafe.Coerce (unsafeCoerce) unsafeCoerceAff ∷ ∀ eff1 eff2 a. Aff eff1 a -> Aff eff2 a From 67ad0d264cebbf96448c8fb5c2f7533da63135db Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 17:13:02 -0700 Subject: [PATCH 11/35] Add lazy thread map --- src/Control/Monad/Aff.js | 26 ++++++++++++++++++++++++++ src/Control/Monad/Aff.purs | 5 ++++- test/Test/Main.purs | 25 ++++++++++++++++++++++--- 3 files changed, 52 insertions(+), 4 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index ff2a230..9908007 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -90,6 +90,32 @@ exports.bracket = function (acquire) { }; }; +exports.mapThread = function () { + var EMPTY = {}; + + return function (f) { + return function (thread) { + var value = EMPTY; + + function force() { + if (value === EMPTY) { + return new Aff(BIND, thread.join, function (result) { + value = new Aff(PURE, f(result)); + return value; + }); + } else { + return value; + } + } + + return { + kill: thread.kill, + join: new Aff(BIND, new Aff(PURE, void 0), force) + }; + }; + }; +}(); + exports._delay = function () { var setDelay = function (n, k) { if (n === 0 && typeof setImmediate !== "undefined") { diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index b5fb31c..ac9efaa 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -15,6 +15,7 @@ module Control.Monad.Aff , atomically , killThread , joinThread + , module Exports ) where import Prelude @@ -28,6 +29,7 @@ import Control.Monad.Eff.Ref (newRef, readRef, writeRef) import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef) import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) +import Control.Monad.Error.Class (try) as Exports import Control.Monad.Rec.Class (class MonadRec, Step(..)) import Control.MonadPlus (class MonadPlus) import Control.MonadZero (class MonadZero) @@ -188,7 +190,7 @@ newtype Thread eff a = Thread } instance functorThread ∷ Functor (Thread eff) where - map f (Thread { kill, join }) = Thread { kill, join: f <$> join } + map = mapThread killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit killThread e (Thread t) = t.kill e @@ -240,6 +242,7 @@ foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff 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 +foreign import mapThread ∷ ∀ eff a b. (a → b) → Thread eff a → Thread eff b foreign import _launchAff ∷ ∀ eff a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 2f400b4..fe54791 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,14 +2,15 @@ module Test.Main where import Prelude import Control.Alt ((<|>)) -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.Aff (Aff, Canceler(..), nonCanceler, runAff, launchAff, makeAff, try, bracket, delay, forkAff, joinThread, killThread) +import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) import Control.Monad.Eff.Console as Console import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error, message) import Control.Monad.Eff.Ref (REF, Ref) import Control.Monad.Eff.Ref as Ref +import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef) import Control.Monad.Error.Class (throwError) import Control.Parallel (parallel, sequential) import Data.Bifunctor (lmap) @@ -21,7 +22,7 @@ import Data.Time.Duration (Milliseconds(..)) import Test.Assert (assert', ASSERT) type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION | eff) -type TestEff eff = Eff (TestEffects (async ∷ ASYNC | eff)) +type TestEff eff = Eff (TestEffects eff) type TestAff eff = Aff (TestEffects eff) newRef ∷ ∀ m eff a. MonadEff (ref ∷ REF | eff) m ⇒ a → m (Ref a) @@ -346,6 +347,23 @@ test_kill_parallel_alt = assert "kill/parallel/alt" do _ ← try $ joinThread t2 eq "killedfookilledbardone" <$> readRef ref +test_mapThread ∷ ∀ eff. TestAff eff Unit +test_mapThread = assert "mapThread" do + ref ← newRef 0 + let + mapFn a = runPure do + unsafeRunRef $ Ref.modifyRef ref (_ + 1) + pure (a + 1) + t1 ← forkAff do + delay (Milliseconds 10.0) + pure 10 + let + t2 = mapFn <$> t1 + a ← joinThread t2 + b ← joinThread t2 + n ← readRef ref + pure (a == 11 && b == 11 && n == 1) + main ∷ TestEff () Unit main = do test_pure @@ -372,3 +390,4 @@ main = do test_kill_parallel test_parallel_alt test_kill_parallel_alt + test_mapThread From 04f96968b23715a03ac81b1173cac4b4d5a9a612 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 18:08:53 -0700 Subject: [PATCH 12/35] Applicative instance for Thread --- src/Control/Monad/Aff.js | 51 ++++++++++++++++---------------------- src/Control/Monad/Aff.purs | 24 +++++++++++++++--- test/Test/Main.purs | 27 +++++++++++++++++--- 3 files changed, 67 insertions(+), 35 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 9908007..829ad0c 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -2,6 +2,9 @@ /* jshint -W083, -W098 */ "use strict"; +// A unique value for empty. +var EMPTY = {}; + /* An awkward approximation. We elide evidence we would otherwise need in PS for @@ -90,47 +93,37 @@ exports.bracket = function (acquire) { }; }; -exports.mapThread = function () { - var EMPTY = {}; - - return function (f) { - return function (thread) { - var value = EMPTY; - - function force() { - if (value === EMPTY) { - return new Aff(BIND, thread.join, function (result) { - value = new Aff(PURE, f(result)); - return value; - }); - } else { - return value; - } - } - - return { - kill: thread.kill, - join: new Aff(BIND, new Aff(PURE, void 0), force) - }; - }; - }; -}(); +exports.memoAff = function (aff) { + var value = EMPTY; + return new Aff(BIND, new Aff(PURE, void 0), function () { + if (value === EMPTY) { + return new Aff(BIND, aff, function (result) { + value = new Aff(PURE, result); + return value; + }); + } else { + return value; + } + }); +}; exports._delay = function () { - var setDelay = function (n, k) { + function setDelay(n, k) { if (n === 0 && typeof setImmediate !== "undefined") { return setImmediate(k); } else { return setTimeout(k, n); } - }; - var clearDelay = function (n, t) { + } + + function clearDelay(n, t) { if (n === 0 && typeof clearImmediate !== "undefined") { return clearImmediate(t); } else { return clearTimeout(t); } - }; + } + return function (right, ms) { return new Aff(ASYNC, function (cb) { return function () { diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index ac9efaa..57e4bfe 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -34,7 +34,7 @@ import Control.Monad.Rec.Class (class MonadRec, Step(..)) import Control.MonadPlus (class MonadPlus) import Control.MonadZero (class MonadZero) import Control.Parallel (parSequence_) -import Control.Parallel.Class (class Parallel) +import Control.Parallel.Class (class Parallel, parallel, sequential) import Control.Plus (class Plus, empty) import Data.Either (Either(..), isLeft) import Data.Function.Uncurried as Fn @@ -190,7 +190,25 @@ newtype Thread eff a = Thread } instance functorThread ∷ Functor (Thread eff) where - map = mapThread + map f (Thread { kill, join }) = Thread + { kill + , join: memoAff (f <$> join) + } + +instance applyThread ∷ Apply (Thread eff) where + apply t1 t2 = Thread + { kill: \err → sequential $ parallel (killThread err t1) *> parallel (killThread err t2) + , join: memoAff do + f ← joinThread t1 + a ← joinThread t2 + pure (f a) + } + +instance applicativeThread ∷ Applicative (Thread eff) where + pure a = Thread + { kill: const (pure unit) + , join: pure a + } killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit killThread e (Thread t) = t.kill e @@ -242,7 +260,7 @@ foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff 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 -foreign import mapThread ∷ ∀ eff a b. (a → b) → Thread eff a → Thread eff b +foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a foreign import _launchAff ∷ ∀ eff a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index fe54791..d84d769 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -347,8 +347,8 @@ test_kill_parallel_alt = assert "kill/parallel/alt" do _ ← try $ joinThread t2 eq "killedfookilledbardone" <$> readRef ref -test_mapThread ∷ ∀ eff. TestAff eff Unit -test_mapThread = assert "mapThread" do +test_thread_map ∷ ∀ eff. TestAff eff Unit +test_thread_map = assert "thread/map" do ref ← newRef 0 let mapFn a = runPure do @@ -364,6 +364,26 @@ test_mapThread = assert "mapThread" do n ← readRef ref pure (a == 11 && b == 11 && n == 1) +test_thread_apply ∷ ∀ eff. TestAff eff Unit +test_thread_apply = assert "thread/apply" do + ref ← newRef 0 + let + applyFn a b = runPure do + unsafeRunRef $ Ref.modifyRef ref (_ + 1) + pure (a + b) + t1 ← forkAff do + delay (Milliseconds 10.0) + pure 10 + t2 ← forkAff do + delay (Milliseconds 15.0) + pure 12 + let + t3 = applyFn <$> t1 <*> t2 + a ← joinThread t3 + b ← joinThread t3 + n ← readRef ref + pure (a == 22 && b == 22 && n == 1) + main ∷ TestEff () Unit main = do test_pure @@ -390,4 +410,5 @@ main = do test_kill_parallel test_parallel_alt test_kill_parallel_alt - test_mapThread + test_thread_map + test_thread_apply From f9be3eff9bca7a025971441aa67c8c438ef7b072 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 22 Jul 2017 21:03:45 -0700 Subject: [PATCH 13/35] Thread def cleanup --- src/Control/Monad/Aff.purs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 57e4bfe..11ae6e6 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -34,7 +34,7 @@ import Control.Monad.Rec.Class (class MonadRec, Step(..)) import Control.MonadPlus (class MonadPlus) import Control.MonadZero (class MonadZero) import Control.Parallel (parSequence_) -import Control.Parallel.Class (class Parallel, parallel, sequential) +import Control.Parallel.Class (class Parallel) import Control.Plus (class Plus, empty) import Data.Either (Either(..), isLeft) import Data.Function.Uncurried as Fn @@ -197,11 +197,8 @@ instance functorThread ∷ Functor (Thread eff) where instance applyThread ∷ Apply (Thread eff) where apply t1 t2 = Thread - { kill: \err → sequential $ parallel (killThread err t1) *> parallel (killThread err t2) - , join: memoAff do - f ← joinThread t1 - a ← joinThread t2 - pure (f a) + { kill: \err → parSequence_ [ killThread err t1, killThread err t2 ] + , join: memoAff (joinThread t1 <*> joinThread t2) } instance applicativeThread ∷ Applicative (Thread eff) where From 2c6284e5a377f621f5e1c94a88dc97a56b63fad6 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 30 Jul 2017 15:13:56 -0700 Subject: [PATCH 14/35] Stack-safe ParAff --- src/Control/Monad/Aff.js | 394 ++++++++++++++++++++++++++++++++++++- src/Control/Monad/Aff.purs | 110 ++++------- test/Test/Main.purs | 16 +- 3 files changed, 437 insertions(+), 83 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 829ad0c..6c60101 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -27,12 +27,26 @@ var BIND = "Bind"; var CATCH = "Catch"; var BRACKET = "Bracket"; +/* + +data ParAff eff a + = forall b. Map (b -> a) (ParAff eff b) + | forall b. Apply (ParAff eff (b -> a)) (ParAff eff b) + | Alt (ParAff eff a) (ParAff eff a) + | Par (Aff eff a) + +*/ +var MAP = "Map" +var APPLY = "Apply" +var ALT = "Alt" + // These are constructors used to implement the recover stack. We still use the // Aff constructor so that property offsets can always inline. var CONS = "Cons"; // Cons-list var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) var RESUME = "Resume"; // Continue indiscriminately var FINALIZED = "Finalized"; // Marker for finalization +var THREAD = "Thread"; function Aff(tag, _1, _2, _3) { this.tag = tag; @@ -81,6 +95,24 @@ exports._liftEff = function (eff) { return new Aff(SYNC, eff); }; +exports._parAffMap = function (f) { + return function (aff) { + return new Aff(MAP, f, aff); + }; +}; + +exports._parAffApply = function (aff1) { + return function (aff2) { + return new Aff(APPLY, aff1, aff2); + }; +}; + +exports._parAffAlt = function (aff1) { + return function (aff2) { + return new Aff(ALT, aff1, aff2); + }; +}; + exports.makeAff = function (k) { return new Aff(ASYNC, k); }; @@ -214,6 +246,10 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { // async effect resuming after the thread was already cancelled. function run(localRunTick) { while (1) { + tmp = null; + result = null; + attempt = null; + canceler = null; switch (status) { case BINDSTEP: status = CONTINUE; @@ -432,11 +468,6 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case BLOCKED: return; case PENDING: return; } - - tmp = null; - result = null; - attempt = null; - canceler = null; } } @@ -518,3 +549,356 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { }; }; }; + +exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff, par) { + function runParAff(cb) { + // Table of all forked threads. + var threadId = 0; + var threads = {}; + + // Table of currently running cancelers, as a product of `Alt` behavior. + var killId = 0; + var kills = {}; + + // Error used for early cancelation on Alt branches. + var early = new Error("ParAff early exit"); + + // Error used to kill the entire tree. + var interrupt = null; + + // The root pointer of the tree. + var root = EMPTY; + + // Walks the applicative tree, substituting non-applicative nodes with + // `THREAD` nodes. In this tree, all applicative nodes use the `_3` slot + // as a mutable slot for memoization. In an unresolved state, the `_3` + // slot is `EMPTY`. In the cases of `ALT` and `APPLY`, we always walk + // the left side first, because both operations are left-associative. As + // we `RETURN` from those branches, we then walk the right side. + function run() { + var status = CONTINUE; + var step = par; + var head = null; + var tail = null; + var tmp, tid; + + loop: while (1) { + tmp = null; + tid = null; + + switch (status) { + case CONTINUE: + switch (step.tag) { + case MAP: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(MAP, step._1, EMPTY, EMPTY); + step = step._2; + break; + case APPLY: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(APPLY, EMPTY, step._2, EMPTY); + step = step._1; + break; + case ALT: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(ALT, EMPTY, step._2, EMPTY); + step = step._1; + break; + default: + // When we hit a leaf value, we suspend the stack in the `THREAD`. + // When the thread resolves, it can bubble back up the tree. + tid = threadId++; + status = RETURN; + tmp = step; + step = new Aff(THREAD, tid, new Aff(CONS, head, tail), EMPTY); + // We prime the effect, but don't immediately run it. We need to + // walk the entire tree first before actually running effects + // because they may all be synchronous and resolve immediately, at + // which point it would attempt to resolve against an incomplete + // tree. + threads[tid] = runAff(resolve(step))(tmp); + } + break; + case RETURN: + // Terminal case, we are back at the root. + if (head === null) { + break loop; + } + // If we are done with the right side, we need to continue down the + // left. Otherwise we should continue up the stack. + if (head._1 === EMPTY) { + head._1 = step; + status = CONTINUE; + step = head._2; + head._2 = EMPTY; + } else { + head._2 = step; + step = head; + if (tail === null) { + head = null; + } else { + head = tail._1; + tail = tail._2; + } + } + } + } + + // Keep a reference to the tree root so it can be cancelled. + root = step; + + // Walk the primed threads and fork them. We store the actual `Thread` + // reference so we can cancel them when needed. + for (tid = 0; tid < threadId; tid++) { + threads[tid] = threads[tid](); + } + } + + function resolve(thread) { + return function (result) { + return function () { + delete threads[thread._1]; + thread._3 = result; + join(result, thread._2._1, thread._2._2); + }; + }; + } + + // When a thread resolves, we need to bubble back up the tree with the + // result, computing the applicative nodes. + function join(result, head, tail) { + var fail, step, lhs, rhs, tmp, kid; + + if (isLeft(result)) { + fail = result; + step = null; + } else { + step = result; + fail = null; + } + + loop: while (1) { + lhs = null; + rhs = null; + tmp = null; + kid = null; + + // We should never continue if the entire tree has been interrupted. + if (interrupt !== null) { + return; + } + + // We've made it all the way to the root of the tree, which means + // the tree has fully evaluated. + if (head === null) { + cb(fail || step)(); + return; + } + + // The tree has already been computed, so we shouldn't try to do it + // again. This should never happen. + // TODO: Remove this? + if (head._3 !== EMPTY) { + return; + } + + switch (head.tag) { + case MAP: + if (fail === null) { + head._3 = right(head._1(fromRight(step))); + step = head._3; + } else { + head._3 = fail; + } + break; + case APPLY: + lhs = head._1._3; + rhs = head._2._3; + // We can only proceed if both sides have resolved. + if (lhs === EMPTY || rhs === EMPTY) { + return; + } + // If either side resolve with an error, we should continue with + // the first error. + if (isLeft(lhs)) { + if (isLeft(rhs)) { + if (step === lhs) { + step = rhs; + } + } else { + step = lhs; + } + } else if (isLeft(rhs)) { + step = rhs; + } else { + head._3 = right(fromRight(lhs)(fromRight(rhs))); + step = head._3; + } + break; + case ALT: + lhs = head._1._3; + rhs = head._2._3; + head._3 = step; + tmp = true; + kid = killId++; + + // Once a side has resolved, we need to cancel the side that is still + // pending before we can continue. + kills[kid] = kill(early, step === lhs ? head._2 : head._1, function (killResult) { + return function () { + delete kills[kid]; + if (isLeft(killResult)) { + fail = killResult; + step = null; + } + if (tmp) { + tmp = false; + } else if (tail === null) { + join(fail || step, null, null); + } else { + join(fail || step, tail._1, tail._2); + } + }; + }); + + if (tmp) { + tmp = false; + return; + } + break; + } + + if (tail === null) { + head = null; + } else { + head = tail._1; + tail = tail._2; + } + } + } + + // Walks a tree, invoking all the cancelers. Returns the table of pending + // cancellation threads. + function kill(error, par, cb) { + var step = par; + var fail = null; + var head = null; + var tail = null; + var count = 0; + var kills = {}; + var tmp, kid; + + loop: while (1) { + tmp = null; + kid = null; + + switch (step.tag) { + case THREAD: + tmp = threads[step._1]; + kid = count++; + if (tmp) { + // Again, we prime the effect but don't run it yet, so that we can + // collect all the threads first. + kills[kid] = runAff(function (result) { + return function () { + count--; + if (fail === null && isLeft(result)) { + fail = result; + } + // We can resolve the callback when all threads have died. + if (count === 0) { + cb(fail || right(void 0))(); + } + }; + })(tmp.kill(error)); + } + // Terminal case. + if (head === null) { + break loop; + } + // Go down the right side of the tree. + step = head._2; + if (tail === null) { + head = null; + } else { + head = tail._1; + tail = tail._2; + } + break; + case MAP: + step = step._2; + break; + case APPLY: + case ALT: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = step; + step = step._1; + break; + } + } + + // Run the cancelation effects. We alias `count` because it's mutable. + for (kid = 0, tmp = count; kid < tmp; kid++) { + kills[kid] = kills[kid](); + } + + return kills; + } + + function ignore () { + return function () {}; + } + + // Cancels the entire tree. If there are already subtrees being canceled, + // we need to first cancel those joins. This is important so that errors + // don't accidentally get swallowed by irrelevant join callbacks. + function cancel(error, cb) { + interrupt = left(error); + + // We can drop the threads here because we are only canceling join + // attempts, which are synchronous anyway. + for (var kid = 0, n = killId; kid < n; kid++) { + runAff(ignore, kills[kid].kill(error))(); + } + + var newKills = kill(error, root, cb); + + return function (killError) { + return new Aff(ASYNC, function (killCb) { + return function () { + for (var kid in newKills) { + if (newKills.hasOwnProperty(kid)) { + runAff(ignore, newKills[kid].kill(killError))(); + } + } + return nonCanceler; + }; + }); + }; + } + + run(); + + return function (killError) { + return new Aff(ASYNC, function (killCb) { + return function () { + return cancel(killError, killCb); + }; + }); + }; + } + + return new Aff(ASYNC, function (cb) { + return function () { + return runParAff(cb); + }; + }); +}; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 11ae6e6..9b3bc35 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -7,6 +7,7 @@ module Control.Monad.Aff , makeAff , launchAff , runAff + , runAff_ , forkAff , liftEff' , bracket @@ -25,25 +26,27 @@ import Control.Apply (lift2) import Control.Monad.Eff (Eff, kind Effect) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Exception (Error, EXCEPTION, error) -import Control.Monad.Eff.Ref (newRef, readRef, writeRef) -import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef) import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) import Control.Monad.Error.Class (try) as Exports import Control.Monad.Rec.Class (class MonadRec, Step(..)) import Control.MonadPlus (class MonadPlus) import Control.MonadZero (class MonadZero) -import Control.Parallel (parSequence_) +import Control.Parallel (parSequence_, parallel) import Control.Parallel.Class (class Parallel) import Control.Plus (class Plus, empty) import Data.Either (Either(..), isLeft) import Data.Function.Uncurried as Fn -import Data.Maybe (Maybe(..)) import Data.Monoid (class Monoid, mempty) import Data.Newtype (class Newtype) import Data.Time.Duration (Milliseconds(..)) import Partial.Unsafe (unsafeCrashWith) +import Unsafe.Coerce (unsafeCoerce) +-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The +-- | computation may either error with an exception, or produce a result of +-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using +-- | `makeAff`. foreign import data Aff ∷ # Effect → Type → Type instance functorAff ∷ Functor (Aff eff) where @@ -96,41 +99,16 @@ instance monadErrorAff ∷ MonadError Error (Aff eff) where instance monadEffAff ∷ MonadEff eff (Aff eff) where liftEff = _liftEff -newtype ParAff eff a = ParAff (Aff eff a) +foreign import data ParAff ∷ # Effect → Type → Type -derive instance newtypeParAff ∷ Newtype (ParAff eff a) _ - -derive newtype instance functorParAff ∷ Functor (ParAff eff) +instance functorParAff ∷ Functor (ParAff eff) where + map = _parAffMap instance applyParAff ∷ Apply (ParAff eff) where - apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do - ref1 ← unsafeRunRef $ newRef Nothing - ref2 ← unsafeRunRef $ newRef Nothing - - t1 ← launchAff do - f ← try ff - liftEff do - ma ← unsafeRunRef $ readRef ref2 - case ma of - Nothing → unsafeRunRef $ writeRef ref1 (Just f) - Just a → k (f <*> a) - - t2 ← launchAff do - a ← try fa - liftEff do - mf ← unsafeRunRef $ readRef ref1 - case mf of - Nothing → unsafeRunRef $ writeRef ref2 (Just a) - Just f → k (f <*> a) - - pure $ Canceler \err → - parSequence_ - [ killThread err t1 - , killThread err t2 - ] + apply = _parAffApply instance applicativeParAff ∷ Applicative (ParAff eff) where - pure = ParAff <<< pure + pure = parallel <<< pure instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where append = lift2 append @@ -138,51 +116,17 @@ instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where mempty = pure mempty -data AltStatus a - = Pending - | Completed a - instance altParAff ∷ Alt (ParAff eff) where - alt = runAlt - where - runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a - runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do - ref ← unsafeRunRef $ newRef Nothing - t1 ← launchAff a1 - t2 ← launchAff a2 - - let - completed ∷ Thread eff a → Either Error a → Aff eff Unit - completed t res = do - val ← liftEff $ unsafeRunRef $ readRef ref - case val, res of - _, Right _ → do - killThread (error "Alt ParAff: early exit") t - liftEff (k res) - Nothing, _ → - liftEff $ unsafeRunRef $ writeRef ref (Just res) - Just res', _ → - liftEff (k res') - - t3 ← launchAff $ completed t2 =<< try (joinThread t1) - t4 ← launchAff $ completed t1 =<< try (joinThread t2) - - pure $ Canceler \err → - parSequence_ - [ killThread err t3 - , killThread err t4 - , killThread err t1 - , killThread err t2 - ] + alt = _parAffAlt instance plusParAff ∷ Plus (ParAff e) where - empty = ParAff empty + empty = parallel empty instance alternativeParAff ∷ Alternative (ParAff e) instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where - parallel = ParAff - sequential (ParAff aff) = aff + parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) + sequential a = Fn.runFn7 _sequential isLeft unsafeFromLeft unsafeFromRight Left Right runAff a newtype Thread eff a = Thread { kill ∷ Error → Aff eff Unit @@ -230,8 +174,11 @@ nonCanceler = Canceler (const (pure unit)) launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff -runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit -runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff +runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Thread eff Unit) +runAff k aff = launchAff $ liftEff <<< k =<< try aff + +runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit +runAff_ k aff = void $ runAff k aff forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) forkAff = liftEff <<< launchAff @@ -255,6 +202,9 @@ 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 _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b +foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b +foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff 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 foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a @@ -270,6 +220,18 @@ foreign import _launchAff (Aff eff a) (Eff eff (Thread eff a)) +foreign import _sequential + ∷ ∀ eff a + . Fn.Fn7 + (Either Error a → Boolean) + (Either Error a → Error) + (Either Error a → a) + (Error → Either Error a) + (a → Either Error a) + ((Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Thread eff Unit)) + (ParAff eff a) + (Aff eff a) + unsafeFromLeft ∷ ∀ x y. Either x y → x unsafeFromLeft = case _ of Left a → a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index d84d769..9843f16 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,7 +2,7 @@ module Test.Main where import Prelude import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, Canceler(..), nonCanceler, runAff, launchAff, makeAff, try, bracket, delay, forkAff, joinThread, killThread) +import Control.Monad.Aff (Aff, Canceler(..), nonCanceler, runAff_, launchAff, makeAff, try, bracket, delay, forkAff, joinThread, killThread) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -12,7 +12,8 @@ import Control.Monad.Eff.Ref (REF, Ref) import Control.Monad.Eff.Ref as Ref import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef) import Control.Monad.Error.Class (throwError) -import Control.Parallel (parallel, sequential) +import Control.Parallel (parallel, sequential, parTraverse_) +import Data.Array as Array import Data.Bifunctor (lmap) import Data.Either (Either(..), isLeft) import Data.Foldable (sum) @@ -47,10 +48,10 @@ assertEff s = case _ of Console.log ("[OK] " <> s) runAssert ∷ ∀ eff. String → TestAff eff Boolean → TestEff eff Unit -runAssert s = runAff (assertEff s) +runAssert s = runAff_ (assertEff s) runAssertEq ∷ ∀ eff a. Eq a ⇒ String → a → TestAff eff a → TestEff eff Unit -runAssertEq s a = runAff (assertEff s <<< map (eq a)) +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) =<< try aff @@ -384,6 +385,12 @@ test_thread_apply = assert "thread/apply" do n ← readRef ref pure (a == 22 && b == 22 && n == 1) +test_parallel_stack ∷ ∀ eff. TestAff eff Unit +test_parallel_stack = assert "parallel/stack" do + ref ← newRef 0 + parTraverse_ (modifyRef ref <<< add) (Array.replicate 100000 1) + eq 100000 <$> readRef ref + main ∷ TestEff () Unit main = do test_pure @@ -412,3 +419,4 @@ main = do test_kill_parallel_alt test_thread_map test_thread_apply + test_parallel_stack From e0caaa46c71923e3ca84f94f24dde142f5994b5b Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 31 Jul 2017 17:25:10 -0700 Subject: [PATCH 15/35] Synchronous ParAff Alt handling --- src/Control/Monad/Aff.js | 43 +++++++++++++++++++++++----------------- test/Test/Main.purs | 17 ++++++++++++++++ 2 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 6c60101..9c9e616 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -33,20 +33,22 @@ data ParAff eff a = forall b. Map (b -> a) (ParAff eff b) | forall b. Apply (ParAff eff (b -> a)) (ParAff eff b) | Alt (ParAff eff a) (ParAff eff a) - | Par (Aff eff a) + | ?Par (Aff eff a) */ var MAP = "Map" var APPLY = "Apply" var ALT = "Alt" -// These are constructors used to implement the recover stack. We still use the -// Aff constructor so that property offsets can always inline. -var CONS = "Cons"; // Cons-list -var RECOVER = "Recover"; // Continue with `Either Error a` (via attempt) +// Various constructors used in interpretation +var CONS = "Cons"; // Cons-list, for stacks +var RECOVER = "Recover"; // Continue with error handler var RESUME = "Resume"; // Continue indiscriminately var FINALIZED = "Finalized"; // Marker for finalization -var THREAD = "Thread"; + +var FORKED = "Forked"; // Reference to a forked thread, with resumption stack +var THREAD = "Thread"; // Actual thread reference +var THUNK = "Thunk"; // Primed effect, ready to invoke function Aff(tag, _1, _2, _3) { this.tag = tag; @@ -570,7 +572,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var root = EMPTY; // Walks the applicative tree, substituting non-applicative nodes with - // `THREAD` nodes. In this tree, all applicative nodes use the `_3` slot + // `FORKED` nodes. In this tree, all applicative nodes use the `_3` slot // as a mutable slot for memoization. In an unresolved state, the `_3` // slot is `EMPTY`. In the cases of `ALT` and `APPLY`, we always walk // the left side first, because both operations are left-associative. As @@ -611,18 +613,18 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff step = step._1; break; default: - // When we hit a leaf value, we suspend the stack in the `THREAD`. + // When we hit a leaf value, we suspend the stack in the `FORKED`. // When the thread resolves, it can bubble back up the tree. tid = threadId++; status = RETURN; tmp = step; - step = new Aff(THREAD, tid, new Aff(CONS, head, tail), EMPTY); + step = new Aff(FORKED, tid, new Aff(CONS, head, tail), EMPTY); // We prime the effect, but don't immediately run it. We need to // walk the entire tree first before actually running effects // because they may all be synchronous and resolve immediately, at // which point it would attempt to resolve against an incomplete // tree. - threads[tid] = runAff(resolve(step))(tmp); + threads[tid] = new Aff(THUNK, runAff(resolve(step))(tmp)); } break; case RETURN: @@ -656,7 +658,10 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff // Walk the primed threads and fork them. We store the actual `Thread` // reference so we can cancel them when needed. for (tid = 0; tid < threadId; tid++) { - threads[tid] = threads[tid](); + tmp = threads[tid]; + if (tmp && tmp.tag === THUNK) { + threads[tid] = new Aff(THREAD, tmp._1()); + } } } @@ -747,7 +752,6 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff head._3 = step; tmp = true; kid = killId++; - // Once a side has resolved, we need to cancel the side that is still // pending before we can continue. kills[kid] = kill(early, step === lhs ? head._2 : head._1, function (killResult) { @@ -796,16 +800,19 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff loop: while (1) { tmp = null; - kid = null; switch (step.tag) { - case THREAD: + case FORKED: tmp = threads[step._1]; - kid = count++; - if (tmp) { + // If we haven't forked the thread yet (such as with a sync Alt), + // then we should just remove it from the queue and continue. + if (tmp.tag === THUNK) { + delete threads[step._1]; + cb(right(void 0))(); + } else { // Again, we prime the effect but don't run it yet, so that we can // collect all the threads first. - kills[kid] = runAff(function (result) { + kills[count++] = runAff(function (result) { return function () { count--; if (fail === null && isLeft(result)) { @@ -816,7 +823,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff cb(fail || right(void 0))(); } }; - })(tmp.kill(error)); + })(tmp._1.kill(error)); } // Terminal case. if (head === null) { diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 9843f16..938ff56 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -327,6 +327,22 @@ test_parallel_alt = assert "parallel/alt" do r2 ← joinThread t1 pure (r1 == "bar" && r2 == "bar") +test_parallel_alt_sync ∷ ∀ eff. TestAff eff Unit +test_parallel_alt_sync = assert "kill/parallel/alt/sync" do + ref ← newRef "" + let + action s = do + bracket + (pure unit) + (\_ → modifyRef ref (_ <> "killed" <> s)) + (\_ → modifyRef ref (_ <> s) $> s) + r1 ← sequential $ + parallel (action "foo") + <|> parallel (action "bar") + <|> parallel (action "baz") + r2 ← readRef ref + pure (r1 == "foo" && r2 == "fookilledfoo") + test_kill_parallel_alt ∷ ∀ eff. TestAff eff Unit test_kill_parallel_alt = assert "kill/parallel/alt" do ref ← newRef "" @@ -416,6 +432,7 @@ main = do test_parallel test_kill_parallel test_parallel_alt + test_parallel_alt_sync test_kill_parallel_alt test_thread_map test_thread_apply From edce196dd5234a69bde2a6124a624a79c6115bb1 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 31 Jul 2017 17:34:24 -0700 Subject: [PATCH 16/35] Appease the linter --- src/Control/Monad/Aff.js | 296 ++++++++++++++++++++------------------- 1 file changed, 149 insertions(+), 147 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 9c9e616..61a05ae 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -36,9 +36,9 @@ data ParAff eff a | ?Par (Aff eff a) */ -var MAP = "Map" -var APPLY = "Apply" -var ALT = "Alt" +var MAP = "Map"; +var APPLY = "Apply"; +var ALT = "Alt"; // Various constructors used in interpretation var CONS = "Cons"; // Cons-list, for stacks @@ -571,108 +571,79 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff // The root pointer of the tree. var root = EMPTY; - // Walks the applicative tree, substituting non-applicative nodes with - // `FORKED` nodes. In this tree, all applicative nodes use the `_3` slot - // as a mutable slot for memoization. In an unresolved state, the `_3` - // slot is `EMPTY`. In the cases of `ALT` and `APPLY`, we always walk - // the left side first, because both operations are left-associative. As - // we `RETURN` from those branches, we then walk the right side. - function run() { - var status = CONTINUE; - var step = par; - var head = null; - var tail = null; - var tmp, tid; + // Walks a tree, invoking all the cancelers. Returns the table of pending + // cancellation threads. + function kill(error, par, cb) { + var step = par; + var fail = null; + var head = null; + var tail = null; + var count = 0; + var kills = {}; + var tmp, kid; loop: while (1) { tmp = null; - tid = null; - switch (status) { - case CONTINUE: - switch (step.tag) { - case MAP: - if (head) { - tail = new Aff(CONS, head, tail); - } - head = new Aff(MAP, step._1, EMPTY, EMPTY); - step = step._2; - break; - case APPLY: - if (head) { - tail = new Aff(CONS, head, tail); - } - head = new Aff(APPLY, EMPTY, step._2, EMPTY); - step = step._1; - break; - case ALT: - if (head) { - tail = new Aff(CONS, head, tail); - } - head = new Aff(ALT, EMPTY, step._2, EMPTY); - step = step._1; - break; - default: - // When we hit a leaf value, we suspend the stack in the `FORKED`. - // When the thread resolves, it can bubble back up the tree. - tid = threadId++; - status = RETURN; - tmp = step; - step = new Aff(FORKED, tid, new Aff(CONS, head, tail), EMPTY); - // We prime the effect, but don't immediately run it. We need to - // walk the entire tree first before actually running effects - // because they may all be synchronous and resolve immediately, at - // which point it would attempt to resolve against an incomplete - // tree. - threads[tid] = new Aff(THUNK, runAff(resolve(step))(tmp)); + switch (step.tag) { + case FORKED: + tmp = threads[step._1]; + // If we haven't forked the thread yet (such as with a sync Alt), + // then we should just remove it from the queue and continue. + if (tmp.tag === THUNK) { + delete threads[step._1]; + cb(right(void 0))(); + } else { + // Again, we prime the effect but don't run it yet, so that we can + // collect all the threads first. + kills[count++] = runAff(function (result) { + return function () { + count--; + if (fail === null && isLeft(result)) { + fail = result; + } + // We can resolve the callback when all threads have died. + if (count === 0) { + cb(fail || right(void 0))(); + } + }; + })(tmp._1.kill(error)); } - break; - case RETURN: - // Terminal case, we are back at the root. + // Terminal case. if (head === null) { break loop; } - // If we are done with the right side, we need to continue down the - // left. Otherwise we should continue up the stack. - if (head._1 === EMPTY) { - head._1 = step; - status = CONTINUE; - step = head._2; - head._2 = EMPTY; + // Go down the right side of the tree. + step = head._2; + if (tail === null) { + head = null; } else { - head._2 = step; - step = head; - if (tail === null) { - head = null; - } else { - head = tail._1; - tail = tail._2; - } + head = tail._1; + tail = tail._2; } + break; + case MAP: + step = step._2; + break; + case APPLY: + case ALT: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = step; + step = step._1; + break; } } - // Keep a reference to the tree root so it can be cancelled. - root = step; - - // Walk the primed threads and fork them. We store the actual `Thread` - // reference so we can cancel them when needed. - for (tid = 0; tid < threadId; tid++) { - tmp = threads[tid]; - if (tmp && tmp.tag === THUNK) { - threads[tid] = new Aff(THREAD, tmp._1()); - } + // Run the cancelation effects. We alias `count` because it's mutable. + kid = 0; + tmp = count; + for (; kid < tmp; kid++) { + kills[kid] = kills[kid](); } - } - function resolve(thread) { - return function (result) { - return function () { - delete threads[thread._1]; - thread._3 = result; - join(result, thread._2._1, thread._2._2); - }; - }; + return kills; } // When a thread resolves, we need to bubble back up the tree with the @@ -787,77 +758,108 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff } } - // Walks a tree, invoking all the cancelers. Returns the table of pending - // cancellation threads. - function kill(error, par, cb) { - var step = par; - var fail = null; - var head = null; - var tail = null; - var count = 0; - var kills = {}; - var tmp, kid; + function resolve(thread) { + return function (result) { + return function () { + delete threads[thread._1]; + thread._3 = result; + join(result, thread._2._1, thread._2._2); + }; + }; + } + + // Walks the applicative tree, substituting non-applicative nodes with + // `FORKED` nodes. In this tree, all applicative nodes use the `_3` slot + // as a mutable slot for memoization. In an unresolved state, the `_3` + // slot is `EMPTY`. In the cases of `ALT` and `APPLY`, we always walk + // the left side first, because both operations are left-associative. As + // we `RETURN` from those branches, we then walk the right side. + function run() { + var status = CONTINUE; + var step = par; + var head = null; + var tail = null; + var tmp, tid; loop: while (1) { tmp = null; + tid = null; - switch (step.tag) { - case FORKED: - tmp = threads[step._1]; - // If we haven't forked the thread yet (such as with a sync Alt), - // then we should just remove it from the queue and continue. - if (tmp.tag === THUNK) { - delete threads[step._1]; - cb(right(void 0))(); - } else { - // Again, we prime the effect but don't run it yet, so that we can - // collect all the threads first. - kills[count++] = runAff(function (result) { - return function () { - count--; - if (fail === null && isLeft(result)) { - fail = result; - } - // We can resolve the callback when all threads have died. - if (count === 0) { - cb(fail || right(void 0))(); - } - }; - })(tmp._1.kill(error)); + switch (status) { + case CONTINUE: + switch (step.tag) { + case MAP: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(MAP, step._1, EMPTY, EMPTY); + step = step._2; + break; + case APPLY: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(APPLY, EMPTY, step._2, EMPTY); + step = step._1; + break; + case ALT: + if (head) { + tail = new Aff(CONS, head, tail); + } + head = new Aff(ALT, EMPTY, step._2, EMPTY); + step = step._1; + break; + default: + // When we hit a leaf value, we suspend the stack in the `FORKED`. + // When the thread resolves, it can bubble back up the tree. + tid = threadId++; + status = RETURN; + tmp = step; + step = new Aff(FORKED, tid, new Aff(CONS, head, tail), EMPTY); + // We prime the effect, but don't immediately run it. We need to + // walk the entire tree first before actually running effects + // because they may all be synchronous and resolve immediately, at + // which point it would attempt to resolve against an incomplete + // tree. + threads[tid] = new Aff(THUNK, runAff(resolve(step))(tmp)); } - // Terminal case. + break; + case RETURN: + // Terminal case, we are back at the root. if (head === null) { break loop; } - // Go down the right side of the tree. - step = head._2; - if (tail === null) { - head = null; + // If we are done with the right side, we need to continue down the + // left. Otherwise we should continue up the stack. + if (head._1 === EMPTY) { + head._1 = step; + status = CONTINUE; + step = head._2; + head._2 = EMPTY; } else { - head = tail._1; - tail = tail._2; - } - break; - case MAP: - step = step._2; - break; - case APPLY: - case ALT: - if (head) { - tail = new Aff(CONS, head, tail); + head._2 = step; + step = head; + if (tail === null) { + head = null; + } else { + head = tail._1; + tail = tail._2; + } } - head = step; - step = step._1; - break; } } - // Run the cancelation effects. We alias `count` because it's mutable. - for (kid = 0, tmp = count; kid < tmp; kid++) { - kills[kid] = kills[kid](); - } + // Keep a reference to the tree root so it can be cancelled. + root = step; - return kills; + // Walk the primed threads and fork them. We store the actual `Thread` + // reference so we can cancel them when needed. + for (tid = 0; tid < threadId; tid++) { + tmp = threads[tid]; + if (tmp && tmp.tag === THUNK) { + threads[tid] = new Aff(THREAD, tmp._1()); + } + } } function ignore () { From 646dd95d798baaf39db259461ec306b988e11f1d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 5 Aug 2017 12:45:39 -0700 Subject: [PATCH 17/35] Comments, compat, thread -> fiber, generalBracket --- src/Control/Monad/Aff.js | 98 +++++++++++-------- src/Control/Monad/Aff.purs | 124 +++++++++++++++-------- src/Control/Monad/Aff/AVar.purs | 20 ++++ src/Control/Monad/Aff/Compat.purs | 50 ++++++++++ src/Control/Monad/Aff/Console.purs | 16 +-- test/Test/Main.purs | 152 +++++++++++++++++------------ 6 files changed, 311 insertions(+), 149 deletions(-) create mode 100644 src/Control/Monad/Aff/Compat.purs diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 61a05ae..4b68615 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -16,7 +16,7 @@ data Aff eff a | Sync (Eff eff a) | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) | forall b. Catch (Error -> a) (Aff eff b) ?(b -> a) - | forall b. Bracket (Aff eff b) (b -> Aff eff Unit) (b -> Aff eff a) + | forall b. Bracket (Aff eff b) (BracketConditions eff b) (b -> Aff eff a) */ var PURE = "Pure"; @@ -44,10 +44,11 @@ var ALT = "Alt"; var CONS = "Cons"; // Cons-list, for stacks var RECOVER = "Recover"; // Continue with error handler var RESUME = "Resume"; // Continue indiscriminately +var BRACKETED = "Bracketed"; // Continue with bracket finalizers var FINALIZED = "Finalized"; // Marker for finalization -var FORKED = "Forked"; // Reference to a forked thread, with resumption stack -var THREAD = "Thread"; // Actual thread reference +var FORKED = "Forked"; // Reference to a forked fiber, with resumption stack +var FIBER = "Fiber"; // Actual fiber reference var THUNK = "Thunk"; // Primed effect, ready to invoke function Aff(tag, _1, _2, _3) { @@ -119,10 +120,10 @@ exports.makeAff = function (k) { return new Aff(ASYNC, k); }; -exports.bracket = function (acquire) { - return function (release) { +exports.generalBracket = function (acquire) { + return function (options) { return function (k) { - return new Aff(BRACKET, acquire, release, k); + return new Aff(BRACKET, acquire, options, k); }; }; }; @@ -199,13 +200,13 @@ function runAsync(left, eff, k) { } } -// Thread state machine +// Fiber state machine var BLOCKED = 0; // No effect is running. var PENDING = 1; // An async effect is running. var RETURN = 2; // The current stack has returned. var CONTINUE = 3; // Run the next effect. var BINDSTEP = 4; // Apply the next bind. -var COMPLETED = 5; // The entire thread has completed. +var COMPLETED = 5; // The entire fiber has completed. exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { return function () { @@ -220,7 +221,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { var fail = null; // Failure step var interrupt = null; // Asynchronous interrupt - // Stack of continuations for the current thread. + // Stack of continuations for the current fiber. var bhead = null; var btail = null; @@ -241,11 +242,11 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { var tmp, result, attempt, canceler; // Each invocation of `run` requires a tick. When an asynchronous effect is - // resolved, we must check that the local tick coincides with the thread + // resolved, we must check that the local tick coincides with the fiber // tick before resuming. This prevents multiple async continuations from - // accidentally resuming the same thread. A common example may be invoking + // accidentally resuming the same fiber. A common example may be invoking // the provided callback in `makeAff` more than once, but it may also be an - // async effect resuming after the thread was already cancelled. + // async effect resuming after the fiber was already cancelled. function run(localRunTick) { while (1) { tmp = null; @@ -372,7 +373,7 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { case RETURN: // If the current stack has returned, and we have no other stacks to - // resume or finalizers to run, the thread has halted and we can + // resume or finalizers to run, the fiber has halted and we can // invoke all join callbacks. Otherwise we need to resume. if (attempts === null) { runTick++; // Increment the counter to prevent reentry after completion. @@ -412,14 +413,14 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { break; // If we have a bracket, we should enqueue the finalizer branch, - // and continue with the success branch only if the thread has + // and continue with the success branch only if the fiber has // not been interrupted. If the bracket acquisition failed, we // should not run either. case BRACKET: bracket--; if (fail === null) { result = fromRight(step); - attempts = new Aff(CONS, attempt._2(result), attempts._2); + attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); if (interrupt === null || bracket > 0) { status = CONTINUE; step = attempt._3(result); @@ -429,6 +430,19 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { } break; + case BRACKETED: + bracket++; + attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); + status = CONTINUE; + if (interrupt !== null) { + step = attempt._1.kill(fromLeft(interrupt))(attempt._2); + } else if (fail !== null) { + step = attempt._1.throw(fromLeft(fail))(attempt._2); + } else { + step = attempt._1.release(attempt._2); + } + break; + case FINALIZED: bracket--; attempts = attempts._2; @@ -455,11 +469,11 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { } } joins = tmp; - // If we have an unhandled exception, and no other thread has joined + // If we have an unhandled exception, and no other fiber has joined // then we need to throw the exception in a fresh stack. if (isLeft(step) && !joins) { setTimeout(function () { - // Guard on joins because a completely synchronous thread can + // Guard on joins because a completely synchronous fiber can // still have an observer. if (!joins) { throw fromLeft(step); @@ -554,9 +568,9 @@ exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff, par) { function runParAff(cb) { - // Table of all forked threads. - var threadId = 0; - var threads = {}; + // Table of all forked fibers. + var fiberId = 0; + var fibers = {}; // Table of currently running cancelers, as a product of `Alt` behavior. var killId = 0; @@ -572,7 +586,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var root = EMPTY; // Walks a tree, invoking all the cancelers. Returns the table of pending - // cancellation threads. + // cancellation fibers. function kill(error, par, cb) { var step = par; var fail = null; @@ -587,22 +601,22 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff switch (step.tag) { case FORKED: - tmp = threads[step._1]; - // If we haven't forked the thread yet (such as with a sync Alt), + tmp = fibers[step._1]; + // If we haven't forked the fiber yet (such as with a sync Alt), // then we should just remove it from the queue and continue. if (tmp.tag === THUNK) { - delete threads[step._1]; + delete fibers[step._1]; cb(right(void 0))(); } else { // Again, we prime the effect but don't run it yet, so that we can - // collect all the threads first. + // collect all the fibers first. kills[count++] = runAff(function (result) { return function () { count--; if (fail === null && isLeft(result)) { fail = result; } - // We can resolve the callback when all threads have died. + // We can resolve the callback when all fibers have died. if (count === 0) { cb(fail || right(void 0))(); } @@ -646,7 +660,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff return kills; } - // When a thread resolves, we need to bubble back up the tree with the + // When a fiber resolves, we need to bubble back up the tree with the // result, computing the applicative nodes. function join(result, head, tail) { var fail, step, lhs, rhs, tmp, kid; @@ -758,12 +772,12 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff } } - function resolve(thread) { + function resolve(fiber) { return function (result) { return function () { - delete threads[thread._1]; - thread._3 = result; - join(result, thread._2._1, thread._2._2); + delete fibers[fiber._1]; + fiber._3 = result; + join(result, fiber._2._1, fiber._2._2); }; }; } @@ -779,11 +793,11 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var step = par; var head = null; var tail = null; - var tmp, tid; + var tmp, fid; loop: while (1) { tmp = null; - tid = null; + fid = null; switch (status) { case CONTINUE: @@ -811,17 +825,17 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff break; default: // When we hit a leaf value, we suspend the stack in the `FORKED`. - // When the thread resolves, it can bubble back up the tree. - tid = threadId++; + // When the fiber resolves, it can bubble back up the tree. + fid = fiberId++; status = RETURN; tmp = step; - step = new Aff(FORKED, tid, new Aff(CONS, head, tail), EMPTY); + step = new Aff(FORKED, fid, new Aff(CONS, head, tail), EMPTY); // We prime the effect, but don't immediately run it. We need to // walk the entire tree first before actually running effects // because they may all be synchronous and resolve immediately, at // which point it would attempt to resolve against an incomplete // tree. - threads[tid] = new Aff(THUNK, runAff(resolve(step))(tmp)); + fibers[fid] = new Aff(THUNK, runAff(resolve(step))(tmp)); } break; case RETURN: @@ -852,12 +866,12 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff // Keep a reference to the tree root so it can be cancelled. root = step; - // Walk the primed threads and fork them. We store the actual `Thread` + // Walk the primed fibers and fork them. We store the actual `Fiber` // reference so we can cancel them when needed. - for (tid = 0; tid < threadId; tid++) { - tmp = threads[tid]; + for (fid = 0; fid < fiberId; fid++) { + tmp = fibers[fid]; if (tmp && tmp.tag === THUNK) { - threads[tid] = new Aff(THREAD, tmp._1()); + fibers[fid] = new Aff(FIBER, tmp._1()); } } } @@ -872,7 +886,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff function cancel(error, cb) { interrupt = left(error); - // We can drop the threads here because we are only canceling join + // We can drop the fibers here because we are only canceling join // attempts, which are synchronous anyway. for (var kid = 0, n = killId; kid < n; kid++) { runAff(ignore, kills[kid].kill(error))(); diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 9b3bc35..e0f6f02 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -1,9 +1,9 @@ module Control.Monad.Aff ( Aff - , Thread + , Fiber , ParAff(..) , Canceler(..) - , nonCanceler + , BracketConditions , makeAff , launchAff , runAff @@ -11,11 +11,12 @@ module Control.Monad.Aff , forkAff , liftEff' , bracket + , generalBracket , delay , finally , atomically - , killThread - , joinThread + , killFiber + , joinFiber , module Exports ) where @@ -30,8 +31,6 @@ import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) import Control.Monad.Error.Class (try) as Exports import Control.Monad.Rec.Class (class MonadRec, Step(..)) -import Control.MonadPlus (class MonadPlus) -import Control.MonadZero (class MonadZero) import Control.Parallel (parSequence_, parallel) import Control.Parallel.Class (class Parallel) import Control.Plus (class Plus, empty) @@ -46,7 +45,7 @@ import Unsafe.Coerce (unsafeCoerce) -- | An `Aff eff a` is an asynchronous computation with effects `eff`. The -- | computation may either error with an exception, or produce a result of -- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using --- | `makeAff`. +-- | `makeAff` or `liftEff`. foreign import data Aff ∷ # Effect → Type → Type instance functorAff ∷ Functor (Aff eff) where @@ -75,12 +74,9 @@ instance altAff ∷ Alt (Aff eff) where instance plusAff ∷ Plus (Aff eff) where empty = throwError (error "Always fails") -instance alternativeAff ∷ Alternative (Aff eff) - -instance monadZeroAff ∷ MonadZero (Aff eff) - -instance monadPlusAff ∷ MonadPlus (Aff eff) - +-- | This instance is provided for compatibility. `Aff` is always stack-safe +-- | within a given fiber. This instance will just result in unnecessary +-- | bind overhead. instance monadRecAff ∷ MonadRec (Aff eff) where tailRecM k = go where @@ -99,11 +95,14 @@ instance monadErrorAff ∷ MonadError Error (Aff eff) where instance monadEffAff ∷ MonadEff eff (Aff eff) where liftEff = _liftEff +-- | Applicative for running parallel effects. Any `Aff` can be coerced to a +-- | `ParAff` and back using the `Parallel` class. foreign import data ParAff ∷ # Effect → Type → Type instance functorParAff ∷ Functor (ParAff eff) where map = _parAffMap +-- | Runs effects in parallel, combining their results. instance applyParAff ∷ Apply (ParAff eff) where apply = _parAffApply @@ -116,6 +115,9 @@ instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where mempty = pure mempty +-- | Races effects in parallel. Returns the first successful result or the +-- | first error if all fail with an exception. Losing branches will be +-- | cancelled. instance altParAff ∷ Alt (ParAff eff) where alt = _parAffAlt @@ -128,35 +130,44 @@ instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) sequential a = Fn.runFn7 _sequential isLeft unsafeFromLeft unsafeFromRight Left Right runAff a -newtype Thread eff a = Thread +-- | Represents a forked computation by way of `forkAff`. `Fiber`s are +-- | memoized, so their results are only computed once. +newtype Fiber eff a = Fiber { kill ∷ Error → Aff eff Unit , join ∷ Aff eff a } -instance functorThread ∷ Functor (Thread eff) where - map f (Thread { kill, join }) = Thread - { kill - , join: memoAff (f <$> join) +instance functorFiber ∷ Functor (Fiber eff) where + map f t = Fiber + { kill: const (pure unit) + , join: memoAff (f <$> joinFiber t) } -instance applyThread ∷ Apply (Thread eff) where - apply t1 t2 = Thread - { kill: \err → parSequence_ [ killThread err t1, killThread err t2 ] - , join: memoAff (joinThread t1 <*> joinThread t2) +instance applyFiber ∷ Apply (Fiber eff) where + apply t1 t2 = Fiber + { kill: const (pure unit) + , join: memoAff (joinFiber t1 <*> joinFiber t2) } -instance applicativeThread ∷ Applicative (Thread eff) where - pure a = Thread +instance applicativeFiber ∷ Applicative (Fiber eff) where + pure a = Fiber { kill: const (pure unit) , join: pure a } -killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit -killThread e (Thread t) = t.kill e +-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks +-- | until the fiber has fully exited. +killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit +killFiber e (Fiber t) = t.kill e -joinThread ∷ ∀ eff a. Thread eff a → Aff eff a -joinThread (Thread t) = t.join +-- | Blocks until the fiber completes, yielding the result. If the fiber +-- | throws an exception, it is rethrown in the current fiber. +joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a +joinFiber (Fiber t) = t.join +-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is +-- | killed, and an async action is pending, the canceler will be called to +-- | clean it up. newtype Canceler eff = Canceler (Error → Aff eff Unit) derive instance newtypeCanceler ∷ Newtype (Canceler eff) _ @@ -165,36 +176,65 @@ instance semigroupCanceler ∷ Semigroup (Canceler eff) where append (Canceler c1) (Canceler c2) = Canceler \err → parSequence_ [ c1 err, c2 err ] +-- | A no-op `Canceler` can be constructed with `mempty`. instance monoidCanceler ∷ Monoid (Canceler eff) where - mempty = nonCanceler - -nonCanceler ∷ ∀ eff. Canceler eff -nonCanceler = Canceler (const (pure unit)) + mempty = Canceler (const (pure unit)) -launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a) +-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. +launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff -runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Thread eff Unit) +-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when +-- | it completes. Returns the pending `Fiber`. +runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit) runAff k aff = launchAff $ liftEff <<< k =<< try aff +-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when +-- | it completes, discarding the `Fiber`. runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit runAff_ k aff = void $ runAff k aff -forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a) +-- | Forks an `Aff` from within another `Aff` context, returning the `Fiber`. +forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) forkAff = liftEff <<< launchAff +-- | Pauses the running fiber. delay ∷ ∀ eff. Milliseconds → Aff eff Unit delay (Milliseconds n) = Fn.runFn2 _delay Right n +-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but +-- | standard `liftEff` won't remove the effect label. liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a liftEff' = liftEff <<< unsafeCoerceEff +-- | Runs the first effect after the second, regardless of whether it completed +-- | successfully or the fiber was cancelled. finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a finally fin a = bracket (pure unit) (const fin) (const a) +-- | Runs an effect such that it cannot be killed. atomically ∷ ∀ eff a. Aff eff a → Aff eff a atomically a = bracket a (const (pure unit)) pure +type BracketConditions eff a = + { kill ∷ Error → a → Aff eff Unit + , throw ∷ Error → a → Aff eff Unit + , release ∷ a → Aff eff Unit + } + +-- | Guarantees resource acquisition and cleanup. The first effect may acquire +-- | some resource, while the second will dispose of it. The third effect makes +-- | use of the resource. Disposal is always run last, regardless. Neither +-- | acquisition nor disposal may be cancelled and are guaranteed to run until +-- | they complete. +bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b +bracket acquire release = + generalBracket acquire + { kill: const release + , throw: const release + , release + } + 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 @@ -205,8 +245,16 @@ foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a -foreign import bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b +foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b + +-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A +-- | `Canceler` effect should be returned to cancel the pending action. The +-- | supplied callback may be invoked only once. Subsequent invocation are +-- | ignored. foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a + +-- | Do not export this function. It is not referentially transparent in +-- | general, and can be used to create global mutable references. foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a foreign import _launchAff @@ -218,7 +266,7 @@ foreign import _launchAff (Error → Either Error a) (a → Either Error a) (Aff eff a) - (Eff eff (Thread eff a)) + (Eff eff (Fiber eff a)) foreign import _sequential ∷ ∀ eff a @@ -228,7 +276,7 @@ foreign import _sequential (Either Error a → a) (Error → Either Error a) (a → Either Error a) - ((Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Thread eff Unit)) + ((Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)) (ParAff eff a) (Aff eff a) diff --git a/src/Control/Monad/Aff/AVar.purs b/src/Control/Monad/Aff/AVar.purs index 3b2b6da..b5056cc 100644 --- a/src/Control/Monad/Aff/AVar.purs +++ b/src/Control/Monad/Aff/AVar.purs @@ -24,38 +24,58 @@ import Data.Maybe (Maybe) toCanceler ∷ ∀ eff. Eff eff Unit → Canceler eff toCanceler = Canceler <<< const <<< liftEff +-- | Creates a fresh AVar with an initial value. makeVar ∷ ∀ eff a. a → Aff (avar ∷ AVAR | eff) (AVar a) makeVar = liftEff <<< AVar.makeVar +-- | Creates a fresh AVar. makeEmptyVar ∷ ∀ eff a. Aff (avar ∷ AVAR | eff) (AVar a) makeEmptyVar = liftEff AVar.makeEmptyVar +-- | Synchronously checks whether an AVar currently has a value. isEmptyVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) Boolean isEmptyVar = liftEff <<< AVar.isEmptyVar +-- | Takes the AVar value, leaving it empty. If the AVar is already empty, +-- | the callback will be queued until the AVar is filled. Multiple takes will +-- | resolve in order as the AVar fills. takeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a takeVar avar = makeAff \k → do c ← AVar.takeVar avar k pure (toCanceler c) +-- | Attempts to synchronously take an AVar value, leaving it empty. If the +-- | AVar is empty, this will return `Nothing`. tryTakeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a) tryTakeVar = liftEff <<< AVar.tryTakeVar +-- | Sets the value of the AVar. If the AVar is already filled, it will be +-- | queued until the value is emptied. Multiple puts will resolve in order as +-- | the AVar becomes available. putVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Unit putVar avar value = makeAff \k → do c ← AVar.putVar avar value k pure (toCanceler c) +-- | Attempts to synchronously fill an AVar. If the AVar is already filled, +-- | this will do nothing. Returns true or false depending on if it succeeded. tryPutVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Boolean tryPutVar avar = liftEff <<< AVar.tryPutVar avar +-- | Reads the AVar value. Unlike `takeVar`, this will not leave the AVar empty. +-- | If the AVar is empty, this will queue until it is filled. Multiple reads +-- | will resolve at the same time, as soon as possible. readVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a readVar avar = makeAff \k → do c ← AVar.readVar avar k pure (toCanceler c) +-- | Attempts to synchronously read an AVar. If the AVar is empty, this will +-- | return `Nothing`. tryReadVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a) tryReadVar = liftEff <<< AVar.tryReadVar +-- | Kills the AVar with an exception. All pending and future actions will +-- | resolve immediately with the provided exception. killVar ∷ ∀ eff a. AVar a → Error → Aff (avar ∷ AVAR | eff) Unit killVar avar = liftEff <<< AVar.killVar avar diff --git a/src/Control/Monad/Aff/Compat.purs b/src/Control/Monad/Aff/Compat.purs new file mode 100644 index 0000000..d2256cc --- /dev/null +++ b/src/Control/Monad/Aff/Compat.purs @@ -0,0 +1,50 @@ +-- | This module provides compatability functions for constructing `Aff`s which +-- | are defined via the FFI. +module Control.Monad.Aff.Compat + ( EffFnAff(..) + , EffFnCanceler(..) + , fromEffFnAff + ) where + +import Prelude +import Control.Monad.Aff (Aff, Canceler(..), makeAff) +import Control.Monad.Eff.Class (liftEff) +import Control.Monad.Eff.Exception (Error) +import Control.Monad.Eff.Uncurried as Fn +import Data.Either (Either(..)) + +newtype EffFnAff eff a = EffFnAff (Fn.EffFn2 eff (Fn.EffFn1 eff Error Unit) (Fn.EffFn1 eff a Unit) (EffFnCanceler eff)) + +newtype EffFnCanceler eff = EffFnCanceler (Fn.EffFn1 eff Error (EffFnAff eff Unit)) + +-- | Lift a FFI definition into an `Aff`. `EffFnAff` makes use of `EffFn` so +-- | `Eff` thunks are unnecessary. A definition might follow this example: +-- | +-- | ```javascript +-- | exports._myAff = function (onError, onSuccess) { +-- | var cancel = doSomethingAsync(function (err, res) { +-- | if (err) { +-- | onError(err); +-- | } else { +-- | onSuccess(res); +-- | } +-- | }); +-- | return function (cancelError) { +-- | return function (onCancelerError, onCancelerSuccess) { +-- | cancel(); +-- | onCancelerSuccess(); +-- | }; +-- | }; +-- | }; +-- | ``` +-- | +-- | ```purescript +-- | foreign import _myAff :: forall eff. EffFnAff (myeffect :: MYEFFECT | eff) String +-- | +-- | myAff :: forall eff. Aff (myeffect :: MYEFFECT | eff) String +-- | myAff = fromEffFnAff _myAff +-- | ```` +fromEffFnAff ∷ ∀ eff a. EffFnAff eff a → Aff eff a +fromEffFnAff (EffFnAff eff) = makeAff \k → do + EffFnCanceler canceler ← Fn.runEffFn2 eff (Fn.mkEffFn1 (k <<< Left)) (Fn.mkEffFn1 (k <<< Right)) + pure $ Canceler \e → fromEffFnAff =<< liftEff (Fn.runEffFn1 canceler e) diff --git a/src/Control/Monad/Aff/Console.purs b/src/Control/Monad/Aff/Console.purs index 379a12c..2f40551 100644 --- a/src/Control/Monad/Aff/Console.purs +++ b/src/Control/Monad/Aff/Console.purs @@ -17,37 +17,37 @@ import Control.Monad.Eff.Console (CONSOLE) as Exports import Control.Monad.Eff.Console as C -- | Write a message to the console. Shorthand for `liftEff $ log x`. -log :: forall eff. String -> Aff (console :: C.CONSOLE | eff) Unit +log ∷ ∀ eff. String → Aff (console ∷ C.CONSOLE | eff) Unit log = liftEff <<< C.log -- | Write a value to the console, using its `Show` instance to produce a -- | `String`. Shorthand for `liftEff $ logShow x`. -logShow :: forall a eff. Show a => a -> Aff (console :: C.CONSOLE | eff) Unit +logShow ∷ ∀ a eff. Show a ⇒ a → Aff (console ∷ C.CONSOLE | eff) Unit logShow = liftEff <<< C.logShow -- | Write a warning to the console. Shorthand for `liftEff $ warn x`. -warn :: forall eff. String -> Aff (console :: C.CONSOLE | eff) Unit +warn ∷ ∀ eff. String → Aff (console ∷ C.CONSOLE | eff) Unit warn = liftEff <<< C.warn -- | Write a warning value to the console, using its `Show` instance to produce -- | a `String`. Shorthand for `liftEff $ warnShow x`. -warnShow :: forall a eff. Show a => a -> Aff (console :: C.CONSOLE | eff) Unit +warnShow ∷ ∀ a eff. Show a ⇒ a → Aff (console ∷ C.CONSOLE | eff) Unit warnShow = liftEff <<< C.warnShow -- | Write an error to the console. Shorthand for `liftEff $ error x`. -error :: forall eff. String -> Aff (console :: C.CONSOLE | eff) Unit +error ∷ ∀ eff. String → Aff (console ∷ C.CONSOLE | eff) Unit error = liftEff <<< C.error -- | Write an error value to the console, using its `Show` instance to produce a -- | `String`. Shorthand for `liftEff $ errorShow x`. -errorShow :: forall a eff. Show a => a -> Aff (console :: C.CONSOLE | eff) Unit +errorShow ∷ ∀ a eff. Show a ⇒ a → Aff (console ∷ C.CONSOLE | eff) Unit errorShow = liftEff <<< C.errorShow -- | Write an info message to the console. Shorthand for `liftEff $ info x`. -info :: forall eff. String -> Aff (console :: C.CONSOLE | eff) Unit +info ∷ ∀ eff. String → Aff (console ∷ C.CONSOLE | eff) Unit info = liftEff <<< C.info -- | Write an info value to the console, using its `Show` instance to produce a -- | `String`. Shorthand for `liftEff $ infoShow x`. -infoShow :: forall a eff. Show a => a -> Aff (console :: C.CONSOLE | eff) Unit +infoShow ∷ ∀ a eff. Show a ⇒ a → Aff (console ∷ C.CONSOLE | eff) Unit infoShow = liftEff <<< C.infoShow diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 938ff56..82987e2 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,7 +2,7 @@ module Test.Main where import Prelude import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, Canceler(..), nonCanceler, runAff_, launchAff, makeAff, try, bracket, delay, forkAff, joinThread, killThread) +import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, joinFiber, killFiber) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -15,9 +15,10 @@ import Control.Monad.Error.Class (throwError) import Control.Parallel (parallel, sequential, parTraverse_) import Data.Array as Array import Data.Bifunctor (lmap) -import Data.Either (Either(..), isLeft) +import Data.Either (Either(..), isLeft, isRight) import Data.Foldable (sum) import Data.Maybe (Maybe(..)) +import Data.Monoid (mempty) import Data.Traversable (traverse) import Data.Time.Duration (Milliseconds(..)) import Test.Assert (assert', ASSERT) @@ -96,7 +97,7 @@ test_delay = assert "delay" do test_fork ∷ ∀ eff. TestAff eff Unit test_fork = assert "fork" do ref ← newRef 0 - thread ← forkAff do + fiber ← forkAff do delay (Milliseconds 10.0) modifyRef ref (_ + 1) writeRef ref 42 @@ -107,41 +108,41 @@ test_fork = assert "fork" do test_join ∷ ∀ eff. TestAff eff Unit test_join = assert "join" do ref ← newRef 1 - thread ← forkAff do + fiber ← forkAff do delay (Milliseconds 10.0) modifyRef ref (_ - 2) readRef ref writeRef ref 42 - eq 40 <$> joinThread thread + eq 40 <$> joinFiber fiber test_join_throw ∷ ∀ eff. TestAff eff Unit test_join_throw = assert "join/throw" do - thread ← forkAff do + fiber ← forkAff do delay (Milliseconds 10.0) throwError (error "Nope.") - isLeft <$> try (joinThread thread) + isLeft <$> try (joinFiber fiber) test_join_throw_sync ∷ ∀ eff. TestAff eff Unit test_join_throw_sync = assert "join/throw/sync" do - thread ← forkAff (throwError (error "Nope.")) - isLeft <$> try (joinThread thread) + fiber ← forkAff (throwError (error "Nope.")) + isLeft <$> try (joinFiber fiber) test_multi_join ∷ ∀ eff. TestAff eff Unit test_multi_join = assert "join/multi" do ref ← newRef 1 - thread1 ← forkAff do + f1 ← forkAff do delay (Milliseconds 10.0) modifyRef ref (_ + 1) pure 10 - thread2 ← forkAff do + f2 ← forkAff do delay (Milliseconds 20.0) modifyRef ref (_ + 1) pure 20 - n1 ← sum <$> traverse joinThread - [ thread1 - , thread1 - , thread1 - , thread2 + n1 ← sum <$> traverse joinFiber + [ f1 + , f1 + , f1 + , f2 ] n2 ← readRef ref pure (n1 == 50 && n2 == 3) @@ -150,10 +151,10 @@ test_makeAff ∷ ∀ eff. TestAff eff Unit test_makeAff = assert "makeAff" do ref1 ← newRef Nothing ref2 ← newRef 0 - thread ← forkAff do + fiber ← forkAff do n ← makeAff \cb → do writeRef ref1 (Just cb) - pure nonCanceler + pure mempty writeRef ref2 n cb ← readRef ref1 case cb of @@ -170,14 +171,14 @@ test_bracket = assert "bracket" do delay (Milliseconds 10.0) modifyRef ref (_ <> [ s ]) pure s - thread ← forkAff do + fiber ← forkAff do delay (Milliseconds 40.0) readRef ref _ ← bracket (action "foo") (\s → void $ action (s <> "/release")) (\s → action (s <> "/run")) - joinThread thread <#> eq + joinFiber fiber <#> eq [ "foo" , "foo/run" , "foo/release" @@ -212,20 +213,48 @@ test_bracket_nested = assert "bracket/nested" do , "foo/bar/run/release/bar/release" ] +test_general_bracket ∷ ∀ eff. TestAff eff Unit +test_general_bracket = assert "bracket/general" do + ref ← newRef "" + let + action s = do + delay (Milliseconds 10.0) + modifyRef ref (_ <> s) + pure s + bracketAction s = + generalBracket (action s) + { kill: \error s' → void $ action (s' <> "/kill/" <> message error) + , throw: \error s' → void $ action (s' <> "/throw/" <> message error) + , release: \s' → void $ action (s' <> "/release") + } + + f1 ← forkAff $ bracketAction "foo" (const (action "a")) + killFiber (error "z") f1 + r1 ← try $ joinFiber f1 + + f2 ← forkAff $ bracketAction "bar" (const (throwError $ error "b")) + r2 ← try $ joinFiber f2 + + f3 ← forkAff $ bracketAction "baz" (const (action "c")) + r3 ← try $ joinFiber f3 + + r4 ← readRef ref + pure (isLeft r1 && isLeft r2 && isRight r3 && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release") + test_kill ∷ ∀ eff. TestAff eff Unit test_kill = assert "kill" do - thread ← forkAff $ makeAff \_ → pure nonCanceler - killThread (error "Nope") thread - isLeft <$> try (joinThread thread) + fiber ← forkAff $ makeAff \_ → pure mempty + killFiber (error "Nope") fiber + isLeft <$> try (joinFiber fiber) test_kill_canceler ∷ ∀ eff. TestAff eff Unit test_kill_canceler = assert "kill/canceler" do ref ← newRef 0 - thread ← forkAff do + fiber ← forkAff do n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref 42)) writeRef ref 2 - killThread (error "Nope") thread - res ← try (joinThread thread) + killFiber (error "Nope") fiber + res ← try (joinFiber fiber) n ← readRef ref pure (n == 42 && (lmap message res) == Left "Nope") @@ -236,13 +265,13 @@ test_kill_bracket = assert "kill/bracket" do action n = do delay (Milliseconds 10.0) modifyRef ref (_ <> n) - thread ← + fiber ← forkAff $ bracket (action "a") (\_ → action "b") (\_ → action "c") - killThread (error "Nope") thread - _ ← try (joinThread thread) + killFiber (error "Nope") fiber + _ ← try (joinFiber fiber) eq "ab" <$> readRef ref test_kill_bracket_nested ∷ ∀ eff. TestAff eff Unit @@ -258,13 +287,13 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do (action (s <> "/bar")) (\s' → void $ action (s' <> "/release")) (\s' → action (s' <> "/run")) - thread ← + fiber ← forkAff $ bracket (bracketAction "foo") (\s → void $ bracketAction (s <> "/release")) (\s → bracketAction (s <> "/run")) - killThread (error "Nope") thread - _ ← try (joinThread thread) + killFiber (error "Nope") fiber + _ ← try (joinFiber fiber) readRef ref <#> eq [ "foo/bar" , "foo/bar/run" @@ -282,13 +311,13 @@ test_parallel = assert "parallel" do delay (Milliseconds 10.0) modifyRef ref (_ <> s) pure s - t1 ← forkAff $ sequential $ + f1 ← forkAff $ sequential $ { a: _, b: _ } <$> parallel (action "foo") <*> parallel (action "bar") delay (Milliseconds 10.0) r1 ← readRef ref - r2 ← joinThread t1 + r2 ← joinFiber f1 pure (r1 == "foobar" && r2.a == "foo" && r2.b == "bar") test_kill_parallel ∷ ∀ eff. TestAff eff Unit @@ -302,14 +331,14 @@ test_kill_parallel = assert "kill/parallel" do (\_ → do delay (Milliseconds 10.0) modifyRef ref (_ <> s)) - t1 ← forkAff $ sequential $ + f1 ← forkAff $ sequential $ parallel (action "foo") *> parallel (action "bar") - t2 ← forkAff do + f2 ← forkAff do delay (Milliseconds 5.0) - killThread (error "Nope") t1 + killFiber (error "Nope") f1 modifyRef ref (_ <> "done") - _ ← try $ joinThread t1 - _ ← try $ joinThread t2 + _ ← try $ joinFiber f1 + _ ← try $ joinFiber f2 eq "killedfookilledbardone" <$> readRef ref test_parallel_alt ∷ ∀ eff. TestAff eff Unit @@ -320,11 +349,11 @@ test_parallel_alt = assert "parallel/alt" do delay (Milliseconds n) modifyRef ref (_ <> s) pure s - t1 ← forkAff $ sequential $ + f1 ← forkAff $ sequential $ parallel (action 10.0 "foo") <|> parallel (action 5.0 "bar") delay (Milliseconds 10.0) r1 ← readRef ref - r2 ← joinThread t1 + r2 ← joinFiber f1 pure (r1 == "bar" && r2 == "bar") test_parallel_alt_sync ∷ ∀ eff. TestAff eff Unit @@ -354,50 +383,50 @@ test_kill_parallel_alt = assert "kill/parallel/alt" do (\_ → do delay (Milliseconds n) modifyRef ref (_ <> s)) - t1 ← forkAff $ sequential $ + f1 ← forkAff $ sequential $ parallel (action 10.0 "foo") <|> parallel (action 20.0 "bar") - t2 ← forkAff do + f2 ← forkAff do delay (Milliseconds 5.0) - killThread (error "Nope") t1 + killFiber (error "Nope") f1 modifyRef ref (_ <> "done") - _ ← try $ joinThread t1 - _ ← try $ joinThread t2 + _ ← try $ joinFiber f1 + _ ← try $ joinFiber f2 eq "killedfookilledbardone" <$> readRef ref -test_thread_map ∷ ∀ eff. TestAff eff Unit -test_thread_map = assert "thread/map" do +test_fiber_map ∷ ∀ eff. TestAff eff Unit +test_fiber_map = assert "fiber/map" do ref ← newRef 0 let mapFn a = runPure do unsafeRunRef $ Ref.modifyRef ref (_ + 1) pure (a + 1) - t1 ← forkAff do + f1 ← forkAff do delay (Milliseconds 10.0) pure 10 let - t2 = mapFn <$> t1 - a ← joinThread t2 - b ← joinThread t2 + f2 = mapFn <$> f1 + a ← joinFiber f2 + b ← joinFiber f2 n ← readRef ref pure (a == 11 && b == 11 && n == 1) -test_thread_apply ∷ ∀ eff. TestAff eff Unit -test_thread_apply = assert "thread/apply" do +test_fiber_apply ∷ ∀ eff. TestAff eff Unit +test_fiber_apply = assert "fiber/apply" do ref ← newRef 0 let applyFn a b = runPure do unsafeRunRef $ Ref.modifyRef ref (_ + 1) pure (a + b) - t1 ← forkAff do + f1 ← forkAff do delay (Milliseconds 10.0) pure 10 - t2 ← forkAff do + f2 ← forkAff do delay (Milliseconds 15.0) pure 12 let - t3 = applyFn <$> t1 <*> t2 - a ← joinThread t3 - b ← joinThread t3 + f3 = applyFn <$> f1 <*> f2 + a ← joinFiber f3 + b ← joinFiber f3 n ← readRef ref pure (a == 22 && b == 22 && n == 1) @@ -425,6 +454,7 @@ main = do test_makeAff test_bracket test_bracket_nested + test_general_bracket test_kill test_kill_canceler test_kill_bracket @@ -434,6 +464,6 @@ main = do test_parallel_alt test_parallel_alt_sync test_kill_parallel_alt - test_thread_map - test_thread_apply + test_fiber_map + test_fiber_apply test_parallel_stack From 5133c20b3600e2d8ff4673feed8c64bdb01825b5 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 8 Aug 2017 16:11:36 -0700 Subject: [PATCH 18/35] Suspend, child supervision --- src/Control/Monad/Aff.js | 774 +++++++++++++++++++++---------------- src/Control/Monad/Aff.purs | 99 +++-- test/Test/Main.purs | 63 ++- 3 files changed, 553 insertions(+), 383 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 4b68615..63ee908 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -13,19 +13,22 @@ efficiency sake. data Aff eff a = Pure a | Throw Error + | Catch (Aff eff a) (Error -> Aff eff a) | Sync (Eff eff a) | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) - | forall b. Catch (Error -> a) (Aff eff b) ?(b -> a) + | forall b. Bind (Aff eff b) (b -> Aff eff a) | forall b. Bracket (Aff eff b) (BracketConditions eff b) (b -> Aff eff a) + | forall b. Fork Boolean (Aff eff b) ?(Thread eff b -> a) */ var PURE = "Pure"; var THROW = "Throw"; +var CATCH = "Catch"; var SYNC = "Sync"; var ASYNC = "Async"; var BIND = "Bind"; -var CATCH = "Catch"; var BRACKET = "Bracket"; +var FORK = "Fork"; /* @@ -94,6 +97,12 @@ exports._bind = function (aff) { }; }; +exports._fork = function (suspended) { + return function (aff) { + return new Aff(FORK, suspended, aff); + }; +}; + exports._liftEff = function (eff) { return new Aff(SYNC, eff); }; @@ -206,367 +215,456 @@ var PENDING = 1; // An async effect is running. var RETURN = 2; // The current stack has returned. var CONTINUE = 3; // Run the next effect. var BINDSTEP = 4; // Apply the next bind. -var COMPLETED = 5; // The entire fiber has completed. +var KILLFORKS = 5; // Killing supervised forks. +var COMPLETED = 6; // The entire fiber has completed. + +function runFiber(util, suspended, aff, completeCb) { + // Monotonically increasing tick, increased on each asynchronous turn. + var runTick = 0; + + // The current branch of the state machine. + var status = CONTINUE; + + // The current point of interest for the state machine branch. + var step = aff; // Successful step + var fail = null; // Failure step + var interrupt = null; // Asynchronous interrupt + + // Stack of continuations for the current fiber. + var bhead = null; + var btail = null; + + // Stack of attempts and finalizers for error recovery. This holds a union + // of an arbitrary Aff finalizer or a Cons list of bind continuations. + var attempts = null; + + // A special state is needed for Bracket, because it cannot be killed. When + // we enter a bracket acquisition or finalizer, we increment the counter, + // and then decrement once complete. + var bracket = 0; + + // Each join gets a new id so they can be revoked. + var joinId = 0; + var joins = {}; + + // Track child forks so they don't outlive the parent thread. + var forkCount = 0; + var forkId = 0; + var forks = {}; + + // Temporary bindings for the various branches. + var tmp, result, attempt, canceler; + + function launchChildFiber(fid, suspended, child) { + forkCount++; + var blocked = true; + var fiber = runFiber(util, suspended, child, function () { + forkCount--; + if (blocked) { + blocked = false; + } else { + delete forks[fid]; + } + }); + if (blocked) { + blocked = false; + forks[fid] = fiber; + } + return fiber; + } -exports._launchAff = function (isLeft, fromLeft, fromRight, left, right, aff) { - return function () { - // Monotonically increasing tick, increased on each asynchronous turn. - var runTick = 0; - - // The current branch of the state machine. - var status = CONTINUE; - - // The current point of interest for the state machine branch. - var step = aff; // Successful step - var fail = null; // Failure step - var interrupt = null; // Asynchronous interrupt - - // Stack of continuations for the current fiber. - var bhead = null; - var btail = null; - - // Stack of attempts and finalizers for error recovery. This holds a union - // of an arbitrary Aff finalizer or a Cons list of bind continuations. - var attempts = null; - - // A special state is needed for Bracket, because it cannot be killed. When - // we enter a bracket acquisition or finalizer, we increment the counter, - // and then decrement once complete. - var bracket = 0; - - // Each join gets a new id so they can be revoked. - var joinId = 0; - var joins = {}; - - // Temporary bindings for the various branches. - var tmp, result, attempt, canceler; - - // Each invocation of `run` requires a tick. When an asynchronous effect is - // resolved, we must check that the local tick coincides with the fiber - // tick before resuming. This prevents multiple async continuations from - // accidentally resuming the same fiber. A common example may be invoking - // the provided callback in `makeAff` more than once, but it may also be an - // async effect resuming after the fiber was already cancelled. - function run(localRunTick) { - while (1) { - tmp = null; - result = null; - attempt = null; - canceler = null; - switch (status) { - case BINDSTEP: + function killChildFibers(finalStep) { + return new Aff(ASYNC, function (cb) { + return function () { + var killError = new Error("[Aff] Child fiber outlived parent"); + var killId = 0; + var kills = {}; + for (var k in forks) { + if (forks.hasOwnProperty(k)) { + kills[killId++] = forks[k].kill(killError); + } + } + forks = {}; + forkCount = 0; + for (var i = 0, len = killId; i < len; i++) { + kills[i] = runFiber(util, false, kills[i], function () { + delete kills[i]; + killId--; + if (killId === 0) { + cb(finalStep)(); + } + }); + } + return function (error) { + return new Aff(SYNC, function () { + for (var k in kills) { + if (kills.hasOwnProperty(k)) { + runFiber(util, false, kills[k].kill(error), function () {}); + } + } + }); + }; + }; + }); + } + + // Each invocation of `run` requires a tick. When an asynchronous effect is + // resolved, we must check that the local tick coincides with the fiber + // tick before resuming. This prevents multiple async continuations from + // accidentally resuming the same fiber. A common example may be invoking + // the provided callback in `makeAff` more than once, but it may also be an + // async effect resuming after the fiber was already cancelled. + function run(localRunTick) { + while (true) { + tmp = null; + result = null; + attempt = null; + canceler = null; + switch (status) { + case BINDSTEP: + status = CONTINUE; + step = bhead(step); + if (btail === null) { + bhead = null; + } else { + bhead = btail._1; + btail = btail._2; + } + break; + + case CONTINUE: + switch (step.tag) { + case BIND: + if (bhead) { + btail = new Aff(CONS, bhead, btail); + } + bhead = step._2; status = CONTINUE; - step = bhead(step); - if (btail === null) { - bhead = null; + step = step._1; + break; + + case PURE: + if (bhead === null) { + status = RETURN; + step = util.right(step._1); } else { - bhead = btail._1; - btail = btail._2; + status = BINDSTEP; + step = step._1; } break; - case CONTINUE: - switch (step.tag) { - case BIND: - if (bhead) { - btail = new Aff(CONS, bhead, btail); + case THROW: + bhead = null; + btail = null; + status = RETURN; + fail = util.left(step._1); + break; + + case SYNC: + status = BLOCKED; + result = runSync(util.left, util.right, step._1); + if (util.isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = util.fromRight(result); + } + break; + + case ASYNC: + status = BLOCKED; + canceler = runAsync(util.left, step._1, function (result) { + return function () { + if (runTick !== localRunTick) { + return; + } + tmp = status; + if (util.isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = util.fromRight(result); + } + // We only need to invoke `run` if the subsequent block has + // switch the status to PENDING. Otherwise the callback was + // resolved synchronously, and the current loop can continue + // normally. + if (tmp === PENDING) { + run(++runTick); + } else { + localRunTick = ++runTick; + } + }; + }); + // If the callback was resolved synchronously, the status will have + // switched to CONTINUE, and we should not move on to PENDING. + if (status === BLOCKED) { + status = PENDING; + step = canceler; + } + break; + + // Enqueue the current stack of binds and continue + case CATCH: + attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts); + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + + // When we evaluate a Bracket, we also enqueue the instruction so we + // can fullfill it later once we return from the acquisition. + case BRACKET: + bracket++; + if (bhead === null) { + attempts = new Aff(CONS, step, attempts); + } else { + attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); + } + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; + break; + + case FORK: + status = BINDSTEP; + step = launchChildFiber(forkId++, step._1, step._2); + break; + } + break; + + case RETURN: + // If the current stack has returned, and we have no other stacks to + // resume or finalizers to run, the fiber has halted and we can + // invoke all join callbacks. Otherwise we need to resume. + if (attempts === null) { + runTick++; // Increment the counter to prevent reentry after completion. + status = KILLFORKS; + step = interrupt || fail || step; + } else { + attempt = attempts._1; + switch (attempt.tag) { + // 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._2; + btail = attempt._3; + if (fail === null) { + status = BINDSTEP; + step = util.fromRight(step); + } else { + status = CONTINUE; + step = attempt._1(util.fromLeft(fail)); + fail = null; + } } - bhead = step._2; - status = CONTINUE; - step = step._1; break; - case PURE: - if (bhead === null) { - status = RETURN; - step = right(step._1); - } else { + // We cannot resume from an interrupt or exception. + case RESUME: + attempts = attempts._2; + if (interrupt === null && fail === null) { + bhead = attempt._1; + btail = attempt._2; status = BINDSTEP; - step = step._1; + step = util.fromRight(step); } break; - case THROW: - bhead = null; - btail = null; - status = RETURN; - fail = left(step._1); - break; - - case SYNC: - status = BLOCKED; - result = runSync(left, right, step._1); - if (isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; + // If we have a bracket, we should enqueue the finalizer branch, + // and continue with the success branch only if the fiber has + // not been interrupted. If the bracket acquisition failed, we + // should not run either. + case BRACKET: + bracket--; + if (fail === null) { + result = util.fromRight(step); + attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); + if (interrupt === null || bracket > 0) { + status = CONTINUE; + step = attempt._3(result); + } } else { - status = BINDSTEP; - step = fromRight(result); + attempts = attempts._2; } break; - case ASYNC: - status = BLOCKED; - canceler = runAsync(left, step._1, function (result) { - return function () { - if (runTick !== localRunTick) { - return; - } - tmp = status; - if (isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = fromRight(result); - } - // We only need to invoke `run` if the subsequent block has - // switch the status to PENDING. Otherwise the callback was - // resolved synchronously, and the current loop can continue - // normally. - if (tmp === PENDING) { - run(++runTick); - } else { - localRunTick = ++runTick; - } - }; - }); - // If the callback was resolved synchronously, the status will have - // switched to CONTINUE, and we should not move on to PENDING. - if (status === BLOCKED) { - status = PENDING; - step = canceler; + case BRACKETED: + bracket++; + attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); + status = CONTINUE; + if (interrupt !== null) { + step = attempt._1.kill(util.fromLeft(interrupt))(attempt._2); + } else if (fail !== null) { + step = attempt._1.throw(util.fromLeft(fail))(attempt._2); + } else { + step = attempt._1.release(attempt._2); } break; - // Enqueue the current stack of binds and continue - case CATCH: - attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts); - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; + case FINALIZED: + bracket--; + attempts = attempts._2; + step = attempt._1; break; - // When we evaluate a Bracket, we also enqueue the instruction so we - // can fullfill it later once we return from the acquisition. - case BRACKET: + // Otherwise we need to run a finalizer, which cannot be interrupted. + // We insert a FINALIZED marker to know when we can release it. + default: bracket++; - if (bhead === null) { - attempts = new Aff(CONS, step, attempts); - } else { - attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); - } - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; - break; + attempts._1 = new Aff(FINALIZED, step); + status = CONTINUE; + step = attempt; } - break; - - case RETURN: - // If the current stack has returned, and we have no other stacks to - // resume or finalizers to run, the fiber has halted and we can - // invoke all join callbacks. Otherwise we need to resume. - if (attempts === null) { - runTick++; // Increment the counter to prevent reentry after completion. - status = COMPLETED; - step = interrupt || fail || step; - } else { - attempt = attempts._1; - switch (attempt.tag) { - // 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._2; - btail = attempt._3; - if (fail === null) { - status = BINDSTEP; - step = fromRight(step); - } else { - status = CONTINUE; - step = attempt._1(fromLeft(fail)); - fail = null; - } - } - break; - - // We cannot resume from an interrupt or exception. - case RESUME: - attempts = attempts._2; - if (interrupt === null && fail === null) { - bhead = attempt._1; - btail = attempt._2; - status = BINDSTEP; - step = fromRight(step); - } - break; - - // If we have a bracket, we should enqueue the finalizer branch, - // and continue with the success branch only if the fiber has - // not been interrupted. If the bracket acquisition failed, we - // should not run either. - case BRACKET: - bracket--; - if (fail === null) { - result = fromRight(step); - attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); - if (interrupt === null || bracket > 0) { - status = CONTINUE; - step = attempt._3(result); - } - } else { - attempts = attempts._2; - } - break; - - case BRACKETED: - bracket++; - attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); - status = CONTINUE; - if (interrupt !== null) { - step = attempt._1.kill(fromLeft(interrupt))(attempt._2); - } else if (fail !== null) { - step = attempt._1.throw(fromLeft(fail))(attempt._2); - } else { - step = attempt._1.release(attempt._2); - } - break; + } + break; - case FINALIZED: - bracket--; - attempts = attempts._2; - step = attempt._1; - break; - - // Otherwise we need to run a finalizer, which cannot be interrupted. - // We insert a FINALIZED marker to know when we can release it. - default: - bracket++; - attempts._1 = new Aff(FINALIZED, step); - status = CONTINUE; - step = attempt; - } + case KILLFORKS: + if (forkCount === 0) { + status = COMPLETED; + } else { + status = CONTINUE; + step = killChildFibers(step); + } + break; + + case COMPLETED: + completeCb(); + tmp = false; + for (var k in joins) { + if ({}.hasOwnProperty.call(joins, k)) { + tmp = true; + runEff(joins[k](step)); } - break; - - case COMPLETED: - tmp = false; - for (var k in joins) { - if ({}.hasOwnProperty.call(joins, k)) { - tmp = true; - runEff(joins[k](step)); + } + joins = tmp; + // If we have an unhandled exception, and no other fiber has joined + // then we need to throw the exception in a fresh stack. + if (util.isLeft(step) && !joins) { + setTimeout(function () { + // Guard on joins because a completely synchronous fiber can + // still have an observer. + if (!joins) { + throw util.fromLeft(step); } - } - joins = tmp; - // If we have an unhandled exception, and no other fiber has joined - // then we need to throw the exception in a fresh stack. - if (isLeft(step) && !joins) { - setTimeout(function () { - // Guard on joins because a completely synchronous fiber can - // still have an observer. - if (!joins) { - throw fromLeft(step); - } - }, 0); - } - return; - case BLOCKED: return; - case PENDING: return; + }, 0); } + return; + case BLOCKED: return; + case PENDING: return; } } + } - function addJoinCallback(cb) { - var jid = joinId++; - joins[jid] = cb; - return function (error) { - return new Aff(SYNC, function () { - delete joins[jid]; - }); - }; - } - - function kill(error) { - return new Aff(ASYNC, function (cb) { - return function () { - // Shadow the canceler binding because it can potentially be - // clobbered if we call `run`. - var canceler; - var killCb = function () { - return cb(right(void 0)); - }; - switch (status) { - case COMPLETED: - canceler = nonCanceler; - killCb()(); - break; - case PENDING: - canceler = addJoinCallback(killCb); - if (interrupt === null) { - interrupt = left(error); - } - // If we can interrupt the pending action, enqueue the canceler as - // a non-interruptible finalizer. - if (bracket === 0) { - attempts = new Aff(CONS, step(error), attempts); - bhead = null; - btail = null; - status = RETURN; - step = null; - fail = null; - run(++runTick); - } - break; - default: - canceler = addJoinCallback(killCb); - if (interrupt === null) { - interrupt = left(error); - } - if (bracket === 0) { - bhead = null; - btail = null; - status = RETURN; - } - } - return canceler; - }; + function addJoinCallback(cb) { + var jid = joinId++; + joins[jid] = cb; + return function (error) { + return new Aff(SYNC, function () { + delete joins[jid]; }); - } + }; + } - function join() { - return new Aff(ASYNC, function (cb) { - return function () { - if (status === COMPLETED) { - joins = true; - cb(step)(); - return nonCanceler; - } - return addJoinCallback(cb); + function kill(error) { + return new Aff(ASYNC, function (cb) { + return function () { + // Shadow the canceler binding because it can potentially be + // clobbered if we call `run`. + var canceler; + var killCb = function () { + return cb(util.right(void 0)); }; - }); - } + if (suspended) { + suspended = false; + status = COMPLETED; + interrupt = util.left(error); + } + switch (status) { + case COMPLETED: + canceler = nonCanceler; + killCb()(); + break; + case PENDING: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = util.left(error); + } + // If we can interrupt the pending action, enqueue the canceler as + // a non-interruptible finalizer. + if (bracket === 0) { + attempts = new Aff(CONS, step(error), attempts); + bhead = null; + btail = null; + status = RETURN; + step = null; + fail = null; + run(++runTick); + } + break; + default: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = util.left(error); + } + if (bracket === 0) { + bhead = null; + btail = null; + status = RETURN; + } + } + return canceler; + }; + }); + } + + function join() { + return new Aff(ASYNC, function (cb) { + return function () { + if (suspended) { + suspended = false; + run(runTick); + } + if (status === COMPLETED) { + joins = true; + cb(step)(); + return nonCanceler; + } + return addJoinCallback(cb); + }; + }); + } + if (suspended === false) { run(runTick); + } - return { - kill: kill, - join: join() - }; + return { + kill: kill, + join: join() + }; +} + +exports._launchAff = function (util, suspended, aff) { + return function () { + return runFiber(util, suspended, aff, function () {}); }; }; -exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff, par) { +exports._sequential = function (util, runAff, par) { function runParAff(cb) { // Table of all forked fibers. var fiberId = 0; @@ -577,7 +675,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var kills = {}; // Error used for early cancelation on Alt branches. - var early = new Error("ParAff early exit"); + var early = new Error("[ParAff] Early exit"); // Error used to kill the entire tree. var interrupt = null; @@ -596,7 +694,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var kills = {}; var tmp, kid; - loop: while (1) { + loop: while (true) { tmp = null; switch (step.tag) { @@ -606,19 +704,19 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff // then we should just remove it from the queue and continue. if (tmp.tag === THUNK) { delete fibers[step._1]; - cb(right(void 0))(); + cb(util.right(void 0))(); } else { // Again, we prime the effect but don't run it yet, so that we can // collect all the fibers first. kills[count++] = runAff(function (result) { return function () { count--; - if (fail === null && isLeft(result)) { + if (fail === null && util.isLeft(result)) { fail = result; } // We can resolve the callback when all fibers have died. if (count === 0) { - cb(fail || right(void 0))(); + cb(fail || util.right(void 0))(); } }; })(tmp._1.kill(error)); @@ -665,7 +763,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff function join(result, head, tail) { var fail, step, lhs, rhs, tmp, kid; - if (isLeft(result)) { + if (util.isLeft(result)) { fail = result; step = null; } else { @@ -673,7 +771,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff fail = null; } - loop: while (1) { + loop: while (true) { lhs = null; rhs = null; tmp = null; @@ -701,7 +799,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff switch (head.tag) { case MAP: if (fail === null) { - head._3 = right(head._1(fromRight(step))); + head._3 = util.right(head._1(util.fromRight(step))); step = head._3; } else { head._3 = fail; @@ -716,18 +814,18 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff } // If either side resolve with an error, we should continue with // the first error. - if (isLeft(lhs)) { - if (isLeft(rhs)) { + if (util.isLeft(lhs)) { + if (util.isLeft(rhs)) { if (step === lhs) { step = rhs; } } else { step = lhs; } - } else if (isLeft(rhs)) { + } else if (util.isLeft(rhs)) { step = rhs; } else { - head._3 = right(fromRight(lhs)(fromRight(rhs))); + head._3 = util.right(util.fromRight(lhs)(util.fromRight(rhs))); step = head._3; } break; @@ -742,7 +840,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff kills[kid] = kill(early, step === lhs ? head._2 : head._1, function (killResult) { return function () { delete kills[kid]; - if (isLeft(killResult)) { + if (util.isLeft(killResult)) { fail = killResult; step = null; } @@ -795,7 +893,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff var tail = null; var tmp, fid; - loop: while (1) { + loop: while (true) { tmp = null; fid = null; @@ -884,7 +982,7 @@ exports._sequential = function (isLeft, fromLeft, fromRight, left, right, runAff // we need to first cancel those joins. This is important so that errors // don't accidentally get swallowed by irrelevant join callbacks. function cancel(error, cb) { - interrupt = left(error); + interrupt = util.left(error); // We can drop the fibers here because we are only canceling join // attempts, which are synchronous anyway. diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index e0f6f02..8092e0e 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -6,9 +6,13 @@ module Control.Monad.Aff , BracketConditions , makeAff , launchAff + , launchSuspendedAff , runAff , runAff_ , forkAff + , suspendAff + , spawnAff + , spawnSuspendedAff , liftEff' , bracket , generalBracket @@ -128,7 +132,7 @@ instance alternativeParAff ∷ Alternative (ParAff e) instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) - sequential a = Fn.runFn7 _sequential isLeft unsafeFromLeft unsafeFromRight Left Right runAff a + sequential a = Fn.runFn3 _sequential ffiUtil runAff a -- | Represents a forked computation by way of `forkAff`. `Fiber`s are -- | memoized, so their results are only computed once. @@ -182,7 +186,11 @@ instance monoidCanceler ∷ Monoid (Canceler eff) where -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) -launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff +launchAff aff = Fn.runFn3 _launchAff ffiUtil false aff + +-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`. +launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) +launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil true aff -- | Forks an `Aff` from an `Eff` context and also takes a callback to run when -- | it completes. Returns the pending `Fiber`. @@ -194,9 +202,25 @@ runAff k aff = launchAff $ liftEff <<< k =<< try aff runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit runAff_ k aff = void $ runAff k aff --- | Forks an `Aff` from within another `Aff` context, returning the `Fiber`. -forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -forkAff = liftEff <<< launchAff +-- | Forks a supervised `Aff` from within a parent `Aff` context, returning the +-- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it +-- | has not completed. +forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +forkAff = _fork false + +-- | Suspends a supervised `Aff` from within a parent `Aff` context, returning +-- | the `Fiber`. A suspended `Fiber` does not execute until requested, via +-- | `joinFiber`. +suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +suspendAff = _fork true + +-- | Forks an unsupervised `Aff`, returning the `Fiber`. +spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +spawnAff = liftEff <<< launchAff + +-- | Suspends an unsupervised `Aff`, returning the `Fiber`. +spawnSuspendedAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +spawnSuspendedAff = liftEff <<< launchSuspendedAff -- | Pauses the running fiber. delay ∷ ∀ eff. Milliseconds → Aff eff Unit @@ -216,12 +240,6 @@ finally fin a = bracket (pure unit) (const fin) (const a) atomically ∷ ∀ eff a. Aff eff a → Aff eff a atomically a = bracket a (const (pure unit)) pure -type BracketConditions eff a = - { kill ∷ Error → a → Aff eff Unit - , throw ∷ Error → a → Aff eff Unit - , release ∷ a → Aff eff Unit - } - -- | Guarantees resource acquisition and cleanup. The first effect may acquire -- | some resource, while the second will dispose of it. The third effect makes -- | use of the resource. Disposal is always run last, regardless. Neither @@ -238,6 +256,7 @@ bracket acquire release = 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 _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber 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) @@ -245,6 +264,14 @@ foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a + +type BracketConditions eff a = + { kill ∷ Error → a → Aff eff Unit + , throw ∷ Error → a → Aff eff Unit + , release ∷ a → Aff eff Unit + } + +-- | A general purpose bracket foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b -- | Constructs an `Aff` from low-level `Eff` effects using a callback. A @@ -259,33 +286,43 @@ foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a foreign import _launchAff ∷ ∀ eff a - . Fn.Fn6 - (Either Error a → Boolean) - (Either Error a → Error) - (Either Error a → a) - (Error → Either Error a) - (a → Either Error a) + . Fn.Fn3 + FFIUtil + Boolean (Aff eff a) (Eff eff (Fiber eff a)) foreign import _sequential ∷ ∀ eff a - . Fn.Fn7 - (Either Error a → Boolean) - (Either Error a → Error) - (Either Error a → a) - (Error → Either Error a) - (a → Either Error a) + . Fn.Fn3 + FFIUtil ((Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)) (ParAff eff a) (Aff eff a) -unsafeFromLeft ∷ ∀ x y. Either x y → x -unsafeFromLeft = case _ of - Left a → a - Right _ → unsafeCrashWith "unsafeFromLeft: Right" +newtype FFIUtil = FFIUtil + { isLeft ∷ ∀ a b. Either a b → Boolean + , fromLeft ∷ ∀ a b. Either a b → a + , fromRight ∷ ∀ a b. Either a b → b + , left ∷ ∀ a b. a → Either a b + , right ∷ ∀ a b. b → Either a b + } -unsafeFromRight ∷ ∀ x y. Either x y → y -unsafeFromRight = case _ of - Right a → a - Left _ → unsafeCrashWith "unsafeFromRight: Left" +ffiUtil ∷ FFIUtil +ffiUtil = FFIUtil + { isLeft + , fromLeft: unsafeFromLeft + , fromRight: unsafeFromRight + , left: Left + , right: Right + } + where + unsafeFromLeft ∷ ∀ a b. Either a b → a + unsafeFromLeft = case _ of + Left a → a + Right _ → unsafeCrashWith "unsafeFromLeft: Right" + + unsafeFromRight ∷ ∀ a b. Either a b → b + unsafeFromRight = case _ of + Right a → a + Left _ → unsafeCrashWith "unsafeFromRight: Left" diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 82987e2..c316707 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,7 +2,7 @@ module Test.Main where import Prelude import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, joinFiber, killFiber) +import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -96,24 +96,24 @@ test_delay = assert "delay" do test_fork ∷ ∀ eff. TestAff eff Unit test_fork = assert "fork" do - ref ← newRef 0 + ref ← newRef "" fiber ← forkAff do delay (Milliseconds 10.0) - modifyRef ref (_ + 1) - writeRef ref 42 + modifyRef ref (_ <> "child") + modifyRef ref (_ <> "go") delay (Milliseconds 20.0) - modifyRef ref (_ - 3) - eq 40 <$> readRef ref + modifyRef ref (_ <> "parent") + eq "gochildparent" <$> readRef ref test_join ∷ ∀ eff. TestAff eff Unit test_join = assert "join" do - ref ← newRef 1 + ref ← newRef "" fiber ← forkAff do delay (Milliseconds 10.0) - modifyRef ref (_ - 2) + modifyRef ref (_ <> "child") readRef ref - writeRef ref 42 - eq 40 <$> joinFiber fiber + modifyRef ref (_ <> "parent") + eq "parentchild" <$> joinFiber fiber test_join_throw ∷ ∀ eff. TestAff eff Unit test_join_throw = assert "join/throw" do @@ -147,6 +147,18 @@ test_multi_join = assert "join/multi" do n2 ← readRef ref pure (n1 == 50 && n2 == 3) +test_suspend ∷ ∀ eff. TestAff eff Unit +test_suspend = assert "suspend" do + ref ← newRef "" + fiber ← suspendAff do + delay (Milliseconds 10.0) + modifyRef ref (_ <> "child") + modifyRef ref (_ <> "go") + delay (Milliseconds 20.0) + modifyRef ref (_ <> "parent") + _ ← joinFiber fiber + eq "goparentchild" <$> readRef ref + test_makeAff ∷ ∀ eff. TestAff eff Unit test_makeAff = assert "makeAff" do ref1 ← newRef Nothing @@ -249,14 +261,14 @@ test_kill = assert "kill" do test_kill_canceler ∷ ∀ eff. TestAff eff Unit test_kill_canceler = assert "kill/canceler" do - ref ← newRef 0 + ref ← newRef "" fiber ← forkAff do - n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref 42)) - writeRef ref 2 + n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref "cancel")) + writeRef ref "done" killFiber (error "Nope") fiber res ← try (joinFiber fiber) n ← readRef ref - pure (n == 42 && (lmap message res) == Left "Nope") + pure (n == "cancel" && (lmap message res) == Left "Nope") test_kill_bracket ∷ ∀ eff. TestAff eff Unit test_kill_bracket = assert "kill/bracket" do @@ -303,6 +315,27 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do , "foo/bar/run/release/bar/release" ] +-- You monster!! +test_kill_child ∷ ∀ eff. TestAff eff Unit +test_kill_child = assert "kill/child" do + ref ← newRef "" + let + action s = generalBracket + (modifyRef ref (_ <> "acquire" <> s)) + { throw: \_ _ → modifyRef ref (_ <> "throw" <> s) + , kill: \_ _ → modifyRef ref (_ <> "kill" <> s) + , release: \_ → modifyRef ref (_ <> "complete" <> s) + } + (\_ -> do + delay (Milliseconds 10.0) + modifyRef ref (_ <> "child" <> s)) + fiber ← forkAff do + _ ← forkAff $ action "foo" + _ ← forkAff $ action "bar" + modifyRef ref (_ <> "parent") + delay (Milliseconds 20.0) + eq "acquirefooacquirebarparentkillfookillbar" <$> readRef ref + test_parallel ∷ ∀ eff. TestAff eff Unit test_parallel = assert "parallel" do ref ← newRef "" @@ -451,6 +484,7 @@ main = do test_join_throw test_join_throw_sync test_multi_join + test_suspend test_makeAff test_bracket test_bracket_nested @@ -459,6 +493,7 @@ main = do test_kill_canceler test_kill_bracket test_kill_bracket_nested + test_kill_child test_parallel test_kill_parallel test_parallel_alt From 1b7a692d5a469b2dc08c2e2ca750e31d87244142 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 8 Aug 2017 16:16:48 -0700 Subject: [PATCH 19/35] Rename bracket condition labels --- src/Control/Monad/Aff.js | 6 +++--- src/Control/Monad/Aff.purs | 14 +++++++------- test/Test/Main.purs | 12 ++++++------ 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 63ee908..39c49b8 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -507,11 +507,11 @@ function runFiber(util, suspended, aff, completeCb) { attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); status = CONTINUE; if (interrupt !== null) { - step = attempt._1.kill(util.fromLeft(interrupt))(attempt._2); + step = attempt._1.killed(util.fromLeft(interrupt))(attempt._2); } else if (fail !== null) { - step = attempt._1.throw(util.fromLeft(fail))(attempt._2); + step = attempt._1.failed(util.fromLeft(fail))(attempt._2); } else { - step = attempt._1.release(attempt._2); + step = attempt._1.completed(attempt._2); } break; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 8092e0e..4f73f77 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -246,11 +246,11 @@ atomically a = bracket a (const (pure unit)) pure -- | acquisition nor disposal may be cancelled and are guaranteed to run until -- | they complete. bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b -bracket acquire release = +bracket acquire completed = generalBracket acquire - { kill: const release - , throw: const release - , release + { killed: const completed + , failed: const completed + , completed } foreign import _pure ∷ ∀ eff a. a → Aff eff a @@ -266,9 +266,9 @@ foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a type BracketConditions eff a = - { kill ∷ Error → a → Aff eff Unit - , throw ∷ Error → a → Aff eff Unit - , release ∷ a → Aff eff Unit + { killed ∷ Error → a → Aff eff Unit + , failed ∷ Error → a → Aff eff Unit + , completed ∷ a → Aff eff Unit } -- | A general purpose bracket diff --git a/test/Test/Main.purs b/test/Test/Main.purs index c316707..df27dcc 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -235,9 +235,9 @@ test_general_bracket = assert "bracket/general" do pure s bracketAction s = generalBracket (action s) - { kill: \error s' → void $ action (s' <> "/kill/" <> message error) - , throw: \error s' → void $ action (s' <> "/throw/" <> message error) - , release: \s' → void $ action (s' <> "/release") + { killed: \error s' → void $ action (s' <> "/kill/" <> message error) + , failed: \error s' → void $ action (s' <> "/throw/" <> message error) + , completed: \s' → void $ action (s' <> "/release") } f1 ← forkAff $ bracketAction "foo" (const (action "a")) @@ -322,9 +322,9 @@ test_kill_child = assert "kill/child" do let action s = generalBracket (modifyRef ref (_ <> "acquire" <> s)) - { throw: \_ _ → modifyRef ref (_ <> "throw" <> s) - , kill: \_ _ → modifyRef ref (_ <> "kill" <> s) - , release: \_ → modifyRef ref (_ <> "complete" <> s) + { failed: \_ _ → modifyRef ref (_ <> "throw" <> s) + , killed: \_ _ → modifyRef ref (_ <> "kill" <> s) + , completed: \_ → modifyRef ref (_ <> "complete" <> s) } (\_ -> do delay (Milliseconds 10.0) From 339193825e43b4aaf63e711bf59e70d0e8b5a35b Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 8 Aug 2017 21:28:18 -0700 Subject: [PATCH 20/35] Use runFiber in sequential --- src/Control/Monad/Aff.js | 48 +++++++++++++++++++------------------- src/Control/Monad/Aff.purs | 5 ++-- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 39c49b8..f58fd07 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -542,7 +542,7 @@ function runFiber(util, suspended, aff, completeCb) { break; case COMPLETED: - completeCb(); + completeCb(step); tmp = false; for (var k in joins) { if ({}.hasOwnProperty.call(joins, k)) { @@ -664,7 +664,7 @@ exports._launchAff = function (util, suspended, aff) { }; }; -exports._sequential = function (util, runAff, par) { +exports._sequential = function (util, par) { function runParAff(cb) { // Table of all forked fibers. var fiberId = 0; @@ -708,18 +708,20 @@ exports._sequential = function (util, runAff, par) { } else { // Again, we prime the effect but don't run it yet, so that we can // collect all the fibers first. - kills[count++] = runAff(function (result) { + kills[count++] = function (aff) { return function () { - count--; - if (fail === null && util.isLeft(result)) { - fail = result; - } - // We can resolve the callback when all fibers have died. - if (count === 0) { - cb(fail || util.right(void 0))(); - } + return runFiber(util, false, aff, function (result) { + count--; + if (fail === null && util.isLeft(result)) { + fail = result; + } + // We can resolve the callback when all fibers have died. + if (count === 0) { + cb(fail || util.right(void 0))(); + } + }); }; - })(tmp._1.kill(error)); + }(tmp._1.kill(error)); } // Terminal case. if (head === null) { @@ -872,11 +874,9 @@ exports._sequential = function (util, runAff, par) { function resolve(fiber) { return function (result) { - return function () { - delete fibers[fiber._1]; - fiber._3 = result; - join(result, fiber._2._1, fiber._2._2); - }; + delete fibers[fiber._1]; + fiber._3 = result; + join(result, fiber._2._1, fiber._2._2); }; } @@ -933,7 +933,11 @@ exports._sequential = function (util, runAff, par) { // because they may all be synchronous and resolve immediately, at // which point it would attempt to resolve against an incomplete // tree. - fibers[fid] = new Aff(THUNK, runAff(resolve(step))(tmp)); + fibers[fid] = function (aff, completeCb) { + return new Aff(THUNK, function () { + return runFiber(util, false, aff, completeCb); + }); + }(tmp, resolve(step)); } break; case RETURN: @@ -974,10 +978,6 @@ exports._sequential = function (util, runAff, par) { } } - function ignore () { - return function () {}; - } - // Cancels the entire tree. If there are already subtrees being canceled, // we need to first cancel those joins. This is important so that errors // don't accidentally get swallowed by irrelevant join callbacks. @@ -987,7 +987,7 @@ exports._sequential = function (util, runAff, par) { // We can drop the fibers here because we are only canceling join // attempts, which are synchronous anyway. for (var kid = 0, n = killId; kid < n; kid++) { - runAff(ignore, kills[kid].kill(error))(); + runFiber(util, false, kills[kid].kill(error), function () {}); } var newKills = kill(error, root, cb); @@ -997,7 +997,7 @@ exports._sequential = function (util, runAff, par) { return function () { for (var kid in newKills) { if (newKills.hasOwnProperty(kid)) { - runAff(ignore, newKills[kid].kill(killError))(); + runFiber(util, false, newKills[kid].kill(killError), function () {}); } } return nonCanceler; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 4f73f77..c98d042 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -132,7 +132,7 @@ instance alternativeParAff ∷ Alternative (ParAff e) instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) - sequential a = Fn.runFn3 _sequential ffiUtil runAff a + sequential a = Fn.runFn2 _sequential ffiUtil a -- | Represents a forked computation by way of `forkAff`. `Fiber`s are -- | memoized, so their results are only computed once. @@ -294,9 +294,8 @@ foreign import _launchAff foreign import _sequential ∷ ∀ eff a - . Fn.Fn3 + . Fn.Fn2 FFIUtil - ((Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)) (ParAff eff a) (Aff eff a) From 5320f7eabfc161c483d9b021cc633346a029dbfc Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 9 Aug 2017 12:35:33 -0700 Subject: [PATCH 21/35] Add never Aff. --- src/Control/Monad/Aff.purs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index c98d042..1988756 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -17,6 +17,7 @@ module Control.Monad.Aff , bracket , generalBracket , delay + , never , finally , atomically , killFiber @@ -226,6 +227,10 @@ spawnSuspendedAff = liftEff <<< launchSuspendedAff delay ∷ ∀ eff. Milliseconds → Aff eff Unit delay (Milliseconds n) = Fn.runFn2 _delay Right n +-- | An async computation which does not resolve. +never ∷ ∀ eff a. Aff eff a +never = makeAff \_ → pure mempty + -- | All `Eff` exceptions are implicitly caught within an `Aff` context, but -- | standard `liftEff` won't remove the effect label. liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a @@ -271,7 +276,9 @@ type BracketConditions eff a = , completed ∷ a → Aff eff Unit } --- | A general purpose bracket +-- | A general purpose bracket which lets you observe the status of the +-- | bracketed action. The bracketed action may have been killed with an +-- | exception, thrown an exception, or completed successfully. foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b -- | Constructs an `Aff` from low-level `Eff` effects using a callback. A From 4f04c8a0256c25161dc960a840fa75ebedd3272f Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 9 Aug 2017 20:54:11 -0700 Subject: [PATCH 22/35] Provide result to bracket completed --- src/Control/Monad/Aff.js | 2 +- src/Control/Monad/Aff.purs | 8 ++++---- test/Test/Main.purs | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index f58fd07..6b693a4 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -511,7 +511,7 @@ function runFiber(util, suspended, aff, completeCb) { } else if (fail !== null) { step = attempt._1.failed(util.fromLeft(fail))(attempt._2); } else { - step = attempt._1.completed(attempt._2); + step = attempt._1.completed(util.fromRight(step))(attempt._2); } break; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 1988756..f5510cc 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -255,7 +255,7 @@ bracket acquire completed = generalBracket acquire { killed: const completed , failed: const completed - , completed + , completed: const completed } foreign import _pure ∷ ∀ eff a. a → Aff eff a @@ -270,16 +270,16 @@ foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a -type BracketConditions eff a = +type BracketConditions eff a b = { killed ∷ Error → a → Aff eff Unit , failed ∷ Error → a → Aff eff Unit - , completed ∷ a → Aff eff Unit + , completed ∷ b → a → Aff eff Unit } -- | A general purpose bracket which lets you observe the status of the -- | bracketed action. The bracketed action may have been killed with an -- | exception, thrown an exception, or completed successfully. -foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b +foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b -- | Constructs an `Aff` from low-level `Eff` effects using a callback. A -- | `Canceler` effect should be returned to cancel the pending action. The diff --git a/test/Test/Main.purs b/test/Test/Main.purs index df27dcc..1f747ca 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -237,7 +237,7 @@ test_general_bracket = assert "bracket/general" do generalBracket (action s) { killed: \error s' → void $ action (s' <> "/kill/" <> message error) , failed: \error s' → void $ action (s' <> "/throw/" <> message error) - , completed: \s' → void $ action (s' <> "/release") + , completed: \r s' → void $ action (s' <> "/release/" <> r) } f1 ← forkAff $ bracketAction "foo" (const (action "a")) @@ -251,7 +251,7 @@ test_general_bracket = assert "bracket/general" do r3 ← try $ joinFiber f3 r4 ← readRef ref - pure (isLeft r1 && isLeft r2 && isRight r3 && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release") + pure (isLeft r1 && isLeft r2 && isRight r3 && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release/c") test_kill ∷ ∀ eff. TestAff eff Unit test_kill = assert "kill" do @@ -324,7 +324,7 @@ test_kill_child = assert "kill/child" do (modifyRef ref (_ <> "acquire" <> s)) { failed: \_ _ → modifyRef ref (_ <> "throw" <> s) , killed: \_ _ → modifyRef ref (_ <> "kill" <> s) - , completed: \_ → modifyRef ref (_ <> "complete" <> s) + , completed: \_ _ → modifyRef ref (_ <> "complete" <> s) } (\_ -> do delay (Milliseconds 10.0) From ffc0b6fcc73f41147473783bb04ea3953605fdf7 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 10 Aug 2017 22:26:13 -0700 Subject: [PATCH 23/35] Make FFI amenable to purs-bundling --- src/Control/Monad/Aff.js | 1200 ++++++++++++++++++------------------ src/Control/Monad/Aff.purs | 7 +- test/Test/Main.purs | 1 + 3 files changed, 614 insertions(+), 594 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 6b693a4..c700d5a 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -2,637 +2,525 @@ /* jshint -W083, -W098 */ "use strict"; -// A unique value for empty. -var EMPTY = {}; - -/* - -An awkward approximation. We elide evidence we would otherwise need in PS for -efficiency sake. - -data Aff eff a - = Pure a - | Throw Error - | Catch (Aff eff a) (Error -> Aff eff a) - | Sync (Eff eff a) - | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) - | forall b. Bind (Aff eff b) (b -> Aff eff a) - | forall b. Bracket (Aff eff b) (BracketConditions eff b) (b -> Aff eff a) - | forall b. Fork Boolean (Aff eff b) ?(Thread eff b -> a) - -*/ -var PURE = "Pure"; -var THROW = "Throw"; -var CATCH = "Catch"; -var SYNC = "Sync"; -var ASYNC = "Async"; -var BIND = "Bind"; -var BRACKET = "Bracket"; -var FORK = "Fork"; - -/* - -data ParAff eff a - = forall b. Map (b -> a) (ParAff eff b) - | forall b. Apply (ParAff eff (b -> a)) (ParAff eff b) - | Alt (ParAff eff a) (ParAff eff a) - | ?Par (Aff eff a) - -*/ -var MAP = "Map"; -var APPLY = "Apply"; -var ALT = "Alt"; - -// Various constructors used in interpretation -var CONS = "Cons"; // Cons-list, for stacks -var RECOVER = "Recover"; // Continue with error handler -var RESUME = "Resume"; // Continue indiscriminately -var BRACKETED = "Bracketed"; // Continue with bracket finalizers -var FINALIZED = "Finalized"; // Marker for finalization - -var FORKED = "Forked"; // Reference to a forked fiber, with resumption stack -var FIBER = "Fiber"; // Actual fiber reference -var THUNK = "Thunk"; // Primed effect, ready to invoke - -function Aff(tag, _1, _2, _3) { - this.tag = tag; - this._1 = _1; - this._2 = _2; - this._3 = _3; -} - -var nonCanceler = function (error) { - return new Aff(PURE, void 0); -}; - -exports._pure = function (a) { - return new Aff(PURE, a); -}; - -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) { - return new Aff(PURE, f(aff._1)); - } else { - return new Aff(BIND, aff, function (value) { - return new Aff(PURE, f(value)); - }); - } - }; -}; - -exports._bind = function (aff) { - return function (k) { - return new Aff(BIND, aff, k); - }; -}; - -exports._fork = function (suspended) { - return function (aff) { - return new Aff(FORK, suspended, aff); - }; -}; - -exports._liftEff = function (eff) { - return new Aff(SYNC, eff); -}; - -exports._parAffMap = function (f) { - return function (aff) { - return new Aff(MAP, f, aff); - }; -}; - -exports._parAffApply = function (aff1) { - return function (aff2) { - return new Aff(APPLY, aff1, aff2); - }; -}; - -exports._parAffAlt = function (aff1) { - return function (aff2) { - return new Aff(ALT, aff1, aff2); - }; -}; - -exports.makeAff = function (k) { - return new Aff(ASYNC, k); -}; +var Aff = function () { + // A unique value for empty. + var EMPTY = {}; + + /* + + An awkward approximation. We elide evidence we would otherwise need in PS for + efficiency sake. + + data Aff eff a + = Pure a + | Throw Error + | Catch (Aff eff a) (Error -> Aff eff a) + | Sync (Eff eff a) + | Async ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) + | forall b. Bind (Aff eff b) (b -> Aff eff a) + | forall b. Bracket (Aff eff b) (BracketConditions eff b) (b -> Aff eff a) + | forall b. Fork Boolean (Aff eff b) ?(Thread eff b -> a) + + */ + var PURE = "Pure"; + var THROW = "Throw"; + var CATCH = "Catch"; + var SYNC = "Sync"; + var ASYNC = "Async"; + var BIND = "Bind"; + var BRACKET = "Bracket"; + var FORK = "Fork"; + + /* + + data ParAff eff a + = forall b. Map (b -> a) (ParAff eff b) + | forall b. Apply (ParAff eff (b -> a)) (ParAff eff b) + | Alt (ParAff eff a) (ParAff eff a) + | ?Par (Aff eff a) + + */ + var MAP = "Map"; + var APPLY = "Apply"; + var ALT = "Alt"; + + // Various constructors used in interpretation + var CONS = "Cons"; // Cons-list, for stacks + var RECOVER = "Recover"; // Continue with error handler + var RESUME = "Resume"; // Continue indiscriminately + var BRACKETED = "Bracketed"; // Continue with bracket finalizers + var FINALIZED = "Finalized"; // Marker for finalization + var FORKED = "Forked"; // Reference to a forked fiber, with resumption stack + var FIBER = "Fiber"; // Actual fiber reference + var THUNK = "Thunk"; // Primed effect, ready to invoke + + function Aff(tag, _1, _2, _3) { + this.tag = tag; + this._1 = _1; + this._2 = _2; + this._3 = _3; + } -exports.generalBracket = function (acquire) { - return function (options) { - return function (k) { - return new Aff(BRACKET, acquire, options, k); + function AffCtr(tag) { + return function (_1, _2, _3) { + return new Aff(tag, _1, _2, _3); }; - }; -}; + } -exports.memoAff = function (aff) { - var value = EMPTY; - return new Aff(BIND, new Aff(PURE, void 0), function () { - if (value === EMPTY) { - return new Aff(BIND, aff, function (result) { - value = new Aff(PURE, result); - return value; - }); - } else { - return value; - } - }); -}; + function nonCanceler(error) { + return new Aff(PURE, void 0); + }; -exports._delay = function () { - function setDelay(n, k) { - if (n === 0 && typeof setImmediate !== "undefined") { - return setImmediate(k); - } else { - return setTimeout(k, n); + function runEff(eff) { + try { + eff(); + } catch (error) { + setTimeout(function () { + throw error; + }, 0); } } - function clearDelay(n, t) { - if (n === 0 && typeof clearImmediate !== "undefined") { - return clearImmediate(t); - } else { - return clearTimeout(t); + function runSync(left, right, eff) { + try { + return right(eff()); + } catch (error) { + return left(error); } } - return function (right, ms) { - return new Aff(ASYNC, function (cb) { - return function () { - var timer = setDelay(ms, cb(right())); - return function () { - return new Aff(SYNC, function () { - return right(clearDelay(ms, timer)); - }); - }; - }; - }); - }; -}(); - -function runEff(eff) { - try { - eff(); - } catch (error) { - setTimeout(function () { - throw error; - }, 0); + function runAsync(left, eff, k) { + try { + return eff(k)(); + } catch (error) { + k(left(error))(); + return nonCanceler; + } } -} -function runSync(left, right, eff) { - try { - return right(eff()); - } catch (error) { - return left(error); - } -} - -function runAsync(left, eff, k) { - try { - return eff(k)(); - } catch (error) { - k(left(error))(); - return nonCanceler; - } -} - -// Fiber state machine -var BLOCKED = 0; // No effect is running. -var PENDING = 1; // An async effect is running. -var RETURN = 2; // The current stack has returned. -var CONTINUE = 3; // Run the next effect. -var BINDSTEP = 4; // Apply the next bind. -var KILLFORKS = 5; // Killing supervised forks. -var COMPLETED = 6; // The entire fiber has completed. - -function runFiber(util, suspended, aff, completeCb) { - // Monotonically increasing tick, increased on each asynchronous turn. - var runTick = 0; - - // The current branch of the state machine. - var status = CONTINUE; - - // The current point of interest for the state machine branch. - var step = aff; // Successful step - var fail = null; // Failure step - var interrupt = null; // Asynchronous interrupt - - // Stack of continuations for the current fiber. - var bhead = null; - var btail = null; - - // Stack of attempts and finalizers for error recovery. This holds a union - // of an arbitrary Aff finalizer or a Cons list of bind continuations. - var attempts = null; - - // A special state is needed for Bracket, because it cannot be killed. When - // we enter a bracket acquisition or finalizer, we increment the counter, - // and then decrement once complete. - var bracket = 0; - - // Each join gets a new id so they can be revoked. - var joinId = 0; - var joins = {}; - - // Track child forks so they don't outlive the parent thread. - var forkCount = 0; - var forkId = 0; - var forks = {}; - - // Temporary bindings for the various branches. - var tmp, result, attempt, canceler; - - function launchChildFiber(fid, suspended, child) { - forkCount++; - var blocked = true; - var fiber = runFiber(util, suspended, child, function () { - forkCount--; + // Fiber state machine + var BLOCKED = 0; // No effect is running. + var PENDING = 1; // An async effect is running. + var RETURN = 2; // The current stack has returned. + var CONTINUE = 3; // Run the next effect. + var BINDSTEP = 4; // Apply the next bind. + var KILLFORKS = 5; // Killing supervised forks. + var COMPLETED = 6; // The entire fiber has completed. + + function runFiber(util, suspended, aff, completeCb) { + // Monotonically increasing tick, increased on each asynchronous turn. + var runTick = 0; + + // The current branch of the state machine. + var status = CONTINUE; + + // The current point of interest for the state machine branch. + var step = aff; // Successful step + var fail = null; // Failure step + var interrupt = null; // Asynchronous interrupt + + // Stack of continuations for the current fiber. + var bhead = null; + var btail = null; + + // Stack of attempts and finalizers for error recovery. This holds a union + // of an arbitrary Aff finalizer or a Cons list of bind continuations. + var attempts = null; + + // A special state is needed for Bracket, because it cannot be killed. When + // we enter a bracket acquisition or finalizer, we increment the counter, + // and then decrement once complete. + var bracket = 0; + + // Each join gets a new id so they can be revoked. + var joinId = 0; + var joins = {}; + + // Track child forks so they don't outlive the parent thread. + var forkCount = 0; + var forkId = 0; + var forks = {}; + + // Temporary bindings for the various branches. + var tmp, result, attempt, canceler; + + function launchChildFiber(fid, suspended, child) { + forkCount++; + var blocked = true; + var fiber = runFiber(util, suspended, child, function () { + forkCount--; + if (blocked) { + blocked = false; + } else { + delete forks[fid]; + } + }); if (blocked) { blocked = false; - } else { - delete forks[fid]; + forks[fid] = fiber; } - }); - if (blocked) { - blocked = false; - forks[fid] = fiber; + return fiber; } - return fiber; - } - function killChildFibers(finalStep) { - return new Aff(ASYNC, function (cb) { - return function () { - var killError = new Error("[Aff] Child fiber outlived parent"); - var killId = 0; - var kills = {}; - for (var k in forks) { - if (forks.hasOwnProperty(k)) { - kills[killId++] = forks[k].kill(killError); - } - } - forks = {}; - forkCount = 0; - for (var i = 0, len = killId; i < len; i++) { - kills[i] = runFiber(util, false, kills[i], function () { - delete kills[i]; - killId--; - if (killId === 0) { - cb(finalStep)(); - } - }); - } - return function (error) { - return new Aff(SYNC, function () { - for (var k in kills) { - if (kills.hasOwnProperty(k)) { - runFiber(util, false, kills[k].kill(error), function () {}); - } + function killChildFibers(finalStep) { + return new Aff(ASYNC, function (cb) { + return function () { + var killError = new Error("[Aff] Child fiber outlived parent"); + var killId = 0; + var kills = {}; + for (var k in forks) { + if (forks.hasOwnProperty(k)) { + kills[killId++] = forks[k].kill(killError); } - }); - }; - }; - }); - } - - // Each invocation of `run` requires a tick. When an asynchronous effect is - // resolved, we must check that the local tick coincides with the fiber - // tick before resuming. This prevents multiple async continuations from - // accidentally resuming the same fiber. A common example may be invoking - // the provided callback in `makeAff` more than once, but it may also be an - // async effect resuming after the fiber was already cancelled. - function run(localRunTick) { - while (true) { - tmp = null; - result = null; - attempt = null; - canceler = null; - switch (status) { - case BINDSTEP: - status = CONTINUE; - step = bhead(step); - if (btail === null) { - bhead = null; - } else { - bhead = btail._1; - btail = btail._2; - } - break; - - case CONTINUE: - switch (step.tag) { - case BIND: - if (bhead) { - btail = new Aff(CONS, bhead, btail); } - bhead = step._2; - status = CONTINUE; - step = step._1; - break; - - case PURE: - if (bhead === null) { - status = RETURN; - step = util.right(step._1); - } else { - status = BINDSTEP; - step = step._1; - } - break; - - case THROW: - bhead = null; - btail = null; - status = RETURN; - fail = util.left(step._1); - break; - - case SYNC: - status = BLOCKED; - result = runSync(util.left, util.right, step._1); - if (util.isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = util.fromRight(result); - } - break; - - case ASYNC: - status = BLOCKED; - canceler = runAsync(util.left, step._1, function (result) { - return function () { - if (runTick !== localRunTick) { - return; + forks = {}; + forkCount = 0; + for (var i = 0, len = killId; i < len; i++) { + kills[i] = runFiber(util, false, kills[i], function () { + delete kills[i]; + killId--; + if (killId === 0) { + cb(finalStep)(); } - tmp = status; - if (util.isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = util.fromRight(result); - } - // We only need to invoke `run` if the subsequent block has - // switch the status to PENDING. Otherwise the callback was - // resolved synchronously, and the current loop can continue - // normally. - if (tmp === PENDING) { - run(++runTick); - } else { - localRunTick = ++runTick; - } - }; - }); - // If the callback was resolved synchronously, the status will have - // switched to CONTINUE, and we should not move on to PENDING. - if (status === BLOCKED) { - status = PENDING; - step = canceler; + }); } - break; - - // Enqueue the current stack of binds and continue - case CATCH: - attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts); - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; - break; + return function (error) { + return new Aff(SYNC, function () { + for (var k in kills) { + if (kills.hasOwnProperty(k)) { + runFiber(util, false, kills[k].kill(error), function () {}); + } + } + }); + }; + }; + }); + } - // When we evaluate a Bracket, we also enqueue the instruction so we - // can fullfill it later once we return from the acquisition. - case BRACKET: - bracket++; - if (bhead === null) { - attempts = new Aff(CONS, step, attempts); + // Each invocation of `run` requires a tick. When an asynchronous effect is + // resolved, we must check that the local tick coincides with the fiber + // tick before resuming. This prevents multiple async continuations from + // accidentally resuming the same fiber. A common example may be invoking + // the provided callback in `makeAff` more than once, but it may also be an + // async effect resuming after the fiber was already cancelled. + function run(localRunTick) { + while (true) { + tmp = null; + result = null; + attempt = null; + canceler = null; + switch (status) { + case BINDSTEP: + status = CONTINUE; + step = bhead(step); + if (btail === null) { + bhead = null; } else { - attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); + bhead = btail._1; + btail = btail._2; } - bhead = null; - btail = null; - status = CONTINUE; - step = step._1; break; - case FORK: - status = BINDSTEP; - step = launchChildFiber(forkId++, step._1, step._2); - break; - } - break; - - case RETURN: - // If the current stack has returned, and we have no other stacks to - // resume or finalizers to run, the fiber has halted and we can - // invoke all join callbacks. Otherwise we need to resume. - if (attempts === null) { - runTick++; // Increment the counter to prevent reentry after completion. - status = KILLFORKS; - step = interrupt || fail || step; - } else { - attempt = attempts._1; - switch (attempt.tag) { - // 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._2; - btail = attempt._3; - if (fail === null) { - status = BINDSTEP; - step = util.fromRight(step); - } else { - status = CONTINUE; - step = attempt._1(util.fromLeft(fail)); - fail = null; - } + case CONTINUE: + switch (step.tag) { + case BIND: + if (bhead) { + btail = new Aff(CONS, bhead, btail); } + bhead = step._2; + status = CONTINUE; + step = step._1; break; - // We cannot resume from an interrupt or exception. - case RESUME: - attempts = attempts._2; - if (interrupt === null && fail === null) { - bhead = attempt._1; - btail = attempt._2; + case PURE: + if (bhead === null) { + status = RETURN; + step = util.right(step._1); + } else { status = BINDSTEP; - step = util.fromRight(step); + step = step._1; } break; - // If we have a bracket, we should enqueue the finalizer branch, - // and continue with the success branch only if the fiber has - // not been interrupted. If the bracket acquisition failed, we - // should not run either. - case BRACKET: - bracket--; - if (fail === null) { - result = util.fromRight(step); - attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); - if (interrupt === null || bracket > 0) { - status = CONTINUE; - step = attempt._3(result); - } + case THROW: + bhead = null; + btail = null; + status = RETURN; + fail = util.left(step._1); + break; + + case SYNC: + status = BLOCKED; + result = runSync(util.left, util.right, step._1); + if (util.isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; } else { - attempts = attempts._2; + status = BINDSTEP; + step = util.fromRight(result); } break; - case BRACKETED: - bracket++; - attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); + case ASYNC: + status = BLOCKED; + canceler = runAsync(util.left, step._1, function (result) { + return function () { + if (runTick !== localRunTick) { + return; + } + tmp = status; + if (util.isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = util.fromRight(result); + } + // We only need to invoke `run` if the subsequent block has + // switch the status to PENDING. Otherwise the callback was + // resolved synchronously, and the current loop can continue + // normally. + if (tmp === PENDING) { + run(++runTick); + } else { + localRunTick = ++runTick; + } + }; + }); + // If the callback was resolved synchronously, the status will have + // switched to CONTINUE, and we should not move on to PENDING. + if (status === BLOCKED) { + status = PENDING; + step = canceler; + } + break; + + // Enqueue the current stack of binds and continue + case CATCH: + attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts); + bhead = null; + btail = null; status = CONTINUE; - if (interrupt !== null) { - step = attempt._1.killed(util.fromLeft(interrupt))(attempt._2); - } else if (fail !== null) { - step = attempt._1.failed(util.fromLeft(fail))(attempt._2); + step = step._1; + break; + + // When we evaluate a Bracket, we also enqueue the instruction so we + // can fullfill it later once we return from the acquisition. + case BRACKET: + bracket++; + if (bhead === null) { + attempts = new Aff(CONS, step, attempts); } else { - step = attempt._1.completed(util.fromRight(step))(attempt._2); + attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); } + bhead = null; + btail = null; + status = CONTINUE; + step = step._1; break; - case FINALIZED: - bracket--; - attempts = attempts._2; - step = attempt._1; + case FORK: + status = BINDSTEP; + step = launchChildFiber(forkId++, step._1, step._2); break; + } + break; - // Otherwise we need to run a finalizer, which cannot be interrupted. - // We insert a FINALIZED marker to know when we can release it. - default: - bracket++; - attempts._1 = new Aff(FINALIZED, step); - status = CONTINUE; - step = attempt; + case RETURN: + // If the current stack has returned, and we have no other stacks to + // resume or finalizers to run, the fiber has halted and we can + // invoke all join callbacks. Otherwise we need to resume. + if (attempts === null) { + runTick++; // Increment the counter to prevent reentry after completion. + status = KILLFORKS; + step = interrupt || fail || step; + } else { + attempt = attempts._1; + switch (attempt.tag) { + // 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._2; + btail = attempt._3; + if (fail === null) { + status = BINDSTEP; + step = util.fromRight(step); + } else { + status = CONTINUE; + step = attempt._1(util.fromLeft(fail)); + fail = null; + } + } + break; + + // We cannot resume from an interrupt or exception. + case RESUME: + attempts = attempts._2; + if (interrupt === null && fail === null) { + bhead = attempt._1; + btail = attempt._2; + status = BINDSTEP; + step = util.fromRight(step); + } + break; + + // If we have a bracket, we should enqueue the finalizer branch, + // and continue with the success branch only if the fiber has + // not been interrupted. If the bracket acquisition failed, we + // should not run either. + case BRACKET: + bracket--; + if (fail === null) { + result = util.fromRight(step); + attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); + if (interrupt === null || bracket > 0) { + status = CONTINUE; + step = attempt._3(result); + } + } else { + attempts = attempts._2; + } + break; + + case BRACKETED: + bracket++; + attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); + status = CONTINUE; + if (interrupt !== null) { + step = attempt._1.killed(util.fromLeft(interrupt))(attempt._2); + } else if (fail !== null) { + step = attempt._1.failed(util.fromLeft(fail))(attempt._2); + } else { + step = attempt._1.completed(util.fromRight(step))(attempt._2); + } + break; + + case FINALIZED: + bracket--; + attempts = attempts._2; + step = attempt._1; + break; + + // Otherwise we need to run a finalizer, which cannot be interrupted. + // We insert a FINALIZED marker to know when we can release it. + default: + bracket++; + attempts._1 = new Aff(FINALIZED, step); + status = CONTINUE; + step = attempt; + } } - } - break; + break; - case KILLFORKS: - if (forkCount === 0) { - status = COMPLETED; - } else { - status = CONTINUE; - step = killChildFibers(step); - } - break; - - case COMPLETED: - completeCb(step); - tmp = false; - for (var k in joins) { - if ({}.hasOwnProperty.call(joins, k)) { - tmp = true; - runEff(joins[k](step)); + case KILLFORKS: + if (forkCount === 0) { + status = COMPLETED; + } else { + status = CONTINUE; + step = killChildFibers(step); } - } - joins = tmp; - // If we have an unhandled exception, and no other fiber has joined - // then we need to throw the exception in a fresh stack. - if (util.isLeft(step) && !joins) { - setTimeout(function () { - // Guard on joins because a completely synchronous fiber can - // still have an observer. - if (!joins) { - throw util.fromLeft(step); + break; + + case COMPLETED: + completeCb(step); + tmp = false; + for (var k in joins) { + if ({}.hasOwnProperty.call(joins, k)) { + tmp = true; + runEff(joins[k](step)); } - }, 0); + } + joins = tmp; + // If we have an unhandled exception, and no other fiber has joined + // then we need to throw the exception in a fresh stack. + if (util.isLeft(step) && !joins) { + setTimeout(function () { + // Guard on joins because a completely synchronous fiber can + // still have an observer. + if (!joins) { + throw util.fromLeft(step); + } + }, 0); + } + return; + case BLOCKED: return; + case PENDING: return; } - return; - case BLOCKED: return; - case PENDING: return; } } - } - function addJoinCallback(cb) { - var jid = joinId++; - joins[jid] = cb; - return function (error) { - return new Aff(SYNC, function () { - delete joins[jid]; - }); - }; - } + function addJoinCallback(cb) { + var jid = joinId++; + joins[jid] = cb; + return function (error) { + return new Aff(SYNC, function () { + delete joins[jid]; + }); + }; + } - function kill(error) { - return new Aff(ASYNC, function (cb) { - return function () { - // Shadow the canceler binding because it can potentially be - // clobbered if we call `run`. - var canceler; - var killCb = function () { - return cb(util.right(void 0)); - }; - if (suspended) { - suspended = false; - status = COMPLETED; - interrupt = util.left(error); - } - switch (status) { - case COMPLETED: - canceler = nonCanceler; - killCb()(); - break; - case PENDING: - canceler = addJoinCallback(killCb); - if (interrupt === null) { - interrupt = util.left(error); - } - // If we can interrupt the pending action, enqueue the canceler as - // a non-interruptible finalizer. - if (bracket === 0) { - attempts = new Aff(CONS, step(error), attempts); - bhead = null; - btail = null; - status = RETURN; - step = null; - fail = null; - run(++runTick); - } - break; - default: - canceler = addJoinCallback(killCb); - if (interrupt === null) { + function kill(error) { + return new Aff(ASYNC, function (cb) { + return function () { + // Shadow the canceler binding because it can potentially be + // clobbered if we call `run`. + var canceler; + var killCb = function () { + return cb(util.right(void 0)); + }; + if (suspended) { + suspended = false; + status = COMPLETED; interrupt = util.left(error); } - if (bracket === 0) { - bhead = null; - btail = null; - status = RETURN; + switch (status) { + case COMPLETED: + canceler = nonCanceler; + killCb()(); + break; + case PENDING: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = util.left(error); + } + // If we can interrupt the pending action, enqueue the canceler as + // a non-interruptible finalizer. + if (bracket === 0) { + attempts = new Aff(CONS, step(error), attempts); + bhead = null; + btail = null; + status = RETURN; + step = null; + fail = null; + run(++runTick); + } + break; + default: + canceler = addJoinCallback(killCb); + if (interrupt === null) { + interrupt = util.left(error); + } + if (bracket === 0) { + bhead = null; + btail = null; + status = RETURN; + } } - } - return canceler; - }; - }); - } + return canceler; + }; + }); + } - function join() { - return new Aff(ASYNC, function (cb) { + var join = new Aff(ASYNC, function (cb) { return function () { if (suspended) { suspended = false; @@ -646,26 +534,18 @@ function runFiber(util, suspended, aff, completeCb) { return addJoinCallback(cb); }; }); - } - if (suspended === false) { - run(runTick); - } - - return { - kill: kill, - join: join() - }; -} + if (suspended === false) { + run(runTick); + } -exports._launchAff = function (util, suspended, aff) { - return function () { - return runFiber(util, suspended, aff, function () {}); - }; -}; + return { + kill: kill, + join: join + }; + } -exports._sequential = function (util, par) { - function runParAff(cb) { + function runPar(util, par, cb) { // Table of all forked fibers. var fiberId = 0; var fibers = {}; @@ -1017,9 +897,143 @@ exports._sequential = function (util, par) { }; } - return new Aff(ASYNC, function (cb) { + Aff.EMPTY = EMPTY; + Aff.pure = AffCtr(PURE); + Aff.throw = AffCtr(THROW); + Aff.catch = AffCtr(CATCH); + Aff.sync = AffCtr(SYNC); + Aff.async = AffCtr(ASYNC); + Aff.bind = AffCtr(BIND); + Aff.bracket = AffCtr(BRACKET); + Aff.fork = AffCtr(FORK); + Aff.parMap = AffCtr(MAP); + Aff.parApply = AffCtr(APPLY); + Aff.parAlt = AffCtr(ALT); + Aff.runFiber = runFiber; + Aff.runPar = runPar; + + return Aff; +}(); + +exports._pure = Aff.pure; + +exports._throwError = Aff.throw; + +exports._catchError = function (aff) { + return function (k) { + return Aff.catch(aff, k); + }; +}; + +exports._map = function (f) { + return function (aff) { + if (aff.tag === "Pure") { + return Aff.pure(f(aff._1)); + } else { + return Aff.bind(aff, function (value) { + return Aff.pure(f(value)); + }); + } + }; +}; + +exports._bind = function (aff) { + return function (k) { + return Aff.bind(aff, k); + }; +}; + +exports._fork = function (suspended) { + return function (aff) { + return Aff.fork(suspended, aff); + }; +}; + +exports._liftEff = Aff.sync; + +exports._parAffMap = function (f) { + return function (aff) { + return Aff.parMap(f, aff); + }; +}; + +exports._parAffApply = function (aff1) { + return function (aff2) { + return Aff.parApply(aff1, aff2); + }; +}; + +exports._parAffAlt = function (aff1) { + return function (aff2) { + return Aff.parAlt(aff1, aff2); + }; +}; + +exports.makeAff = Aff.async; + +exports.generalBracket = function (acquire) { + return function (options) { + return function (k) { + return Aff.bracket(acquire, options, k); + }; + }; +}; + +exports.memoAff = function (aff) { + var value = Aff.EMPTY; + return Aff.bind(Aff.pure(void 0), function () { + if (value === Aff.EMPTY) { + return Aff.bind(aff, function (result) { + value = Aff.pure(result); + return value; + }); + } else { + return value; + } + }); +}; + +exports._delay = function () { + function setDelay(n, k) { + if (n === 0 && typeof setImmediate !== "undefined") { + return setImmediate(k); + } else { + return setTimeout(k, n); + } + } + + function clearDelay(n, t) { + if (n === 0 && typeof clearImmediate !== "undefined") { + return clearImmediate(t); + } else { + return clearTimeout(t); + } + } + + return function (right, ms) { + return Aff.async(function (cb) { + return function () { + var timer = setDelay(ms, cb(right())); + return function () { + return Aff.sync(function () { + return right(clearDelay(ms, timer)); + }); + }; + }; + }); + }; +}(); + +exports._launchAff = function (util, suspended, aff) { + return function () { + return Aff.runFiber(util, suspended, aff, function () {}); + }; +}; + +exports._sequential = function(util, par) { + return Aff.async(function (cb) { return function () { - return runParAff(cb); + return Aff.runPar(util, par, cb); }; }); }; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index f5510cc..ce2ce38 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -39,7 +39,7 @@ import Control.Monad.Rec.Class (class MonadRec, Step(..)) import Control.Parallel (parSequence_, parallel) import Control.Parallel.Class (class Parallel) import Control.Plus (class Plus, empty) -import Data.Either (Either(..), isLeft) +import Data.Either (Either(..)) import Data.Function.Uncurried as Fn import Data.Monoid (class Monoid, mempty) import Data.Newtype (class Newtype) @@ -323,6 +323,11 @@ ffiUtil = FFIUtil , right: Right } where + isLeft ∷ ∀ a b. Either a b → Boolean + isLeft = case _ of + Left _ -> true + Right _ → false + unsafeFromLeft ∷ ∀ a b. Either a b → a unsafeFromLeft = case _ of Left a → a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 1f747ca..2cb82ae 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -172,6 +172,7 @@ test_makeAff = assert "makeAff" do case cb of Just k → do liftEff $ k (Right 42) + _ ← joinFiber fiber eq 42 <$> readRef ref2 Nothing → pure false From afd150f11ad193b7f6a63c9dbc252e34247fd097 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 11 Aug 2017 10:31:50 -0700 Subject: [PATCH 24/35] FFI cleanup --- src/Control/Monad/Aff.js | 68 +++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 33 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index c700d5a..0733f9e 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -62,9 +62,11 @@ var Aff = function () { } function AffCtr(tag) { - return function (_1, _2, _3) { + var fn = function (_1, _2, _3) { return new Aff(tag, _1, _2, _3); }; + fn.tag = tag; + return fn; } function nonCanceler(error) { @@ -898,40 +900,40 @@ var Aff = function () { } Aff.EMPTY = EMPTY; - Aff.pure = AffCtr(PURE); - Aff.throw = AffCtr(THROW); - Aff.catch = AffCtr(CATCH); - Aff.sync = AffCtr(SYNC); - Aff.async = AffCtr(ASYNC); - Aff.bind = AffCtr(BIND); - Aff.bracket = AffCtr(BRACKET); - Aff.fork = AffCtr(FORK); - Aff.parMap = AffCtr(MAP); - Aff.parApply = AffCtr(APPLY); - Aff.parAlt = AffCtr(ALT); + Aff.Pure = AffCtr(PURE); + Aff.Throw = AffCtr(THROW); + Aff.Catch = AffCtr(CATCH); + Aff.Sync = AffCtr(SYNC); + Aff.Async = AffCtr(ASYNC); + Aff.Bind = AffCtr(BIND); + Aff.Bracket = AffCtr(BRACKET); + Aff.Fork = AffCtr(FORK); + Aff.ParMap = AffCtr(MAP); + Aff.ParApply = AffCtr(APPLY); + Aff.ParAlt = AffCtr(ALT); Aff.runFiber = runFiber; Aff.runPar = runPar; return Aff; }(); -exports._pure = Aff.pure; +exports._pure = Aff.Pure; -exports._throwError = Aff.throw; +exports._throwError = Aff.Throw; exports._catchError = function (aff) { return function (k) { - return Aff.catch(aff, k); + return Aff.Catch(aff, k); }; }; exports._map = function (f) { return function (aff) { - if (aff.tag === "Pure") { - return Aff.pure(f(aff._1)); + if (aff.tag === Aff.Pure.tag) { + return Aff.Pure(f(aff._1)); } else { - return Aff.bind(aff, function (value) { - return Aff.pure(f(value)); + return Aff.Bind(aff, function (value) { + return Aff.Pure(f(value)); }); } }; @@ -939,52 +941,52 @@ exports._map = function (f) { exports._bind = function (aff) { return function (k) { - return Aff.bind(aff, k); + return Aff.Bind(aff, k); }; }; exports._fork = function (suspended) { return function (aff) { - return Aff.fork(suspended, aff); + return Aff.Fork(suspended, aff); }; }; -exports._liftEff = Aff.sync; +exports._liftEff = Aff.Sync; exports._parAffMap = function (f) { return function (aff) { - return Aff.parMap(f, aff); + return Aff.ParMap(f, aff); }; }; exports._parAffApply = function (aff1) { return function (aff2) { - return Aff.parApply(aff1, aff2); + return Aff.ParApply(aff1, aff2); }; }; exports._parAffAlt = function (aff1) { return function (aff2) { - return Aff.parAlt(aff1, aff2); + return Aff.ParAlt(aff1, aff2); }; }; -exports.makeAff = Aff.async; +exports.makeAff = Aff.Async; exports.generalBracket = function (acquire) { return function (options) { return function (k) { - return Aff.bracket(acquire, options, k); + return Aff.Bracket(acquire, options, k); }; }; }; exports.memoAff = function (aff) { var value = Aff.EMPTY; - return Aff.bind(Aff.pure(void 0), function () { + return Aff.Bind(Aff.Pure(void 0), function () { if (value === Aff.EMPTY) { - return Aff.bind(aff, function (result) { - value = Aff.pure(result); + return Aff.Bind(aff, function (result) { + value = Aff.Pure(result); return value; }); } else { @@ -1011,11 +1013,11 @@ exports._delay = function () { } return function (right, ms) { - return Aff.async(function (cb) { + return Aff.Async(function (cb) { return function () { var timer = setDelay(ms, cb(right())); return function () { - return Aff.sync(function () { + return Aff.Sync(function () { return right(clearDelay(ms, timer)); }); }; @@ -1031,7 +1033,7 @@ exports._launchAff = function (util, suspended, aff) { }; exports._sequential = function(util, par) { - return Aff.async(function (cb) { + return Aff.Async(function (cb) { return function () { return Aff.runPar(util, par, cb); }; From 8b0ce0b448f04bed5e9c7a405ab5b81d53a26ea9 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 11 Aug 2017 20:36:03 -0700 Subject: [PATCH 25/35] Scheduler for async resumption --- src/Control/Monad/Aff.js | 151 +++++++++++++++++++++---------------- src/Control/Monad/Aff.purs | 12 +-- test/Test/Main.purs | 8 +- 3 files changed, 99 insertions(+), 72 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 0733f9e..a79c4b1 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -100,21 +100,50 @@ var Aff = function () { } } + var schedule = function () { + var limit = 1024; + var size = 0; + var ix = 0; + var queue = new Array(limit); + var draining = false; + + return function (cb) { + var i, thunk; + if (size === limit) { + throw new Error("[Aff] Scheduler full"); + } + queue[(ix + size) % limit] = cb; + size++; + + if (!draining) { + draining = true; + while (size) { + size--; + thunk = queue[ix]; + queue[ix] = void 0; + ix = (ix + 1) % limit; + thunk(); + } + draining = false; + } + }; + }(); + // Fiber state machine - var BLOCKED = 0; // No effect is running. - var PENDING = 1; // An async effect is running. - var RETURN = 2; // The current stack has returned. - var CONTINUE = 3; // Run the next effect. - var BINDSTEP = 4; // Apply the next bind. + var SUSPENDED = 0; // Suspended, pending a join. + var CONTINUE = 1; // Interpret the next instruction. + var BINDSTEP = 2; // Apply the next bind. + var PENDING = 3; // An async effect is running. + var RETURN = 4; // The current stack has returned. var KILLFORKS = 5; // Killing supervised forks. var COMPLETED = 6; // The entire fiber has completed. - function runFiber(util, suspended, aff, completeCb) { + function runFiber(util, initStatus, aff, completeCb) { // Monotonically increasing tick, increased on each asynchronous turn. var runTick = 0; // The current branch of the state machine. - var status = CONTINUE; + var status = initStatus; // The current point of interest for the state machine branch. var step = aff; // Successful step @@ -146,10 +175,10 @@ var Aff = function () { // Temporary bindings for the various branches. var tmp, result, attempt, canceler; - function launchChildFiber(fid, suspended, child) { + function launchChildFiber(fid, childStatus, child) { forkCount++; var blocked = true; - var fiber = runFiber(util, suspended, child, function () { + var fiber = runFiber(util, childStatus, child, function () { forkCount--; if (blocked) { blocked = false; @@ -178,7 +207,7 @@ var Aff = function () { forks = {}; forkCount = 0; for (var i = 0, len = killId; i < len; i++) { - kills[i] = runFiber(util, false, kills[i], function () { + kills[i] = runFiber(util, CONTINUE, kills[i], function () { delete kills[i]; killId--; if (killId === 0) { @@ -190,7 +219,7 @@ var Aff = function () { return new Aff(SYNC, function () { for (var k in kills) { if (kills.hasOwnProperty(k)) { - runFiber(util, false, kills[k].kill(error), function () {}); + runFiber(util, CONTINUE, kills[k].kill(error), function () {}); } } }); @@ -252,7 +281,6 @@ var Aff = function () { break; case SYNC: - status = BLOCKED; result = runSync(util.left, util.right, step._1); if (util.isLeft(result)) { status = RETURN; @@ -267,41 +295,30 @@ var Aff = function () { break; case ASYNC: - status = BLOCKED; - canceler = runAsync(util.left, step._1, function (result) { + status = PENDING; + step = runAsync(util.left, step._1, function (result) { return function () { if (runTick !== localRunTick) { return; - } - tmp = status; - if (util.isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; } else { - status = BINDSTEP; - step = util.fromRight(result); - } - // We only need to invoke `run` if the subsequent block has - // switch the status to PENDING. Otherwise the callback was - // resolved synchronously, and the current loop can continue - // normally. - if (tmp === PENDING) { - run(++runTick); - } else { - localRunTick = ++runTick; + runTick++; } + schedule(function () { + if (util.isLeft(result)) { + status = RETURN; + fail = result; + } else if (bhead === null) { + status = RETURN; + step = result; + } else { + status = BINDSTEP; + step = util.fromRight(result); + } + run(runTick); + }); }; }); - // If the callback was resolved synchronously, the status will have - // switched to CONTINUE, and we should not move on to PENDING. - if (status === BLOCKED) { - status = PENDING; - step = canceler; - } - break; + return; // Enqueue the current stack of binds and continue case CATCH: @@ -375,7 +392,7 @@ var Aff = function () { } break; - // If we have a bracket, we should enqueue the finalizer branch, + // If we have a bracket, we should enqueue the handlers, // and continue with the success branch only if the fiber has // not been interrupted. If the bracket acquisition failed, we // should not run either. @@ -393,6 +410,8 @@ var Aff = function () { } break; + // Enqueue the appropriate handler. We increase the bracket count + // because it should be cancelled. case BRACKETED: bracket++; attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); @@ -447,14 +466,16 @@ var Aff = function () { if (util.isLeft(step) && !joins) { setTimeout(function () { // Guard on joins because a completely synchronous fiber can - // still have an observer. + // still have an observer which was added after-the-fact. if (!joins) { throw util.fromLeft(step); } }, 0); } return; - case BLOCKED: return; + case SUSPENDED: + status = CONTINUE; + break; case PENDING: return; } } @@ -479,12 +500,11 @@ var Aff = function () { var killCb = function () { return cb(util.right(void 0)); }; - if (suspended) { - suspended = false; + switch (status) { + case SUSPENDED: status = COMPLETED; interrupt = util.left(error); - } - switch (status) { + /* fallthrough */ case COMPLETED: canceler = nonCanceler; killCb()(); @@ -524,20 +544,25 @@ var Aff = function () { var join = new Aff(ASYNC, function (cb) { return function () { - if (suspended) { - suspended = false; + var canceler; + switch (status) { + case SUSPENDED: + canceler = addJoinCallback(cb); run(runTick); - } - if (status === COMPLETED) { - joins = true; + break; + case COMPLETED: + canceler = nonCanceler; + joins = true; cb(step)(); - return nonCanceler; + break; + default: + canceler = addJoinCallback(cb); } - return addJoinCallback(cb); + return canceler; }; }); - if (suspended === false) { + if (status === CONTINUE) { run(runTick); } @@ -592,7 +617,7 @@ var Aff = function () { // collect all the fibers first. kills[count++] = function (aff) { return function () { - return runFiber(util, false, aff, function (result) { + return runFiber(util, CONTINUE, aff, function (result) { count--; if (fail === null && util.isLeft(result)) { fail = result; @@ -817,7 +842,7 @@ var Aff = function () { // tree. fibers[fid] = function (aff, completeCb) { return new Aff(THUNK, function () { - return runFiber(util, false, aff, completeCb); + return runFiber(util, CONTINUE, aff, completeCb); }); }(tmp, resolve(step)); } @@ -869,7 +894,7 @@ var Aff = function () { // We can drop the fibers here because we are only canceling join // attempts, which are synchronous anyway. for (var kid = 0, n = killId; kid < n; kid++) { - runFiber(util, false, kills[kid].kill(error), function () {}); + runFiber(util, CONTINUE, kills[kid].kill(error), function () {}); } var newKills = kill(error, root, cb); @@ -879,7 +904,7 @@ var Aff = function () { return function () { for (var kid in newKills) { if (newKills.hasOwnProperty(kid)) { - runFiber(util, false, newKills[kid].kill(killError), function () {}); + runFiber(util, CONTINUE, newKills[kid].kill(killError), function () {}); } } return nonCanceler; @@ -945,9 +970,9 @@ exports._bind = function (aff) { }; }; -exports._fork = function (suspended) { +exports._fork = function (status) { return function (aff) { - return Aff.Fork(suspended, aff); + return Aff.Fork(status, aff); }; }; @@ -1026,9 +1051,9 @@ exports._delay = function () { }; }(); -exports._launchAff = function (util, suspended, aff) { +exports._launchAff = function (util, status, aff) { return function () { - return Aff.runFiber(util, suspended, aff, function () {}); + return Aff.runFiber(util, status, aff, function () {}); }; }; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index ce2ce38..702c717 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -187,11 +187,11 @@ instance monoidCanceler ∷ Monoid (Canceler eff) where -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) -launchAff aff = Fn.runFn3 _launchAff ffiUtil false aff +launchAff aff = Fn.runFn3 _launchAff ffiUtil 1 aff -- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`. launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) -launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil true aff +launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil 0 aff -- | Forks an `Aff` from an `Eff` context and also takes a callback to run when -- | it completes. Returns the pending `Fiber`. @@ -207,13 +207,13 @@ runAff_ k aff = void $ runAff k aff -- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it -- | has not completed. forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -forkAff = _fork false +forkAff = _fork 1 -- | Suspends a supervised `Aff` from within a parent `Aff` context, returning -- | the `Fiber`. A suspended `Fiber` does not execute until requested, via -- | `joinFiber`. suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -suspendAff = _fork true +suspendAff = _fork 0 -- | Forks an unsupervised `Aff`, returning the `Fiber`. spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) @@ -261,7 +261,7 @@ bracket acquire completed = 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 _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a) +foreign import _fork ∷ ∀ eff a. Int → Aff eff a → Aff eff (Fiber 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) @@ -295,7 +295,7 @@ foreign import _launchAff ∷ ∀ eff a . Fn.Fn3 FFIUtil - Boolean + Int (Aff eff a) (Eff eff (Fiber eff a)) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 2cb82ae..808c930 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -138,14 +138,14 @@ test_multi_join = assert "join/multi" do delay (Milliseconds 20.0) modifyRef ref (_ + 1) pure 20 - n1 ← sum <$> traverse joinFiber + n1 ← traverse joinFiber [ f1 , f1 , f1 , f2 ] n2 ← readRef ref - pure (n1 == 50 && n2 == 3) + pure (sum n1 == 50 && n2 == 3) test_suspend ∷ ∀ eff. TestAff eff Unit test_suspend = assert "suspend" do @@ -264,7 +264,9 @@ test_kill_canceler ∷ ∀ eff. TestAff eff Unit test_kill_canceler = assert "kill/canceler" do ref ← newRef "" fiber ← forkAff do - n ← makeAff \_ → pure (Canceler \_ → liftEff (writeRef ref "cancel")) + n ← makeAff \_ → pure $ Canceler \_ → do + delay (Milliseconds 20.0) + liftEff (writeRef ref "cancel") writeRef ref "done" killFiber (error "Nope") fiber res ← try (joinFiber fiber) From 8bcb2aec31d01b2e14338a99368302d44d0ccde8 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 11 Aug 2017 20:59:44 -0700 Subject: [PATCH 26/35] Linter --- src/Control/Monad/Aff.js | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index a79c4b1..3f3ea1d 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -71,7 +71,7 @@ var Aff = function () { function nonCanceler(error) { return new Aff(PURE, void 0); - }; + } function runEff(eff) { try { @@ -504,7 +504,9 @@ var Aff = function () { case SUSPENDED: status = COMPLETED; interrupt = util.left(error); - /* fallthrough */ + canceler = nonCanceler; + killCb()(); + break; case COMPLETED: canceler = nonCanceler; killCb()(); From 93846c973e55eb4c4e8e2e29d2afe0813f911dfc Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 14 Aug 2017 11:42:49 -0700 Subject: [PATCH 27/35] Refactor internal Fiber API, bug fixes --- src/Control/Monad/Aff.js | 627 +++++++++++++++++++------------------ src/Control/Monad/Aff.purs | 60 ++-- test/Test/Main.purs | 24 +- 3 files changed, 368 insertions(+), 343 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index 3f3ea1d..cbedbe3 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -48,7 +48,7 @@ var Aff = function () { var CONS = "Cons"; // Cons-list, for stacks var RECOVER = "Recover"; // Continue with error handler var RESUME = "Resume"; // Continue indiscriminately - var BRACKETED = "Bracketed"; // Continue with bracket finalizers + var RELEASE = "Release"; // Continue with bracket finalizers var FINALIZED = "Finalized"; // Marker for finalization var FORKED = "Forked"; // Reference to a forked fiber, with resumption stack var FIBER = "Fiber"; // Actual fiber reference @@ -100,50 +100,64 @@ var Aff = function () { } } - var schedule = function () { + var Scheduler = function () { var limit = 1024; var size = 0; var ix = 0; var queue = new Array(limit); var draining = false; - return function (cb) { - var i, thunk; - if (size === limit) { - throw new Error("[Aff] Scheduler full"); + function drain() { + var thunk; + draining = true; + while (size !== 0) { + size--; + thunk = queue[ix]; + queue[ix] = void 0; + ix = (ix + 1) % limit; + thunk(); } - queue[(ix + size) % limit] = cb; - size++; - - if (!draining) { - draining = true; - while (size) { - size--; - thunk = queue[ix]; - queue[ix] = void 0; - ix = (ix + 1) % limit; - thunk(); + draining = false; + } + + return { + isDraining: function () { + return draining; + }, + enqueue: function (cb) { + var i, tmp; + if (size === limit) { + tmp = draining; + drain(); + draining = tmp; + } + + queue[(ix + size) % limit] = cb; + size++; + + if (!draining) { + drain(); } - draining = false; } }; }(); // Fiber state machine - var SUSPENDED = 0; // Suspended, pending a join. - var CONTINUE = 1; // Interpret the next instruction. - var BINDSTEP = 2; // Apply the next bind. - var PENDING = 3; // An async effect is running. - var RETURN = 4; // The current stack has returned. - var KILLFORKS = 5; // Killing supervised forks. - var COMPLETED = 6; // The entire fiber has completed. - - function runFiber(util, initStatus, aff, completeCb) { + var SUSPENDED = 0; // Suspended, pending a join. + var CONTINUE = 1; // Interpret the next instruction. + var STEP_BIND = 2; // Apply the next bind. + var STEP_RESULT = 3; // Handle potential failure from a result. + var PENDING = 4; // An async effect is running. + var RETURN = 5; // The current stack has returned. + var KILLALL = 6; // Killing supervised forks. + var COMPLETED = 7; // The entire fiber has completed. + + function makeFiber(util, aff) { // Monotonically increasing tick, increased on each asynchronous turn. var runTick = 0; // The current branch of the state machine. - var status = initStatus; + var status = SUSPENDED; // The current point of interest for the state machine branch. var step = aff; // Successful step @@ -154,78 +168,88 @@ var Aff = function () { var bhead = null; var btail = null; - // Stack of attempts and finalizers for error recovery. This holds a union - // of an arbitrary Aff finalizer or a Cons list of bind continuations. + // Stack of attempts and finalizers for error recovery. var attempts = null; // A special state is needed for Bracket, because it cannot be killed. When // we enter a bracket acquisition or finalizer, we increment the counter, // and then decrement once complete. - var bracket = 0; + var bracketCount = 0; // Each join gets a new id so they can be revoked. - var joinId = 0; - var joins = {}; + var joinId = 0; + var joins = null; + var rethrow = true; // Track child forks so they don't outlive the parent thread. var forkCount = 0; var forkId = 0; - var forks = {}; - - // Temporary bindings for the various branches. - var tmp, result, attempt, canceler; + var forks = null; - function launchChildFiber(fid, childStatus, child) { + function makeChildFiber(childAff) { forkCount++; - var blocked = true; - var fiber = runFiber(util, childStatus, child, function () { - forkCount--; - if (blocked) { - blocked = false; - } else { - delete forks[fid]; + forks = forks || {}; + + var fiberId = forkId++; + var fiber = makeFiber(util, childAff); + + fiber.onComplete({ + rethrow: true, + handler: function (result) { + return function () { + forkCount--; + delete forks[fiberId]; + }; } - }); - if (blocked) { - blocked = false; - forks[fid] = fiber; - } + })(); + + forks[fiberId] = fiber; return fiber; } - function killChildFibers(finalStep) { - return new Aff(ASYNC, function (cb) { - return function () { - var killError = new Error("[Aff] Child fiber outlived parent"); - var killId = 0; - var kills = {}; - for (var k in forks) { - if (forks.hasOwnProperty(k)) { - kills[killId++] = forks[k].kill(killError); - } - } - forks = {}; - forkCount = 0; - for (var i = 0, len = killId; i < len; i++) { - kills[i] = runFiber(util, CONTINUE, kills[i], function () { - delete kills[i]; - killId--; - if (killId === 0) { - cb(finalStep)(); + function killChildFibers(cb) { + return function () { + var killError = new Error("[Aff] Child fiber outlived parent"); + var killCount = 0; + var kills = {}; + + function kill(fid) { + kills[fid] = forks[fid].kill(killError, function (result) { + return function () { + delete kills[fid]; + killCount--; + if (util.isLeft(result) && util.fromLeft(result)) { + setTimeout(function () { + throw util.fromLeft(result); + }, 0); } - }); + if (killCount === 0) { + cb(); + } + }; + })(); + } + + for (var k in forks) { + if (forks.hasOwnProperty(k)) { + killCount++; + kill(k); } - return function (error) { - return new Aff(SYNC, function () { - for (var k in kills) { - if (kills.hasOwnProperty(k)) { - runFiber(util, CONTINUE, kills[k].kill(error), function () {}); - } + } + + forks = {}; + forkCount = 0; + + return function (error) { + return new Aff(SYNC, function () { + for (var k in kills) { + if (kills.hasOwnProperty(k)) { + kills[k](); } - }); - }; + } + }); }; - }); + }; } // Each invocation of `run` requires a tick. When an asynchronous effect is @@ -235,13 +259,15 @@ var Aff = function () { // the provided callback in `makeAff` more than once, but it may also be an // async effect resuming after the fiber was already cancelled. function run(localRunTick) { + var tmp, result, attempt, canceler; while (true) { tmp = null; result = null; attempt = null; canceler = null; + switch (status) { - case BINDSTEP: + case STEP_BIND: status = CONTINUE; step = bhead(step); if (btail === null) { @@ -252,6 +278,19 @@ var Aff = function () { } break; + case STEP_RESULT: + if (util.isLeft(step)) { + status = RETURN; + fail = step; + step = null; + } else if (bhead === null) { + status = RETURN; + } else { + status = STEP_BIND; + step = util.fromRight(step); + } + break; + case CONTINUE: switch (step.tag) { case BIND: @@ -268,30 +307,14 @@ var Aff = function () { status = RETURN; step = util.right(step._1); } else { - status = BINDSTEP; + status = STEP_BIND; step = step._1; } break; - case THROW: - bhead = null; - btail = null; - status = RETURN; - fail = util.left(step._1); - break; - case SYNC: - result = runSync(util.left, util.right, step._1); - if (util.isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = util.fromRight(result); - } + status = STEP_RESULT; + step = runSync(util.left, util.right, step._1); break; case ASYNC: @@ -300,26 +323,25 @@ var Aff = function () { return function () { if (runTick !== localRunTick) { return; - } else { - runTick++; } - schedule(function () { - if (util.isLeft(result)) { - status = RETURN; - fail = result; - } else if (bhead === null) { - status = RETURN; - step = result; - } else { - status = BINDSTEP; - step = util.fromRight(result); - } + runTick++; + Scheduler.enqueue(function () { + status = STEP_RESULT; + step = result; run(runTick); }); }; }); return; + case THROW: + bhead = null; + btail = null; + status = RETURN; + fail = util.left(step._1); + step = null; + break; + // Enqueue the current stack of binds and continue case CATCH: attempts = new Aff(CONS, new Aff(RECOVER, step._2, bhead, btail), attempts); @@ -332,11 +354,11 @@ var Aff = function () { // When we evaluate a Bracket, we also enqueue the instruction so we // can fullfill it later once we return from the acquisition. case BRACKET: - bracket++; + bracketCount++; if (bhead === null) { - attempts = new Aff(CONS, step, attempts); + attempts = new Aff(CONS, step, attempts); } else { - attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); + attempts = new Aff(CONS, step, new Aff(CONS, new Aff(RESUME, bhead, btail), attempts)); } bhead = null; btail = null; @@ -345,8 +367,12 @@ var Aff = function () { break; case FORK: - status = BINDSTEP; - step = launchChildFiber(forkId++, step._1, step._2); + status = STEP_BIND; + result = makeChildFiber(step._2); + if (step._1) { + result.run(); + } + step = result; break; } break; @@ -356,38 +382,41 @@ var Aff = function () { // resume or finalizers to run, the fiber has halted and we can // invoke all join callbacks. Otherwise we need to resume. if (attempts === null) { - runTick++; // Increment the counter to prevent reentry after completion. - status = KILLFORKS; + status = KILLALL; step = interrupt || fail || step; } else { - attempt = attempts._1; + attempt = attempts._1; + attempts = attempts._2; + switch (attempt.tag) { // 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) { + if (interrupt) { + status = RETURN; + } else { bhead = attempt._2; btail = attempt._3; - if (fail === null) { - status = BINDSTEP; - step = util.fromRight(step); - } else { + if (fail) { status = CONTINUE; step = attempt._1(util.fromLeft(fail)); fail = null; + } else { + status = STEP_BIND; + step = util.fromRight(step); } } break; // We cannot resume from an interrupt or exception. case RESUME: - attempts = attempts._2; - if (interrupt === null && fail === null) { + if (interrupt || fail) { + status = RETURN; + } else { bhead = attempt._1; btail = attempt._2; - status = BINDSTEP; + status = STEP_BIND; step = util.fromRight(step); } break; @@ -397,24 +426,22 @@ var Aff = function () { // not been interrupted. If the bracket acquisition failed, we // should not run either. case BRACKET: - bracket--; + bracketCount--; if (fail === null) { result = util.fromRight(step); - attempts = new Aff(CONS, new Aff(BRACKETED, attempt._2, result), attempts._2); - if (interrupt === null || bracket > 0) { + attempts = new Aff(CONS, new Aff(RELEASE, attempt._2, result), attempts); + if (interrupt === null || bracketCount > 0) { status = CONTINUE; step = attempt._3(result); } - } else { - attempts = attempts._2; } break; // Enqueue the appropriate handler. We increase the bracket count // because it should be cancelled. - case BRACKETED: - bracket++; - attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts._2); + case RELEASE: + bracketCount++; + attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts); status = CONTINUE; if (interrupt !== null) { step = attempt._1.killed(util.fromLeft(interrupt))(attempt._2); @@ -426,48 +453,51 @@ var Aff = function () { break; case FINALIZED: - bracket--; - attempts = attempts._2; - step = attempt._1; + bracketCount--; + status = RETURN; + step = attempt._1; break; // Otherwise we need to run a finalizer, which cannot be interrupted. // We insert a FINALIZED marker to know when we can release it. default: - bracket++; - attempts._1 = new Aff(FINALIZED, step); - status = CONTINUE; - step = attempt; + bracketCount++; + attempts = new Aff(CONS, new Aff(FINALIZED, step), attempts); + status = CONTINUE; + step = attempt; } } break; - case KILLFORKS: + case KILLALL: if (forkCount === 0) { status = COMPLETED; } else { - status = CONTINUE; - step = killChildFibers(step); + killChildFibers(function () { + Scheduler.enqueue(function () { + status = COMPLETED; + run(++runTick); + }); + })(); + return; } break; case COMPLETED: - completeCb(step); - tmp = false; for (var k in joins) { if ({}.hasOwnProperty.call(joins, k)) { - tmp = true; - runEff(joins[k](step)); + rethrow = rethrow && joins[k].rethrow; + runEff(joins[k].handler(step)); } } - joins = tmp; + joins = null; // If we have an unhandled exception, and no other fiber has joined // then we need to throw the exception in a fresh stack. - if (util.isLeft(step) && !joins) { + if (util.isLeft(step) && rethrow) { setTimeout(function () { - // Guard on joins because a completely synchronous fiber can + // Guard on reathrow because a completely synchronous fiber can // still have an observer which was added after-the-fact. - if (!joins) { + if (rethrow) { throw util.fromLeft(step); } }, 0); @@ -481,96 +511,112 @@ var Aff = function () { } } - function addJoinCallback(cb) { - var jid = joinId++; - joins[jid] = cb; - return function (error) { - return new Aff(SYNC, function () { + function onComplete(join) { + return function () { + if (status === COMPLETED) { + rethrow = rethrow && join.rethrow; + join.handler(step)(); + return function () {}; + } + + var jid = joinId++; + joins = joins || {}; + joins[jid] = join; + + return function() { delete joins[jid]; - }); + }; }; } - function kill(error) { - return new Aff(ASYNC, function (cb) { - return function () { - // Shadow the canceler binding because it can potentially be - // clobbered if we call `run`. - var canceler; - var killCb = function () { - return cb(util.right(void 0)); - }; - switch (status) { - case SUSPENDED: - status = COMPLETED; - interrupt = util.left(error); - canceler = nonCanceler; - killCb()(); - break; - case COMPLETED: - canceler = nonCanceler; - killCb()(); - break; - case PENDING: - canceler = addJoinCallback(killCb); - if (interrupt === null) { - interrupt = util.left(error); - } - // If we can interrupt the pending action, enqueue the canceler as - // a non-interruptible finalizer. - if (bracket === 0) { - attempts = new Aff(CONS, step(error), attempts); - bhead = null; - btail = null; - status = RETURN; - step = null; - fail = null; - run(++runTick); - } - break; - default: - canceler = addJoinCallback(killCb); - if (interrupt === null) { - interrupt = util.left(error); - } - if (bracket === 0) { - bhead = null; - btail = null; - status = RETURN; + function kill(error, cb) { + return function () { + if (status === COMPLETED) { + cb(util.right(void 0))(); + return function () {}; + } + + var canceler = onComplete({ + rethrow: false, + handler: function (result) { + if (fail) { + return cb(fail); + } else { + return cb(util.right(void 0)); } } - return canceler; - }; - }); - } + })(); - var join = new Aff(ASYNC, function (cb) { - return function () { - var canceler; switch (status) { + case KILLALL: + break; case SUSPENDED: - canceler = addJoinCallback(cb); + interrupt = util.left(error); + status = COMPLETED; + step = interrupt; run(runTick); break; - case COMPLETED: - canceler = nonCanceler; - joins = true; - cb(step)(); + case PENDING: + if (interrupt === null) { + interrupt = util.left(error); + } + if (bracketCount === 0) { + if (status === PENDING) { + attempts = new Aff(CONS, step(error), attempts); + } + bhead = null; + btail = null; + status = RETURN; + step = null; + fail = null; + run(++runTick); + } break; default: - canceler = addJoinCallback(cb); + if (interrupt === null) { + interrupt = util.left(error); + } + if (bracketCount === 0) { + bhead = null; + btail = null; + status = RETURN; + step = null; + fail = null; + } } + return canceler; }; - }); + } - if (status === CONTINUE) { - run(runTick); + function join(cb) { + return function () { + var canceler = onComplete({ + rethrow: false, + handler: cb + })(); + if (status === SUSPENDED) { + run(runTick); + } + return canceler; + }; } return { kill: kill, - join: join + join: join, + onComplete: onComplete, + run: function () { + if (status === SUSPENDED) { + if (!Scheduler.isDraining()) { + Scheduler.enqueue(function () { + run(runTick); + }); + } else { + run(runTick); + } + } + } }; } @@ -609,29 +655,17 @@ var Aff = function () { switch (step.tag) { case FORKED: tmp = fibers[step._1]; - // If we haven't forked the fiber yet (such as with a sync Alt), - // then we should just remove it from the queue and continue. - if (tmp.tag === THUNK) { - delete fibers[step._1]; - cb(util.right(void 0))(); - } else { - // Again, we prime the effect but don't run it yet, so that we can - // collect all the fibers first. - kills[count++] = function (aff) { - return function () { - return runFiber(util, CONTINUE, aff, function (result) { - count--; - if (fail === null && util.isLeft(result)) { - fail = result; - } - // We can resolve the callback when all fibers have died. - if (count === 0) { - cb(fail || util.right(void 0))(); - } - }); - }; - }(tmp._1.kill(error)); - } + kills[count++] = tmp.kill(error, function (result) { + return function () { + count--; + if (fail === null && util.isLeft(result)) { + fail = result; + } + if (count === 0) { + cb(fail || util.right(void 0))(); + } + }; + }); // Terminal case. if (head === null) { break loop; @@ -783,9 +817,11 @@ var Aff = function () { function resolve(fiber) { return function (result) { - delete fibers[fiber._1]; - fiber._3 = result; - join(result, fiber._2._1, fiber._2._2); + return function () { + delete fibers[fiber._1]; + fiber._3 = result; + join(result, fiber._2._1, fiber._2._2); + }; }; } @@ -837,16 +873,12 @@ var Aff = function () { status = RETURN; tmp = step; step = new Aff(FORKED, fid, new Aff(CONS, head, tail), EMPTY); - // We prime the effect, but don't immediately run it. We need to - // walk the entire tree first before actually running effects - // because they may all be synchronous and resolve immediately, at - // which point it would attempt to resolve against an incomplete - // tree. - fibers[fid] = function (aff, completeCb) { - return new Aff(THUNK, function () { - return runFiber(util, CONTINUE, aff, completeCb); - }); - }(tmp, resolve(step)); + tmp = makeFiber(util, tmp); + tmp.onComplete({ + rethrow: false, + handler: resolve(step) + })(); + fibers[fid] = tmp; } break; case RETURN: @@ -877,13 +909,8 @@ var Aff = function () { // Keep a reference to the tree root so it can be cancelled. root = step; - // Walk the primed fibers and fork them. We store the actual `Fiber` - // reference so we can cancel them when needed. for (fid = 0; fid < fiberId; fid++) { - tmp = fibers[fid]; - if (tmp && tmp.tag === THUNK) { - fibers[fid] = new Aff(FIBER, tmp._1()); - } + fibers[fid].run(); } } @@ -893,20 +920,21 @@ var Aff = function () { function cancel(error, cb) { interrupt = util.left(error); - // We can drop the fibers here because we are only canceling join - // attempts, which are synchronous anyway. - for (var kid = 0, n = killId; kid < n; kid++) { - runFiber(util, CONTINUE, kills[kid].kill(error), function () {}); + for (var kid in kills) { + if ({}.prototype.hasOwnProperty.call(kills, kid)) { + kills[kid](); + } } + kills = null; var newKills = kill(error, root, cb); return function (killError) { return new Aff(ASYNC, function (killCb) { return function () { for (var kid in newKills) { - if (newKills.hasOwnProperty(kid)) { - runFiber(util, CONTINUE, newKills[kid].kill(killError), function () {}); + if ({}.prototype.hasOwnProperty.call(newKills, kid)) { + newKills[kid](); } } return nonCanceler; @@ -926,20 +954,21 @@ var Aff = function () { }; } - Aff.EMPTY = EMPTY; - Aff.Pure = AffCtr(PURE); - Aff.Throw = AffCtr(THROW); - Aff.Catch = AffCtr(CATCH); - Aff.Sync = AffCtr(SYNC); - Aff.Async = AffCtr(ASYNC); - Aff.Bind = AffCtr(BIND); - Aff.Bracket = AffCtr(BRACKET); - Aff.Fork = AffCtr(FORK); - Aff.ParMap = AffCtr(MAP); - Aff.ParApply = AffCtr(APPLY); - Aff.ParAlt = AffCtr(ALT); - Aff.runFiber = runFiber; - Aff.runPar = runPar; + Aff.EMPTY = EMPTY; + Aff.Pure = AffCtr(PURE); + Aff.Throw = AffCtr(THROW); + Aff.Catch = AffCtr(CATCH); + Aff.Sync = AffCtr(SYNC); + Aff.Async = AffCtr(ASYNC); + Aff.Bind = AffCtr(BIND); + Aff.Bracket = AffCtr(BRACKET); + Aff.Fork = AffCtr(FORK); + Aff.ParMap = AffCtr(MAP); + Aff.ParApply = AffCtr(APPLY); + Aff.ParAlt = AffCtr(ALT); + Aff.makeFiber = makeFiber; + Aff.runPar = runPar; + Aff.Scheduler = Scheduler; return Aff; }(); @@ -972,9 +1001,9 @@ exports._bind = function (aff) { }; }; -exports._fork = function (status) { +exports._fork = function (immediate) { return function (aff) { - return Aff.Fork(status, aff); + return Aff.Fork(immediate, aff); }; }; @@ -1008,18 +1037,10 @@ exports.generalBracket = function (acquire) { }; }; -exports.memoAff = function (aff) { - var value = Aff.EMPTY; - return Aff.Bind(Aff.Pure(void 0), function () { - if (value === Aff.EMPTY) { - return Aff.Bind(aff, function (result) { - value = Aff.Pure(result); - return value; - }); - } else { - return value; - } - }); +exports._makeFiber = function (util, aff) { + return function () { + return Aff.makeFiber(util, aff); + }; }; exports._delay = function () { @@ -1053,12 +1074,6 @@ exports._delay = function () { }; }(); -exports._launchAff = function (util, status, aff) { - return function () { - return Aff.runFiber(util, status, aff, function () {}); - }; -}; - exports._sequential = function(util, par) { return Aff.Async(function (cb) { return function () { diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 702c717..061a526 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -26,13 +26,14 @@ module Control.Monad.Aff ) where import Prelude + import Control.Alt (class Alt) import Control.Alternative (class Alternative) import Control.Apply (lift2) import Control.Monad.Eff (Eff, kind Effect) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Exception (Error, EXCEPTION, error) -import Control.Monad.Eff.Unsafe (unsafeCoerceEff) +import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff) import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) import Control.Monad.Error.Class (try) as Exports import Control.Monad.Rec.Class (class MonadRec, Step(..)) @@ -135,40 +136,38 @@ instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) sequential a = Fn.runFn2 _sequential ffiUtil a +type OnComplete eff a = + { rethrow ∷ Boolean + , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit + } + -- | Represents a forked computation by way of `forkAff`. `Fiber`s are -- | memoized, so their results are only computed once. newtype Fiber eff a = Fiber - { kill ∷ Error → Aff eff Unit - , join ∷ Aff eff a + { kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit)) + , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit) + , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit) + , run ∷ Eff eff Unit } instance functorFiber ∷ Functor (Fiber eff) where - map f t = Fiber - { kill: const (pure unit) - , join: memoAff (f <$> joinFiber t) - } + map f t = unsafePerformEff (makeFiber (f <$> joinFiber t)) instance applyFiber ∷ Apply (Fiber eff) where - apply t1 t2 = Fiber - { kill: const (pure unit) - , join: memoAff (joinFiber t1 <*> joinFiber t2) - } + apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2)) instance applicativeFiber ∷ Applicative (Fiber eff) where - pure a = Fiber - { kill: const (pure unit) - , join: pure a - } + pure a = unsafePerformEff (makeFiber (pure a)) -- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks -- | until the fiber has fully exited. killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit -killFiber e (Fiber t) = t.kill e +killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k -- | Blocks until the fiber completes, yielding the result. If the fiber -- | throws an exception, it is rethrown in the current fiber. joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a -joinFiber (Fiber t) = t.join +joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k -- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is -- | killed, and an async action is pending, the canceler will be called to @@ -187,11 +186,14 @@ instance monoidCanceler ∷ Monoid (Canceler eff) where -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) -launchAff aff = Fn.runFn3 _launchAff ffiUtil 1 aff +launchAff aff = do + fiber@(Fiber { run }) ← makeFiber aff + run + pure fiber -- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`. launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) -launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil 0 aff +launchSuspendedAff = makeFiber -- | Forks an `Aff` from an `Eff` context and also takes a callback to run when -- | it completes. Returns the pending `Fiber`. @@ -207,13 +209,13 @@ runAff_ k aff = void $ runAff k aff -- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it -- | has not completed. forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -forkAff = _fork 1 +forkAff = _fork true -- | Suspends a supervised `Aff` from within a parent `Aff` context, returning -- | the `Fiber`. A suspended `Fiber` does not execute until requested, via -- | `joinFiber`. suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -suspendAff = _fork 0 +suspendAff = _fork false -- | Forks an unsupervised `Aff`, returning the `Fiber`. spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) @@ -261,7 +263,7 @@ bracket acquire completed = 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 _fork ∷ ∀ eff a. Int → Aff eff a → Aff eff (Fiber eff a) +foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber 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) @@ -269,6 +271,7 @@ foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a +foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a)) type BracketConditions eff a b = { killed ∷ Error → a → Aff eff Unit @@ -287,17 +290,8 @@ foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions e -- | ignored. foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a --- | Do not export this function. It is not referentially transparent in --- | general, and can be used to create global mutable references. -foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a - -foreign import _launchAff - ∷ ∀ eff a - . Fn.Fn3 - FFIUtil - Int - (Aff eff a) - (Eff eff (Fiber eff a)) +makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) +makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff foreign import _sequential ∷ ∀ eff a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 808c930..d31653b 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -1,8 +1,9 @@ module Test.Main where import Prelude + import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber) +import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -19,8 +20,9 @@ import Data.Either (Either(..), isLeft, isRight) import Data.Foldable (sum) import Data.Maybe (Maybe(..)) import Data.Monoid (mempty) -import Data.Traversable (traverse) +import Data.Time (Millisecond) import Data.Time.Duration (Milliseconds(..)) +import Data.Traversable (traverse) import Test.Assert (assert', ASSERT) type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION | eff) @@ -168,6 +170,7 @@ test_makeAff = assert "makeAff" do writeRef ref1 (Just cb) pure mempty writeRef ref2 n + delay (Milliseconds 5.0) cb ← readRef ref1 case cb of Just k → do @@ -242,6 +245,7 @@ test_general_bracket = assert "bracket/general" do } f1 ← forkAff $ bracketAction "foo" (const (action "a")) + delay (Milliseconds 5.0) killFiber (error "z") f1 r1 ← try $ joinFiber f1 @@ -256,7 +260,7 @@ test_general_bracket = assert "bracket/general" do test_kill ∷ ∀ eff. TestAff eff Unit test_kill = assert "kill" do - fiber ← forkAff $ makeAff \_ → pure mempty + fiber ← forkAff never killFiber (error "Nope") fiber isLeft <$> try (joinFiber fiber) @@ -268,6 +272,7 @@ test_kill_canceler = assert "kill/canceler" do delay (Milliseconds 20.0) liftEff (writeRef ref "cancel") writeRef ref "done" + delay (Milliseconds 10.0) killFiber (error "Nope") fiber res ← try (joinFiber fiber) n ← readRef ref @@ -285,6 +290,7 @@ test_kill_bracket = assert "kill/bracket" do (action "a") (\_ → action "b") (\_ → action "c") + delay (Milliseconds 5.0) killFiber (error "Nope") fiber _ ← try (joinFiber fiber) eq "ab" <$> readRef ref @@ -307,6 +313,7 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do (bracketAction "foo") (\s → void $ bracketAction (s <> "/release")) (\s → bracketAction (s <> "/run")) + delay (Milliseconds 5.0) killFiber (error "Nope") fiber _ ← try (joinFiber fiber) readRef ref <#> eq @@ -335,6 +342,7 @@ test_kill_child = assert "kill/child" do fiber ← forkAff do _ ← forkAff $ action "foo" _ ← forkAff $ action "bar" + delay (Milliseconds 5.0) modifyRef ref (_ <> "parent") delay (Milliseconds 20.0) eq "acquirefooacquirebarparentkillfookillbar" <$> readRef ref @@ -351,7 +359,7 @@ test_parallel = assert "parallel" do { a: _, b: _ } <$> parallel (action "foo") <*> parallel (action "bar") - delay (Milliseconds 10.0) + delay (Milliseconds 15.0) r1 ← readRef ref r2 ← joinFiber f1 pure (r1 == "foobar" && r2.a == "foo" && r2.b == "bar") @@ -472,6 +480,12 @@ test_parallel_stack = assert "parallel/stack" do parTraverse_ (modifyRef ref <<< add) (Array.replicate 100000 1) eq 100000 <$> readRef ref +test_scheduler_size ∷ ∀ eff. TestAff eff Unit +test_scheduler_size = assert "scheduler" do + ref ← newRef 0 + _ ← traverse joinFiber =<< traverse forkAff (Array.replicate 100000 (modifyRef ref (add 1))) + eq 100000 <$> readRef ref + main ∷ TestEff () Unit main = do test_pure @@ -504,4 +518,6 @@ main = do test_kill_parallel_alt test_fiber_map test_fiber_apply + -- Turn on if we decide to schedule forks + -- test_scheduler_size test_parallel_stack From 637e913f899cf83e595303d43a198368c7dd962d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 14 Aug 2017 19:22:45 -0700 Subject: [PATCH 28/35] Fill in missing functions --- src/Control/Monad/Aff.purs | 35 +++++++++++++++++++++++++++++++---- test/Test/Main.purs | 1 - 2 files changed, 31 insertions(+), 5 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 061a526..b4506e8 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -3,7 +3,6 @@ module Control.Monad.Aff , Fiber , ParAff(..) , Canceler(..) - , BracketConditions , makeAff , launchAff , launchSuspendedAff @@ -14,14 +13,18 @@ module Control.Monad.Aff , spawnAff , spawnSuspendedAff , liftEff' - , bracket - , generalBracket + , attempt , delay , never , finally , atomically , killFiber , joinFiber + , cancelWith + , bracket + , BracketConditions + , generalBracket + , nonCanceler , module Exports ) where @@ -182,7 +185,11 @@ instance semigroupCanceler ∷ Semigroup (Canceler eff) where -- | A no-op `Canceler` can be constructed with `mempty`. instance monoidCanceler ∷ Monoid (Canceler eff) where - mempty = Canceler (const (pure unit)) + mempty = nonCanceler + +-- | A canceler which does not cancel anything. +nonCanceler ∷ ∀ eff. Canceler eff +nonCanceler = Canceler (const (pure unit)) -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) @@ -238,6 +245,15 @@ never = makeAff \_ → pure mempty liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a liftEff' = liftEff <<< unsafeCoerceEff +-- | A monomorphic version of `try`. Catches thrown errors and lifts them +-- | into an `Either`. +attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a) +attempt = try + +-- | Ignores any errors. +apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit +apathize = attempt >>> map (const unit) + -- | Runs the first effect after the second, regardless of whether it completed -- | successfully or the fiber was cancelled. finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a @@ -247,6 +263,17 @@ finally fin a = bracket (pure unit) (const fin) (const a) atomically ∷ ∀ eff a. Aff eff a → Aff eff a atomically a = bracket a (const (pure unit)) pure +-- | Attaches a custom `Canceler` to an action. If the computation is canceled, +-- | then the custom `Canceler` will be run afterwards. +cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a +cancelWith aff (Canceler cancel) = + generalBracket (pure unit) + { killed: \e _ → cancel e + , failed: const pure + , completed: const pure + } + (const aff) + -- | Guarantees resource acquisition and cleanup. The first effect may acquire -- | some resource, while the second will dispose of it. The third effect makes -- | use of the resource. Disposal is always run last, regardless. Neither diff --git a/test/Test/Main.purs b/test/Test/Main.purs index d31653b..def2bd4 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -20,7 +20,6 @@ import Data.Either (Either(..), isLeft, isRight) import Data.Foldable (sum) import Data.Maybe (Maybe(..)) import Data.Monoid (mempty) -import Data.Time (Millisecond) import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (traverse) import Test.Assert (assert', ASSERT) From 116b499949e5edef1fb17b9cf190b94487e24eba Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 15 Aug 2017 21:35:10 -0700 Subject: [PATCH 29/35] Add supervise combinator --- src/Control/Monad/Aff.js | 303 ++++++++++++++++++++++--------------- src/Control/Monad/Aff.purs | 40 ++--- test/Test/Main.purs | 15 +- 3 files changed, 203 insertions(+), 155 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index cbedbe3..deb5ec4 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -1,5 +1,5 @@ /* globals setImmediate, clearImmediate, setTimeout, clearTimeout */ -/* jshint -W083, -W098 */ +/* jshint -W083, -W098, -W003 */ "use strict"; var Aff = function () { @@ -20,6 +20,7 @@ var Aff = function () { | forall b. Bind (Aff eff b) (b -> Aff eff a) | forall b. Bracket (Aff eff b) (BracketConditions eff b) (b -> Aff eff a) | forall b. Fork Boolean (Aff eff b) ?(Thread eff b -> a) + | Sequential (ParAff aff a) */ var PURE = "Pure"; @@ -30,6 +31,7 @@ var Aff = function () { var BIND = "Bind"; var BRACKET = "Bracket"; var FORK = "Fork"; + var SEQ = "Sequential"; /* @@ -142,79 +144,35 @@ var Aff = function () { }; }(); - // Fiber state machine - var SUSPENDED = 0; // Suspended, pending a join. - var CONTINUE = 1; // Interpret the next instruction. - var STEP_BIND = 2; // Apply the next bind. - var STEP_RESULT = 3; // Handle potential failure from a result. - var PENDING = 4; // An async effect is running. - var RETURN = 5; // The current stack has returned. - var KILLALL = 6; // Killing supervised forks. - var COMPLETED = 7; // The entire fiber has completed. - - function makeFiber(util, aff) { - // Monotonically increasing tick, increased on each asynchronous turn. - var runTick = 0; - - // The current branch of the state machine. - var status = SUSPENDED; - - // The current point of interest for the state machine branch. - var step = aff; // Successful step - var fail = null; // Failure step - var interrupt = null; // Asynchronous interrupt - - // Stack of continuations for the current fiber. - var bhead = null; - var btail = null; - - // Stack of attempts and finalizers for error recovery. - var attempts = null; - - // A special state is needed for Bracket, because it cannot be killed. When - // we enter a bracket acquisition or finalizer, we increment the counter, - // and then decrement once complete. - var bracketCount = 0; - - // Each join gets a new id so they can be revoked. - var joinId = 0; - var joins = null; - var rethrow = true; - - // Track child forks so they don't outlive the parent thread. - var forkCount = 0; - var forkId = 0; - var forks = null; - - function makeChildFiber(childAff) { - forkCount++; - forks = forks || {}; - - var fiberId = forkId++; - var fiber = makeFiber(util, childAff); - - fiber.onComplete({ - rethrow: true, - handler: function (result) { - return function () { - forkCount--; - delete forks[fiberId]; - }; - } - })(); + function Supervisor(util) { + var fibers = {}; + var fiberId = 0; + var count = 0; - forks[fiberId] = fiber; - return fiber; - } - - function killChildFibers(cb) { - return function () { - var killError = new Error("[Aff] Child fiber outlived parent"); + return { + register: function (fiber) { + var fid = fiberId++; + fiber.onComplete({ + rethrow: true, + handler: function (result) { + return function () { + count--; + delete fibers[fid]; + }; + } + }); + fibers[fid] = fiber; + count++; + }, + isEmpty: function () { + return count === 0; + }, + killAll: function (killError, cb) { var killCount = 0; var kills = {}; function kill(fid) { - kills[fid] = forks[fid].kill(killError, function (result) { + kills[fid] = fibers[fid].kill(killError, function (result) { return function () { delete kills[fid]; killCount--; @@ -230,15 +188,16 @@ var Aff = function () { })(); } - for (var k in forks) { - if (forks.hasOwnProperty(k)) { + for (var k in fibers) { + if (fibers.hasOwnProperty(k)) { killCount++; kill(k); } } - forks = {}; - forkCount = 0; + fibers = {}; + fiberId = 0; + count = 0; return function (error) { return new Aff(SYNC, function () { @@ -249,8 +208,47 @@ var Aff = function () { } }); }; - }; - } + } + }; + } + + // Fiber state machine + var SUSPENDED = 0; // Suspended, pending a join. + var CONTINUE = 1; // Interpret the next instruction. + var STEP_BIND = 2; // Apply the next bind. + var STEP_RESULT = 3; // Handle potential failure from a result. + var PENDING = 4; // An async effect is running. + var RETURN = 5; // The current stack has returned. + var COMPLETED = 6; // The entire fiber has completed. + + function Fiber(util, supervisor, aff) { + // Monotonically increasing tick, increased on each asynchronous turn. + var runTick = 0; + + // The current branch of the state machine. + var status = SUSPENDED; + + // The current point of interest for the state machine branch. + var step = aff; // Successful step + var fail = null; // Failure step + var interrupt = null; // Asynchronous interrupt + + // Stack of continuations for the current fiber. + var bhead = null; + var btail = null; + + // Stack of attempts and finalizers for error recovery. + var attempts = null; + + // A special state is needed for Bracket, because it cannot be killed. When + // we enter a bracket acquisition or finalizer, we increment the counter, + // and then decrement once complete. + var bracketCount = 0; + + // Each join gets a new id so they can be revoked. + var joinId = 0; + var joins = null; + var rethrow = true; // Each invocation of `run` requires a tick. When an asynchronous effect is // resolved, we must check that the local tick coincides with the fiber @@ -368,11 +366,19 @@ var Aff = function () { case FORK: status = STEP_BIND; - result = makeChildFiber(step._2); + tmp = Fiber(util, supervisor, step._2); + if (supervisor) { + supervisor.register(tmp); + } if (step._1) { - result.run(); + tmp.run(); } - step = result; + step = tmp; + break; + + case SEQ: + status = CONTINUE; + step = sequential(util, supervisor, step._1); break; } break; @@ -382,7 +388,7 @@ var Aff = function () { // resume or finalizers to run, the fiber has halted and we can // invoke all join callbacks. Otherwise we need to resume. if (attempts === null) { - status = KILLALL; + status = COMPLETED; step = interrupt || fail || step; } else { attempt = attempts._1; @@ -469,23 +475,9 @@ var Aff = function () { } break; - case KILLALL: - if (forkCount === 0) { - status = COMPLETED; - } else { - killChildFibers(function () { - Scheduler.enqueue(function () { - status = COMPLETED; - run(++runTick); - }); - })(); - return; - } - break; - case COMPLETED: for (var k in joins) { - if ({}.hasOwnProperty.call(joins, k)) { + if (joins.hasOwnProperty(k)) { rethrow = rethrow && joins[k].rethrow; runEff(joins[k].handler(step)); } @@ -548,8 +540,6 @@ var Aff = function () { })(); switch (status) { - case KILLALL: - break; case SUSPENDED: interrupt = util.left(error); status = COMPLETED; @@ -620,7 +610,7 @@ var Aff = function () { }; } - function runPar(util, par, cb) { + function runPar(util, supervisor, par, cb) { // Table of all forked fibers. var fiberId = 0; var fibers = {}; @@ -873,12 +863,15 @@ var Aff = function () { status = RETURN; tmp = step; step = new Aff(FORKED, fid, new Aff(CONS, head, tail), EMPTY); - tmp = makeFiber(util, tmp); + tmp = Fiber(util, supervisor, tmp); tmp.onComplete({ rethrow: false, handler: resolve(step) })(); fibers[fid] = tmp; + if (supervisor) { + supervisor.register(tmp); + } } break; case RETURN: @@ -921,7 +914,7 @@ var Aff = function () { interrupt = util.left(error); for (var kid in kills) { - if ({}.prototype.hasOwnProperty.call(kills, kid)) { + if (kills.hasOwnProperty(kid)) { kills[kid](); } } @@ -933,7 +926,7 @@ var Aff = function () { return new Aff(ASYNC, function (killCb) { return function () { for (var kid in newKills) { - if ({}.prototype.hasOwnProperty.call(newKills, kid)) { + if (newKills.hasOwnProperty(kid)) { newKills[kid](); } } @@ -954,21 +947,31 @@ var Aff = function () { }; } - Aff.EMPTY = EMPTY; - Aff.Pure = AffCtr(PURE); - Aff.Throw = AffCtr(THROW); - Aff.Catch = AffCtr(CATCH); - Aff.Sync = AffCtr(SYNC); - Aff.Async = AffCtr(ASYNC); - Aff.Bind = AffCtr(BIND); - Aff.Bracket = AffCtr(BRACKET); - Aff.Fork = AffCtr(FORK); - Aff.ParMap = AffCtr(MAP); - Aff.ParApply = AffCtr(APPLY); - Aff.ParAlt = AffCtr(ALT); - Aff.makeFiber = makeFiber; - Aff.runPar = runPar; - Aff.Scheduler = Scheduler; + function sequential(util, supervisor, par) { + return new Aff(ASYNC, function (cb) { + return function () { + return runPar(util, supervisor, par, cb); + }; + }); + } + + Aff.EMPTY = EMPTY; + Aff.Pure = AffCtr(PURE); + Aff.Throw = AffCtr(THROW); + Aff.Catch = AffCtr(CATCH); + Aff.Sync = AffCtr(SYNC); + Aff.Async = AffCtr(ASYNC); + Aff.Bind = AffCtr(BIND); + Aff.Bracket = AffCtr(BRACKET); + Aff.Fork = AffCtr(FORK); + Aff.Seq = AffCtr(SEQ); + Aff.ParMap = AffCtr(MAP); + Aff.ParApply = AffCtr(APPLY); + Aff.ParAlt = AffCtr(ALT); + Aff.Fiber = Fiber; + Aff.Supervisor = Supervisor; + Aff.Scheduler = Scheduler; + Aff.nonCanceler = nonCanceler; return Aff; }(); @@ -1039,10 +1042,70 @@ exports.generalBracket = function (acquire) { exports._makeFiber = function (util, aff) { return function () { - return Aff.makeFiber(util, aff); + return Aff.Fiber(util, null, aff); }; }; +exports._supervise = function (util, aff) { + return Aff.Async(function (cb) { + return function () { + var supervisor = Aff.Supervisor(util); + var fiber = Aff.Fiber(util, supervisor, aff); + var killing = false; + var cancelCb = fiber.onComplete({ + rethrow: false, + handler: function (result) { + return function () { + killing = true; + supervisor.killAll(new Error("[Aff] Child fiber outlived parent"), cb(result)); + }; + } + })(); + + fiber.run(); + + return function (killError) { + return Aff.Async(function (killCb) { + return function () { + if (killing) { + return Aff.nonCanceler; + } + cancelCb(); + + var killResult = null; + var killedAll = false; + + var canceler1 = fiber.kill(killError, function (result) { + return function () { + if (killedAll) { + killCb(result)(); + } else { + killResult = result; + } + }; + })(); + + var canceler2 = supervisor.killAll(killError, function () { + if (killResult) { + killCb(killResult)(); + } else { + killedAll = true; + } + }); + + return function (/* unused */) { + return Aff.Sync(function () { + canceler1(); + canceler2(); + }); + }; + }; + }); + }; + }; + }); +}; + exports._delay = function () { function setDelay(n, k) { if (n === 0 && typeof setImmediate !== "undefined") { @@ -1074,10 +1137,4 @@ exports._delay = function () { }; }(); -exports._sequential = function(util, par) { - return Aff.Async(function (cb) { - return function () { - return Aff.runPar(util, par, cb); - }; - }); -}; +exports._sequential = Aff.Seq; diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index b4506e8..2592155 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -10,9 +10,8 @@ module Control.Monad.Aff , runAff_ , forkAff , suspendAff - , spawnAff - , spawnSuspendedAff , liftEff' + , supervise , attempt , delay , never @@ -137,7 +136,7 @@ instance alternativeParAff ∷ Alternative (ParAff e) instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a) - sequential a = Fn.runFn2 _sequential ffiUtil a + sequential = _sequential type OnComplete eff a = { rethrow ∷ Boolean @@ -212,25 +211,21 @@ runAff k aff = launchAff $ liftEff <<< k =<< try aff runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit runAff_ k aff = void $ runAff k aff --- | Forks a supervised `Aff` from within a parent `Aff` context, returning the --- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it --- | has not completed. -forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`. +forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) forkAff = _fork true --- | Suspends a supervised `Aff` from within a parent `Aff` context, returning --- | the `Fiber`. A suspended `Fiber` does not execute until requested, via --- | `joinFiber`. -suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) +-- | Suspends n `Aff` from within a parent `Aff` context, returning the `Fiber`. +-- | A suspended `Aff` is not executed until a consumer observes the result +-- | with `joinFiber`. +suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) suspendAff = _fork false --- | Forks an unsupervised `Aff`, returning the `Fiber`. -spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -spawnAff = liftEff <<< launchAff - --- | Suspends an unsupervised `Aff`, returning the `Fiber`. -spawnSuspendedAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) -spawnSuspendedAff = liftEff <<< launchSuspendedAff +-- | Creates a new supervision context for some `Aff`, guaranteeing fiber +-- | cleanup when the parent completes. Any pending fibers forked within +-- | the context will be killed and have their cancelers run. +supervise ∷ ∀ eff a. Aff eff a → Aff eff a +supervise aff = Fn.runFn2 _supervise ffiUtil aff -- | Pauses the running fiber. delay ∷ ∀ eff. Milliseconds → Aff eff Unit @@ -299,6 +294,8 @@ foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a)) +foreign import _supervise ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Aff eff a) +foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a type BracketConditions eff a b = { killed ∷ Error → a → Aff eff Unit @@ -320,13 +317,6 @@ foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff -foreign import _sequential - ∷ ∀ eff a - . Fn.Fn2 - FFIUtil - (ParAff eff a) - (Aff eff a) - newtype FFIUtil = FFIUtil { isLeft ∷ ∀ a b. Either a b → Boolean , fromLeft ∷ ∀ a b. Either a b → a diff --git a/test/Test/Main.purs b/test/Test/Main.purs index def2bd4..93ad5fb 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -3,7 +3,7 @@ module Test.Main where import Prelude import Control.Alt ((<|>)) -import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never) +import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never, supervise) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -324,9 +324,8 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do , "foo/bar/run/release/bar/release" ] --- You monster!! -test_kill_child ∷ ∀ eff. TestAff eff Unit -test_kill_child = assert "kill/child" do +test_kill_supervise ∷ ∀ eff. TestAff eff Unit +test_kill_supervise = assert "kill/supervise" do ref ← newRef "" let action s = generalBracket @@ -338,13 +337,15 @@ test_kill_child = assert "kill/child" do (\_ -> do delay (Milliseconds 10.0) modifyRef ref (_ <> "child" <> s)) - fiber ← forkAff do + fiber ← forkAff $ supervise do _ ← forkAff $ action "foo" _ ← forkAff $ action "bar" delay (Milliseconds 5.0) modifyRef ref (_ <> "parent") + delay (Milliseconds 1.0) + killFiber (error "nope") fiber delay (Milliseconds 20.0) - eq "acquirefooacquirebarparentkillfookillbar" <$> readRef ref + eq "acquirefooacquirebarkillfookillbar" <$> readRef ref test_parallel ∷ ∀ eff. TestAff eff Unit test_parallel = assert "parallel" do @@ -509,7 +510,7 @@ main = do test_kill_canceler test_kill_bracket test_kill_bracket_nested - test_kill_child + test_kill_supervise test_parallel test_kill_parallel test_parallel_alt From ae7a9f7564d3ad47bfeafa9db93593ca94989fa9 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 16 Aug 2017 15:28:55 -0700 Subject: [PATCH 30/35] Implement supervise with generalBracket --- src/Control/Monad/Aff.js | 136 +++++++++++++------------------------ src/Control/Monad/Aff.purs | 45 +++++++++--- 2 files changed, 82 insertions(+), 99 deletions(-) diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js index deb5ec4..bd209c7 100644 --- a/src/Control/Monad/Aff.js +++ b/src/Control/Monad/Aff.js @@ -168,45 +168,47 @@ var Aff = function () { return count === 0; }, killAll: function (killError, cb) { - var killCount = 0; - var kills = {}; + return function () { + var killCount = 0; + var kills = {}; - function kill(fid) { - kills[fid] = fibers[fid].kill(killError, function (result) { - return function () { - delete kills[fid]; - killCount--; - if (util.isLeft(result) && util.fromLeft(result)) { - setTimeout(function () { - throw util.fromLeft(result); - }, 0); - } - if (killCount === 0) { - cb(); - } - }; - })(); - } + function kill(fid) { + kills[fid] = fibers[fid].kill(killError, function (result) { + return function () { + delete kills[fid]; + killCount--; + if (util.isLeft(result) && util.fromLeft(result)) { + setTimeout(function () { + throw util.fromLeft(result); + }, 0); + } + if (killCount === 0) { + cb(); + } + }; + })(); + } - for (var k in fibers) { - if (fibers.hasOwnProperty(k)) { - killCount++; - kill(k); + for (var k in fibers) { + if (fibers.hasOwnProperty(k)) { + killCount++; + kill(k); + } } - } - fibers = {}; - fiberId = 0; - count = 0; + fibers = {}; + fiberId = 0; + count = 0; - return function (error) { - return new Aff(SYNC, function () { - for (var k in kills) { - if (kills.hasOwnProperty(k)) { - kills[k](); + return function (error) { + return new Aff(SYNC, function () { + for (var k in kills) { + if (kills.hasOwnProperty(k)) { + kills[k](); + } } - } - }); + }); + }; }; } }; @@ -1046,64 +1048,18 @@ exports._makeFiber = function (util, aff) { }; }; -exports._supervise = function (util, aff) { - return Aff.Async(function (cb) { - return function () { - var supervisor = Aff.Supervisor(util); - var fiber = Aff.Fiber(util, supervisor, aff); - var killing = false; - var cancelCb = fiber.onComplete({ - rethrow: false, - handler: function (result) { - return function () { - killing = true; - supervisor.killAll(new Error("[Aff] Child fiber outlived parent"), cb(result)); - }; - } - })(); - - fiber.run(); - - return function (killError) { - return Aff.Async(function (killCb) { - return function () { - if (killing) { - return Aff.nonCanceler; - } - cancelCb(); - - var killResult = null; - var killedAll = false; - - var canceler1 = fiber.kill(killError, function (result) { - return function () { - if (killedAll) { - killCb(result)(); - } else { - killResult = result; - } - }; - })(); - - var canceler2 = supervisor.killAll(killError, function () { - if (killResult) { - killCb(killResult)(); - } else { - killedAll = true; - } - }); - - return function (/* unused */) { - return Aff.Sync(function () { - canceler1(); - canceler2(); - }); - }; - }; - }); - }; +exports._makeSupervisedFiber = function (util, aff) { + return function () { + var supervisor = Aff.Supervisor(util); + return { + fiber: Aff.Fiber(util, supervisor, aff), + supervisor: supervisor }; - }); + }; +}; + +exports._killAll = function (error, supervisor, cb) { + return supervisor.killAll(error, cb); }; exports._delay = function () { diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 2592155..784d47a 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -193,8 +193,8 @@ nonCanceler = Canceler (const (pure unit)) -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`. launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) launchAff aff = do - fiber@(Fiber { run }) ← makeFiber aff - run + fiber ← makeFiber aff + case fiber of Fiber f → f.run pure fiber -- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`. @@ -221,12 +221,6 @@ forkAff = _fork true suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) suspendAff = _fork false --- | Creates a new supervision context for some `Aff`, guaranteeing fiber --- | cleanup when the parent completes. Any pending fibers forked within --- | the context will be killed and have their cancelers run. -supervise ∷ ∀ eff a. Aff eff a → Aff eff a -supervise aff = Fn.runFn2 _supervise ffiUtil aff - -- | Pauses the running fiber. delay ∷ ∀ eff. Milliseconds → Aff eff Unit delay (Milliseconds n) = Fn.runFn2 _delay Right n @@ -282,6 +276,38 @@ bracket acquire completed = , completed: const completed } +type Supervised eff a = + { fiber ∷ Fiber eff a + , supervisor ∷ Supervisor eff + } + +-- | Creates a new supervision context for some `Aff`, guaranteeing fiber +-- | cleanup when the parent completes. Any pending fibers forked within +-- | the context will be killed and have their cancelers run. +supervise ∷ ∀ eff a. Aff eff a → Aff eff a +supervise aff = + generalBracket (liftEff acquire) + { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ] + , failed: const (killAll killError) + , completed: const (killAll killError) + } + (joinFiber <<< _.fiber) + where + killError ∷ Error + killError = + error "[Aff] Child fiber outlived parent" + + killAll ∷ Error → Supervised eff a → Aff eff Unit + killAll err sup = makeAff \k → + Fn.runFn3 _killAll err sup.supervisor (k (pure unit)) + + acquire ∷ Eff eff (Supervised eff a) + acquire = do + sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff + case sup.fiber of Fiber f → f.run + pure sup + +foreign import data Supervisor ∷ # Effect → Type 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 @@ -294,7 +320,8 @@ foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a)) -foreign import _supervise ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Aff eff a) +foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a)) +foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff)) foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a type BracketConditions eff a b = From 200f2fe3e2fb8be457be3b1560f7e70b37d95bde Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 17 Aug 2017 14:18:48 -0700 Subject: [PATCH 31/35] Add launchAff_ and runSuspendedAff --- src/Control/Monad/Aff.purs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs index 784d47a..e81912e 100644 --- a/src/Control/Monad/Aff.purs +++ b/src/Control/Monad/Aff.purs @@ -5,9 +5,11 @@ module Control.Monad.Aff , Canceler(..) , makeAff , launchAff + , launchAff_ , launchSuspendedAff , runAff , runAff_ + , runSuspendedAff , forkAff , suspendAff , liftEff' @@ -146,10 +148,10 @@ type OnComplete eff a = -- | Represents a forked computation by way of `forkAff`. `Fiber`s are -- | memoized, so their results are only computed once. newtype Fiber eff a = Fiber - { kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit)) + { run ∷ Eff eff Unit + , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit)) , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit) , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit) - , run ∷ Eff eff Unit } instance functorFiber ∷ Functor (Fiber eff) where @@ -197,6 +199,10 @@ launchAff aff = do case fiber of Fiber f → f.run pure fiber +-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`. +launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit +launchAff_ = void <<< launchAff + -- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`. launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a) launchSuspendedAff = makeFiber @@ -211,11 +217,16 @@ runAff k aff = launchAff $ liftEff <<< k =<< try aff runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit runAff_ k aff = void $ runAff k aff +-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run +-- | when it completes. Returns the suspended `Fiber`. +runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit) +runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff + -- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`. forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) forkAff = _fork true --- | Suspends n `Aff` from within a parent `Aff` context, returning the `Fiber`. +-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`. -- | A suspended `Aff` is not executed until a consumer observes the result -- | with `joinFiber`. suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a) From 59fd52dcc3f3835a59030ffb695d15ad2f8db50b Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 17 Aug 2017 14:18:59 -0700 Subject: [PATCH 32/35] Update README --- README.md | 246 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 144 insertions(+), 102 deletions(-) diff --git a/README.md b/README.md index 982f769..2046d30 100644 --- a/README.md +++ b/README.md @@ -3,22 +3,16 @@ [![Latest release](http://img.shields.io/github/release/slamdata/purescript-aff.svg)](https://github.com/slamdata/purescript-aff/releases) [![Build status](https://travis-ci.org/slamdata/purescript-aff.svg?branch=master)](https://travis-ci.org/slamdata/purescript-aff) -An asynchronous effect monad for PureScript. - -The moral equivalent of `ErrorT (ContT Unit (Eff e)) a`, for effects `e`. - -`Aff` lets you say goodbye to monad transformers and callback hell! +An asynchronous effect monad and threading model for PureScript. # Example ```purescript main = launchAff do response <- Ajax.get "http://foo.bar" - liftEff $ log response.body + log response.body ``` -See the [tests](https://github.com/slamdata/purescript-aff/blob/master/test/Test/Main.purs) for more examples. - # Getting Started ## Installation @@ -38,57 +32,84 @@ deleteBlankLines path = do saveFile path contents' ``` -This looks like ordinary, synchronous, imperative code, but actually operates asynchronously without any callbacks. Error handling is baked in so you only deal with it when you want to. +This looks like ordinary, synchronous, imperative code, but actually operates +asynchronously without any callbacks. Error handling is baked in so you only +deal with it when you want to. -The library contains instances for `Semigroup`, `Monoid`, `Apply`, `Applicative`, `Bind`, `Monad`, `Alt`, `Plus`, `MonadPlus`, `MonadEff`, and `MonadError`. These instances allow you to compose asynchronous code as easily as `Eff`, as well as interop with existing `Eff` code. +The library contains instances for `Semigroup`, `Monoid`, `Apply`, +`Applicative`, `Bind`, `Monad`, `Alt`, `Plus`, `MonadEff`, and `MonadError`. +These instances allow you to compose asynchronous code as easily as `Eff`, as +well as interop with existing `Eff` code. ## Escaping Callback Hell -Hopefully, you're using libraries that already use the `Aff` type, so you don't even have to think about callbacks! +Hopefully, you're using libraries that already use the `Aff` type, so you +don't even have to think about callbacks! -If you're building your own library, or you have to interact with some native code that expects callbacks, then *purescript-aff* provides a `makeAff` function: +If you're building your own library, then *purescript-aff* provides a +`makeAff` function: ```purescript -makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a +makeAff :: forall eff a. ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) -> Aff eff a ``` -This function expects you to provide a handler, which should call a user-supplied error callback or success callback with the result of the asynchronous computation. +This function expects you to provide a handler, which should call the +supplied callback with the result of the asynchronous computation. -For example, let's say we have an AJAX request function that expects a callback: +You should also return `Canceler`, which is just a cleanup effect. Since +`Aff` threads may be killed, all asynchronous operations should provide a +mechanism for unscheduling it. + +*purescript-aff* also provides functions for easily binding FFI definitions in +`Control.Monad.Aff.Compat`. ```javascript -exports.ajaxGet = function(callback) { // accepts a callback - return function(request) { // and a request - return function() { // returns an effect - doNativeRequest(request, function(response) { - callback(response)(); // callback itself returns an effect - }); - } - } -} +exports._ajaxGet = function (request) { // accepts a request + return function (onError, onSuccess) { // and callbacks + var req = doNativeRequest(request, function (err, response) { // make the request + if (err != null) { + onError(err); // invoke the error callback in case of an error + } else { + onSuccess(response); // invoke the success callback with the reponse + } + }); + + // Return a canceler, which is just another Aff effect. + return function (cancelError) { + return function (cancelerError, cancelerSuccess) { + req.cancel(); // cancel the request + cancelerSuccess(); // invoke the success callback for the canceler + }; + }; + }; +}; ``` ```purescript -foreign import ajaxGet :: forall e. (Response -> Eff e Unit) -> Request -> Eff e Unit +foreign import _ajaxGet :: forall eff. Request -> EffFnAff (ajax :: AJAX | eff) Response ``` We can wrap this into an asynchronous computation like so: ```purescript -ajaxGet' :: forall e. Request -> Aff e Response -ajaxGet' req = makeAff (\error success -> ajaxGet success req) +ajaxGet :: forall eff. Request -> Aff (ajax :: AJAX | eff) Response +ajaxGet = fromEffFnAff <<< _ajaxGet ``` -This eliminates callback hell and allows us to write code simply using `do` notation: +This eliminates callback hell and allows us to write code simply using `do` +notation: ```purescript -do response <- ajaxGet' req - liftEff $ log response.body +example = do + response <- ajaxGet req + log response.body ``` ## Eff -All purely synchronous computations (`Eff`) can be lifted to asynchronous computations with `liftEff` defined in `Control.Monad.Eff.Class` (see [here](https://github.com/purescript/purescript-eff)). +All purely synchronous computations (`Eff`) can be lifted to asynchronous +computations with `liftEff` defined in `Control.Monad.Eff.Class` (see +[here](https://github.com/purescript/purescript-eff)). ```purescript import Control.Monad.Eff.Class @@ -96,67 +117,72 @@ import Control.Monad.Eff.Class liftEff $ log "Hello world!" ``` -This lets you write your whole program in `Aff`, and still call out to synchronous code. - -If your `Eff` code throws exceptions (`err :: Exception`), you can remove the exceptions using `liftEff'`, which brings exceptions to the value level as an `Either Error a`: +This lets you write your whole program in `Aff`, and still call out to +synchronous code. -```purescript -do e <- liftEff' myExcFunc - liftEff $ either (const $ log "Oh noes!") (const $ log "Yays!") e -``` +If your `Eff` code throws exceptions (`err :: Exception`), you can remove the +exception label using `liftEff'`. Exceptions are part of `Aff`s built-in +semantics, so they will always be caught and propagated anyway. ## Dealing with Failure -The `Aff` monad has error handling baked in, so ordinarily you don't have to worry about it. +`Aff` has error handling baked in, so ordinarily you don't have to worry +about it. -When you need to deal with failure, you have several options. +When you need to deal with failure, you have a few options. - 1. **Attempt** - 2. **Alt** - 3. **MonadError** + 1. **Alt** + 2. **MonadError** + 3. **Bracketing** -#### 1. Attempt +#### 1. Alt -If you want to attempt a computation but recover from failure, you can use the `attempt` function: +Because `Aff` has an `Alt` instance, you may also use the operator `<|>` to +provide an alternative computation in the event of failure: ```purescript -attempt :: forall e a. Aff e a -> Aff e (Either Error a) +example = do + result <- Ajax.get "http://foo.com" <|> Ajax.get "http://bar.com" + pure result ``` -This returns an `Either Error a` that you can use to recover from failure. - -```purescript -do e <- attempt $ Ajax.get "http://foo.com" - liftEff $ either (const $ log "Oh noes!") (const $ log "Yays!") e -``` +#### 2. MonadError -#### 2. Alt +`Aff` has a `MonadError` instance, which comes with two functions: +`catchError`, and `throwError`. -Because `Aff` has an `Alt` instance, you may also use the operator `<|>` to provide an alternative computation in the event of failure: +These are defined in +[purescript-transformers](http://github.com/purescript/purescript-transformers). +Here's an example of how you can use them: ```purescript -do result <- Ajax.get "http://foo.com" <|> Ajax.get "http://bar.com" - return result +example = do + resp <- Ajax.get "http://foo.com" `catchError` \_ -> pure defaultResponse + when (resp.statusCode /= 200) do + throwError myErr + pure resp.body ``` -#### 3. MonadError - -`Aff` has a `MonadError` instance, which comes with two functions: `catchError`, and `throwError`. +#### 3. Bracketing -These are defined in [purescript-transformers](http://github.com/purescript/purescript-transformers). -Here's an example of how you can use them: +`Aff` threads can be cancelled, but sometimes we need to guarantee an action +gets run even in the presence of exceptions or cancellation. Use `bracket` to +acquire resources and clean them up. ```purescript -do resp <- (Ajax.get "http://foo.com") `catchError` (const $ pure defaultResponse) - if resp.statusCode != 200 then throwError myErr - else pure resp.body +example = + bracket + (openFile myFile) + (\file -> closeFile file) + (\file -> appendFile "hello" file) ``` -Thrown exceptions are propagated on the error channel, and can be recovered from using `attempt` or `catchError`. +In this case, `closeFile` will always be called regardless of exceptions once +`openFile` completes. ## Forking -Using the `forkAff`, you can "fork" an asynchronous computation, which means +Using `forkAff`, you can "fork" an asynchronous computation, which means that its activities will not block the current thread of execution: ```purescript @@ -167,66 +193,82 @@ Because Javascript is single-threaded, forking does not actually cause the computation to be run in a separate thread. Forking just allows the subsequent actions to execute without waiting for the forked computation to complete. -If the asynchronous computation supports it, you can "kill" a forked computation -using the returned canceler: +Forking returns a `Fiber eff a`, representing the deferred computation. You can +kill a `Fiber` with `killFiber`, which will run any cancelers and cleanup, and +you can observe a `Fiber`'s final value with `joinFiber`. If a `Fiber` threw +an exception, it will be rethrown upon joining. ```purescript -canceler <- forkAff myAff -canceled <- canceler `cancel` (error "Just had to cancel") -_ <- liftEff $ if canceled then (log "Canceled") else (log "Not Canceled") +example = do + fiber <- forkAff myAff + killFiber (error "Just had to cancel") fiber + result <- try (joinFiber fiber) + if isLeft result + then (log "Canceled") + else (log "Not Canceled") ``` -If you want to run a custom canceler if some other asynchronous computation is -cancelled, you can use the `cancelWith` combinator: - -```purescript -otherAff `cancelWith` myCanceler -``` ## AVars -The `Control.Monad.Aff.AVar` module contains asynchronous variables, which are very similar to Haskell's `MVar` construct. These can be used as low-level building blocks for asynchronous programs. +The `Control.Monad.Aff.AVar` module contains asynchronous variables, which +are very similar to Haskell's `MVar`. These can be used as low-level building +blocks for asynchronous programs. ```purescript -do v <- makeVar - forkAff do - delay (Milliseconds 50.0) - putVar v 1.0 - a <- takeVar v - liftEff $ log ("Succeeded with " ++ show a) +example = d + v <- makeEmptyVar + _ <- forkAff do + delay (Milliseconds 50.0) + putVar v 1.0 + a <- takeVar v + log ("Succeeded with " <> show a) ``` -You can use these constructs as one-sided blocking queues, which suspend (if -necessary) on `take` operations, or as asynchronous, empty-or-full variables. - ## Parallel Execution -There are `MonadPar` and `MonadRace` instances defined for `Aff`, allowing for parallel execution of `Aff` computations. - -There are two ways of taking advantage of these instances - directly through the `par` and `race` functions from these classes, or by using the `Parallel` newtype wrapper that enables parallel behaviours through the `Applicative` and `Alternative` operators. +The `Parallel` instance for `Aff` makes writing parallel computations a breeze. -In the following example, using the newtype, two Ajax requests are initiated simultaneously (rather than in sequence, as they would be for `Aff`): +Using `parallel` from `Control.Parallel` will turn a regular `Aff` into +`ParAff`. `ParAff` has an `Applicative` instance which will run effects in +parallel, and an `Alternative` instance which will race effects, returning the +one which completes first (canceling the others). To get an `Aff` back, just +run it with `sequential`. ```purescript -runParallel (f <$> parallel (Ajax.get "http://foo.com") <*> parallel (Ajax.get "http://foo.com")) +-- Make two requests in parallel +example = + sequential $ + Tuple <$> parallel (Ajax.get "https://foo.com") + <*> parallel (Ajax.get "https://bar.com") ``` -And the equivalent using the `MonadPar` function directly: - ```purescript -par f (Ajax.get "http://foo.com") (Ajax.get "http://foo.com") +-- Make a request with a 3 second timeout +example = + sequential $ oneOf + [ parallel (Just <$> Ajax.get "https://foo.com") + , parallel (Nothing <$ delay (Milliseconds 3000.0)) + ] ``` -The `race` function from `MonadPar` or the `(<|>)` operator of the `Alt` instance of `Parallel` allows you to race two asynchronous computations, and use whichever value comes back first (or the first error, if both err). +```purescript +tvShows = + [ "Stargate_SG-1" + , "Battlestar_Galactics" + , "Farscape" + ] + +getPage page = + Ajax.get $ "https://wikipedia.org/wiki/" <> page -The `runParallel` function allows you to unwrap the `Aff` and return to normal monadic (sequential) composition. +-- Get all pages in parallel +allPages = parTraverse getPage tvShows -A parallel computation can be canceled if both of its individual components can be canceled. +-- Get the page that loads the fastest +fastestPage = parOneOfMap getPage tvShows +``` # API Docs API documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-aff). - -# See also - -[A good overview of Aff](https://github.com/degoes-consulting/lambdaconf-2015/blob/master/speakers/jdegoes/async-purescript/presentation.pdf) was provided during LambdaConf 2015 conference From 047eb550301dd97096e26ce0fbdc4413f12341b9 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 17 Aug 2017 21:03:34 -0700 Subject: [PATCH 33/35] Fix effect typo --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 2046d30..ee4d1f0 100644 --- a/README.md +++ b/README.md @@ -120,9 +120,9 @@ liftEff $ log "Hello world!" This lets you write your whole program in `Aff`, and still call out to synchronous code. -If your `Eff` code throws exceptions (`err :: Exception`), you can remove the -exception label using `liftEff'`. Exceptions are part of `Aff`s built-in -semantics, so they will always be caught and propagated anyway. +If your `Eff` code throws exceptions (`exception :: EXCEPTION`), you can +remove the exception label using `liftEff'`. Exceptions are part of `Aff`s +built-in semantics, so they will always be caught and propagated anyway. ## Dealing with Failure From 7576856ace7f31349c5e8aede93860500aa942ed Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 18 Aug 2017 15:20:24 -0700 Subject: [PATCH 34/35] Add a few more tests --- test/Test/Main.purs | 44 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 93ad5fb..c554407 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -257,6 +257,25 @@ test_general_bracket = assert "bracket/general" do r4 ← readRef ref pure (isLeft r1 && isLeft r2 && isRight r3 && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release/c") +test_supervise ∷ ∀ eff. TestAff eff Unit +test_supervise = assert "supervise" do + ref ← newRef "" + r1 ← supervise do + _ ← forkAff do + bracket + (modifyRef ref (_ <> "acquire")) + (\_ → modifyRef ref (_ <> "release")) + (\_ → delay (Milliseconds 10.0)) + _ ← forkAff do + delay (Milliseconds 11.0) + modifyRef ref (_ <> "delay") + delay (Milliseconds 5.0) + modifyRef ref (_ <> "done") + pure "done" + delay (Milliseconds 20.0) + r2 ← readRef ref + pure (r1 == "done" && r2 == "acquiredonerelease") + test_kill ∷ ∀ eff. TestAff eff Unit test_kill = assert "kill" do fiber ← forkAff never @@ -401,7 +420,7 @@ test_parallel_alt = assert "parallel/alt" do pure (r1 == "bar" && r2 == "bar") test_parallel_alt_sync ∷ ∀ eff. TestAff eff Unit -test_parallel_alt_sync = assert "kill/parallel/alt/sync" do +test_parallel_alt_sync = assert "parallel/alt/sync" do ref ← newRef "" let action s = do @@ -416,6 +435,27 @@ test_parallel_alt_sync = assert "kill/parallel/alt/sync" do r2 ← readRef ref pure (r1 == "foo" && r2 == "fookilledfoo") +test_parallel_mixed ∷ ∀ eff. TestAff eff Unit +test_parallel_mixed = assert "parallel/mixed" do + ref ← newRef "" + let + action n s = parallel do + delay (Milliseconds n) + modifyRef ref (_ <> s) + pure s + { r1, r2, r3 } ← sequential $ + { r1: _, r2: _, r3: _ } + <$> action 10.0 "a" + <*> (action 15.0 "a" + <|> action 12.0 "b" + <|> action 16.0 "c") + <*> (action 15.0 "a" + <|> ((<>) <$> action 13.0 "d" <*> action 14.0 "e") + <|> action 16.0 "f") + delay (Milliseconds 20.0) + r4 ← readRef ref + pure (r1 == "a" && r2 == "b" && r3 == "de" && r4 == "abde") + test_kill_parallel_alt ∷ ∀ eff. TestAff eff Unit test_kill_parallel_alt = assert "kill/parallel/alt" do ref ← newRef "" @@ -506,6 +546,7 @@ main = do test_bracket test_bracket_nested test_general_bracket + test_supervise test_kill test_kill_canceler test_kill_bracket @@ -515,6 +556,7 @@ main = do test_kill_parallel test_parallel_alt test_parallel_alt_sync + test_parallel_mixed test_kill_parallel_alt test_fiber_map test_fiber_apply From 69bf7edd72f3bed998a31b40d7632a02873f3d01 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 18 Aug 2017 16:23:26 -0700 Subject: [PATCH 35/35] README edits --- README.md | 64 +++++++++++++++++++++++++++++++-------------- test/Test/Main.purs | 17 +++++++++++- 2 files changed, 61 insertions(+), 20 deletions(-) diff --git a/README.md b/README.md index ee4d1f0..cc7a1b7 100644 --- a/README.md +++ b/README.md @@ -37,17 +37,17 @@ asynchronously without any callbacks. Error handling is baked in so you only deal with it when you want to. The library contains instances for `Semigroup`, `Monoid`, `Apply`, -`Applicative`, `Bind`, `Monad`, `Alt`, `Plus`, `MonadEff`, and `MonadError`. -These instances allow you to compose asynchronous code as easily as `Eff`, as -well as interop with existing `Eff` code. +`Applicative`, `Bind`, `Monad`, `Alt`, `Plus`, `MonadEff`, `MonadError`, and +`Parallel`. These instances allow you to compose asynchronous code as easily +as `Eff`, as well as interop with existing `Eff` code. ## Escaping Callback Hell Hopefully, you're using libraries that already use the `Aff` type, so you don't even have to think about callbacks! -If you're building your own library, then *purescript-aff* provides a -`makeAff` function: +If you're building your own library, then you can make an `Aff` from +low-level `Eff` callbacks with `makeAff`. ```purescript makeAff :: forall eff a. ((Either Error a -> Eff eff Unit) -> Eff eff (Canceler eff)) -> Aff eff a @@ -60,8 +60,8 @@ You should also return `Canceler`, which is just a cleanup effect. Since `Aff` threads may be killed, all asynchronous operations should provide a mechanism for unscheduling it. -*purescript-aff* also provides functions for easily binding FFI definitions in -`Control.Monad.Aff.Compat`. +`Control.Monad.Aff.Compat` provides functions for easily binding FFI +definitions: ```javascript exports._ajaxGet = function (request) { // accepts a request @@ -108,12 +108,9 @@ example = do ## Eff All purely synchronous computations (`Eff`) can be lifted to asynchronous -computations with `liftEff` defined in `Control.Monad.Eff.Class` (see -[here](https://github.com/purescript/purescript-eff)). +computations with `liftEff` defined in `Control.Monad.Eff.Class`. ```purescript -import Control.Monad.Eff.Class - liftEff $ log "Hello world!" ``` @@ -212,18 +209,47 @@ example = do ## AVars The `Control.Monad.Aff.AVar` module contains asynchronous variables, which -are very similar to Haskell's `MVar`. These can be used as low-level building -blocks for asynchronous programs. +are very similar to Haskell's `MVar`. + +`AVar`s represent a value that is either full or empty. Calling `takeVar` on +an empty `AVar` will queue until it is filled by a matching `putVar`. ```purescript -example = d - v <- makeEmptyVar +example = do + var <- makeEmptyVar + _ <- forkAff do + value <- takeVar var + log $ "Got a value: " <> value _ <- forkAff do - delay (Milliseconds 50.0) - putVar v 1.0 - a <- takeVar v - log ("Succeeded with " <> show a) + delay (Milliseconds 100.0) + putVar var "hello" + pure unit ``` +``` +(Waits 100ms) +> Got a value: hello +``` + +Likewise, calling `putVar` will queue until it is taken: + +```purescript +example = do + var <- makeEmptyVar + _ <- forkAff do + delay (Milliseconds 100.0) + value <- takeVar var + log $ "Got a value: " <> value + putVar var "hello" + log "Value taken" +``` +``` +(Waits 100ms) +> Value taken +> Got a value: hello +``` + +These combinators (and a few more) can be used as the building blocks for +complex asynchronous coordination. ## Parallel Execution diff --git a/test/Test/Main.purs b/test/Test/Main.purs index c554407..831e4eb 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -4,6 +4,7 @@ import Prelude import Control.Alt ((<|>)) import Control.Monad.Aff (Aff, Canceler(..), runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never, supervise) +import Control.Monad.Aff.AVar (AVAR, makeEmptyVar, takeVar, putVar) import Control.Monad.Eff (Eff, runPure) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Console (CONSOLE) @@ -24,7 +25,7 @@ import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (traverse) import Test.Assert (assert', ASSERT) -type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION | eff) +type TestEffects eff = (assert ∷ ASSERT, console ∷ CONSOLE, ref ∷ REF, exception ∷ EXCEPTION, avar ∷ AVAR | eff) type TestEff eff = Eff (TestEffects eff) type TestAff eff = Aff (TestEffects eff) @@ -514,6 +515,19 @@ test_fiber_apply = assert "fiber/apply" do n ← readRef ref pure (a == 22 && b == 22 && n == 1) +test_avar_order ∷ ∀ eff. TestAff eff Unit +test_avar_order = assert "avar/order" do + ref ← newRef "" + var ← makeEmptyVar + f1 ← forkAff do + delay (Milliseconds 10.0) + value ← takeVar var + modifyRef ref (_ <> value) + putVar var "foo" + modifyRef ref (_ <> "taken") + joinFiber f1 + eq "takenfoo" <$> readRef ref + test_parallel_stack ∷ ∀ eff. TestAff eff Unit test_parallel_stack = assert "parallel/stack" do ref ← newRef 0 @@ -558,6 +572,7 @@ main = do test_parallel_alt_sync test_parallel_mixed test_kill_parallel_alt + test_avar_order test_fiber_map test_fiber_apply -- Turn on if we decide to schedule forks