From 6a59739ad266db092b81fb85b9bb2073d603df71 Mon Sep 17 00:00:00 2001 From: Robert Porter Date: Sat, 12 Dec 2020 10:54:09 +0900 Subject: [PATCH 1/4] Add promise flattening and lazy boxing --- src/Web/Promise.purs | 10 ++++++++-- src/Web/Promise/Internal.purs | 6 +++--- src/Web/Promise/Lazy.purs | 30 +++++++++++++++++++++--------- 3 files changed, 32 insertions(+), 14 deletions(-) diff --git a/src/Web/Promise.purs b/src/Web/Promise.purs index 2642976..fd351f4 100644 --- a/src/Web/Promise.purs +++ b/src/Web/Promise.purs @@ -14,11 +14,17 @@ 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 :: forall k1 k2. k1 -> k2 -> 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) diff --git a/src/Web/Promise/Internal.purs b/src/Web/Promise/Internal.purs index e1b71a8..e421fa8 100644 --- a/src/Web/Promise/Internal.purs +++ b/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 diff --git a/src/Web/Promise/Lazy.purs b/src/Web/Promise/Lazy.purs index c0288a6..48a536b 100644 --- a/src/Web/Promise/Lazy.purs +++ b/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,19 @@ 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_ (mkEffectFn1 \bs -> pure (P.resolve (Box (map (\(Box b) -> b) bs)))) as'' race :: forall a. Array (LazyPromise a) -> LazyPromise a race as = LazyPromise do as' <- traverse (\(LazyPromise a) -> a) as - runEffectFn1 P.race as' \ No newline at end of file + runEffectFn1 P.race as' From 83ab3c8ade5785e35ed26608b9c3cfa10aa43ba4 Mon Sep 17 00:00:00 2001 From: Robert Porter Date: Sat, 12 Dec 2020 13:26:50 +0900 Subject: [PATCH 2/4] Pulled out `rebox` for clarity --- src/Web/Promise/Lazy.purs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Web/Promise/Lazy.purs b/src/Web/Promise/Lazy.purs index 48a536b..5933e6d 100644 --- a/src/Web/Promise/Lazy.purs +++ b/src/Web/Promise/Lazy.purs @@ -60,7 +60,9 @@ all :: forall a. Array (LazyPromise a) -> LazyPromise (Array a) all as = LazyPromise do as' <- traverse (\(LazyPromise a) -> a) as as'' <- runEffectFn1 P.all as' - runEffectFn2 P.then_ (mkEffectFn1 \bs -> pure (P.resolve (Box (map (\(Box b) -> b) bs)))) 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 From 2357dc69f34012bd56e69c2a369a415c6b3b7ef6 Mon Sep 17 00:00:00 2001 From: Robert Porter Date: Sat, 12 Dec 2020 13:41:55 +0900 Subject: [PATCH 3/4] Flatten doesn't need to be polykinded --- src/Web/Promise.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Web/Promise.purs b/src/Web/Promise.purs index fd351f4..d653a46 100644 --- a/src/Web/Promise.purs +++ b/src/Web/Promise.purs @@ -14,7 +14,7 @@ import Web.Promise.Rejection (Rejection) type Executor a = (a -> Effect Unit) -> (Rejection -> Effect Unit) -> Effect Unit -class Flatten :: forall k1 k2. k1 -> k2 -> Constraint +class Flatten :: Type -> Type -> Constraint class Flatten a b | a -> b instance flattenPromise :: Flatten a b => Flatten (Promise a) b From 2cee0ae13f58d6b302ac036abd790c0cb4961c4e Mon Sep 17 00:00:00 2001 From: Robert Porter Date: Wed, 16 Dec 2020 10:44:02 +0900 Subject: [PATCH 4/4] Provide `resolve` with the flattening constraint --- src/Web/Promise.purs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Web/Promise.purs b/src/Web/Promise.purs index d653a46..d39042f 100644 --- a/src/Web/Promise.purs +++ b/src/Web/Promise.purs @@ -8,7 +8,7 @@ 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) @@ -33,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