diff --git a/src/Control/Monad/Promise.purs b/src/Control/Monad/Promise.purs index 96dbcd8..bfe818c 100644 --- a/src/Control/Monad/Promise.purs +++ b/src/Control/Monad/Promise.purs @@ -2,6 +2,7 @@ module Control.Monad.Promise ( Promise , PurePromise , promise + , then_ , then' , resolve , catch @@ -17,11 +18,13 @@ import Prelude import Control.Monad.Eff (Eff, kind Effect) import Control.Monad.Eff.Class (class MonadEff) -import Control.Monad.Eff.Exception (Error) +import Control.Monad.Eff.Exception (EXCEPTION, Error, throwException) +import Control.Monad.Eff.Unsafe (unsafeCoerceEff) import Control.Monad.Error.Class (class MonadError, class MonadThrow) -import Control.Monad.Promise.Unsafe (class Deferred, undefer) import Control.Monad.Promise.Unsafe (class Deferred) as Exports +import Control.Monad.Promise.Unsafe (class Deferred, undefer) import Data.Array as Array +import Data.Either (Either(..)) import Data.Foldable (class Foldable) import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3) import Data.Monoid (class Monoid, mempty) @@ -54,15 +57,23 @@ thenn -> (c -> Promise r b) -> Promise r a -> Promise r b -thenn succ err p = - let then'' = runFn3 thenImpl - in then'' p succ err +thenn succ err p = runFn3 thenImpl p succ err -- | Given a promise and a function which uses that promise's resolved value, -- | create a new promise that resolves to the function's output. -then' :: forall r a b. Deferred => (a -> Promise r b) -> Promise r a -> Promise r b +then' :: forall r a b. (a -> Promise r b) -> Promise r a -> Promise r b then' = flip thenn reject +-- | Useful for when you need to transform an error and a resolved value into +-- | the same type. +then_ + :: forall r a b + . (a -> Promise r b) + -> (Error -> Promise r b) + -> Promise r a + -> Promise r b +then_ = thenn + foreign import resolveImpl :: forall r a. a -> Promise r a @@ -83,21 +94,24 @@ catchAnything catchAnything = runFn2 catchImpl -- | Deals with any errors that may be thrown by the given promise. -catch :: forall r a. Deferred => Promise r a -> (Error -> Promise r a) -> Promise r a +catch :: forall r a. Promise r a -> (Error -> Promise r a) -> Promise r a catch = catchAnything foreign import rejectImpl :: forall r b c. c -> Promise r b -- | Throw an error into a promise. -reject :: forall r b. Deferred => Error -> Promise r b +reject :: forall r b. Error -> Promise r b reject = rejectImpl +attempt :: forall r a. Promise r a -> Promise r (Either Error a) +attempt p = p # then_ (resolve <<< Right) (resolve <<< Left) + foreign import allImpl :: forall r a. Array (Promise r a) -> Promise r (Array a) -- | Run all promises in the given `Foldable`, returning a new promise which either -- | resolves to a collection of all the given promises' results, or rejects with -- | the first promise to reject. -all :: forall f g r a. Deferred => Foldable f => Unfoldable g => f (Promise r a) -> Promise r (g a) +all :: forall f g r a. Foldable f => Unfoldable g => f (Promise r a) -> Promise r (g a) all = map Array.toUnfoldable <<< allImpl <<< Array.fromFoldable foreign import raceImpl :: forall r a. Array (Promise r a) -> Promise r a @@ -106,7 +120,7 @@ foreign import raceImpl :: forall r a. Array (Promise r a) -> Promise r a -- | `x` in `xs` to resolve, `race xs` won't terminate until each promise is -- | settled. -- | In addition, if `Array.fromFoldable xs` is `[]`, `race xs` will never settle. -race :: forall f r a. Deferred => Foldable f => f (Promise r a) -> Promise r a +race :: forall f r a. Foldable f => f (Promise r a) -> Promise r a race = raceImpl <<< Array.fromFoldable foreign import delayImpl @@ -126,8 +140,8 @@ foreign import promiseToEffImpl (c -> Eff eff b) (Eff eff Unit) --- | Consume a promise. Note that this is the only standard way to discharge the --- | `Deferred` constraints you are likely to have. +-- | Consume a promise. Note that this is the only standard way to safely +-- | discharge the `Deferred` constraints you are likely to have. runPromise :: forall eff a b. (a -> Eff eff b) -> (Error -> Eff eff b) @@ -135,38 +149,46 @@ runPromise -> Eff eff Unit runPromise onSucc onErr p = runFn3 promiseToEffImpl (undefer p) onSucc onErr -instance functorPromise :: Deferred => Functor (Promise r) where - map :: forall r a b. Deferred => (a -> b) -> Promise r a -> Promise r b +yoloPromise :: forall eff a. (Deferred => Promise eff a) -> Eff (exception :: EXCEPTION | eff) Unit +yoloPromise dp = addEx $ runPromise (const (pure unit)) (removeEx <<< throwException) dp + where + removeEx :: Eff (exception :: EXCEPTION | eff) Unit -> Eff eff Unit + removeEx = unsafeCoerceEff + addEx :: Eff eff Unit -> Eff (exception :: EXCEPTION | eff) Unit + addEx = unsafeCoerceEff + +instance functorPromise :: Functor (Promise r) where + map :: forall r a b. (a -> b) -> Promise r a -> Promise r b map f p = p # then' \ a -> resolve (f a) -instance applyPromise :: Deferred => Apply (Promise r) where - apply :: forall r a b. Deferred => Promise r (a -> b) -> Promise r a -> Promise r b +instance applyPromise :: Apply (Promise r) where + apply :: forall r a b. Promise r (a -> b) -> Promise r a -> Promise r b apply pf pa = pf # then' \ f -> pa # then' \ a -> resolve (f a) -instance applicativePromise :: Deferred => Applicative (Promise r) where +instance applicativePromise :: Applicative (Promise r) where pure = resolve -instance bindPromise :: Deferred => Bind (Promise r) where - bind :: forall r a b. Deferred => Promise r a -> (a -> Promise r b) -> Promise r b +instance bindPromise :: Bind (Promise r) where + bind :: forall r a b. Promise r a -> (a -> Promise r b) -> Promise r b bind = flip then' -instance monadPromise :: Deferred => Monad (Promise r) +instance monadPromise :: Monad (Promise r) -instance monadThrowPromise :: Deferred => MonadThrow Error (Promise r) where - throwError :: forall r a. Deferred => Error -> Promise r a +instance monadThrowPromise :: MonadThrow Error (Promise r) where + throwError :: forall r a. Error -> Promise r a throwError = reject -instance monadErrorPromise :: Deferred => MonadError Error (Promise r) where - catchError :: forall r a. Deferred => Promise r a -> (Error -> Promise r a) -> Promise r a +instance monadErrorPromise :: MonadError Error (Promise r) where + catchError :: forall r a. Promise r a -> (Error -> Promise r a) -> Promise r a catchError = catch -instance semigroupPromise :: (Deferred, Semigroup a) => Semigroup (Promise r a) where - append :: forall r a. Deferred => Semigroup a => Promise r a -> Promise r a -> Promise r a +instance semigroupPromise :: Semigroup a => Semigroup (Promise r a) where + append :: forall r a. Semigroup a => Promise r a -> Promise r a -> Promise r a append a b = append <$> a <*> b -instance monoidPromise :: (Deferred, Monoid a) => Monoid (Promise r a) where - mempty :: forall r a. Deferred => Monoid a => Promise r a +instance monoidPromise :: Monoid a => Monoid (Promise r a) where + mempty :: forall r a. Monoid a => Promise r a mempty = resolve mempty foreign import liftEffImpl :: forall eff a. Eff eff a -> Promise eff a diff --git a/src/Control/Monad/Promise/Nonstandard.purs b/src/Control/Monad/Promise/Nonstandard.purs index 381b319..a63390d 100644 --- a/src/Control/Monad/Promise/Nonstandard.purs +++ b/src/Control/Monad/Promise/Nonstandard.purs @@ -1,5 +1,6 @@ module Control.Monad.Promise.Nonstandard - ( done + ( doneDeferred + , done , finally ) where @@ -20,8 +21,11 @@ foreign import doneImpl (Eff r Unit) -- | Call's a promise's `done` method, causing execution. -done :: forall r a c. (a -> Eff r c) -> (Error -> Eff r c) -> (Deferred => Promise r a) -> Eff r Unit -done onSucc onErr p = runFn3 doneImpl onSucc onErr (undefer p) +doneDeferred :: forall r a c. (a -> Eff r c) -> (Error -> Eff r c) -> (Deferred => Promise r a) -> Eff r Unit +doneDeferred onSucc onErr p = runFn3 doneImpl onSucc onErr (undefer p) + +done :: forall r a c. (a -> Eff r c) -> (Error -> Eff r c) -> Promise r a -> Eff r Unit +done onSucc onErr p = runFn3 doneImpl onSucc onErr p foreign import finallyImpl :: forall r a. Fn2 (Promise r a) (Eff r Unit) (Promise r a) diff --git a/src/Control/Monad/Promise/Unsafe.js b/src/Control/Monad/Promise/Unsafe.js index 4c61efb..285a9ae 100644 --- a/src/Control/Monad/Promise/Unsafe.js +++ b/src/Control/Monad/Promise/Unsafe.js @@ -1,3 +1,3 @@ exports.undefer = function (f) { return f(); -} +}; diff --git a/src/Control/Monad/Promise/Unsafe.purs b/src/Control/Monad/Promise/Unsafe.purs index e7481cf..24d8ca0 100644 --- a/src/Control/Monad/Promise/Unsafe.purs +++ b/src/Control/Monad/Promise/Unsafe.purs @@ -1,6 +1,11 @@ -module Control.Monad.Promise.Unsafe where +module Control.Monad.Promise.Unsafe + ( class Deferred + , undefer + ) where -- | A class for side-effecting promises which don't prematurely execute. +-- Internal NOTE: this class should always appear as a constraint when an Eff is +-- in negative position and a Promise is in positive position. class Deferred -- | Note: use of this function may result in arbitrary side effects. diff --git a/test/Main.purs b/test/Main.purs index 7340d76..75caa8b 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -15,7 +15,7 @@ type AppEff = (console :: CONSOLE) main :: Eff AppEff Unit main = do Promise.runPromise onSuccess onError prom1 - NS.done onSuccess onError (NS.finally prom2 (log "hi")) + NS.doneDeferred onSuccess onError (NS.finally prom2 (log "hi")) prom1 :: Promise.Deferred => Promise.Promise AppEff Unit prom1 = do @@ -30,7 +30,9 @@ prom2 = Promise.resolve "hello" # Promise.then' \ a -> Console.log a prom3 :: Promise.Deferred => Promise.Promise AppEff String prom3 = Promise.promise k where - k onSucc _ = onSucc "this shouldn't be shown on console" + k onSucc _ = do + log "this shouldn't be shown on console" + onSucc "nor this" prom4 :: Promise.Deferred => Promise.Promise AppEff Unit prom4 = do