From 89af4ae4d760ab30168ef1db4f97cec80bbeb2b3 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Sat, 14 Dec 2019 04:38:44 -0600 Subject: [PATCH] Move arrow transformers into a separate module --- server/graphql-engine.cabal | 1 + server/src-lib/Control/Arrow/Extended.hs | 247 +++-------------------- server/src-lib/Control/Arrow/Trans.hs | 231 +++++++++++++++++++++ server/src-lib/Hasura/Incremental.hs | 36 +--- 4 files changed, 263 insertions(+), 252 deletions(-) create mode 100644 server/src-lib/Control/Arrow/Trans.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 2ffbd5b8..3bfa4e68 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -195,6 +195,7 @@ library , generic-arbitrary exposed-modules: Control.Arrow.Extended + , Control.Arrow.Trans , Control.Monad.Stateless , Control.Monad.Unique diff --git a/server/src-lib/Control/Arrow/Extended.hs b/server/src-lib/Control/Arrow/Extended.hs index 490079e1..71defb77 100644 --- a/server/src-lib/Control/Arrow/Extended.hs +++ b/server/src-lib/Control/Arrow/Extended.hs @@ -1,48 +1,34 @@ {-# OPTIONS_GHC -Wno-inline-rule-shadowing -Wno-orphans #-} -- see Note [Arrow rewrite rules] {-# LANGUAGE Arrows #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -- | The missing standard library for arrows. Some of the functionality in this module is similar to -- Paterson’s original @arrows@ library, but it has been modernized to work with recent versions of -- GHC. module Control.Arrow.Extended ( module Control.Arrow + , module Control.Arrow.Trans + , (>->) , (<-<) + , dup , foldlA' , traverseA_ , traverseA , onNothingA - , ArrowTrans(..) - , ArrowKleisli(..) , bindA - - , ArrowError(..) - , liftEitherA - , mapErrorA - , ErrorA(..) - - , ArrowReader(..) - , ReaderA(..) - - , ArrowWriter(..) - , WriterA(WriterA, runWriterA) ) where -import Prelude hiding (id, (.)) +import Prelude hiding (id, (.)) import Control.Arrow +import Control.Arrow.Trans import Control.Category import Control.Monad -import Control.Monad.Error.Class -import Control.Monad.Reader.Class -import Control.Monad.Writer.Class import Data.Foldable infixl 1 >-> @@ -62,6 +48,10 @@ f >-> g = proc (e, s) -> do (<-<) = flip (>->) {-# INLINE (<-<) #-} +dup :: (Arrow arr) => arr a (a, a) +dup = arr \x -> (x, x) +{-# INLINE dup #-} + -- | 'foldl'' lifted to arrows. See also Note [Weird control operator types]. foldlA' :: (ArrowChoice arr, Foldable t) => arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b foldlA' f = arr (\(e, (v, (xs, s))) -> (e, (v, (toList xs, s)))) >>> go where @@ -126,8 +116,20 @@ onNothingA f = proc (e, (v, s)) -> case v of Nothing -> f -< (e, s) {-# INLINABLE onNothingA #-} --- This rule is missing from Control.Arrow; see Note [Arrow rewrite rules] -{-# RULES "arr/arr/R" forall f g h. arr f . (arr g . h) = arr (f . g) . h #-} +-- These rules are missing from Control.Arrow; see Note [Arrow rewrite rules] +{-# RULES +"arr/arr/R" forall f g h. arr f . (arr g . h) = arr (f . g) . h + +"&&&/id" forall f. f &&& id = first f . dup +"id/&&&" forall f. id &&& f = second f . dup +"&&&/arr" forall f g. f &&& arr g = first f . arr (id &&& g) +"arr/&&&" forall f g. arr f &&& g = second g . arr (f &&& id) + +"|||/id" forall f. f ||| id = arr (id ||| id) . left f +"id/|||" forall f. id ||| f = arr (id ||| id) . right f +"|||/arr" forall f g. f ||| arr g = arr (id ||| g) . left f +"arr/|||" forall f g. arr f ||| g = arr (f ||| id) . right g +#-} -- | The class of /Kleisli arrows/, arrows made from monadic functions. Instances should satisfy -- the following laws: @@ -184,218 +186,15 @@ bindA = arrM id instance (Monad m) => ArrowKleisli m (Kleisli m) where arrM = Kleisli -class (Arrow arr, Arrow (t arr)) => ArrowTrans t arr where - liftA :: arr a b -> t arr a b - -class (Arrow arr) => ArrowError e arr | arr -> e where - throwA :: arr e a - -- see Note [Weird control operator types] - catchA :: arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b - -liftEitherA :: (ArrowChoice arr, ArrowError e arr) => arr (Either e a) a -liftEitherA = throwA ||| returnA -{-# INLINE liftEitherA #-} - -mapErrorA :: (ArrowError e arr) => arr (a, s) b -> arr (a, ((e -> e), s)) b -mapErrorA f = proc (a, (g, s)) -> (f -< (a, s)) `catchA` \e -> throwA -< g e -{-# INLINE mapErrorA #-} - -class (Arrow arr) => ArrowReader r arr | arr -> r where - askA :: arr a r - -- see Note [Weird control operator types] - localA :: arr (a, s) b -> arr (a, (r, s)) b - -class (Monoid w, Arrow arr) => ArrowWriter w arr | arr -> w where - tellA :: arr w () - listenA :: arr a b -> arr a (b, w) - -instance (MonadError e m) => ArrowError e (Kleisli m) where - throwA = Kleisli throwError - catchA (Kleisli f) (Kleisli g) = Kleisli \(a, s) -> f (a, s) `catchError` \e -> g (a, (e, s)) - -instance (MonadReader r m) => ArrowReader r (Kleisli m) where - askA = Kleisli $ const ask - localA (Kleisli f) = Kleisli \(a, (r, s)) -> local (const r) (f (a, s)) - -instance (MonadWriter w m) => ArrowWriter w (Kleisli m) where - tellA = Kleisli tell - listenA (Kleisli f) = Kleisli (listen . f) - -newtype ErrorA e arr a b = ErrorA { runErrorA :: arr a (Either e b) } - deriving (Functor) - -instance (ArrowChoice arr) => Category (ErrorA e arr) where - id = ErrorA (arr Right) - {-# INLINE id #-} - ErrorA f . ErrorA g = ErrorA ((arr Left ||| f) . g) - {-# INLINABLE (.) #-} - -sequenceFirst :: (Functor f) => (f a, b) -> f (a, b) -sequenceFirst (a, b) = (, b) <$> a -{-# INLINABLE sequenceFirst #-} - -instance (ArrowChoice arr) => Arrow (ErrorA e arr) where - arr f = ErrorA (arr (Right . f)) - {-# INLINE arr #-} - first (ErrorA f) = ErrorA (arr sequenceFirst . first f) - {-# INLINE first #-} - -reassociateEither :: Either (Either a b) c -> Either a (Either b c) -reassociateEither = either (either Left (Right . Left)) (Right . Right) - -instance (ArrowChoice arr) => ArrowChoice (ErrorA e arr) where - left (ErrorA f) = ErrorA (arr reassociateEither . left f) - {-# INLINE left #-} - ErrorA f ||| ErrorA g = ErrorA (f ||| g) - {-# INLINE (|||) #-} - -instance (ArrowChoice arr, ArrowApply arr) => ArrowApply (ErrorA e arr) where - app = ErrorA (app . first (arr runErrorA)) - {-# INLINE app #-} - -instance (ArrowChoice arr) => ArrowTrans (ErrorA e) arr where - liftA f = ErrorA (arr Right . f) - {-# INLINE liftA #-} - -instance (ArrowChoice arr) => ArrowError e (ErrorA e arr) where - throwA = ErrorA (arr Left) - {-# INLINE throwA #-} - catchA (ErrorA f) (ErrorA g) = ErrorA proc (a, s) -> do - r <- f -< (a, s) - case r of - Left e -> g -< (a, (e, s)) - Right v -> returnA -< Right v - {-# INLINABLE catchA #-} - instance (ArrowKleisli m arr, ArrowChoice arr) => ArrowKleisli m (ErrorA e arr) where arrM = liftA . arrM {-# INLINE arrM #-} -instance (ArrowReader r arr, ArrowChoice arr) => ArrowReader r (ErrorA e arr) where - askA = liftA askA - {-# INLINE askA #-} - localA (ErrorA f) = ErrorA (localA f) - {-# INLINE localA #-} -instance (ArrowWriter w arr, ArrowChoice arr) => ArrowWriter w (ErrorA e arr) where - tellA = liftA tellA - {-# INLINE tellA #-} - listenA (ErrorA f) = ErrorA (arr sequenceFirst . listenA f) - {-# INLINE listenA #-} - -newtype ReaderA r arr a b = ReaderA { runReaderA :: arr (a, r) b } - -instance (Arrow arr) => Category (ReaderA r arr) where - id = ReaderA (arr fst) - {-# INLINE id #-} - ReaderA f . ReaderA g = ReaderA proc (a, r) -> do - b <- g -< (a, r) - f -< (b, r) - {-# INLINE (.) #-} - -instance (Arrow arr) => Arrow (ReaderA r arr) where - arr f = ReaderA (arr (f . fst)) - {-# INLINE arr #-} - first (ReaderA f) = ReaderA proc ((a, c), r) -> do - b <- f -< (a, r) - returnA -< (b, c) - {-# INLINE first #-} - -instance (ArrowChoice arr) => ArrowChoice (ReaderA r arr) where - left (ReaderA f) = ReaderA proc (e, r) -> case e of - Left a -> arr Left . f -< (a, r) - Right b -> returnA -< Right b - {-# INLINE left #-} - ReaderA f ||| ReaderA g = ReaderA ((f ||| g) . arr \(e, r) -> ((, r) +++ (, r)) e) - {-# INLINE (|||) #-} - -instance (ArrowApply arr) => ArrowApply (ReaderA r arr) where - app = ReaderA (app . arr \((ReaderA f, x), r) -> (f, (x, r))) - {-# INLINE app #-} - -instance (Arrow arr) => ArrowTrans (ReaderA r) arr where - liftA f = ReaderA (f . arr fst) - {-# INLINE liftA #-} - -instance (Arrow arr) => ArrowReader r (ReaderA r arr) where - askA = ReaderA (arr snd) - {-# INLINE askA #-} - localA (ReaderA f) = ReaderA proc ((a, (r, s)), _) -> f -< ((a, s), r) - {-# INLINE localA #-} - instance (ArrowKleisli m arr) => ArrowKleisli m (ReaderA r arr) where arrM = liftA . arrM {-# INLINE arrM #-} -instance (ArrowError e arr) => ArrowError e (ReaderA r arr) where - throwA = liftA throwA - {-# INLINE throwA #-} - catchA (ReaderA f) (ReaderA g) = ReaderA proc ((a, s), r) -> - (f -< ((a, s), r)) `catchA` \e -> g -< ((a, (e, s)), r) - {-# INLINE catchA #-} -instance (ArrowWriter w arr) => ArrowWriter w (ReaderA r arr) where - tellA = liftA tellA - {-# INLINE tellA #-} - listenA (ReaderA f) = ReaderA (listenA f) - {-# INLINE listenA #-} - -newtype WriterA w arr a b - -- Internally defined using state passing to avoid space leaks. The real constructor should be - -- left unexported to avoid misuse. - = MkWriterA (arr (a, w) (b, w)) - -pattern WriterA :: (Monoid w, Arrow arr) => arr a (b, w) -> WriterA w arr a b -pattern WriterA { runWriterA } <- MkWriterA ((\f -> f . arr (, mempty)) -> runWriterA) - where - WriterA f = MkWriterA (arr (\((b, w), w1) -> let !w2 = w1 <> w in (b, w2)) . first f) -{-# COMPLETE WriterA #-} - -instance (Category arr) => Category (WriterA w arr) where - id = MkWriterA id - {-# INLINE id #-} - MkWriterA f . MkWriterA g = MkWriterA (f . g) - {-# INLINE (.) #-} - -instance (Arrow arr) => Arrow (WriterA w arr) where - arr f = MkWriterA (arr $ first f) - {-# INLINE arr #-} - first (MkWriterA f) = MkWriterA proc ((a1, b), w1) -> do - (a2, w2) <- f -< (a1, w1) - returnA -< ((a2, b), w2) - {-# INLINE first #-} - -instance (ArrowChoice arr) => ArrowChoice (WriterA w arr) where - left (MkWriterA f) = MkWriterA proc (e, w) -> case e of - Left a -> arr (first Left) . f -< (a, w) - Right b -> returnA -< (Right b, w) - {-# INLINE left #-} - f ||| g = arr (either id id) . right g . left f - {-# INLINE (|||) #-} - -instance (ArrowApply arr) => ArrowApply (WriterA w arr) where - app = MkWriterA (app . arr \((MkWriterA f, x), w) -> (f, (x, w))) - {-# INLINE app #-} - -instance (Arrow arr) => ArrowTrans (WriterA w) arr where - liftA = MkWriterA . first - {-# INLINE liftA #-} - -instance (Monoid w, Arrow arr) => ArrowWriter w (WriterA w arr) where - tellA = MkWriterA $ arr \(w, w1) -> let !w2 = w1 <> w in ((), w2) - listenA (WriterA f) = WriterA (arr (\(a, w) -> ((a, w), w)) . f) - {-# INLINE listenA #-} - instance (ArrowKleisli m arr) => ArrowKleisli m (WriterA w arr) where arrM = liftA . arrM {-# INLINE arrM #-} -instance (ArrowError e arr) => ArrowError e (WriterA w arr) where - throwA = liftA throwA - {-# INLINE throwA #-} - catchA (MkWriterA f) (MkWriterA g) = MkWriterA proc ((a, s), w) -> - (f -< ((a, s), w)) `catchA` \e -> g -< ((a, (e, s)), w) - {-# INLINE catchA #-} -instance (ArrowReader r arr) => ArrowReader r (WriterA w arr) where - askA = liftA askA - {-# INLINE askA #-} - localA (MkWriterA f) = MkWriterA proc ((a, (r, s)), w) -> (| localA (f -< ((a, s), w)) |) r - {-# INLINE localA #-} {- Note [Weird control operator types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/server/src-lib/Control/Arrow/Trans.hs b/server/src-lib/Control/Arrow/Trans.hs new file mode 100644 index 00000000..fd34b6dd --- /dev/null +++ b/server/src-lib/Control/Arrow/Trans.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Control.Arrow.Trans + ( ArrowTrans(..) + + , ArrowError(..) + , liftEitherA + , mapErrorA + , ErrorA(..) + + , ArrowReader(..) + , ReaderA(..) + + , ArrowWriter(..) + , WriterA(WriterA, runWriterA) + ) where + +import Prelude hiding ((.), id) + +import Control.Arrow +import Control.Category +import Control.Monad.Error.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class + +class (Arrow arr, Arrow (t arr)) => ArrowTrans t arr where + liftA :: arr a b -> t arr a b + +class (Arrow arr) => ArrowError e arr | arr -> e where + throwA :: arr e a + -- see Note [Weird control operator types] + catchA :: arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b + +liftEitherA :: (ArrowChoice arr, ArrowError e arr) => arr (Either e a) a +liftEitherA = throwA ||| returnA +{-# INLINE liftEitherA #-} + +mapErrorA :: (ArrowError e arr) => arr (a, s) b -> arr (a, ((e -> e), s)) b +mapErrorA f = proc (a, (g, s)) -> (f -< (a, s)) `catchA` \e -> throwA -< g e +{-# INLINE mapErrorA #-} + +class (Arrow arr) => ArrowReader r arr | arr -> r where + askA :: arr a r + -- see Note [Weird control operator types] + localA :: arr (a, s) b -> arr (a, (r, s)) b + +class (Monoid w, Arrow arr) => ArrowWriter w arr | arr -> w where + tellA :: arr w () + listenA :: arr a b -> arr a (b, w) + +instance (MonadError e m) => ArrowError e (Kleisli m) where + throwA = Kleisli throwError + catchA (Kleisli f) (Kleisli g) = Kleisli \(a, s) -> f (a, s) `catchError` \e -> g (a, (e, s)) + +instance (MonadReader r m) => ArrowReader r (Kleisli m) where + askA = Kleisli $ const ask + localA (Kleisli f) = Kleisli \(a, (r, s)) -> local (const r) (f (a, s)) + +instance (MonadWriter w m) => ArrowWriter w (Kleisli m) where + tellA = Kleisli tell + listenA (Kleisli f) = Kleisli (listen . f) + +newtype ErrorA e arr a b = ErrorA { runErrorA :: arr a (Either e b) } + deriving (Functor) + +instance (ArrowChoice arr) => Category (ErrorA e arr) where + id = ErrorA (arr Right) + {-# INLINE id #-} + ErrorA f . ErrorA g = ErrorA ((arr Left ||| f) . g) + {-# INLINABLE (.) #-} + +sequenceFirst :: (Functor f) => (f a, b) -> f (a, b) +sequenceFirst (a, b) = (, b) <$> a +{-# INLINABLE sequenceFirst #-} + +instance (ArrowChoice arr) => Arrow (ErrorA e arr) where + arr f = ErrorA (arr (Right . f)) + {-# INLINE arr #-} + first (ErrorA f) = ErrorA (arr sequenceFirst . first f) + {-# INLINE first #-} + +reassociateEither :: Either (Either a b) c -> Either a (Either b c) +reassociateEither = either (either Left (Right . Left)) (Right . Right) + +instance (ArrowChoice arr) => ArrowChoice (ErrorA e arr) where + left (ErrorA f) = ErrorA (arr reassociateEither . left f) + {-# INLINE left #-} + ErrorA f ||| ErrorA g = ErrorA (f ||| g) + {-# INLINE (|||) #-} + +instance (ArrowChoice arr, ArrowApply arr) => ArrowApply (ErrorA e arr) where + app = ErrorA (app . first (arr runErrorA)) + {-# INLINE app #-} + +instance (ArrowChoice arr) => ArrowTrans (ErrorA e) arr where + liftA f = ErrorA (arr Right . f) + {-# INLINE liftA #-} + +instance (ArrowChoice arr) => ArrowError e (ErrorA e arr) where + throwA = ErrorA (arr Left) + {-# INLINE throwA #-} + catchA (ErrorA f) (ErrorA g) = ErrorA proc (a, s) -> do + r <- f -< (a, s) + case r of + Left e -> g -< (a, (e, s)) + Right v -> returnA -< Right v + {-# INLINABLE catchA #-} + +instance (ArrowReader r arr, ArrowChoice arr) => ArrowReader r (ErrorA e arr) where + askA = liftA askA + {-# INLINE askA #-} + localA (ErrorA f) = ErrorA (localA f) + {-# INLINE localA #-} +instance (ArrowWriter w arr, ArrowChoice arr) => ArrowWriter w (ErrorA e arr) where + tellA = liftA tellA + {-# INLINE tellA #-} + listenA (ErrorA f) = ErrorA (arr sequenceFirst . listenA f) + {-# INLINE listenA #-} + +newtype ReaderA r arr a b = ReaderA { runReaderA :: arr (a, r) b } + +instance (Arrow arr) => Category (ReaderA r arr) where + id = ReaderA (arr fst) + {-# INLINE id #-} + ReaderA f . ReaderA g = ReaderA proc (a, r) -> do + b <- g -< (a, r) + f -< (b, r) + {-# INLINE (.) #-} + +instance (Arrow arr) => Arrow (ReaderA r arr) where + arr f = ReaderA (arr (f . fst)) + {-# INLINE arr #-} + first (ReaderA f) = ReaderA proc ((a, c), r) -> do + b <- f -< (a, r) + returnA -< (b, c) + {-# INLINE first #-} + +instance (ArrowChoice arr) => ArrowChoice (ReaderA r arr) where + left (ReaderA f) = ReaderA proc (e, r) -> case e of + Left a -> arr Left . f -< (a, r) + Right b -> returnA -< Right b + {-# INLINE left #-} + ReaderA f ||| ReaderA g = ReaderA ((f ||| g) . arr \(e, r) -> ((, r) +++ (, r)) e) + {-# INLINE (|||) #-} + +instance (ArrowApply arr) => ArrowApply (ReaderA r arr) where + app = ReaderA (app . arr \((ReaderA f, x), r) -> (f, (x, r))) + {-# INLINE app #-} + +instance (Arrow arr) => ArrowTrans (ReaderA r) arr where + liftA f = ReaderA (f . arr fst) + {-# INLINE liftA #-} + +instance (Arrow arr) => ArrowReader r (ReaderA r arr) where + askA = ReaderA (arr snd) + {-# INLINE askA #-} + localA (ReaderA f) = ReaderA proc ((a, (r, s)), _) -> f -< ((a, s), r) + {-# INLINE localA #-} + +instance (ArrowError e arr) => ArrowError e (ReaderA r arr) where + throwA = liftA throwA + {-# INLINE throwA #-} + catchA (ReaderA f) (ReaderA g) = ReaderA proc ((a, s), r) -> + (f -< ((a, s), r)) `catchA` \e -> g -< ((a, (e, s)), r) + {-# INLINE catchA #-} +instance (ArrowWriter w arr) => ArrowWriter w (ReaderA r arr) where + tellA = liftA tellA + {-# INLINE tellA #-} + listenA (ReaderA f) = ReaderA (listenA f) + {-# INLINE listenA #-} + +newtype WriterA w arr a b + -- Internally defined using state passing to avoid space leaks. The real constructor should be + -- left unexported to avoid misuse. + = MkWriterA (arr (a, w) (b, w)) + +pattern WriterA :: (Monoid w, Arrow arr) => arr a (b, w) -> WriterA w arr a b +pattern WriterA { runWriterA } <- MkWriterA ((\f -> f . arr (, mempty)) -> runWriterA) + where + WriterA f = MkWriterA (arr (\((b, w), w1) -> let !w2 = w1 <> w in (b, w2)) . first f) +{-# COMPLETE WriterA #-} + +instance (Category arr) => Category (WriterA w arr) where + id = MkWriterA id + {-# INLINE id #-} + MkWriterA f . MkWriterA g = MkWriterA (f . g) + {-# INLINE (.) #-} + +instance (Arrow arr) => Arrow (WriterA w arr) where + arr f = MkWriterA (arr $ first f) + {-# INLINE arr #-} + first (MkWriterA f) = MkWriterA proc ((a1, b), w1) -> do + (a2, w2) <- f -< (a1, w1) + returnA -< ((a2, b), w2) + {-# INLINE first #-} + +instance (ArrowChoice arr) => ArrowChoice (WriterA w arr) where + left (MkWriterA f) = MkWriterA proc (e, w) -> case e of + Left a -> arr (first Left) . f -< (a, w) + Right b -> returnA -< (Right b, w) + {-# INLINE left #-} + f ||| g = arr (either id id) . right g . left f + {-# INLINE (|||) #-} + +instance (ArrowApply arr) => ArrowApply (WriterA w arr) where + app = MkWriterA (app . arr \((MkWriterA f, x), w) -> (f, (x, w))) + {-# INLINE app #-} + +instance (Arrow arr) => ArrowTrans (WriterA w) arr where + liftA = MkWriterA . first + {-# INLINE liftA #-} + +instance (Monoid w, Arrow arr) => ArrowWriter w (WriterA w arr) where + tellA = MkWriterA $ arr \(w, w1) -> let !w2 = w1 <> w in ((), w2) + listenA (WriterA f) = WriterA (arr (\(a, w) -> ((a, w), w)) . f) + {-# INLINE listenA #-} + +instance (ArrowError e arr) => ArrowError e (WriterA w arr) where + throwA = liftA throwA + {-# INLINE throwA #-} + catchA (MkWriterA f) (MkWriterA g) = MkWriterA proc ((a, s), w) -> + (f -< ((a, s), w)) `catchA` \e -> g -< ((a, (e, s)), w) + {-# INLINE catchA #-} +instance (ArrowReader r arr) => ArrowReader r (WriterA w arr) where + askA = liftA askA + {-# INLINE askA #-} + localA (MkWriterA f) = MkWriterA proc ((a, (r, s)), w) -> (| localA (f -< ((a, s), w)) |) r + {-# INLINE localA #-} diff --git a/server/src-lib/Hasura/Incremental.hs b/server/src-lib/Hasura/Incremental.hs index 0e6f0eef..92bcfe77 100644 --- a/server/src-lib/Hasura/Incremental.hs +++ b/server/src-lib/Hasura/Incremental.hs @@ -262,39 +262,19 @@ instance (Monad m) => ArrowKleisli m (Rule m) where {-# INLINE arrM #-} class (Arrow arr) => ArrowCache arr where - -- | Adds equality-based caching to the given rule. After each execution of the rule, its input - -- and result values are cached. On the next rebuild, the input value is compared via '==' to the - -- previous input value. If they are the same, the previous build result is returned /without/ - -- re-executing the rule. Otherwise, the old cached values are discarded, and the rule is + -- | Adds equality-based caching to the given arrow. After each execution of the arrow, its input + -- and result values are cached. On the next execution, the new input value is compared via '==' + -- to the previous input value. If they are the same, the previous result is returned /without/ + -- re-executing the arrow. Otherwise, the old cached values are discarded, and the arrow is -- re-executed to produce a new set of cached values. -- -- Indescriminate use of 'cache' is likely to have little effect except to increase memory usage, - -- since the input and result of each rule execution must be retained in memory. Avoid using - -- 'cache' around rules with large input or output that is likely to change often unless profiling + -- since the input and result of each execution must be retained in memory. Avoid using 'cache' + -- around arrows with large input or output that is likely to change often unless profiling -- indicates it is computationally expensive enough to be worth the memory overhead. -- - -- __Note that only direct inputs and outputs of a 'Rule' are cached.__ It is extremely important - -- to take care in your choice of the base monad @m@: - -- - -- * Monads that provide access to extra information through a side-channel, such as 'ReaderT', - -- 'StateT', or 'IO', will __not__ expose that information to dependency analysis. If that - -- information changes between builds, but the rule’s direct inputs remain unchanged, the rule - -- will __not__ be re-executed. - -- - -- * Dually, monads that perform side-effects as part of execution, such as 'StateT', 'WriterT', - -- or 'IO', will __not__ have their side-effects automatically replayed if the cached result - -- is used. If the side effects are only necessary to change some state to bring it in line - -- with the updated inputs, that is entirely fine (and likely even desirable), but if the - -- side-effects are necessary to produce each result, caching will lead to incorrect behavior. - -- - -- The safest monad to use for @m@ is therefore 'Identity', which suffers neither of the above - -- problems by construction. However, in practice, it is highly desirable to be able to execute - -- rules that may perform side-effects in 'IO', so the capability is exposed. - -- - -- For a safe way to use other effects with 'Rule', use arrow transformers like 'ErrorA', - -- 'ReaderA', and 'WriterA' on top of a base @'Rule' m@ arrow. Such uses are completely safe, as - -- the extra information added by other transformers /will/ be exposed to dependency analysis and - -- /will/ be cached. + -- __Note that only direct inputs and outputs of the given arrow are cached.__ If an arrow + -- provides access to values through a side-channel, they will __not__ participate in caching. cache :: (Eq a) => arr a b -> arr a b instance (ArrowChoice arr, ArrowCache arr) => ArrowCache (ErrorA e arr) where