diff --git a/src/Effect/Aff.purs b/src/Effect/Aff.purs index 6dbef67..3e0bae5 100644 --- a/src/Effect/Aff.purs +++ b/src/Effect/Aff.purs @@ -1,402 +1,178 @@ -module Effect.Aff - ( Aff - , Fiber - , ParAff(..) - , Canceler(..) - , makeAff - , launchAff - , launchAff_ - , launchSuspendedAff - , runAff - , runAff_ - , runSuspendedAff - , forkAff - , suspendAff - , supervise - , attempt - , apathize - , delay - , never - , finally - , invincible - , killFiber - , joinFiber - , cancelWith - , bracket - , BracketConditions - , generalBracket - , nonCanceler - , effectCanceler - , fiberCanceler - , module Exports - ) where - -import Prelude - -import Control.Alt (class Alt) -import Control.Alternative (class Alternative) -import Control.Apply (lift2) -import Control.Lazy (class Lazy) -import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) -import Control.Monad.Error.Class (try, throwError, catchError) as Exports -import Control.Monad.Rec.Class (class MonadRec, Step(..)) -import Control.Parallel (parSequence_, parallel) -import Control.Parallel.Class (class Parallel) -import Control.Parallel.Class (sequential, parallel) as Exports -import Control.Plus (class Plus, empty) -import Data.Either (Either(..)) -import Data.Function.Uncurried as Fn -import Data.Newtype (class Newtype) -import Data.Time.Duration (Milliseconds(..)) -import Data.Time.Duration (Milliseconds(..)) as Exports -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Exception (Error, error) -import Effect.Exception (Error, error, message) as Exports -import Effect.Unsafe (unsafePerformEffect) -import Partial.Unsafe (unsafeCrashWith) -import Unsafe.Coerce (unsafeCoerce) - --- | An `Aff a` is an asynchronous computation with effects. The --- | computation may either error with an exception, or produce a result of --- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using --- | `makeAff` or `liftEffect`. -foreign import data Aff ∷ Type → Type - -instance functorAff ∷ Functor Aff where - map = _map - -instance applyAff ∷ Apply Aff where - apply = ap - -instance applicativeAff ∷ Applicative Aff where - pure = _pure - -instance bindAff ∷ Bind Aff where - bind = _bind - -instance monadAff ∷ Monad Aff - -instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where - append = lift2 append - -instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where - mempty = pure mempty - -instance altAff ∷ Alt Aff where - alt a1 a2 = catchError a1 (const a2) - -instance plusAff ∷ Plus Aff where - empty = throwError (error "Always fails") - --- | 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 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 where - throwError = _throwError - -instance monadErrorAff ∷ MonadError Error Aff where - catchError = _catchError - -instance monadEffectAff ∷ MonadEffect Aff where - liftEffect = _liftEffect - -instance lazyAff ∷ Lazy (Aff a) where - defer f = pure unit >>= f - --- | Applicative for running parallel effects. Any `Aff` can be coerced to a --- | `ParAff` and back using the `Parallel` class. -foreign import data ParAff ∷ Type → Type - -instance functorParAff ∷ Functor ParAff where - map = _parAffMap - --- | Runs effects in parallel, combining their results. -instance applyParAff ∷ Apply ParAff where - apply = _parAffApply - -instance applicativeParAff ∷ Applicative ParAff where - pure = parallel <<< pure - -instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where - append = lift2 append - -instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff 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 where - alt = _parAffAlt - -instance plusParAff ∷ Plus ParAff where - empty = parallel empty - -instance alternativeParAff ∷ Alternative ParAff - -instance parallelAff ∷ Parallel ParAff Aff where - parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a) - sequential = _sequential - -type OnComplete a = - { rethrow ∷ Boolean - , handler ∷ (Either Error a → Effect Unit) → Effect Unit - } - --- | Represents a forked computation by way of `forkAff`. `Fiber`s are --- | memoized, so their results are only computed once. -newtype Fiber a = Fiber - { run ∷ Effect Unit - , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit)) - , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit) - , onComplete ∷ OnComplete a → Effect (Effect Unit) - , isSuspended ∷ Effect Boolean - } - -instance functorFiber ∷ Functor Fiber where - map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t)) - -instance applyFiber ∷ Apply Fiber where - apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2)) - -instance applicativeFiber ∷ Applicative Fiber where - pure a = unsafePerformEffect (makeFiber (pure a)) - --- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks --- | until the fiber has fully exited. -killFiber ∷ ∀ a. Error → Fiber a → Aff Unit -killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _ - then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit)) - else makeAff \k → effectCanceler <$> 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 ∷ Fiber ~> Aff -joinFiber (Fiber t) = makeAff \k → effectCanceler <$> 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 --- | clean it up. -newtype Canceler = Canceler (Error → Aff Unit) - -derive instance newtypeCanceler ∷ Newtype Canceler _ - -instance semigroupCanceler ∷ Semigroup Canceler 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 where - mempty = nonCanceler - --- | A canceler which does not cancel anything. -nonCanceler ∷ Canceler -nonCanceler = Canceler (const (pure unit)) - --- | A canceler from an Effect action. -effectCanceler ∷ Effect Unit → Canceler -effectCanceler = Canceler <<< const <<< liftEffect - --- | A canceler from a Fiber. -fiberCanceler ∷ ∀ a. Fiber a → Canceler -fiberCanceler = Canceler <<< flip killFiber - --- | Forks an `Aff` from an `Effect` context, returning the `Fiber`. -launchAff ∷ ∀ a. Aff a → Effect (Fiber a) -launchAff aff = do - fiber ← makeFiber aff - case fiber of Fiber f → f.run - pure fiber - --- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`. -launchAff_ ∷ ∀ a. Aff a → Effect Unit -launchAff_ = void <<< launchAff - --- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`. -launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a) -launchSuspendedAff = makeFiber - --- | Forks an `Aff` from an `Effect` context and also takes a callback to run when --- | it completes. Returns the pending `Fiber`. -runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit) -runAff k aff = launchAff $ liftEffect <<< k =<< try aff - --- | Forks an `Aff` from an `Effect` context and also takes a callback to run when --- | it completes, discarding the `Fiber`. -runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit -runAff_ k aff = void $ runAff k aff - --- | Suspends an `Aff` from an `Effect` context and also takes a callback to run --- | when it completes. Returns the suspended `Fiber`. -runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit) -runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff - --- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`. -forkAff ∷ ∀ a. Aff a → Aff (Fiber a) -forkAff = _fork true - --- | 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 ∷ ∀ a. Aff a → Aff (Fiber a) -suspendAff = _fork false - --- | Pauses the running fiber. -delay ∷ Milliseconds → Aff Unit -delay (Milliseconds n) = Fn.runFn2 _delay Right n - --- | An async computation which does not resolve. -never ∷ ∀ a. Aff a -never = makeAff \_ → pure mempty - --- | A monomorphic version of `try`. Catches thrown errors and lifts them --- | into an `Either`. -attempt ∷ ∀ a. Aff a → Aff (Either Error a) -attempt = try - --- | Ignores any errors. -apathize ∷ ∀ a. Aff a → Aff 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 ∷ ∀ a. Aff Unit → Aff a → Aff a -finally fin a = bracket (pure unit) (const fin) (const a) - --- | Runs an effect such that it cannot be killed. -invincible ∷ ∀ a. Aff a → Aff a -invincible 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 ∷ ∀ a. Aff a → Canceler → Aff 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 --- | acquisition nor disposal may be cancelled and are guaranteed to run until --- | they complete. -bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b -bracket acquire completed = - generalBracket acquire - { killed: const completed - , failed: const completed - , completed: const completed - } - -type Supervised a = - { fiber ∷ Fiber a - , supervisor ∷ Supervisor - } - --- | 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 ∷ ∀ a. Aff a → Aff a -supervise aff = - generalBracket (liftEffect 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 a → Aff Unit - killAll err sup = makeAff \k → - Fn.runFn3 _killAll err sup.supervisor (k (pure unit)) - - acquire ∷ Effect (Supervised a) - acquire = do - sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff - case sup.fiber of Fiber f → f.run - pure sup - -foreign import data Supervisor ∷ Type -foreign import _pure ∷ ∀ a. a → Aff a -foreign import _throwError ∷ ∀ a. Error → Aff a -foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a -foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a) -foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b -foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b -foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit) -foreign import _liftEffect ∷ ∀ a. Effect a → Aff a -foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b -foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b -foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a -foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a)) -foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a)) -foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler) -foreign import _sequential ∷ ParAff ~> Aff - -type BracketConditions a b = - { killed ∷ Error → a → Aff Unit - , failed ∷ Error → a → Aff Unit - , completed ∷ b → a → Aff 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 ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b - --- | Constructs an `Aff` from low-level `Effect` 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 ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a - -makeFiber ∷ ∀ a. Aff a → Effect (Fiber a) -makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff - -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 - } - -ffiUtil ∷ FFIUtil -ffiUtil = FFIUtil - { isLeft - , fromLeft: unsafeFromLeft - , fromRight: unsafeFromRight - , left: Left - , 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 - Right _ → unsafeCrashWith "unsafeFromLeft: Right" - - unsafeFromRight ∷ ∀ a b. Either a b → b - unsafeFromRight = case _ of - Right a → a - Left _ → unsafeCrashWith "unsafeFromRight: Left" +module Effect.Aff + ( Aff + , Canceler + , BracketConditions + , Fiber + , ParAff + , makeAff + , launchAff + , launchAff_ + , launchSuspendedAff + , runAff + , runAff_ + , runSuspendedAff + , forkAff + , suspendAff + , supervise + , attempt + , apathize + , delay + , never + , finally + , invincible + , killFiber + , joinFiber + , liftEffect' + , unsafeLiftEffect + , cancelWith + , bracket + , generalBracket + , nonCanceler + , effectCanceler + , fiberCanceler + , module Exports + ) +where + +import Control.Monad.Error.Class (throwError) +import Control.Monad.Error.Class (try, throwError, catchError) as Exports +import Control.Parallel.Class (sequential, parallel) as Exports +import Data.Either (Either, either) +import Data.Time.Duration (Milliseconds(..)) as Exports +import Data.Time.Duration (Milliseconds) +import Effect (Effect) +import Effect.Aff.General as G +import Effect.Exception (Error) +import Effect.Exception (Error, error, message) as Exports +import Prelude (type (~>), Unit, map, pure, (<<<), (>=>)) + +type Aff = G.Aff Error + +type Canceler = G.Canceler + +type BracketConditions a b = G.BracketConditions Error a b + +type Fiber = G.Fiber Error + +type ParAff = G.ParAff Error + +generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b +generalBracket = G.generalBracket + +makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a +makeAff f = G.makeAff (\g → f (g <<< either G.Failed G.Succeeded)) + +-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks +-- | until the fiber has fully exited. +killFiber ∷ ∀ a. Error → Fiber a → Aff Unit +killFiber = G.killFiber + +-- | Blocks until the fiber completes, yielding the result. If the fiber +-- | throws an exception, it is rethrown in the current fiber. +joinFiber ∷ Fiber ~> Aff +joinFiber = G.tryJoinFiber >=> case _ of + G.Interrupted e → throwError e + G.Failed e → throwError e + G.Succeeded a → pure a + +-- | Allows safely throwing to the error channel. +liftEffect' ∷ ∀ a. Effect (Either Error a) → Aff a +liftEffect' = G.liftEffect' <<< map (either G.Failed G.Succeeded) + +-- | Assumes that any thrown error is of type e. +unsafeLiftEffect ∷ ∀ a. Effect a → Aff a +unsafeLiftEffect = G.unsafeLiftEffect + +-- | A canceler which does not cancel anything. +nonCanceler ∷ Canceler +nonCanceler = G.nonCanceler + +-- | A canceler from an Effect action. +effectCanceler ∷ Effect Unit → Canceler +effectCanceler = G.effectCanceler + +-- | A canceler from a Fiber. +fiberCanceler ∷ ∀ a. Fiber a → Canceler +fiberCanceler = G.fiberCanceler + +-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`. +launchAff ∷ ∀ a. Aff a → Effect (Fiber a) +launchAff = G.launchAff + +-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`. +launchAff_ ∷ ∀ a. Aff a → Effect Unit +launchAff_ = G.launchAff_ + +-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`. +launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a) +launchSuspendedAff = G.launchSuspendedAff + +-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when +-- | it completes. Returns the pending `Fiber`. +runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit) +runAff = G.runAff + +-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when +-- | it completes, discarding the `Fiber`. +runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit +runAff_ = G.runAff_ + +-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run +-- | when it completes. Returns the suspended `Fiber`. +runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit) +runSuspendedAff = G.runSuspendedAff + +-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`. +forkAff ∷ ∀ a. Aff a → Aff (Fiber a) +forkAff = G.forkAff + +-- | 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 ∷ ∀ a. Aff a → Aff (Fiber a) +suspendAff = G.suspendAff + +-- | Pauses the running fiber. +delay ∷ Milliseconds → Aff Unit +delay = G.delay + +-- | An async computation which does not resolve. +never ∷ ∀ a. Aff a +never = G.never + +-- | A monomorphic version of `try` that can map the error type. Catches thrown +-- | errors and lifts them into an `Either`. +attempt ∷ ∀ a. Aff a → Aff (Either Error a) +attempt = G.attempt + +-- | Ignores any errors. +apathize ∷ ∀ a. Aff a → Aff Unit +apathize = G.apathize + +-- | Runs the first effect after the second, regardless of whether it completed +-- | successfully or the fiber was cancelled. +finally ∷ ∀ a. Aff Unit → Aff a → Aff a +finally = G.finally <<< G.apathize + +-- | Runs an effect such that it cannot be killed. +invincible ∷ ∀ a. Aff a → Aff a +invincible = G.invincible + +-- | Attaches a custom `Canceler` to an action. If the computation is canceled, +-- | then the custom `Canceler` will be run afterwards. +cancelWith ∷ ∀ a. Aff a → Canceler → Aff a +cancelWith = G.cancelWith + +-- | 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 ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b +bracket acquire release = G.bracket acquire (\a → G.catch (release a) G.panic) + +-- | 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 ∷ ∀ a. Aff a → Aff a +supervise = G.supervise diff --git a/src/Effect/Aff/Class.purs b/src/Effect/Aff/Class.purs index 2e3ef5f..4d49d8c 100644 --- a/src/Effect/Aff/Class.purs +++ b/src/Effect/Aff/Class.purs @@ -1,44 +1,43 @@ -module Effect.Aff.Class where - -import Prelude -import Control.Monad.Cont.Trans (ContT) -import Control.Monad.Except.Trans (ExceptT) -import Control.Monad.List.Trans (ListT) -import Control.Monad.Maybe.Trans (MaybeT) -import Control.Monad.Reader.Trans (ReaderT) -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 Effect.Aff (Aff) -import Effect.Class (class MonadEffect) - -class MonadEffect m ⇐ MonadAff m where - liftAff ∷ Aff ~> m - -instance monadAffAff ∷ MonadAff Aff where - liftAff = identity - -instance monadAffContT ∷ MonadAff m ⇒ MonadAff (ContT r m) where - liftAff = lift <<< liftAff - -instance monadAffExceptT ∷ MonadAff m ⇒ MonadAff (ExceptT e m) where - liftAff = lift <<< liftAff - -instance monadAffListT ∷ MonadAff m ⇒ MonadAff (ListT m) where - liftAff = lift <<< liftAff - -instance monadAffMaybe ∷ MonadAff m ⇒ MonadAff (MaybeT m) where - liftAff = lift <<< liftAff - -instance monadAffReader ∷ MonadAff m ⇒ MonadAff (ReaderT r m) where - liftAff = lift <<< liftAff - -instance monadAffRWS ∷ (MonadAff m, Monoid w) ⇒ MonadAff (RWST r w s m) where - liftAff = lift <<< liftAff - -instance monadAffState ∷ MonadAff m ⇒ MonadAff (StateT s m) where - liftAff = lift <<< liftAff - -instance monadAffWriter ∷ (MonadAff m, Monoid w) ⇒ MonadAff (WriterT w m) where - liftAff = lift <<< liftAff +module Effect.Aff.Class where + +import Control.Monad.Cont (ContT, lift) +import Control.Monad.Except (ExceptT) +import Control.Monad.List.Trans (ListT) +import Control.Monad.Maybe.Trans (MaybeT) +import Control.Monad.RWS (RWST) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State (StateT) +import Control.Monad.Writer (WriterT) +import Effect.Aff.General (Aff, Error) +import Effect.Class (class MonadEffect) +import Prelude (class Monoid, type (~>), identity, (<<<)) + +class MonadEffect m ⇐ MonadAff m where + liftAff ∷ Aff Error ~> m + +instance monadAffAff ∷ MonadAff (Aff Error) where + liftAff = identity + +instance monadAffContT ∷ MonadAff m ⇒ MonadAff (ContT r m) where + liftAff = lift <<< liftAff + +instance monadAffExceptT ∷ MonadAff m ⇒ MonadAff (ExceptT Error m) where + liftAff = lift <<< liftAff + +instance monadAffListT ∷ MonadAff m ⇒ MonadAff (ListT m) where + liftAff = lift <<< liftAff + +instance monadAffMaybe ∷ MonadAff m ⇒ MonadAff (MaybeT m) where + liftAff = lift <<< liftAff + +instance monadAffReader ∷ MonadAff m ⇒ MonadAff (ReaderT r m) where + liftAff = lift <<< liftAff + +instance monadAffRWS ∷ (MonadAff m, Monoid w) ⇒ MonadAff (RWST r w s m) where + liftAff = lift <<< liftAff + +instance monadAffState ∷ MonadAff m ⇒ MonadAff (StateT s m) where + liftAff = lift <<< liftAff + +instance monadAffWriter ∷ (MonadAff m, Monoid w) ⇒ MonadAff (WriterT w m) where + liftAff = lift <<< liftAff diff --git a/src/Effect/Aff/Compat.purs b/src/Effect/Aff/Compat.purs index 541d1ef..b727e3a 100644 --- a/src/Effect/Aff/Compat.purs +++ b/src/Effect/Aff/Compat.purs @@ -1,53 +1,24 @@ --- | This module provides compatability functions for constructing `Aff`s which --- | are defined via the FFI. -module Effect.Aff.Compat - ( EffectFnAff(..) - , EffectFnCanceler(..) - , EffectFnCb - , fromEffectFnAff - , module Effect.Uncurried - ) where - -import Prelude -import Data.Either (Either(..)) -import Effect.Aff (Aff, Canceler(..), makeAff, nonCanceler) -import Effect.Exception (Error) -import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, mkEffectFn3, runEffectFn1, runEffectFn2, runEffectFn3) - -type EffectFnCb a = EffectFn1 a Unit - -newtype EffectFnAff a = EffectFnAff (EffectFn2 (EffectFnCb Error) (EffectFnCb a) EffectFnCanceler) - -newtype EffectFnCanceler = EffectFnCanceler (EffectFn3 Error (EffectFnCb Error) (EffectFnCb Unit) Unit) - --- | Lift a FFI definition into an `Aff`. `EffectFnAff` makes use of `EffectFn` so --- | `Effect` 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, onCancelerError, onCancelerSuccess) { --- | cancel(); --- | onCancelerSuccess(); --- | }; --- | }; --- | ``` --- | --- | ```purescript --- | foreign import _myAff :: EffectFnAff String --- | --- | myAff :: Aff String --- | myAff = fromEffectFnAff _myAff --- | ```` -fromEffectFnAff ∷ EffectFnAff ~> Aff -fromEffectFnAff (EffectFnAff eff) = makeAff \k → do - EffectFnCanceler canceler ← runEffectFn2 eff (mkEffectFn1 (k <<< Left)) (mkEffectFn1 (k <<< Right)) - pure $ Canceler \e → makeAff \k2 → do - runEffectFn3 canceler e (mkEffectFn1 (k2 <<< Left)) (mkEffectFn1 (k2 <<< Right)) - pure nonCanceler +module Effect.Aff.Compat + ( EffectFnAff + , EffectFnCanceler + , fromEffectFnAff + , module Effect.Uncurried + , module Exports + ) where + +import Effect.Aff (Aff, Error) +import Effect.Aff.General.Compat (EffectFnCb) as Exports +import Effect.Aff.General.Compat as G +import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, mkEffectFn3, runEffectFn1, runEffectFn2, runEffectFn3) +import Prelude (type (~>)) + +type EffectFnCb a = G.EffectFnCb a + +newtype EffectFnAff a = EffectFnAff + (EffectFn2 (EffectFnCb Error) (EffectFnCb a) EffectFnCanceler) + +type EffectFnCanceler = G.EffectFnCanceler + +fromEffectFnAff ∷ EffectFnAff ~> Aff +fromEffectFnAff (EffectFnAff f) = + G.fromEffectFnAff (G.EffectFnAff (mkEffectFn3 \a b _ → runEffectFn2 f a b)) diff --git a/src/Effect/Aff.js b/src/Effect/Aff/General.js similarity index 80% rename from src/Effect/Aff.js rename to src/Effect/Aff/General.js index ff8bca2..6ab29a2 100644 --- a/src/Effect/Aff.js +++ b/src/Effect/Aff/General.js @@ -11,27 +11,33 @@ var Aff = function () { An awkward approximation. We elide evidence we would otherwise need in PS for efficiency sake. - data Aff eff a + data Aff e a = Pure a - | Throw Error - | Catch (Aff eff a) (Error -> Aff eff a) - | Sync (Eff eff a) + | Throw e + | Catch (Aff e a) (e -> Aff e a) + | Sync (Effect a) + | SyncResult (Effect (Either e a)) + | SyncUnsafe (Effect 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) ?(Fiber eff b -> a) | Sequential (ParAff aff a) + | Panic Error */ var PURE = "Pure"; var THROW = "Throw"; var CATCH = "Catch"; var SYNC = "Sync"; + var SYNC_RESULT = "SyncResult" + var SYNC_UNSAFE = "SyncUnsafe" var ASYNC = "Async"; var BIND = "Bind"; var BRACKET = "Bracket"; var FORK = "Fork"; var SEQ = "Sequential"; + var PANIC = "Panic"; /* @@ -56,16 +62,19 @@ var Aff = function () { var FIBER = "Fiber"; // Actual fiber reference var THUNK = "Thunk"; // Primed effect, ready to invoke - function Aff(tag, _1, _2, _3) { + var early = new Error("[ParAff] Early exit"); + + function Aff(tag, _1, _2, _3, extra) { this.tag = tag; this._1 = _1; this._2 = _2; this._3 = _3; + this.extra = extra; } function AffCtr(tag) { - var fn = function (_1, _2, _3) { - return new Aff(tag, _1, _2, _3); + var fn = function (_1, _2, _3, extra) { + return new Aff(tag, _1, _2, _3, extra); }; fn.tag = tag; return fn; @@ -85,20 +94,12 @@ var Aff = function () { } } - function runSync(left, right, eff) { - try { - return right(eff()); - } catch (error) { - return left(error); + function errorFromVal(x) { + if (x instanceof Error) { + return x; } - } - - function runAsync(left, eff, k) { - try { - return eff(k)(); - } catch (error) { - k(left(error))(); - return nonCanceler; + else { + return new Error(x+''); } } @@ -160,7 +161,7 @@ var Aff = function () { delete fibers[fid]; }; } - }); + })(); fibers[fid] = fiber; count++; }, @@ -177,9 +178,10 @@ var Aff = function () { return function () { delete kills[fid]; killCount--; - if (util.isLeft(result) && util.fromLeft(result)) { + if (!util.isSucceeded(result)) { setTimeout(function () { - throw util.fromLeft(result); + throw util.isFailed(result) ? util.fromFailed(result) + : util.fromInterrupted(result); }, 0); } if (killCount === 0) { @@ -280,7 +282,7 @@ var Aff = function () { break; case STEP_RESULT: - if (util.isLeft(step)) { + if (!util.isSucceeded(step)) { status = RETURN; fail = step; step = null; @@ -288,7 +290,7 @@ var Aff = function () { status = RETURN; } else { status = STEP_BIND; - step = util.fromRight(step); + step = util.fromSucceeded(step); } break; @@ -306,44 +308,112 @@ var Aff = function () { case PURE: if (bhead === null) { status = RETURN; - step = util.right(step._1); + step = util.succeeded(step._1); } else { status = STEP_BIND; step = step._1; } break; + // If the Effect throws, die. + // Otherwise, return the result. case SYNC: - status = STEP_RESULT; - step = runSync(util.left, util.right, step._1); + try { + status = STEP_RESULT; + step = util.succeeded(step._1()); + } catch (error) { + interrupt = util.interrupted(errorFromVal(error)); + if (bracketCount === 0) { + status = RETURN; + step = null; + fail = null; + } + } + break; + + // If the Effect throws, die. + // Otherwise, map Lefts to errors and Rights to returns. + case SYNC_RESULT: + try { + status = STEP_RESULT; + step = step._1(); + } catch (error) { + interrupt = util.interrupted(errorFromVal(error)); + if (bracketCount === 0) { + status = RETURN; + step = null; + fail = null; + } + } + break; + + // If the Effect throws, send to the error channel. + // Otherwise, return the result. + case SYNC_UNSAFE: + status = STEP_RESULT; + try { + step = util.succeeded(step._1()); + } catch (error) { + step = util.failed(error); + } break; case ASYNC: status = PENDING; - step = runAsync(util.left, step._1, function (result) { - return function () { - if (runTick !== localRunTick) { - return; + tmp = step._1; + step = nonCanceler; + Scheduler.enqueue(function () { + if (runTick !== localRunTick) { + return; + } + var skipRun = true; + var canceler; + try { + canceler = tmp(function (result) { + return function () { + if (runTick !== localRunTick) { + return; + } + ++runTick; + status = STEP_RESULT; + step = result; + // Do not recurse on run if we are synchronous with runAsync. + if (skipRun) { + skipRun = false; + } else { + run(runTick); + } + }; + })(); + // Only update the canceler if the asynchronous action has not + // resolved synchronously. If it has, then the next status and + // step have already been set. + if (skipRun) { + step = canceler; + skipRun = false; } - runTick++; - Scheduler.enqueue(function () { - // It's possible to interrupt the fiber between enqueuing and - // resuming, so we need to check that the runTick is still - // valid. - if (runTick !== localRunTick + 1) { - return; - } - status = STEP_RESULT; - step = result; + // If runAsync already resolved then the next step needs to be + // run. + else { run(runTick); - }); - }; + } + } catch (error) { + interrupt = util.interrupted(errorFromVal(error)); + if (bracketCount === 0) { + status = RETURN; + step = null; + fail = null; + } + else { + status = STEP_RESULT; + } + } }); return; case THROW: status = RETURN; - fail = util.left(step._1); + fail = util.failed(step._1); step = null; break; @@ -385,13 +455,25 @@ var Aff = function () { if (step._1) { tmp.run(); } - step = util.right(tmp); + step = util.succeeded(tmp); break; case SEQ: status = CONTINUE; step = sequential(util, supervisor, step._1); break; + + case PANIC: + interrupt = util.interrupted(step._1); + if (bracketCount === 0) { + status = RETURN; + step = null; + fail = null; + } + else { + status = STEP_RESULT; + } + break; } break; @@ -422,7 +504,7 @@ var Aff = function () { status = RETURN; } else if (fail) { status = CONTINUE; - step = attempt._2(util.fromLeft(fail)); + step = attempt._2(util.fromFailed(fail)); fail = null; } break; @@ -437,7 +519,7 @@ var Aff = function () { bhead = attempt._1; btail = attempt._2; status = STEP_BIND; - step = util.fromRight(step); + step = util.fromSucceeded(step); } break; @@ -448,7 +530,7 @@ var Aff = function () { case BRACKET: bracketCount--; if (fail === null) { - result = util.fromRight(step); + result = util.fromSucceeded(step); // We need to enqueue the Release with the same interrupt // status as the Bracket that is initiating it. attempts = new Aff(CONS, new Aff(RELEASE, attempt._2, result), attempts, tmp); @@ -470,11 +552,11 @@ var Aff = function () { // It has only been killed if the interrupt status has changed // since we enqueued the item. if (interrupt && interrupt !== tmp) { - step = attempt._1.killed(util.fromLeft(interrupt))(attempt._2); + step = attempt._1.killed(util.fromInterrupted(interrupt))(attempt._2); } else if (fail) { - step = attempt._1.failed(util.fromLeft(fail))(attempt._2); + step = attempt._1.failed(util.fromFailed(fail))(attempt._2); } else { - step = attempt._1.completed(util.fromRight(step))(attempt._2); + step = attempt._1.completed(util.fromSucceeded(step))(attempt._2); } fail = null; break; @@ -508,24 +590,28 @@ var Aff = function () { // running finalizers. This should always rethrow in a fresh stack. if (interrupt && fail) { setTimeout(function () { - throw util.fromLeft(fail); + throw util.fromFailed(fail); }, 0); // If we have an unhandled exception, and no other fiber has joined // then we need to throw the exception in a fresh stack. - } else if (util.isLeft(step) && rethrow) { + } else if (!util.isSucceeded(step) && rethrow) { setTimeout(function () { // Guard on reathrow because a completely synchronous fiber can // still have an observer which was added after-the-fact. if (rethrow) { - throw util.fromLeft(step); + throw util.isFailed(step) ? util.fromFailed(step) + : util.fromInterrupted(step); } }, 0); } return; + case SUSPENDED: status = CONTINUE; break; + case PENDING: return; + } } } @@ -553,27 +639,27 @@ var Aff = function () { function kill(error, cb) { return function () { if (status === COMPLETED) { - cb(util.right(void 0))(); + cb(util.succeeded(void 0))(); return function () {}; } var canceler = onComplete({ rethrow: false, handler: function (/* unused */) { - return cb(util.right(void 0)); + return cb(util.succeeded(void 0)); } })(); switch (status) { case SUSPENDED: - interrupt = util.left(error); + interrupt = util.interrupted(error); status = COMPLETED; step = interrupt; run(runTick); break; case PENDING: if (interrupt === null) { - interrupt = util.left(error); + interrupt = util.interrupted(error); } if (bracketCount === 0) { if (status === PENDING) { @@ -587,7 +673,7 @@ var Aff = function () { break; default: if (interrupt === null) { - interrupt = util.left(error); + interrupt = util.interrupted(error); } if (bracketCount === 0) { status = RETURN; @@ -630,8 +716,21 @@ var Aff = function () { run(runTick); } } + }, + status: function () { + switch (status) { + case SUSPENDED: return util.statusSuspended; + case COMPLETED: return util.statusCompleted(step); + default: + if (interrupt === null) { + return util.statusRunning; + } + else { + return util.statusDying(util.fromInterrupted(interrupt)); + } + } } - }; + } } function runPar(util, supervisor, par, cb) { @@ -643,9 +742,6 @@ var Aff = function () { 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; @@ -706,7 +802,7 @@ var Aff = function () { } if (count === 0) { - cb(util.right(void 0))(); + cb(util.succeeded(void 0))(); } else { // Run the cancelation effects. We alias `count` because it's mutable. kid = 0; @@ -724,10 +820,11 @@ var Aff = function () { function join(result, head, tail) { var fail, step, lhs, rhs, tmp, kid; - if (util.isLeft(result)) { + if (!util.isSucceeded(result)) { fail = result; step = null; - } else { + } + else { step = result; fail = null; } @@ -760,7 +857,7 @@ var Aff = function () { switch (head.tag) { case MAP: if (fail === null) { - head._3 = util.right(head._1(util.fromRight(step))); + head._3 = util.succeeded(head._1(util.fromSucceeded(step))); step = head._3; } else { head._3 = fail; @@ -797,7 +894,7 @@ var Aff = function () { // We can only proceed if both sides have resolved. return; } else { - step = util.right(util.fromRight(lhs)(util.fromRight(rhs))); + step = util.succeeded(util.fromSucceeded(lhs)(util.fromSucceeded(rhs))); head._3 = step; } break; @@ -805,13 +902,17 @@ var Aff = function () { lhs = head._1._3; rhs = head._2._3; // We can only proceed if both have resolved or we have a success - if (lhs === EMPTY && util.isLeft(rhs) || rhs === EMPTY && util.isLeft(lhs)) { + if (lhs === EMPTY && !util.isSucceeded(rhs) || rhs === EMPTY && !util.isSucceeded(lhs)) { return; } - // If both sides resolve with an error, we should continue with the - // first error - if (lhs !== EMPTY && util.isLeft(lhs) && rhs !== EMPTY && util.isLeft(rhs)) { - fail = step === lhs ? rhs : lhs; + // If both sides resolve with an error, continue with the errors + // appended in order. + if (lhs !== EMPTY && util.isFailed(lhs) && rhs !== EMPTY && util.isFailed(rhs)) { + fail = util.failed( + step === lhs + ? head.extra(util.fromFailed(rhs))(util.fromFailed(lhs)) + : head.extra(util.fromFailed(lhs))(util.fromFailed(rhs)) + ); step = null; head._3 = fail; } else { @@ -898,7 +999,7 @@ var Aff = function () { if (head) { tail = new Aff(CONS, head, tail); } - head = new Aff(ALT, EMPTY, step._2, EMPTY); + head = new Aff(ALT, EMPTY, step._2, EMPTY, step.extra); step = step._1; break; default: @@ -948,7 +1049,11 @@ var Aff = function () { root = step; for (fid = 0; fid < fiberId; fid++) { - fibers[fid].run(); + tmp = fibers[fid]; + // If a Fiber resolves synchronously then all other Fibers are already + // deleted. + if (typeof tmp === 'undefined') break; + tmp.run(); } } @@ -957,7 +1062,7 @@ var Aff = function () { // all pending branches including those that were in the process of being // canceled. function cancel(error, cb) { - interrupt = util.left(error); + interrupt = util.interrupted(error); var innerKills; for (var kid in kills) { if (kills.hasOwnProperty(kid)) { @@ -1011,11 +1116,14 @@ var Aff = function () { Aff.Throw = AffCtr(THROW); Aff.Catch = AffCtr(CATCH); Aff.Sync = AffCtr(SYNC); + Aff.SyncResult = AffCtr(SYNC_RESULT); + Aff.SyncUnsafe = AffCtr(SYNC_UNSAFE); Aff.Async = AffCtr(ASYNC); Aff.Bind = AffCtr(BIND); Aff.Bracket = AffCtr(BRACKET); Aff.Fork = AffCtr(FORK); Aff.Seq = AffCtr(SEQ); + Aff.Panic = AffCtr(PANIC); Aff.ParMap = AffCtr(MAP); Aff.ParApply = AffCtr(APPLY); Aff.ParAlt = AffCtr(ALT); @@ -1063,6 +1171,10 @@ exports._fork = function (immediate) { exports._liftEffect = Aff.Sync; +exports._liftEffectResult = Aff.SyncResult; + +exports._liftEffectUnsafe = Aff.SyncUnsafe; + exports._parAffMap = function (f) { return function (aff) { return Aff.ParMap(f, aff); @@ -1075,9 +1187,11 @@ exports._parAffApply = function (aff1) { }; }; -exports._parAffAlt = function (aff1) { - return function (aff2) { - return Aff.ParAlt(aff1, aff2); +exports._parAffAlt = function (append) { + return function (aff1) { + return function (aff2) { + return Aff.ParAlt(aff1, aff2, null, append); + }; }; }; @@ -1143,3 +1257,5 @@ exports._delay = function () { }(); exports._sequential = Aff.Seq; + +exports._panic = Aff.Panic; diff --git a/src/Effect/Aff/General.purs b/src/Effect/Aff/General.purs new file mode 100644 index 0000000..b8c5d0d --- /dev/null +++ b/src/Effect/Aff/General.purs @@ -0,0 +1,561 @@ +module Effect.Aff.General + ( Aff + , Fiber + , FiberStatus(..) + , ParAff(..) + , Canceler(..) + , AffResult(..) + , isInterrupted + , isFailed + , isSucceeded + , makeAff + , launchAff + , launchAff_ + , launchSuspendedAff + , runAff + , runAff_ + , runSuspendedAff + , forkAff + , suspendAff + , supervise + , attempt + , apathize + , delay + , never + , catch + , finally + , invincible + , killFiber + , joinFiber + , tryJoinFiber + , liftEffect' + , unsafeLiftEffect + , cancelWith + , bracket + , panic + , BracketConditions + , generalBracket + , nonCanceler + , effectCanceler + , fiberCanceler + , status + , lmapFlipped + , (#!) + , absurdL + , absurdR + , wrapL + , wrapL' + , unwrapL + , unwrapL' + , wrapR + , wrapR' + , unwrapR + , unwrapR' + , module Exports + ) where + +import Prelude + +import Control.Alt (class Alt) +import Control.Alternative (class Alternative) +import Control.Apply (lift2) +import Control.Lazy (class Lazy) +import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try) +import Control.Monad.Error.Class (try, throwError, catchError) as Exports +import Control.Monad.Rec.Class (class MonadRec, Step(..)) +import Control.Parallel (parSequence_, parallel) +import Control.Parallel.Class (class Parallel) +import Control.Parallel.Class (sequential, parallel) as Exports +import Control.Plus (class Plus, empty) +import Data.Bifunctor (class Bifunctor, bimap, lmap) +import Data.Either (Either(..)) +import Data.Function.Uncurried as Fn +import Data.Newtype (class Newtype) +import Data.Time.Duration (Milliseconds(..)) +import Data.Time.Duration (Milliseconds(..)) as Exports +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Exception (Error, error) +import Effect.Exception (Error, error, message) as Exports +import Effect.Unsafe (unsafePerformEffect) +import Partial.Unsafe (unsafeCrashWith) +import Unsafe.Coerce (unsafeCoerce) + +-- | An `Aff a` is an asynchronous computation with effects. The +-- | computation may either error with an exception, or produce a result of +-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using +-- | `makeAff` or `liftEffect`. +foreign import data Aff ∷ Type → Type → Type + +instance functorAff ∷ Functor (Aff e) where + map = _map + +instance bifunctorAff ∷ Bifunctor Aff where + bimap f g m = catch (map g m) (throwError <<< f) + +instance applyAff ∷ Apply (Aff e) where + apply = ap + +instance applicativeAff ∷ Applicative (Aff e) where + pure = _pure + +instance bindAff ∷ Bind (Aff e) where + bind = _bind + +instance monadAff ∷ Monad (Aff e) + +instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff e a) where + append = lift2 append + +instance monoidAff ∷ Monoid a ⇒ Monoid (Aff e a) where + mempty = pure mempty + +instance altAff ∷ Alt (Aff e) where + alt a1 a2 = catchError a1 (const a2) + +instance plusAff ∷ Monoid e ⇒ Plus (Aff e) where + empty = throwError mempty + +-- | 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 e) 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 e (Aff e) where + throwError = _throwError + +instance monadErrorAff ∷ MonadError e (Aff e) where + catchError = _catchError + +instance monadEffectAff ∷ MonadEffect (Aff e) where + liftEffect = _liftEffect + +instance lazyAff ∷ Lazy (Aff e a) where + defer f = pure unit >>= f + +-- | Applicative for running parallel effects. Any `Aff` can be coerced to a +-- | `ParAff` and back using the `Parallel` class. +foreign import data ParAff ∷ Type → Type → Type + +instance functorParAff ∷ Functor (ParAff e) where + map = _parAffMap + +-- | Runs effects in parallel, combining their results. +instance applyParAff ∷ Apply (ParAff e) where + apply = _parAffApply + +instance applicativeParAff ∷ Applicative (ParAff e) where + pure = parallel <<< pure + +instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff e a) where + append = lift2 append + +instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff e a) where + mempty = pure mempty + +-- | Races effects in parallel. Losing branches will be cancelled. +instance altParAff ∷ Semigroup e ⇒ Alt (ParAff e) where + alt = _parAffAlt append + +instance plusParAff ∷ Monoid e ⇒ Plus (ParAff e) where + empty = parallel empty + +instance alternativeParAff ∷ Monoid e ⇒ Alternative (ParAff e) + +instance parallelAff ∷ Parallel (ParAff e) (Aff e) where + parallel = (unsafeCoerce ∷ ∀ a. Aff e a → ParAff e a) + sequential = _sequential + +data AffResult e a + = Succeeded a + | Failed e + | Interrupted Error + +derive instance functorAffResult ∷ Functor (AffResult e) + +instance showAffResult ∷ (Show a, Show e) ⇒ Show (AffResult e a) where + show (Succeeded a) = "(Succeeded " <> show a <> ")" + show (Failed e) = "(Failed " <> show e <> ")" + show (Interrupted a) = "(Interrupted " <> show a <> ")" + +instance bifunctorAffResult ∷ Bifunctor AffResult where + bimap _ g (Succeeded a) = Succeeded (g a) + bimap f _ (Failed e) = Failed (f e) + bimap _ _ (Interrupted e) = Interrupted e + +isInterrupted ∷ ∀ e a. AffResult e a → Boolean +isInterrupted = case _ of + Interrupted _ → true + _ → false + +isFailed ∷ ∀ e a. AffResult e a → Boolean +isFailed = case _ of + Failed _ → true + _ → false + +isSucceeded ∷ ∀ e a. AffResult e a → Boolean +isSucceeded = case _ of + Succeeded _ → true + _ → false + +type OnComplete e a = + { rethrow ∷ Boolean + , handler ∷ (AffResult e a → Effect Unit) → Effect Unit + } + +-- | Represents a forked computation by way of `forkAff`. `Fiber`s are +-- | memoized, so their results are only computed once. +newtype Fiber e a = Fiber + { run ∷ Effect Unit + , kill ∷ ∀ e. Fn.Fn2 Error (AffResult e Unit → Effect Unit) (Effect (Effect Unit)) + , join ∷ (AffResult e a → Effect Unit) → Effect (Effect Unit) + , onComplete ∷ OnComplete e a → Effect (Effect Unit) + , isSuspended ∷ Effect Boolean + , status ∷ Effect (FiberStatus e a) + } + +instance functorFiber ∷ Functor (Fiber e) where + map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t)) + +instance applyFiber ∷ Apply (Fiber e) where + apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2)) + +instance applicativeFiber ∷ Applicative (Fiber e) where + pure a = unsafePerformEffect (makeFiber (pure a)) + +-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks +-- | until the fiber has fully exited. +killFiber ∷ ∀ e1 e2 a. Error → Fiber e1 a → Aff e2 Unit +killFiber e (Fiber t) = _liftEffect t.isSuspended >>= if _ + then _liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit)) + else makeAff \k → effectCanceler <$> 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 ∷ ∀ e. Fiber e ~> Aff e +joinFiber = tryJoinFiber >=> case _ of + Interrupted e → panic e + Failed e → throwError e + Succeeded a → pure a + +tryJoinFiber ∷ ∀ e1 e2 a. Fiber e1 a → Aff e2 (AffResult e1 a) +tryJoinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join (k <<< Succeeded) + +-- | Allows safely throwing to the error channel. +liftEffect' ∷ ∀ e a. Effect (AffResult e a) → Aff e a +liftEffect' = _liftEffectResult + +-- | Assumes that any thrown error is of type e. +unsafeLiftEffect ∷ ∀ e a. Effect a → Aff e a +unsafeLiftEffect = _liftEffectUnsafe + +data FiberStatus e a + = Suspended + | Completed (AffResult e a) + | Running + | Dying Error + +derive instance functorFiberStatus ∷ Functor (FiberStatus e) + +instance bifunctorFiberStatus ∷ Bifunctor FiberStatus where + bimap f g (Completed x) = Completed (bimap f g x) + bimap _ _ Suspended = Suspended + bimap _ _ Running = Running + bimap _ _ (Dying e) = Dying e + +instance showFiberStatus ∷ (Show e, Show a) ⇒ Show (FiberStatus e a) where + show Suspended = "Suspended" + show (Completed x) = "(Completed " <> show x <> ")" + show Running = "Running" + show (Dying e) = "(Dying " <> show e <> ")" + +status ∷ ∀ e a. Fiber e a → Effect (FiberStatus e a) +status (Fiber t) = t.status + +-- | 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 = Canceler (Error → Aff Void Unit) + +derive instance newtypeCanceler ∷ Newtype Canceler _ + +instance semigroupCanceler ∷ Semigroup Canceler 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 where + mempty = nonCanceler + +-- | A canceler which does not cancel anything. +nonCanceler ∷ Canceler +nonCanceler = Canceler (const (pure unit)) + +-- | A canceler from an Effect action. +effectCanceler ∷ Effect Unit → Canceler +effectCanceler = Canceler <<< const <<< liftEffect + +-- | A canceler from a Fiber. +fiberCanceler ∷ ∀ e a. Fiber e a → Canceler +fiberCanceler = Canceler <<< flip killFiber + +-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`. +launchAff ∷ ∀ e a. Aff e a → Effect (Fiber e a) +launchAff aff = do + fiber ← makeFiber aff + case fiber of Fiber f → f.run + pure fiber + +-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`. +launchAff_ ∷ ∀ e a. Aff e a → Effect Unit +launchAff_ = void <<< launchAff + +-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`. +launchSuspendedAff ∷ ∀ e a. Aff e a → Effect (Fiber e a) +launchSuspendedAff = makeFiber + +-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when +-- | it completes. Returns the pending `Fiber`. +runAff ∷ ∀ e a. (Either e a → Effect Unit) → Aff e a → Effect (Fiber e Unit) +runAff k aff = launchAff $ liftEffect <<< k =<< try aff + +-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when +-- | it completes, discarding the `Fiber`. +runAff_ ∷ ∀ e a. (Either e a → Effect Unit) → Aff e a → Effect Unit +runAff_ k aff = void $ runAff k aff + +-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run +-- | when it completes. Returns the suspended `Fiber`. +runSuspendedAff ∷ ∀ e a. (Either e a → Effect Unit) → Aff e a → Effect (Fiber e Unit) +runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff + +-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`. +forkAff ∷ ∀ e1 e2 a. Aff e1 a → Aff e2 (Fiber e1 a) +forkAff = _fork true + +-- | 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 ∷ ∀ e1 e2 a. Aff e1 a → Aff e2 (Fiber e1 a) +suspendAff = _fork false + +-- | Pauses the running fiber. +delay ∷ ∀ e. Milliseconds → Aff e Unit +delay (Milliseconds n) = Fn.runFn2 _delay Succeeded n + +-- | An async computation which does not resolve. +never ∷ ∀ e a. Aff e a +never = makeAff \_ → pure mempty + +-- | A version of `catchError` that can map the error type. +catch ∷ ∀ e1 e2 a. Aff e1 a → (e1 → Aff e2 a) → Aff e2 a +catch = _catchError + +-- | A monomorphic version of `try` that can map the error type. Catches thrown +-- | errors and lifts them into an `Either`. +attempt ∷ ∀ e1 e2 a. Aff e1 a → Aff e2 (Either e1 a) +attempt m = catch (Right <$> m) (pure <<< Left) + +-- | Ignores any errors. +apathize ∷ ∀ e e' a. Aff e a → Aff e' 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 ∷ ∀ e a. Aff Void Unit → Aff e a → Aff e a +finally fin a = bracket (pure unit) (const fin) (const a) + +-- | Runs an effect such that it cannot be killed. +invincible ∷ ∀ e a. Aff e a → Aff e a +invincible 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 ∷ ∀ e a. Aff e a → Canceler → Aff e 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 +-- | acquisition nor disposal may be cancelled and are guaranteed to run until +-- | they complete. +bracket ∷ ∀ e a b. Aff e a → (a → Aff Void Unit) → (a → Aff e b) → Aff e b +bracket acquire completed = + generalBracket acquire + { killed: const completed + , failed: const completed + , completed: const completed + } + +panic ∷ ∀ e a. Error → Aff e a +panic = _panic + +absurdL ∷ ∀ f a b. Bifunctor f ⇒ f Void b → f a b +absurdL = unsafeCoerce -- lmap absurd + +absurdR ∷ ∀ f a b. Bifunctor f ⇒ f a Void → f a b +absurdR = unsafeCoerce -- rmap absurd + +wrapL ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ f b c → f a c +wrapL = unsafeCoerce -- lmap wrap + +wrapL' ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ (b → a) → f b c → f a c +wrapL' _ = unsafeCoerce -- lmap wrap + +unwrapL ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ f a c → f b c +unwrapL = unsafeCoerce -- lmap unwrap + +unwrapL' ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ (b → a) → f a c → f b c +unwrapL' _ = unsafeCoerce -- lmap unwrap + +wrapR ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ f c b → f c a +wrapR = unsafeCoerce -- rmap wrap + +unwrapR ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ f c a → f c b +unwrapR = unsafeCoerce -- rmap unwrap + +wrapR' ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ (b → a) → f c b → f c a +wrapR' _ = unsafeCoerce -- rmap wrap + +unwrapR' ∷ ∀ f a b c. Bifunctor f ⇒ Newtype a b ⇒ (b → a) → f c a → f c b +unwrapR' _ = unsafeCoerce -- rmap unwrap + +type Supervised e a = + { fiber ∷ Fiber e a + , supervisor ∷ Supervisor + } + +-- | 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 ∷ ∀ e a. Aff e a → Aff e a +supervise aff = + generalBracket (_liftEffect 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 ∷ ∀ e2. Error → Supervised e a → Aff e2 Unit + killAll err sup = makeAff \k → + Fn.runFn3 _killAll err sup.supervisor (k (Succeeded unit)) + + acquire ∷ Effect (Supervised e a) + acquire = do + sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff + case sup.fiber of Fiber f → f.run + pure sup + +foreign import data Supervisor ∷ Type +foreign import _pure ∷ ∀ e a. a → Aff e a +foreign import _throwError ∷ ∀ e a. e → Aff e a +foreign import _catchError ∷ ∀ e1 e2 a. Aff e1 a → (e1 → Aff e2 a) → Aff e2 a +foreign import _fork ∷ ∀ e1 e2 a. Boolean → Aff e1 a → Aff e2 (Fiber e1 a) +foreign import _map ∷ ∀ e a b. (a → b) → Aff e a → Aff e b +foreign import _bind ∷ ∀ e a b. Aff e a → (a → Aff e b) → Aff e b +foreign import _delay ∷ ∀ e a. Fn.Fn2 (Unit → AffResult a Unit) Number (Aff e Unit) +foreign import _liftEffect ∷ ∀ e a. Effect a → Aff e a +foreign import _liftEffectResult ∷ ∀ e a. Effect (AffResult e a) → Aff e a +foreign import _liftEffectUnsafe ∷ ∀ e a. Effect a → Aff e a +foreign import _parAffMap ∷ ∀ e a b. (a → b) → ParAff e a → ParAff e b +foreign import _parAffApply ∷ ∀ e a b. ParAff e (a → b) → ParAff e a → ParAff e b +foreign import _parAffAlt ∷ ∀ e a. (e → e → e) → ParAff e a → ParAff e a → ParAff e a +foreign import _makeFiber ∷ ∀ e a. Fn.Fn2 FFIUtil (Aff e a) (Effect (Fiber e a)) +foreign import _makeSupervisedFiber ∷ ∀ e a. Fn.Fn2 FFIUtil (Aff e a) (Effect (Supervised e a)) +foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler) +foreign import _sequential ∷ ∀ e. ParAff e ~> Aff e +foreign import _panic ∷ ∀ e a. Error → Aff e a + +type BracketConditions e a b = + { killed ∷ Error → a → Aff Void Unit + , failed ∷ e → a → Aff Void Unit + , completed ∷ b → a → Aff Void 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 ∷ ∀ e a b. Aff e a → BracketConditions e a b → (a → Aff e b) → Aff e b + +-- | Constructs an `Aff` from low-level `Effect` 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 ∷ ∀ e a. ((AffResult e a → Effect Unit) → Effect Canceler) → Aff e a + +lmapFlipped ∷ ∀ f a1 b a2. Bifunctor f ⇒ f a1 b → (a1 → a2) → f a2 b +lmapFlipped = flip lmap + +infixl 1 lmapFlipped as #! + +makeFiber ∷ ∀ e a. Aff e a → Effect (Fiber e a) +makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff + +newtype FFIUtil = FFIUtil + { isInterrupted ∷ ∀ e a. AffResult e a → Boolean + , isFailed ∷ ∀ e a. AffResult e a → Boolean + , isSucceeded ∷ ∀ e a. AffResult e a → Boolean + , fromInterrupted ∷ ∀ e b. AffResult e b → Error + , fromFailed ∷ ∀ e a. AffResult e a → e + , fromSucceeded ∷ ∀ e a. AffResult e a → a + , succeeded ∷ ∀ e a. a → AffResult e a + , failed ∷ ∀ e a. e → AffResult e a + , interrupted ∷ ∀ e a. Error → AffResult e a + , statusSuspended ∷ ∀ e a. FiberStatus e a + , statusCompleted ∷ ∀ e a. AffResult e a → FiberStatus e a + , statusRunning ∷ ∀ e a. FiberStatus e a + , statusDying ∷ ∀ e a. Error → FiberStatus e a + } + +ffiUtil ∷ FFIUtil +ffiUtil = FFIUtil + { isInterrupted + , isFailed + , isSucceeded + , fromInterrupted: unsafeFromInterrupted + , fromFailed: unsafeFromFailed + , fromSucceeded: unsafeFromSucceeded + , succeeded: Succeeded + , failed: Failed + , interrupted: Interrupted + , statusSuspended: Suspended + , statusCompleted: Completed + , statusRunning: Running + , statusDying: Dying + } + where + unsafeFromInterrupted ∷ ∀ e a. AffResult e a → Error + unsafeFromInterrupted = case _ of + Interrupted e → e + Failed _ → unsafeCrashWith "unsafeFromInterrupted: Failed" + Succeeded _ → unsafeCrashWith "unsafeFromInterrupted: Succeeded" + + unsafeFromFailed ∷ ∀ e a. AffResult e a → e + unsafeFromFailed = case _ of + Failed e → e + Interrupted _ → unsafeCrashWith "unsafeFromFailed: Interrupted" + Succeeded _ → unsafeCrashWith "unsafeFromFailed: Succeeded" + + unsafeFromSucceeded ∷ ∀ e a. AffResult e a → a + unsafeFromSucceeded = case _ of + Succeeded a → a + Failed _ → unsafeCrashWith "unsafeFromSucceeded: Failed" + Interrupted _ → unsafeCrashWith "unsafeFromSucceeded: Interrupted" diff --git a/src/Effect/Aff/General/Class.purs b/src/Effect/Aff/General/Class.purs new file mode 100644 index 0000000..ffd25d7 --- /dev/null +++ b/src/Effect/Aff/General/Class.purs @@ -0,0 +1,44 @@ +module Effect.Aff.General.Class where + +import Prelude +import Control.Monad.Cont.Trans (ContT) +import Control.Monad.Except.Trans (ExceptT) +import Control.Monad.List.Trans (ListT) +import Control.Monad.Maybe.Trans (MaybeT) +import Control.Monad.Reader.Trans (ReaderT) +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 Effect.Aff.General (Aff) +import Effect.Class (class MonadEffect) + +class MonadEffect m ⇐ MonadAff e m | m → e where + liftAff ∷ Aff e ~> m + +instance monadAffAff ∷ MonadAff e (Aff e) where + liftAff = identity + +instance monadAffContT ∷ MonadAff e m ⇒ MonadAff e (ContT r m) where + liftAff = lift <<< liftAff + +instance monadAffExceptT ∷ MonadAff e m ⇒ MonadAff e (ExceptT e m) where + liftAff = lift <<< liftAff + +instance monadAffListT ∷ MonadAff e m ⇒ MonadAff e (ListT m) where + liftAff = lift <<< liftAff + +instance monadAffMaybe ∷ MonadAff e m ⇒ MonadAff e (MaybeT m) where + liftAff = lift <<< liftAff + +instance monadAffReader ∷ MonadAff e m ⇒ MonadAff e (ReaderT r m) where + liftAff = lift <<< liftAff + +instance monadAffRWS ∷ (MonadAff e m, Monoid w) ⇒ MonadAff e (RWST r w s m) where + liftAff = lift <<< liftAff + +instance monadAffState ∷ MonadAff e m ⇒ MonadAff e (StateT s m) where + liftAff = lift <<< liftAff + +instance monadAffWriter ∷ (MonadAff e m, Monoid w) ⇒ MonadAff e (WriterT w m) where + liftAff = lift <<< liftAff diff --git a/src/Effect/Aff/General/Compat.purs b/src/Effect/Aff/General/Compat.purs new file mode 100644 index 0000000..e85c671 --- /dev/null +++ b/src/Effect/Aff/General/Compat.purs @@ -0,0 +1,61 @@ +-- | This module provides compatability functions for constructing `Aff`s which +-- | are defined via the FFI. +module Effect.Aff.General.Compat + ( EffectFnAff(..) + , EffectFnCanceler(..) + , EffectFnCb + , fromEffectFnAff + , module Effect.Uncurried + ) where + +import Prelude + +import Effect.Aff.General (Aff, AffResult(..), Canceler(..), catch, makeAff, nonCanceler, panic) +import Effect.Exception (Error) +import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, mkEffectFn3, runEffectFn1, runEffectFn2, runEffectFn3) + +type EffectFnCb a = EffectFn1 a Unit + +newtype EffectFnAff e a = EffectFnAff (EffectFn3 (EffectFnCb e) (EffectFnCb a) (EffectFnCb Error) EffectFnCanceler) + +newtype EffectFnCanceler = EffectFnCanceler (EffectFn3 Error (EffectFnCb Error) (EffectFnCb Unit) Unit) + +-- | Lift a FFI definition into an `Aff`. `EffectFnAff` makes use of `EffectFn` so +-- | `Effect` thunks are unnecessary. A definition might follow this example: +-- | +-- | ```javascript +-- | exports._myAff = function (onError, onSuccess) { +-- | var cancel = doSomethingAsync(function (err, res, panic) { +-- | if (err) { +-- | onError(err); +-- | } else { +-- | onSuccess(res); +-- | } +-- | }); +-- | return function (cancelError, onCancelerError, onCancelerSuccess) { +-- | cancel(); +-- | onCancelerSuccess(); +-- | }; +-- | }; +-- | ``` +-- | +-- | ```purescript +-- | foreign import _myAff :: EffectFnAff String +-- | +-- | myAff :: Aff String +-- | myAff = fromEffectFnAff _myAff +-- | ```` +fromEffectFnAff ∷ ∀ e. EffectFnAff e ~> Aff e +fromEffectFnAff (EffectFnAff eff) = makeAff \k → do + EffectFnCanceler canceler ← + runEffectFn3 eff (mkEffectFn1 (k <<< Failed)) + (mkEffectFn1 (k <<< Succeeded)) + (mkEffectFn1 (k <<< Interrupted)) + pure $ Canceler \e → + catch + ( makeAff \k2 → ado + runEffectFn3 canceler e (mkEffectFn1 (k2 <<< Interrupted)) + (mkEffectFn1 (k2 <<< Succeeded)) + in nonCanceler + ) + panic diff --git a/test/Test/Bench.purs b/test/Test/Bench.purs index 1b8862e..9ae3d67 100644 --- a/test/Test/Bench.purs +++ b/test/Test/Bench.purs @@ -4,11 +4,11 @@ import Prelude import Control.Monad.Rec.Class (Step(..), tailRecM) import Performance.Minibench (bench) import Effect (Effect) -import Effect.Aff as Aff +import Effect.Aff.General as Aff import Effect.Unsafe (unsafePerformEffect) import Effect.Console as Console -loop1 ∷ Int → Aff.Aff Int +loop1 ∷ ∀ e. Int → Aff.Aff e Int loop1 = tailRecM go where go n @@ -26,7 +26,7 @@ loop1 = tailRecM go pure n pure $ Loop (n - 1) -loop2 ∷ Int → Aff.Aff Int +loop2 ∷ ∀ e. Int → Aff.Aff e Int loop2 = go where go n @@ -44,7 +44,7 @@ loop2 = go pure n loop2 (n - 1) -fib1 ∷ Int → Aff.Aff Int +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) diff --git a/test/Test/Main.js b/test/Test/Main.js new file mode 100644 index 0000000..3eb4a9c --- /dev/null +++ b/test/Test/Main.js @@ -0,0 +1,3 @@ +'use strict'; + +exports.throwAnything = function (x) { return function () { throw x; }; }; diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 4f70574..1c72cdb 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -5,20 +5,24 @@ import Prelude import Control.Alt ((<|>)) import Control.Lazy (fix) import Control.Monad.Error.Class (throwError, catchError) +import Control.Monad.Rec.Class (forever) import Control.Parallel (parallel, sequential, parTraverse_) +import Control.Plus (empty) import Data.Array as Array import Data.Bifunctor (lmap) -import Data.Either (Either(..), either, isLeft, isRight) +import Data.Either (Either(..), either, isLeft) import Data.Foldable (sum) import Data.Maybe (Maybe(..)) +import Data.Newtype (unwrap) +import Data.Semigroup.First (First(..)) import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (traverse) import Effect (Effect) -import Effect.Aff (Aff, Canceler(..), runAff, runAff_, launchAff, makeAff, try, bracket, generalBracket, delay, forkAff, suspendAff, joinFiber, killFiber, never, supervise, Error, error, message) -import Effect.Aff.Compat as AC +import Effect.Aff.General (Aff, AffResult(..), Canceler(..), Fiber, FiberStatus(..), absurdL, attempt, bracket, catch, delay, forkAff, generalBracket, invincible, isFailed, isInterrupted, isSucceeded, joinFiber, killFiber, launchAff, liftEffect', makeAff, never, panic, runAff, runAff_, status, supervise, suspendAff, try, tryJoinFiber, unsafeLiftEffect) +import Effect.Aff.General.Compat as AC import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console as Console -import Effect.Exception (throwException) +import Effect.Class.Console as Console +import Effect.Exception (Error, error, message, throwException) import Effect.Ref (Ref) import Effect.Ref as Ref import Effect.Unsafe (unsafePerformEffect) @@ -36,44 +40,50 @@ writeRef r = liftEffect <<< flip Ref.write r modifyRef ∷ ∀ m a. MonadEffect m ⇒ Ref a → (a → a) → m a modifyRef r = liftEffect <<< flip Ref.modify r -assertEff ∷ String → Either Error Boolean → Effect Unit +assertEff ∷ ∀ e. Show e ⇒ String → Either e Boolean → Effect Unit assertEff s = case _ of Left err → do Console.log ("[Error] " <> s) - throwException err + throwException (error (show err)) Right r → do assert' ("Assertion failure " <> s) r Console.log ("[OK] " <> s) -runAssert ∷ String → Aff Boolean → Effect Unit +runAssert ∷ ∀ e. Show e ⇒ String → Aff e Boolean → Effect Unit runAssert s = runAff_ (assertEff s) -runAssertEq ∷ ∀ a. Eq a ⇒ String → a → Aff a → Effect Unit +runAssert' ∷ String → Aff (First Error) Boolean → Effect Unit +runAssert' = runAssert + +runAssertEq ∷ ∀ e a. Show e ⇒ Eq a ⇒ String → a → Aff e a → Effect Unit runAssertEq s a = runAff_ (assertEff s <<< map (eq a)) -assertEq ∷ ∀ a. Eq a ⇒ String → a → Aff a → Aff Unit +runAssertEq' ∷ ∀ a. Eq a ⇒ String → a → Aff (First Error) a → Effect Unit +runAssertEq' = runAssertEq + +assertEq ∷ ∀ e a. Show e ⇒ Eq a ⇒ String → a → Aff e a → Aff e Unit assertEq s a aff = liftEffect <<< assertEff s <<< map (eq a) =<< try aff -assert ∷ String → Aff Boolean → Aff Unit +assert ∷ ∀ e. Show e ⇒ String → Aff e Boolean → Aff e Unit assert s aff = liftEffect <<< assertEff s =<< try aff -withTimeout ∷ ∀ a. Milliseconds → Aff a → Aff a +withTimeout ∷ ∀ a. Milliseconds → Aff (First Error) a → Aff (First Error) a withTimeout ms aff = either throwError pure =<< sequential do - parallel (try aff) <|> parallel (delay ms $> Left (error "Timed out")) + parallel (try aff) <|> parallel (delay ms $> Left (First (error "Timed out"))) test_pure ∷ Effect Unit -test_pure = runAssertEq "pure" 42 (pure 42) +test_pure = runAssertEq' "pure" 42 (pure 42) test_bind ∷ Effect Unit -test_bind = runAssertEq "bind" 44 do +test_bind = runAssertEq' "bind" 44 do n1 ← pure 42 n2 ← pure (n1 + 1) n3 ← pure (n2 + 1) pure n3 test_try ∷ Effect Unit -test_try = runAssert "try" do +test_try = runAssert' "try" do n ← try (pure 42) case n of Right 42 → pure true @@ -85,18 +95,70 @@ test_throw = runAssert "try/throw" do pure (isLeft n) test_liftEffect ∷ Effect Unit -test_liftEffect = runAssertEq "liftEffect" 42 do +test_liftEffect = runAssertEq' "liftEffect" 42 do ref ← newRef 0 liftEffect do writeRef ref 42 readRef ref -test_delay ∷ Aff Unit +test_liftEffect_throw ∷ Effect Unit +test_liftEffect_throw = runAssertEq' "liftEffect/throw" "exception" do + ref ← newRef "" + fbr ← (forkAff <<< supervise) do + generalBracket (pure unit) + { killed: \err _ → writeRef ref (message err) + , failed: \_ _ → writeRef ref "Nope." + , completed: \_ _ → writeRef ref "Nope." + } + (\_ → liftEffect (throwException (error "exception"))) + delay (Milliseconds 10.0) + readRef ref + +test_liftEffect'_Right ∷ Effect Unit +test_liftEffect'_Right = runAssertEq' "liftEffect'/Right" 1 do + liftEffect' (pure (Succeeded 1)) + +test_liftEffect'_Left ∷ Effect Unit +test_liftEffect'_Left = runAssertEq "liftEffect'/Left" (Left 1) do + (try (liftEffect' (pure (Failed 1))) ∷ Aff Int (Either Int Unit)) +-- + +test_liftEffect'_throw ∷ Effect Unit +test_liftEffect'_throw = runAssertEq' "liftEffect'/throw" "exception" do + ref ← newRef "" + fbr ← (forkAff <<< supervise) do + generalBracket (pure unit) + { killed: \err _ → writeRef ref (message err) + , failed: \_ _ → writeRef ref "Nope." + , completed: \_ _ → writeRef ref "Nope." + } + (\_ → liftEffect' (throwException (error "exception"))) + delay (Milliseconds 10.0) + readRef ref + +test_unsafeLiftEffect_pure ∷ Effect Unit +test_unsafeLiftEffect_pure = runAssertEq "unsafeLiftEffect/pure" 1 do + (unsafeLiftEffect (pure 1) ∷ Aff Unit Int) + +test_unsafeLiftEffect_throw ∷ Effect Unit +test_unsafeLiftEffect_throw = runAssertEq' "unsafeLiftEffect/throw" "exception" do + ref ← newRef "" + fbr ← (forkAff <<< supervise) do + generalBracket (pure unit) + { killed: \_ _ → writeRef ref "Nope." + , failed: \err _ → writeRef ref err + , completed: \_ _ → writeRef ref "Nope." + } + (\_ → unsafeLiftEffect (throwAnything "exception")) + delay (Milliseconds 10.0) + readRef ref + +test_delay ∷ Aff (First Error) Unit test_delay = assert "delay" do delay (Milliseconds 1000.0) pure true -test_fork ∷ Aff Unit +test_fork ∷ Aff (First Error) Unit test_fork = assert "fork" do ref ← newRef "" fiber ← forkAff do @@ -107,7 +169,7 @@ test_fork = assert "fork" do _ ← modifyRef ref (_ <> "parent") eq "gochildparent" <$> readRef ref -test_join ∷ Aff Unit +test_join ∷ Aff (First Error) Unit test_join = assert "join" do ref ← newRef "" fiber ← forkAff do @@ -117,19 +179,19 @@ test_join = assert "join" do _ ← modifyRef ref (_ <> "parent") eq "parentchild" <$> joinFiber fiber -test_join_throw ∷ Aff Unit +test_join_throw ∷ Aff (First Error) Unit test_join_throw = assert "join/throw" do fiber ← forkAff do delay (Milliseconds 10.0) - throwError (error "Nope.") + throwError (First (error "Nope.")) isLeft <$> try (joinFiber fiber) -test_join_throw_sync ∷ Aff Unit +test_join_throw_sync ∷ Aff (First Error) Unit test_join_throw_sync = assert "join/throw/sync" do - fiber ← forkAff (throwError (error "Nope.")) + fiber ← forkAff (throwError (First (error "Nope."))) isLeft <$> try (joinFiber fiber) -test_multi_join ∷ Aff Unit +test_multi_join ∷ Aff (First Error) Unit test_multi_join = assert "join/multi" do ref ← newRef 1 f1 ← forkAff do @@ -149,7 +211,7 @@ test_multi_join = assert "join/multi" do n2 ← readRef ref pure (sum n1 == 50 && n2 == 3) -test_suspend ∷ Aff Unit +test_suspend ∷ Aff (First Error) Unit test_suspend = assert "suspend" do ref ← newRef "" fiber ← suspendAff do @@ -161,7 +223,7 @@ test_suspend = assert "suspend" do _ ← joinFiber fiber eq "goparentchild" <$> readRef ref -test_makeAff ∷ Aff Unit +test_makeAff ∷ Aff (First Error) Unit test_makeAff = assert "makeAff" do ref1 ← newRef Nothing ref2 ← newRef 0 @@ -174,12 +236,12 @@ test_makeAff = assert "makeAff" do cb ← readRef ref1 case cb of Just k → do - liftEffect $ k (Right 42) + liftEffect $ k (Succeeded 42) _ ← joinFiber fiber eq 42 <$> readRef ref2 Nothing → pure false -test_bracket ∷ Aff Unit +test_bracket ∷ Aff Void Unit test_bracket = assert "bracket" do ref ← newRef [] let @@ -192,7 +254,7 @@ test_bracket = assert "bracket" do readRef ref _ ← bracket (action "foo") - (\s → void $ action (s <> "/release")) + (\s → action (s <> "/release") # void) (\s → action (s <> "/run")) joinFiber fiber <#> eq [ "foo" @@ -200,7 +262,7 @@ test_bracket = assert "bracket" do , "foo/release" ] -test_bracket_nested ∷ Aff Unit +test_bracket_nested ∷ Aff Void Unit test_bracket_nested = assert "bracket/nested" do ref ← newRef [] let @@ -229,7 +291,7 @@ test_bracket_nested = assert "bracket/nested" do , "foo/bar/run/release/bar/release" ] -test_general_bracket ∷ Aff Unit +test_general_bracket ∷ Aff (First Error) Unit test_general_bracket = assert "bracket/general" do ref ← newRef "" let @@ -238,27 +300,32 @@ test_general_bracket = assert "bracket/general" do _ ← modifyRef ref (_ <> s) pure s bracketAction s = - generalBracket (action s) + generalBracket (action s # absurdL) { killed: \error s' → void $ action (s' <> "/kill/" <> message error) - , failed: \error s' → void $ action (s' <> "/throw/" <> message error) + , failed: \(First error) s' → void $ action (s' <> "/throw/" <> message error) , completed: \r s' → void $ action (s' <> "/release/" <> r) } - f1 ← forkAff $ bracketAction "foo" (const (action "a")) + f1 ← forkAff $ bracketAction "foo" (const (action "a" # absurdL)) delay (Milliseconds 5.0) killFiber (error "z") f1 - r1 ← try $ joinFiber f1 + r1 ← tryJoinFiber f1 - f2 ← forkAff $ bracketAction "bar" (const (throwError $ error "b")) - r2 ← try $ joinFiber f2 + f2 ← forkAff $ bracketAction "bar" (const (throwError $ First (error "b"))) + r2 ← tryJoinFiber f2 - f3 ← forkAff $ bracketAction "baz" (const (action "c")) - r3 ← try $ joinFiber f3 + f3 ← forkAff $ bracketAction "baz" (const (action "c" # absurdL)) + r3 ← tryJoinFiber f3 r4 ← readRef ref - pure (isLeft r1 && isLeft r2 && isRight r3 && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release/c") - -test_supervise ∷ Aff Unit + + pure $ + isInterrupted r1 + && isFailed r2 + && isSucceeded r3 + && r4 == "foofoo/kill/zbarbar/throw/bbazcbaz/release/c" + +test_supervise ∷ Aff (First Error) Unit test_supervise = assert "supervise" do ref ← newRef "" r1 ← supervise do @@ -277,13 +344,13 @@ test_supervise = assert "supervise" do r2 ← readRef ref pure (r1 == "done" && r2 == "acquiredonerelease") -test_kill ∷ Aff Unit +test_kill ∷ Aff (First Error) Unit test_kill = assert "kill" do fiber ← forkAff never killFiber (error "Nope") fiber - isLeft <$> try (joinFiber fiber) + isInterrupted <$> tryJoinFiber fiber -test_kill_canceler ∷ Aff Unit +test_kill_canceler ∷ Aff (First Error) Unit test_kill_canceler = assert "kill/canceler" do ref ← newRef "" fiber ← forkAff do @@ -293,11 +360,13 @@ test_kill_canceler = assert "kill/canceler" do writeRef ref "done" delay (Milliseconds 10.0) killFiber (error "Nope") fiber - res ← try (joinFiber fiber) + res ← tryJoinFiber fiber n ← readRef ref - pure (n == "cancel" && (lmap message res) == Left "Nope") + pure $ n == "cancel" && case res of + Interrupted e → message e == "Nope" + _ → false -test_kill_bracket ∷ Aff Unit +test_kill_bracket ∷ Aff (First Error) Unit test_kill_bracket = assert "kill/bracket" do ref ← newRef "" let @@ -306,15 +375,15 @@ test_kill_bracket = assert "kill/bracket" do void $ modifyRef ref (_ <> n) fiber ← forkAff $ bracket - (action "a") + (action "a" # absurdL) (\_ → action "b") - (\_ → action "c") + (\_ → action "c" # absurdL) delay (Milliseconds 5.0) killFiber (error "Nope") fiber - _ ← try (joinFiber fiber) + _ ← tryJoinFiber fiber eq "ab" <$> readRef ref -test_kill_bracket_nested ∷ Aff Unit +test_kill_bracket_nested ∷ Aff Void Unit test_kill_bracket_nested = assert "kill/bracket/nested" do ref ← newRef [] let @@ -334,7 +403,7 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do (\s → bracketAction (s <> "/run")) delay (Milliseconds 5.0) killFiber (error "Nope") fiber - _ ← try (joinFiber fiber) + _ ← tryJoinFiber fiber readRef ref <#> eq [ "foo/bar" , "foo/bar/run" @@ -344,7 +413,7 @@ test_kill_bracket_nested = assert "kill/bracket/nested" do , "foo/bar/run/release/bar/release" ] -test_kill_supervise ∷ Aff Unit +test_kill_supervise ∷ Aff (First Error) Unit test_kill_supervise = assert "kill/supervise" do ref ← newRef "" let @@ -367,17 +436,17 @@ test_kill_supervise = assert "kill/supervise" do delay (Milliseconds 20.0) eq "acquirefooacquirebarkillfookillbar" <$> readRef ref -test_kill_finalizer_catch ∷ Aff Unit +test_kill_finalizer_catch ∷ Aff (First Error) Unit test_kill_finalizer_catch = assert "kill/finalizer/catch" do ref ← newRef "" fiber ← forkAff $ bracket (delay (Milliseconds 10.0)) - (\_ → throwError (error "Finalizer") `catchError` \_ → writeRef ref "caught") + (\_ → throwError (First (error "Finalizer")) `catch` \_ → writeRef ref "caught") (\_ → pure unit) killFiber (error "Nope") fiber eq "caught" <$> readRef ref -test_kill_finalizer_bracket ∷ Aff Unit +test_kill_finalizer_bracket ∷ Aff (First Error) Unit test_kill_finalizer_bracket = assert "kill/finalizer/bracket" do ref ← newRef "" fiber ← forkAff $ bracket @@ -392,7 +461,7 @@ test_kill_finalizer_bracket = assert "kill/finalizer/bracket" do killFiber (error "Nope") fiber eq "completed" <$> readRef ref -test_parallel ∷ Aff Unit +test_parallel ∷ Aff (First Error) Unit test_parallel = assert "parallel" do ref ← newRef "" let @@ -409,7 +478,7 @@ test_parallel = assert "parallel" do r2 ← joinFiber f1 pure (r1 == "foobar" && r2.a == "foo" && r2.b == "bar") -test_parallel_throw ∷ Aff Unit +test_parallel_throw ∷ Aff (First Error) Unit test_parallel_throw = assert "parallel/throw" $ withTimeout (Milliseconds 100.0) do ref ← newRef "" let @@ -419,12 +488,12 @@ test_parallel_throw = assert "parallel/throw" $ withTimeout (Milliseconds 100.0) pure s r1 ← try $ sequential $ { a: _, b: _ } - <$> parallel (action 10.0 "foo" *> throwError (error "Nope")) + <$> parallel (action 10.0 "foo" *> throwError (First (error "Nope"))) <*> parallel never r2 ← readRef ref pure (isLeft r1 && r2 == "foo") -test_kill_parallel ∷ Aff Unit +test_kill_parallel ∷ Aff (First Error) Unit test_kill_parallel = assert "kill/parallel" do ref ← newRef "" let @@ -441,11 +510,11 @@ test_kill_parallel = assert "kill/parallel" do delay (Milliseconds 5.0) killFiber (error "Nope") f1 modifyRef ref (_ <> "done") - _ ← try $ joinFiber f1 - _ ← try $ joinFiber f2 + _ ← tryJoinFiber f1 + _ ← tryJoinFiber f2 eq "killedfookilledbardone" <$> readRef ref -test_parallel_alt ∷ Aff Unit +test_parallel_alt ∷ Aff (First Error) Unit test_parallel_alt = assert "parallel/alt" do ref ← newRef "" let @@ -460,15 +529,15 @@ test_parallel_alt = assert "parallel/alt" do r2 ← joinFiber f1 pure (r1 == "bar" && r2 == "bar") -test_parallel_alt_throw ∷ Aff Unit +test_parallel_alt_throw ∷ Aff (First Error) Unit test_parallel_alt_throw = assert "parallel/alt/throw" do r1 ← sequential $ - parallel (delay (Milliseconds 10.0) *> throwError (error "Nope.")) + parallel (delay (Milliseconds 10.0) *> throwError (First (error "Nope."))) <|> parallel (delay (Milliseconds 11.0) $> "foo") <|> parallel (delay (Milliseconds 12.0) $> "bar") pure (r1 == "foo") -test_parallel_alt_sync ∷ Aff Unit +test_parallel_alt_sync ∷ Aff (First Error) Unit test_parallel_alt_sync = assert "parallel/alt/sync" do ref ← newRef "" let @@ -484,7 +553,7 @@ test_parallel_alt_sync = assert "parallel/alt/sync" do r2 ← readRef ref pure (r1 == "foo" && r2 == "fookilledfoo") -test_parallel_mixed ∷ Aff Unit +test_parallel_mixed ∷ Aff (First Error) Unit test_parallel_mixed = assert "parallel/mixed" do ref ← newRef "" let @@ -505,7 +574,7 @@ test_parallel_mixed = assert "parallel/mixed" do r4 ← readRef ref pure (r1 == "a" && r2 == "b" && r3 == "de" && r4 == "abde") -test_kill_parallel_alt ∷ Aff Unit +test_kill_parallel_alt ∷ Aff (First Error) Unit test_kill_parallel_alt = assert "kill/parallel/alt" do ref ← newRef "" let @@ -516,20 +585,20 @@ test_kill_parallel_alt = assert "kill/parallel/alt" do (\_ → do delay (Milliseconds n) void $ modifyRef ref (_ <> s)) - f1 ← forkAff $ sequential $ + f1 ∷ Fiber (First Error) Unit ← forkAff $ sequential $ parallel (action 10.0 "foo") <|> parallel (action 20.0 "bar") f2 ← forkAff do delay (Milliseconds 5.0) killFiber (error "Nope") f1 modifyRef ref (_ <> "done") - _ ← try $ joinFiber f1 - _ ← try $ joinFiber f2 + _ ← tryJoinFiber f1 + _ ← tryJoinFiber f2 eq "killedfookilledbardone" <$> readRef ref -test_kill_parallel_alt_finalizer ∷ Aff Unit +test_kill_parallel_alt_finalizer ∷ Aff (First Error) Unit test_kill_parallel_alt_finalizer = assert "kill/parallel/alt/finalizer" do ref ← newRef "" - f1 ← forkAff $ sequential $ + f1 ∷ Fiber (First Error) Unit ← forkAff $ sequential $ parallel (delay (Milliseconds 10.0)) <|> parallel do bracket (pure unit) @@ -541,11 +610,29 @@ test_kill_parallel_alt_finalizer = assert "kill/parallel/alt/finalizer" do delay (Milliseconds 15.0) killFiber (error "Nope") f1 modifyRef ref (_ <> "done") - _ ← try $ joinFiber f1 - _ ← try $ joinFiber f2 + _ ← tryJoinFiber f1 + _ ← tryJoinFiber f2 eq "killeddone" <$> readRef ref -test_fiber_map ∷ Aff Unit +test_parallel_alt_semigroup ∷ Aff (First Error) Unit +test_parallel_alt_semigroup = assertEq "parallel/alt/semigroup" + (Left [1,2] ∷ Either (Array Int) Unit) do + attempt <<< sequential $ + -- Delay to test ordering. + parallel (delay (Milliseconds 1.0) *> throwError [1]) + <|> parallel (throwError [2]) + +test_parallel_alt_monoid ∷ Aff (First Error) Unit +test_parallel_alt_monoid = assertEq "parallel/alt/monoid" + (Left [1,2] ∷ Either (Array Int) Unit) do + attempt <<< sequential $ + -- Delay to test ordering. + parallel (throwError [1]) + <|> empty + <|> parallel (delay (Milliseconds 1.0) *> throwError [2]) + <|> empty + +test_fiber_map ∷ Aff (First Error) Unit test_fiber_map = assert "fiber/map" do ref ← newRef 0 let @@ -562,7 +649,7 @@ test_fiber_map = assert "fiber/map" do n ← readRef ref pure (a == 11 && b == 11 && n == 1) -test_fiber_apply ∷ Aff Unit +test_fiber_apply ∷ Aff (First Error) Unit test_fiber_apply = assert "fiber/apply" do ref ← newRef 0 let @@ -582,11 +669,11 @@ test_fiber_apply = assert "fiber/apply" do n ← readRef ref pure (a == 22 && b == 22 && n == 1) -test_efffn ∷ Aff Unit +test_efffn ∷ Aff (First Error) Unit test_efffn = assert "efffn" do ref ← newRef "" let - effectDelay ms = AC.fromEffectFnAff $ AC.EffectFnAff $ AC.mkEffectFn2 \ke kc → do + effectDelay ms = AC.fromEffectFnAff $ AC.EffectFnAff $ AC.mkEffectFn3 \ke kc _ → do fiber ← runAff (either (AC.runEffectFn1 ke) (AC.runEffectFn1 kc)) (delay ms) pure $ AC.EffectFnCanceler $ AC.mkEffectFn3 \e cke ckc → do runAff_ (either (AC.runEffectFn1 cke) (AC.runEffectFn1 ckc)) (killFiber e fiber) @@ -599,19 +686,19 @@ test_efffn = assert "efffn" do delay (Milliseconds 20.0) eq "done" <$> readRef ref -test_parallel_stack ∷ Aff Unit +test_parallel_stack ∷ Aff (First Error) Unit test_parallel_stack = assert "parallel/stack" do ref ← newRef 0 parTraverse_ (modifyRef ref <<< add) (Array.replicate 100000 1) eq 100000 <$> readRef ref -test_scheduler_size ∷ Aff Unit +test_scheduler_size ∷ Aff (First Error) 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 -test_lazy ∷ Aff Unit +test_lazy ∷ Aff (First Error) Unit test_lazy = assert "Lazy Aff" do ref ← newRef 0 fix \loop -> do @@ -624,14 +711,14 @@ test_lazy = assert "Lazy Aff" do pure unit eq 10 <$> readRef ref -test_regression_return_fork ∷ Aff Unit +test_regression_return_fork ∷ Aff (First Error) Unit test_regression_return_fork = assert "regression/return-fork" do bracket (forkAff (pure unit)) (const (pure unit)) (const (pure true)) -test_regression_par_apply_async_canceler ∷ Aff Unit +test_regression_par_apply_async_canceler ∷ Aff (First Error) Unit test_regression_par_apply_async_canceler = assert "regression/par-apply-async-canceler" do ref ← newRef "" let @@ -643,29 +730,81 @@ test_regression_par_apply_async_canceler = assert "regression/par-apply-async-ca action2 = do delay (Milliseconds 5.0) void $ modifyRef ref (_ <> "throw") - throwError (error "Nope.") + throwError (First (error "Nope.")) catchError (sequential (parallel action1 *> parallel action2)) - \err -> do + \(First err) -> do val <- readRef ref pure (val == "throwdone" && message err == "Nope.") -test_regression_bracket_catch_cleanup ∷ Aff Unit +test_regression_bracket_catch_cleanup ∷ Aff (First Error) Unit test_regression_bracket_catch_cleanup = assert "regression/bracket-catch-cleanup" do - res :: Either Error Unit ← + res :: Either (First Error) Unit ← try $ bracket (pure unit) (\_ → catchError (pure unit) (const (pure unit))) - (\_ → throwError (error "Nope.")) - pure $ lmap message res == Left "Nope." - -test_regression_kill_sync_async ∷ Aff Unit -test_regression_kill_sync_async = assert "regression/kill-sync-async" do - ref ← newRef "" - f1 ← forkAff $ makeAff \k -> k (Left (error "Boom.")) *> mempty - killFiber (error "Nope.") f1 - pure true + (\_ → throwError (First (error "Nope."))) + pure $ lmap (message <<< unwrap) res == Left "Nope." + +test_fiber_status_suspended ∷ Aff (First Error) Unit +test_fiber_status_suspended = assert "fiber/status/suspended" do + t ← suspendAff (pure unit) + liftEffect ado + t_status ← status t + in case t_status of + Suspended → true + _ → false + +test_fiber_status_completed ∷ Aff (First Error) Unit +test_fiber_status_completed = assert "fiber/status/completed" do + t ← forkAff (pure "done") + _ ← joinFiber t + liftEffect ado + t_status ← status t + in case t_status of + Completed (Succeeded r) → r == "done" + _ → false + +test_fiber_status_running ∷ Aff (First Error) Unit +test_fiber_status_running = assert "fiber/status/running" do + t ← forkAff (delay (Milliseconds 1000.0)) + liftEffect ado + t_status ← status t + in case t_status of + Running → true + _ → false + +test_fiber_status_killed ∷ Aff (First Error) Unit +test_fiber_status_killed = assert "fiber/status/killed" do + t ← forkAff (forever (delay (Milliseconds 1000.0))) + killFiber (error "die") t + liftEffect ado + t_status ← status t + in case t_status of + Completed (Interrupted e) → message e == "die" + _ → false + +test_fiber_status_dying ∷ Aff (First Error) Unit +test_fiber_status_dying = assert "fiber/status/dying" do + t ← forkAff (invincible (delay (Milliseconds 1000.0))) + _ ← forkAff (killFiber (error "die") t) + delay (Milliseconds 20.0) + liftEffect ado + t_status ← status t + in case t_status of + Dying e → message e == "die" + _ → false + +test_panic ∷ Aff Void Unit +test_panic = assert "panic" do + t ← forkAff (panic (error "panic!")) + _ ← tryJoinFiber t -- Observe the panic so it is not thrown globally. + liftEffect ado + t_status ← status t + in case t_status of + Completed (Interrupted e) → message e == "panic!" + _ → false main ∷ Effect Unit main = do @@ -674,6 +813,12 @@ main = do test_try test_throw test_liftEffect + test_liftEffect_throw + test_liftEffect'_Right + test_liftEffect'_Left + test_liftEffect'_throw + test_unsafeLiftEffect_pure + test_unsafeLiftEffect_throw void $ launchAff do test_delay @@ -684,14 +829,14 @@ main = do test_multi_join test_suspend test_makeAff - test_bracket - test_bracket_nested + test_bracket # absurdL + test_bracket_nested # absurdL test_general_bracket test_supervise test_kill test_kill_canceler test_kill_bracket - test_kill_bracket_nested + test_kill_bracket_nested # absurdL test_kill_supervise test_kill_finalizer_catch test_kill_finalizer_bracket @@ -704,6 +849,8 @@ main = do test_parallel_mixed test_kill_parallel_alt test_kill_parallel_alt_finalizer + test_parallel_alt_semigroup + test_parallel_alt_monoid test_lazy test_efffn test_fiber_map @@ -714,4 +861,11 @@ main = do test_regression_return_fork test_regression_par_apply_async_canceler test_regression_bracket_catch_cleanup - test_regression_kill_sync_async + test_fiber_status_suspended + test_fiber_status_completed + test_fiber_status_running + test_fiber_status_killed + test_fiber_status_dying + test_panic # absurdL + +foreign import throwAnything ∷ ∀ a b. a → Effect b