Add promise flattening and lazy boxing (#8)

Author: robertdp

src/Web/Promise.purs

@@ -8,17 +8,23 @@ import Prelude
 
 import Effect (Effect)
 import Effect.Uncurried (mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn2)
-import Web.Promise.Internal (Promise, reject, resolve)
+import Web.Promise.Internal (Promise, reject)
 import Web.Promise.Internal as P
 import Web.Promise.Rejection (Rejection)
 
 type Executor a = (a -> Effect Unit) -> (Rejection -> Effect Unit) -> Effect Unit
 
-new :: forall a. Executor a -> Effect (Promise a)
+class Flatten :: Type -> Type -> Constraint
+class Flatten a b | a -> b
+
+instance flattenPromise :: Flatten a b => Flatten (Promise a) b
+else instance flattenDone :: Flatten a a
+
+new :: forall a b. Flatten a b => Executor a -> Effect (Promise b)
 new k = runEffectFn1 P.new $ mkEffectFn2 \onResolve onReject ->
   k (runEffectFn1 onResolve) (runEffectFn1 onReject)
 
-then_ :: forall a b. (a -> Effect (Promise b)) -> Promise a -> Effect (Promise b)
+then_ :: forall a b c. Flatten b c => (a -> Effect (Promise b)) -> Promise a -> Effect (Promise c)
 then_ k p = runEffectFn2 P.then_ (mkEffectFn1 k) p
 
 catch :: forall a b. (Rejection -> Effect (Promise b)) -> Promise a -> Effect (Promise b)
@@ -27,6 +33,9 @@ catch k p = runEffectFn2 P.catch (mkEffectFn1 k) p
 finally :: forall a. (Effect (Promise Unit)) -> Promise a -> Effect (Promise a)
 finally = runEffectFn2 P.finally
 
+resolve :: forall a b. Flatten a b => a -> Promise b
+resolve = P.resolve
+
 all :: forall a. Array (Promise a) -> Effect (Promise (Array a))
 all = runEffectFn1 P.all
 

src/Web/Promise/Internal.purs

@@ -10,15 +10,15 @@ foreign import data Promise :: Type -> Type
 
 type role Promise representational
 
-foreign import new :: forall a. EffectFn1 (EffectFn2 (EffectFn1 a Unit) (EffectFn1 Rejection Unit) Unit) (Promise a)
+foreign import new :: forall a b. EffectFn1 (EffectFn2 (EffectFn1 a Unit) (EffectFn1 Rejection Unit) Unit) (Promise b)
 
-foreign import then_ :: forall a b. EffectFn2 (EffectFn1 a (Promise b)) (Promise a) (Promise b)
+foreign import then_ :: forall a b c. EffectFn2 (EffectFn1 a (Promise b)) (Promise a) (Promise c)
 
 foreign import catch :: forall a b. EffectFn2 (EffectFn1 Rejection (Promise b)) (Promise a) (Promise b)
 
 foreign import finally :: forall a. EffectFn2 (Effect (Promise Unit)) (Promise a) (Promise a)
 
-foreign import resolve :: forall a. a -> Promise a
+foreign import resolve :: forall a b. a -> Promise b
 
 foreign import reject :: forall a. Rejection -> Promise a
 

src/Web/Promise/Lazy.purs

@@ -6,13 +6,16 @@ import Data.Newtype (class Newtype)
 import Data.Traversable (traverse)
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
-import Effect.Uncurried (mkEffectFn1, runEffectFn1, runEffectFn2)
-import Web.Promise (Rejection)
+import Effect.Uncurried (mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn2)
+import Web.Promise (Executor, Rejection)
 import Web.Promise.Internal as P
 
+-- | A trivial box that adds a layer between promises to prevent automatic flattening.
+data Box a = Box a
+
 -- | A pure `Promise` that has not been executed yet. This type can be used
 -- | with `do` syntax.
-newtype LazyPromise a = LazyPromise (Effect (P.Promise a))
+newtype LazyPromise a = LazyPromise (Effect (P.Promise (Box a)))
 
 derive instance newtypeLazyPromise :: Newtype (LazyPromise a) _
 
@@ -23,17 +26,21 @@ instance applyLazyPromise :: Apply LazyPromise where
   apply = ap
 
 instance applicativeLazyPromise :: Applicative LazyPromise where
-  pure = LazyPromise <<< pure <<< P.resolve
+  pure = LazyPromise <<< pure <<< P.resolve <<< Box
 
 instance bindLazyPromise :: Bind LazyPromise where
   bind (LazyPromise p) k = LazyPromise do
     p' <- p
-    runEffectFn2 P.then_ (mkEffectFn1 \a -> let (LazyPromise b) = k a in b) p'
+    runEffectFn2 P.then_ (mkEffectFn1 \(Box a) -> let (LazyPromise b) = k a in b) p'
 
 instance monadLazyPromise :: Monad LazyPromise
 
 instance monadEffectLazyPromise :: MonadEffect LazyPromise where
-  liftEffect = LazyPromise <<< map P.resolve
+  liftEffect = LazyPromise <<< map (P.resolve <<< Box)
+
+new :: forall a. Executor a -> LazyPromise a
+new k = LazyPromise $ runEffectFn1 P.new $ mkEffectFn2 \onResolve onReject ->
+  k (runEffectFn1 onResolve <<< Box) (runEffectFn1 onReject)
 
 catch :: forall a b. (Rejection -> LazyPromise b) -> LazyPromise a -> LazyPromise b
 catch k (LazyPromise p) = LazyPromise do
@@ -43,14 +50,21 @@ catch k (LazyPromise p) = LazyPromise do
 finally :: forall a. LazyPromise Unit -> LazyPromise a -> LazyPromise a
 finally (LazyPromise p1) (LazyPromise p2) = LazyPromise do
   p2' <- p2
-  runEffectFn2 P.finally p1 p2'
+  runEffectFn2 P.finally finalize p2'
+  where
+  finalize = do
+    p1' <- p1
+    runEffectFn2 P.then_ (mkEffectFn1 \(Box a) -> pure (P.resolve a)) p1'
 
 all :: forall a. Array (LazyPromise a) -> LazyPromise (Array a)
 all as = LazyPromise do
   as' <- traverse (\(LazyPromise a) -> a) as
-  runEffectFn1 P.all as'
+  as'' <- runEffectFn1 P.all as'
+  runEffectFn2 P.then_ rebox as''
+  where
+  rebox = mkEffectFn1 \bs -> pure (P.resolve (Box (map (\(Box b) -> b) bs)))
 
 race :: forall a. Array (LazyPromise a) -> LazyPromise a
 race as = LazyPromise do
   as' <- traverse (\(LazyPromise a) -> a) as
-  runEffectFn1 P.race as'
+  runEffectFn1 P.race as'