Conservative defer

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,47 +140,55 @@ 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)
   -> (Deferred => Promise eff a)
   -> 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

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)

src/Control/Monad/Promise/Unsafe.js

@@ -1,3 +1,3 @@
 exports.undefer = function (f) {
   return f();
-}
+};

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.

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