hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 17:02:49 +03:00
Code Issues Projects Releases Wiki Activity

Switch to a CPS implementation of Rule

Browse Source 
This is significantly more performance, even without specialization,
which dramatically improves compile times.
This commit is contained in:
Alexis King 2019-12-10 19:46:34 -06:00
parent c322e8a5d4
commit 780857fb19
13 changed files with 358 additions and 308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
server/Makefile
View File

@ -55,7 +55,7 @@ release-image: $(project).cabal
ci-binary:
mkdir -p packaging/build/rootfs
# --no-terminal for a cleaner output in circleci
stack $(STACK_FLAGS) build --no-terminal --test --no-run-tests --bench --no-run-benchmarks --ghc-options=-Werror $(BUILD_FLAGS)
stack $(STACK_FLAGS) build --no-terminal --test --no-run-tests --bench --no-run-benchmarks --ghc-options='-j2 -Werror' $(BUILD_FLAGS)
mkdir -p $(build_output)
cp $(build_dir)/$(project)/$(project) $(build_dir)/graphql-engine-tests/graphql-engine-tests $(build_output)
echo "$(VERSION)" > $(build_output)/version.txt

94
server/src-lib/Control/Arrow/Extended.hs
View File

@ -43,7 +43,6 @@ import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Data.Foldable
import Data.Tuple (swap)
infixl 1 >->
infixr 1 <-<
@ -70,6 +69,7 @@ foldlA' f = arr (\(e, (v, (xs, s))) -> (e, (v, (toList xs, s)))) >>> go where
[] -> Left v
x:xs' -> Right ((e, (v, (x, s))), (e, (xs', s)))
step = first f >>> arr (\(!v, (e, (xs, s))) -> (e, (v, (xs, s)))) >>> go
{-# INLINABLE foldlA' #-}
-- | An indexed version of Twan van Laarhoven’s @FunList@ type (see
-- <https://twanvl.nl/blog/haskell/non-regular1>). A value of type @'Traversal' a b (t b)@ is a
@ -102,25 +102,26 @@ traverseA f = second (first $ arr traversal) >>> go where
Yield a k -> do
b <- f -< (e, (a, s))
go -< (e, (k b, s))
{-# NOINLINE[1] traverseA #-}
-- In the common case of using traverseA on Maybe, the general traverseA generates needlessly
-- complex code due to the combination of recursion and indirection through Traversal. Since Maybe
-- is finite, we can do much better by avoiding the recursion completely.
traverseA_Maybe :: (ArrowChoice arr) => arr (e, (a, s)) b -> arr (e, (Maybe a, s)) (Maybe b)
traverseA_Maybe f = proc (e, (v, s)) -> case v of
Just a -> arr Just . f -< (e, (a, s))
Nothing -> returnA -< Nothing
{-# INLINABLE traverseA_Maybe #-}
{-# RULES "traverseA @Maybe" traverseA = traverseA_Maybe #-}
onNothingA :: (ArrowChoice arr) => arr (e, s) a -> arr (e, (Maybe a, s)) a
onNothingA f = proc (e, (v, s)) -> case v of
Just a -> returnA -< a
Nothing -> f -< (e, s)
{-# INLINABLE onNothingA #-}
{-# RULES -- These rules are missing from Control.Arrow; see Note [Arrow rewrite rules]
"arr/arr/R" forall f g h. arr f . (arr g . h) = arr (f . g) . h
"first/push" [~1] forall f g. first (f . g) = first f . first g
"second/push" [~1] forall f g. second (f . g) = second f . second g
"left/push" [~1] forall f g. left (f . g) = left f . left g
"right/push" [~1] forall f g. right (f . g) = right f . right g
"first/pull" [1] forall f g. first f . first g = first (f . g)
"second/pull" [1] forall f g. second f . second g = second (f . g)
"left/pull" [1] forall f g. left f . left g = left (f . g)
"right/pull" [1] forall f g. right f . right g = right (f . g)
#-}
-- 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 #-}
-- | The class of /Kleisli arrows/, arrows made from monadic functions. Instances should satisfy
-- the following laws:
@ -131,6 +132,9 @@ class (Monad m, Arrow arr) => ArrowKleisli m arr | arr -> m where
arrM :: (a -> m b) -> arr a b
{-# RULES -- see Note [Arrow rewrite rules]
"arrM/pure" arrM pure = id
"arrM/pure/f" forall f. arrM (pure . f) = arr f
"arr/arrM" forall f g. arr f . arrM g = arrM (fmap f . g)
"arrM/arr" forall f g. arrM f . arr g = arrM (f . g)
"arrM/arrM" forall f g. arrM f . arrM g = arrM (f <=< g)
@ -184,9 +188,11 @@ class (Arrow arr) => ArrowError e arr | arr -> e where
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
@ -214,76 +220,115 @@ newtype ErrorA e arr a b = ErrorA { runErrorA :: arr a (Either e b) }
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))
first (ErrorA f) = ErrorA (arr (fmap swap . sequence . swap) . first 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 (either (either Left (Right . Left)) (Right . Right)) . left f)
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
listenA (ErrorA f) = ErrorA (arr (\(r, w) -> (, w) <$> r) . listenA f)
{-# 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
@ -298,38 +343,53 @@ pattern WriterA { runWriterA } <- MkWriterA ((\f -> f . arr (, mempty)) -> runWr
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1
server/src-lib/Hasura/GraphQL/Schema.hs
View File

@ -690,6 +690,7 @@ mkGCtxMapTable tableCache funcCache tabInfo = do
noFilter :: AnnBoolExpPartialSQL
noFilter = annBoolExpTrue
{-# SCC mkGCtxMap #-}
mkGCtxMap
:: forall m. (MonadError QErr m)
=> TableCache -> FunctionCache -> m GCtxMap

451
server/src-lib/Hasura/Incremental.hs
View File

@ -10,7 +10,6 @@ module Hasura.Incremental
, rebuildRule
, result
, mapRule
, ArrowCache(..)
, ArrowDistribute(..)
) where
@ -44,155 +43,223 @@ import Data.Tuple (swap)
-- 'Result' contains the built value, accessible via 'result', but it also allows supplying a new
-- input value using 'rebuild' to produce a new result incrementally.
newtype Rule m a b
= Rule { build :: a -> m (Result m a b) }
deriving (Functor)
-- Note: this is a CPS encoding of `a -> m (Result m a b)`. In practice, the CPS encoding seems to
-- provide meaningful performance improvements: it cuts down significantly on allocation and is
-- friendlier to GHC’s optimizer.
= Rule (forall r. a -> (b -> Rule m a b -> m r) -> m r)
-- | Modifies a 'Rule' by applying a natural transformation.
mapRule :: (Functor n) => (forall r. m r -> n r) -> Rule m a b -> Rule n a b
mapRule f rule = Rule \input -> f (build rule input) <&> \result' ->
result' { rebuild = build (mapRule f (Rule $ rebuild result')) }
instance (Applicative m) => Applicative (Rule m a) where
pure a = Rule . const . pure $ pure a
rule1 <*> rule2 = Rule $ \input -> liftA2 (<*>) (build rule1 input) (build rule2 input)
instance (Functor m) => Profunctor (Rule m) where
dimap f g (Rule build) = Rule (fmap (dimap f g) . build . f)
ruleArrM :: (Functor m) => (a -> m b) -> Rule m a b
ruleArrM f = Rule $ fix \build -> fmap (Result build) . f
{-# INLINABLE[0] ruleArrM #-}
ruleCompose :: (Monad m) => Rule m b c -> Rule m a b -> Rule m a c
ruleCompose rule2 rule1 = Rule $ \input -> do
result1 <- build rule1 input
result2 <- build rule2 (result result1)
pure $ Result
{ rebuild = build (Rule (rebuild result2) `ruleCompose` Rule (rebuild result1))
, result = result result2
}
{-# INLINABLE[0] ruleCompose #-}
ruleFirst :: (Functor m) => Rule m a b -> Rule m (a, c) (b, c)
ruleFirst (Rule build) = Rule $ \(a, b) -> resultFirst b <$> build a
where
resultFirst b Result { rebuild, result } = Result
{ rebuild = \(a, b') -> resultFirst b' <$> rebuild a
, result = (result, b)
}
{-# INLINABLE[0] ruleFirst #-}
-- This is significantly trickier to implement than 'first'! Here’s how to think about it: the first
-- time the rule executes, we know nothing about previous runs, so if we’re given 'Left', we have to
-- call the original rule we’re given. At that point, as long as we are still given 'Left' on every
-- rebuild, we can take advantage of whatever caching happened on the previous run, so we keep
-- recursively calling 'leftResult'.
--
-- However, as soon as we get 'Right', we have to bail out. We return the input we’re given, and we
-- forget about any previous executions of the rule completely. If we’re given 'Left' on a
-- subsequent rebuild, we start over from the original rule again.
ruleLeft :: (Applicative m) => Rule m a b -> Rule m (Either a c) (Either b c)
ruleLeft (Rule build) = Rule eitherResult
where
eitherResult = either (fmap leftResult . build) rightResult
leftResult Result { rebuild, result } = Result
{ rebuild = either (fmap leftResult . rebuild) rightResult
, result = Left result
}
rightResult input = pure Result
{ rebuild = eitherResult
, result = Right input
}
{-# INLINABLE[0] ruleLeft #-}
firstM :: (Functor m) => (a -> m b) -> (a, c) -> m (b, c)
firstM f (a, b) = (, b) <$> f a
{-# INLINABLE firstM #-}
leftM :: (Applicative m) => (a -> m b) -> Either a c -> m (Either b c)
leftM f = \case
Left a -> Left <$> f a
Right b -> pure $ Right b
{-# INLINABLE leftM #-}
{-# RULES -- see Note [Rule rewrite rules]
"Rule/associate" forall f g h. f `ruleCompose` (g `ruleCompose` h) = (f `ruleCompose` g) `ruleCompose` h
"Rule/arrM/arrM" forall f g. ruleArrM f `ruleCompose` ruleArrM g = ruleArrM (f <=< g)
"Rule/arrM/arrM/R" forall f g h. ruleArrM f `ruleCompose` (ruleArrM g `ruleCompose` h) = ruleArrM (f <=< g) `ruleCompose` h
"Rule/arrM/arrM/L" forall f g h. (f `ruleCompose` ruleArrM g) `ruleCompose` ruleArrM h = f `ruleCompose` ruleArrM (g <=< h)
"Rule/first/arrM" forall f. ruleFirst (ruleArrM f) = ruleArrM (firstM f)
"Rule/left/arrM" forall f. ruleLeft (ruleArrM f) = ruleArrM (leftM f)
"Rule/first/push" [~1] forall f g. ruleFirst (f `ruleCompose` g) = ruleFirst f `ruleCompose` ruleFirst g
"Rule/left/push" [~1] forall f g. ruleLeft (f `ruleCompose` g) = ruleLeft f `ruleCompose` ruleLeft g
"Rule/first/pull" [1] forall f g. ruleFirst f `ruleCompose` ruleFirst g = ruleFirst (f `ruleCompose` g)
"Rule/left/pull" [1] forall f g. ruleLeft f `ruleCompose` ruleLeft g = ruleLeft (f `ruleCompose` g)
#-}
instance (Functor m) => Strong (Rule m) where
first' = ruleFirst
{-# INLINE first' #-}
instance (Applicative m) => Choice (Rule m) where
left' = ruleLeft
{-# INLINE left' #-}
instance (Monad m) => Category (Rule m) where
id = arrM pure
{-# INLINE id #-}
(.) = ruleCompose
{-# INLINE (.) #-}
instance (Monad m) => Arrow (Rule m) where
arr f = arrM (pure . f)
{-# INLINE arr #-}
first = ruleFirst
{-# INLINE first #-}
second f = arr swap . first f . arr swap
{-# INLINE second #-}
f *** g = second g . first f
{-# INLINE (***) #-}
f &&& g = (f *** g) . arr (\x -> (x, x))
{-# INLINE (&&&) #-}
instance (Monad m) => ArrowChoice (Rule m) where
left = ruleLeft
{-# INLINE left #-}
right f = arr (either Right Left) . ruleLeft f . arr (either Right Left)
{-# INLINE right #-}
f +++ g = right g . left f
{-# INLINE (+++) #-}
f ||| g = arr (either id id) . (f +++ g)
{-# INLINE (|||) #-}
instance (Monad m) => ArrowKleisli m (Rule m) where
arrM = ruleArrM
{-# INLINE arrM #-}
build :: (Applicative m) => Rule m a b -> a -> m (Result m a b)
build (Rule r) a = r a \b r' -> pure $ Result b r'
{-# INLINE build #-}
data Result m a b
= Result
{ rebuild :: !(a -> m (Result m a b))
, result :: !b
{ result :: !b
, rebuildRule :: !(Rule m a b)
} deriving (Functor)
rebuildRule :: Result m a b -> Rule m a b
rebuildRule = Rule . rebuild
rebuild :: (Applicative m) => Result m a b -> a -> m (Result m a b)
rebuild = build . rebuildRule
{-# INLINE rebuild #-}
instance (Applicative m) => Applicative (Result m a) where
pure a = fix $ \result -> Result
{ rebuild = const $ pure result
, result = a
}
result1 <*> result2 = Result
{ rebuild = \input -> liftA2 (<*>) (rebuild result1 input) (rebuild result2 input)
, result = result result1 $ result result2
}
{- Note [Rule rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As explained by Note [Arrow rewrite rules] in Control.Arrow.Extended, it’s important to define
type-specific rewrite rules to get good performance with arrows when the concrete type is used. This
is especially important for `Rule`, since the recursive definitions of operations like `.` and `arr`
are very difficult for the optimizer to deal with, and the composition of lots of small rules
created with `arr` is very inefficient.
instance (Functor m) => Profunctor (Result m) where
dimap f g Result { rebuild, result } = Result
{ rebuild = fmap (dimap f g) . rebuild . f
, result = g result
}
Since GHC aggressively specializes and inlines class methods, the rules cannot be defined on the
class methods themselves. Instead, the class methods expand to auxiliary definitions, and those
definitions include an INLINABLE[0] pragma that ensures they do not inline until the final
optimization phase. The rules are defined in terms of those definitions, so they will be able to do
their work in prior phases.
Note [Desugaring derived operations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One subtlety to the above is that we want to define operations in terms of other operations as much
as possible to avoid the need to write an enormous number of rewrite rules, but if we define them
that way directly, then we’ll end up using needlessly inefficient implementations when the
operations aren’t specialized. Therefore, we provide efficient implementations of operations like
`second`, but aggressively rewrite them in terms of simpler primitives like `first` when GHC is able
to specialize them. -}
rComp :: Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
Rule f `rComp` Rule g = Rule \a k -> g a \b g' -> f b \c f' -> k c (f' `rComp` g')
{-# INLINABLE[0] rComp #-}
{-# RULES "associate" forall f g h. f `rComp` (g `rComp` h) = (f `rComp` g) `rComp` h #-}
rId :: Rule m a a
rId = Rule \a k -> k a rId
{-# INLINABLE[0] rId #-}
{-# RULES
"f/id" forall f. f `rComp` rId = f
"id/f" forall f. rId `rComp` f = f
#-}
rArr :: (a -> b) -> Rule m a b
rArr f = Rule \a k -> k (f a) (rArr f)
{-# INLINABLE[0] rArr #-}
{-# RULES
"arr/id" rArr (\x -> x) = rId
"arr/const" [1] forall x. rArr (\_ -> x) = rPure x
"arr/arr" forall f g. rArr f `rComp` rArr g = rArr (f . g)
"arr/arr/f" forall f g h. (f `rComp` rArr g) `rComp` rArr h = f `rComp` rArr (g . h)
#-}
rArrM :: (Monad m) => (a -> m b) -> Rule m a b
rArrM f = Rule \a k -> f a >>= \b -> k b (rArrM f)
{-# INLINABLE[0] rArrM #-}
{-# RULES
"arrM/arrM" forall f g. rArrM f `rComp` rArrM g = rArrM (f <=< g)
"arr/arrM" forall f g. rArr f `rComp` rArrM g = rArrM (fmap f . g)
"arrM/arr" forall f g. rArrM f `rComp` rArr g = rArrM (f . g)
"arrM/arrM/f" forall f g h. (f `rComp` rArrM g) `rComp` rArrM h = f `rComp` rArrM (g <=< h)
"arr/arrM/f" forall f g h. (f `rComp` rArr g) `rComp` rArrM h = f `rComp` rArrM (fmap g . h)
"arrM/arr/f" forall f g h. (f `rComp` rArrM g) `rComp` rArr h = f `rComp` rArrM (g . h)
#-}
rFirst :: Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst (Rule r) = Rule \(a, c) k -> r a \b r' -> k (b, c) (rFirst r')
{-# INLINABLE[0] rFirst #-}
{-# RULES
"first/id" rFirst rId = rId
"first/arr" forall f. rFirst (rArr f) = rArr (second f)
"first/arrM" forall f. rFirst (rArrM f) = rArrM (runKleisli (first (Kleisli f)))
"first/push" [~1] forall f g. rFirst (f `rComp` g) = rFirst f `rComp` rFirst g
"first/pull" [1] forall f g. rFirst f `rComp` rFirst g = rFirst (f `rComp` g)
"first/f/pull" [1] forall f g h. (f `rComp` rFirst g) `rComp` rFirst h = f `rComp` rFirst (g `rComp` h)
#-}
rLeft :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
rLeft r0 = go r0 where
go (Rule r) = Rule \e k -> case e of
Left a -> r a \b r' -> k (Left b) (go r')
Right c -> k (Right c) (go r0)
{-# INLINABLE[0] rLeft #-}
{-# RULES
"left/id" rLeft rId = rId
"left/arr" forall f. rLeft (rArr f) = rArr (left f)
"left/arrM" forall f. rLeft (rArrM f) = rArrM (runKleisli (left (Kleisli f)))
"left/push" [~1] forall f g. rLeft (f `rComp` g) = rLeft f `rComp` rLeft g
"left/pull" [1] forall f g. rLeft f `rComp` rLeft g = rLeft (f `rComp` g)
"left/f/pull" [1] forall f g h. (f `rComp` rLeft g) `rComp` rLeft h = f `rComp` rLeft (g `rComp` h)
#-}
rPure :: b -> Rule m a b
rPure a = Rule \_ k -> k a (rPure a)
{-# INLINABLE[0] rPure #-}
{-# RULES "pure/push" [~1] rPure = rArr . const #-} -- see Note [Desugaring derived operations]
rSecond :: Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond (Rule r) = Rule \(c, a) k -> r a \b r' -> k (c, b) (rSecond r')
{-# INLINABLE[0] rSecond #-}
-- see Note [Desugaring derived operations]
{-# RULES "second/push" [~1] forall f. rSecond f = rArr swap . rFirst f . rArr swap #-}
swapEither :: Either a b -> Either b a
swapEither = either Right Left
{-# INLINE[0] swapEither #-}
rRight :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
rRight r0 = go r0 where
go (Rule r) = Rule \e k -> case e of
Left c -> k (Left c) (go r0)
Right a -> r a \b r' -> k (Right b) (go r')
{-# INLINABLE[0] rRight #-}
-- see Note [Desugaring derived operations]
{-# RULES "right/push" [~1] forall f. rRight f = rArr swapEither . rLeft f . rArr swapEither #-}
rSplit :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
Rule f `rSplit` Rule g = Rule \(a, b) k -> f a \c f' -> g b \d g' -> k (c, d) (f' `rSplit` g')
{-# INLINABLE[0] rSplit #-}
-- see Note [Desugaring derived operations]
{-# RULES "***/push" [~1] forall f g. f `rSplit` g = rSecond g . rFirst f #-}
rFanout :: Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
Rule f `rFanout` Rule g = Rule \a k -> f a \b f' -> g a \c g' -> k (b, c) (f' `rFanout` g')
{-# INLINABLE[0] rFanout #-}
-- see Note [Desugaring derived operations]
{-# RULES "&&&/push" [~1] forall f g. f `rFanout` g = (f *** g) . rArr (\a -> (a, a)) #-}
rFork :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
f0 `rFork` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \e k -> case e of
Left a -> f a \b f' -> k (Left b) (go f' g0)
Right a -> g a \b g' -> k (Right b) (go f0 g')
{-# INLINABLE[0] rFork #-}
-- see Note [Desugaring derived operations]
{-# RULES "+++/push" [~1] forall f g. f `rFork` g = rRight g . rLeft f #-}
fromEither :: Either a a -> a
fromEither = either id id
{-# INLINE[0] fromEither #-}
rFanin :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
f0 `rFanin` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \e k -> case e of
Left a -> f a \b f' -> k b (go f' g0)
Right a -> g a \b g' -> k b (go f0 g')
{-# INLINABLE[0] rFanin #-}
-- see Note [Desugaring derived operations]
{-# RULES "|||/push" [~1] forall f g. f `rFanin` g = rArr fromEither . (f +++ g) #-}
instance Functor (Rule m a) where
fmap f r = arr f . r
{-# INLINE fmap #-}
instance Applicative (Rule m a) where
pure = rPure
{-# INLINE pure #-}
(<*>) = liftA2 ($)
{-# INLINE (<*>) #-}
liftA2 f g h = arr (uncurry f) . (g &&& h)
{-# INLINE liftA2 #-}
instance Profunctor (Rule m) where
dimap f g r = arr g . r . arr f
{-# INLINE dimap #-}
lmap f r = r . arr f
{-# INLINE lmap #-}
rmap = fmap
{-# INLINE rmap #-}
instance Strong (Rule m) where
first' = rFirst
{-# INLINE first' #-}
second' = rSecond
{-# INLINE second' #-}
instance Choice (Rule m) where
left' = rLeft
{-# INLINE left' #-}
right' = rRight
{-# INLINE right' #-}
instance Category (Rule m) where
id = rId
{-# INLINE id #-}
(.) = rComp
{-# INLINE (.) #-}
instance Arrow (Rule m) where
arr = rArr
{-# INLINE arr #-}
first = rFirst
{-# INLINE first #-}
second = rSecond
{-# INLINE second #-}
(***) = rSplit
{-# INLINE (***) #-}
(&&&) = rFanout
{-# INLINE (&&&) #-}
instance ArrowChoice (Rule m) where
left = rLeft
{-# INLINE left #-}
right = rRight
{-# INLINE right #-}
(+++) = rFork
{-# INLINE (+++) #-}
(|||) = rFanin
{-# INLINE (|||) #-}
instance (Monad m) => ArrowKleisli m (Rule m) where
arrM = rArrM
{-# INLINE arrM #-}
class (Arrow arr) => ArrowCache arr where
-- | Adds equality-based caching to the given rule. After each execution of the rule, its input
@ -232,82 +299,62 @@ class (Arrow arr) => ArrowCache arr where
instance (ArrowChoice arr, ArrowCache arr) => ArrowCache (ErrorA e arr) where
cache (ErrorA f) = ErrorA (cache f)
{-# INLINE cache #-}
instance (Monoid w, ArrowCache arr) => ArrowCache (WriterA w arr) where
cache (WriterA f) = WriterA (cache f)
{-# INLINE cache #-}
instance (Monad m) => ArrowCache (Rule m) where
cache :: forall a b. (Eq a) => Rule m a b -> Rule m a b
cache (Rule build) = Rule \input -> cacheResult input <$> build input
instance ArrowCache (Rule m) where
cache (Rule r0) = Rule \a k -> r0 a \b r0' -> k b (cached a b r0')
where
cacheResult :: a -> Result m a b -> Result m a b
cacheResult oldInput Result { rebuild, result } = fix \cachedBuild -> Result
{ rebuild = \newInput -> if
| oldInput == newInput -> pure cachedBuild
| otherwise -> cacheResult newInput <$> rebuild newInput
, result
}
cached a b (Rule r) = Rule \a' k -> if
| a == a' -> k b (cached a b (Rule r))
| otherwise -> r a' \b' r' -> k b' (cached a' b' r')
{-# INLINABLE cache #-}
class (ArrowChoice arr) => ArrowDistribute arr where
-- | Given a 'Rule' that operates on key-value pairs, produces a 'Rule' that operates on a
-- 'M.HashMap'. If the input rule is incremental in its argument, the resulting rule will be
-- incremental as well for any entries in the map that do not change between builds.
--
-- TODO: Laws that capture order-independence.
class (Arrow arr) => ArrowDistribute arr where
-- | Distributes an arrow that operates on key-value pairs, over a 'M.HashMap' in an
-- order-independent way.
--
-- This is intended to be used as a control operator in @proc@ notation; see
-- Note [Weird control operator types] in "Control.Arrow.Extended".
keyed
:: (Eq k, Hashable k)
=> arr (e, (k, (a, s))) b
-> arr (e, (M.HashMap k a, s)) (M.HashMap k b)
-- Note that 'ErrorA' does /not/ support an instance of 'ArrowDistribute', as it is impossible to
-- define an instance that short-circuits on the first error! A hypothetical 'ErrorsA' could support
-- such an instance, however, as it could combine all the errors produced by each branch.
-> arr (e, (HashMap k a, s)) (HashMap k b)
instance (Monoid w, ArrowDistribute arr) => ArrowDistribute (WriterA w arr) where
keyed (WriterA f) = WriterA (arr (swap . sequence . fmap swap) <<< keyed f)
keyed (WriterA f) = WriterA (arr (swap . sequence . fmap swap) . keyed f)
{-# INLINE keyed #-}
instance (Monad m) => ArrowDistribute (Rule m) where
-- | Unlike 'traverseA', using 'keyed' preserves incrementalization: if the input rule is
-- incremental in its argument, the resulting rule will be incremental as well for any entries in
-- the map that do not change between builds.
instance ArrowDistribute (Rule m) where
keyed
:: forall a b k e s. (Eq k, Hashable k)
:: forall a b k e s
. (Eq k, Hashable k)
=> Rule m (e, (k, (a, s))) b
-> Rule m (e, (M.HashMap k a, s)) (M.HashMap k b)
keyed entryRule = buildWith M.empty
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyed r0 = keyedWith M.empty
where
buildWith
:: M.HashMap k (Rule m (e, (a, s)) b)
-> Rule m (e, (M.HashMap k a, s)) (M.HashMap k b)
buildWith !ruleMap = Rule \(e, (valueMap, s)) ->
M.traverseWithKey (processEntry e s) valueMap <&> \resultMap -> Result
{ rebuild = build (buildWith (Rule . rebuild <$> resultMap))
, result = result <$> resultMap
}
where
processEntry :: e -> s -> k -> a -> m (Result m (e, (a, s)) b)
processEntry e s k v = build (ruleForKey k) (e, (v, s))
keyedWith
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith !rs = Rule \(e, (vs, s)) c ->
M.foldrWithKey (process rs e s) (finish c) vs M.empty M.empty
ruleForKey :: k -> Rule m (e, (a, s)) b
ruleForKey k = case M.lookup k ruleMap of
Just existingRule -> existingRule
Nothing -> lmap (\(e, (v, s)) -> (e, (k, (v, s)))) entryRule
process
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> e -> s -> k -> a
-> (HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
process rs e s k a c !vs' !rs' =
let Rule r = M.lookupDefault r0 k rs
in r (e, (k, (a, s))) \b r' -> c (M.insert k b vs') (M.insert k r' rs')
{- Note [Rule rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As explained by Note [Arrow rewrite rules] in Control.Arrow.Extended, it’s important to define
type-specific rewrite rules to get good performance with arrows. This is especially important for
`Rule`, since the recursive definitions of operations like `.` and `arr` are very difficult for the
optimizer to deal with, and the composition of lots of small rules created with `arr` is very
inefficient.
Fortunately, efficient rules for `Rule` aren’t too hard. The idea is to define all the operations in
terms of a small set of primitives: `.`, `arrM`, `first`, and `left`. Then we can introduce rules
for `arrM` fusion, and the arguments to `arrM` are just plain old monadic actions, which GHC is
really good at optimizing already. This doesn’t get rid of uses of `.` entirely, but it
significantly reduces them.
Since GHC aggressively specializes and inlines class methods, the rules cannot be defined on the
class methods themselves. Instead, the class methods expand to auxiliary definitions, and those
definitions include an INLINABLE[0] pragma that ensures they do not inline until the final
optimization phase. The rules are defined in terms of those definitions, so they will be able to do
their work in prior phases. -}
finish
:: (HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r)
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
finish c !vs' !rs' = c vs' (keyedWith rs')
{-# INLINABLE keyed #-}

57
server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
View File

@ -54,7 +54,6 @@ import Hasura.RQL.DDL.Utils
import Hasura.RQL.Types
import Hasura.RQL.Types.Catalog
import Hasura.RQL.Types.QueryCollection
import Hasura.RQL.Types.Run
import Hasura.SQL.Types
buildRebuildableSchemaCache
@ -65,9 +64,6 @@ buildRebuildableSchemaCache = do
result <- flip runReaderT CatalogSync $ Inc.build buildSchemaCacheRule (catalogMetadata, M.empty)
pure $ RebuildableSchemaCache (Inc.result result) M.empty (Inc.rebuildRule result)
-- see Note [Specialization of buildRebuildableSchemaCache]
{-# SPECIALIZE buildRebuildableSchemaCache :: Run (RebuildableSchemaCache Run) #-}
newtype CacheRWT m a
= CacheRWT { unCacheRWT :: StateT (RebuildableSchemaCache m) m a }
deriving
@ -108,11 +104,11 @@ instance (MonadIO m, MonadTx m, MonadUnique m) => CacheRWM (CacheRWT m) where
unique <- newUnique
assign (rscInvalidationMap . at name) (Just unique)
{-# INLINABLE buildSchemaCacheRule #-} -- see Note [Specialization of buildRebuildableSchemaCache]
{-# SCC buildSchemaCacheRule #-}
buildSchemaCacheRule
-- Note: by supplying BuildReason via MonadReader, it does not participate in caching, which is
-- what we want!
:: ( Inc.ArrowCache arr, Inc.ArrowDistribute arr, ArrowKleisli m arr
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache arr, ArrowKleisli m arr
, MonadIO m, MonadTx m, MonadReader BuildReason m, HasHttpManager m, HasSQLGenCtx m )
=> (CatalogMetadata, InvalidationMap) `arr` SchemaCache
buildSchemaCacheRule = proc inputs -> do
@ -131,8 +127,9 @@ buildSchemaCacheRule = proc inputs -> do
, scInconsistentObjs = inconsistentObjects <> extraInconsistentObjects
}
where
{-# SCC buildAndCollectInfo #-}
buildAndCollectInfo
:: ( Inc.ArrowCache arr, Inc.ArrowDistribute arr, ArrowKleisli m arr
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache arr, ArrowKleisli m arr
, ArrowWriter (Seq CollectedInfo) arr, MonadIO m, MonadTx m, MonadReader BuildReason m
, HasHttpManager m, HasSQLGenCtx m )
=> (CatalogMetadata, InvalidationMap) `arr` BuildOutputs
@ -233,9 +230,10 @@ buildSchemaCacheRule = proc inputs -> do
-- metadata objects for any entries in the second map that don’t appear in the first map. This
-- is used to “line up” the metadata for relationships, computed fields, permissions, etc. with
-- the tracked table info.
{-# SCC alignExtraTableInfo #-}
alignExtraTableInfo
:: forall a b arr
. (Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr)
. (ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr)
=> (b -> MetadataObject)
-> ( M.HashMap QualifiedTable a
, M.HashMap QualifiedTable [b]
@ -255,10 +253,10 @@ buildSchemaCacheRule = proc inputs -> do
recordInconsistencies -< (map mkMetadataObject extras, errorMessage)
returnA -< Nothing
{-# SCC buildTableEventTriggers #-}
buildTableEventTriggers
:: ( Inc.ArrowDistribute arr, ArrowKleisli m arr, ArrowWriter (Seq CollectedInfo) arr
, MonadIO m, MonadTx m, MonadReader BuildReason m
, HasSQLGenCtx m )
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
, ArrowKleisli m arr, MonadIO m, MonadTx m, MonadReader BuildReason m, HasSQLGenCtx m )
=> (TableCoreCache, [CatalogEventTrigger]) `arr` EventTriggerInfoMap
buildTableEventTriggers = proc (tableCache, eventTriggers) ->
(\infos -> M.catMaybes infos >- returnA) <-<
@ -287,6 +285,7 @@ buildSchemaCacheRule = proc inputs -> do
|) (addTableContext qt . addTriggerContext))
|) metadataObject
{-# SCC addRemoteSchema #-}
addRemoteSchema
:: ( ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr, ArrowKleisli m arr
, MonadIO m, HasHttpManager m )
@ -398,39 +397,3 @@ withMetadataCheck cascade action = do
diffInconsistentObjects = M.difference `on` groupInconsistentMetadataById
newInconsistentObjects = nub $ concatMap toList $
M.elems (currentInconsMeta `diffInconsistentObjects` originalInconsMeta)
{- Note [Specialization of buildRebuildableSchemaCache]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As mentioned in Note [Arrow rewrite rules] in Control.Arrow.Extended and Note [Rule rewrite rules]
in Hasura.Incremental, it is very important that `buildRebuildableSchemaCache` be specialized to
ensure the relevant rules fire. This is a bit subtle, as GHC will only specialize non-class methods
across modules under the following conditions:
(1) The definition is marked INLINABLE.
(2) The use site is not overloaded; i.e. all typeclass constraints are satisfied.
This means that even if we mark `buildRebuildableSchemaCache` INLINABLE, GHC still won’t be able to
specialize it unless its immediate use site has a concrete type. If we were to have some polymorphic
function
foo :: (MonadFoo m) => m Bar
foo = do { ...; cache <- buildRebuildableSchemaCache; ... }
then GHC would not be able to specialize `buildRebuildableSchemaCache` unless `foo` is also
specialized, since that’s the only way it is able to know which type to specialize it at!
Fortunately, this cross-module specialization is transitive, so as long as we mark `foo` INLINABLE
as well, then when `foo` is specialized, `buildRebuildableSchemaCache` is also specialized. The only
downside to this approach is it means the eventual top-level caller that instantiates the
constraints ends up having to specialize an enormous amount of code all at once, which tends to
bring compile times to a crawl (and may even run out of memory).
A better solution, where possible, is to insert explicit SPECIALIZE pragmas to encourage GHC to do
the specialization early. For example, we could write
{-# SPECIALIZE foo :: FooM Bar #-}
alongside the definition of `foo`, and GHC will immediately produce a specialized version of `foo`
on `FooM`. If a caller then uses `foo` in `FooM`, it will use the specialized version.
I regret this being necessary, but I don’t see a way around it. -}

2
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Common.hs
View File

@ -65,7 +65,7 @@ bindErrorA
:: (ArrowChoice arr, ArrowKleisli m arr, ArrowError e arr, MonadError e m)
=> arr (m a) a
bindErrorA = liftEitherA <<< arrM \m -> (Right <$> m) `catchError` (pure . Left)
{-# INLINABLE bindErrorA #-}
{-# INLINE bindErrorA #-}
withRecordDependencies
:: (ArrowWriter (Seq CollectedInfo) arr)

10
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Dependencies.hs
View File

@ -12,22 +12,14 @@ import Control.Lens hiding ((.=))
import Data.Aeson
import Data.List (nub)
import qualified Hasura.Incremental as Inc
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.Types
import Hasura.SQL.Types
-- see Note [Specialization of buildRebuildableSchemaCache] in Hasura.RQL.DDL.Schema.Cache
{-# SPECIALIZE resolveDependencies
:: Inc.Rule CacheBuildM
( BuildOutputs
, [(MetadataObject, SchemaObjId, SchemaDependency)]
) (BuildOutputs, [InconsistentMetadata], DepMap) #-}
-- | Processes collected 'CIDependency' values into a 'DepMap', performing integrity checking to
-- ensure the dependencies actually exist. If a dependency is missing, its transitive dependents are
-- removed from the cache, and 'InconsistentMetadata's are returned.
{-# SCC resolveDependencies #-}
resolveDependencies
:: (ArrowKleisli m arr, QErrM m)
=> ( BuildOutputs

18
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Fields.hs
View File

@ -24,17 +24,9 @@ import Hasura.RQL.Types
import Hasura.RQL.Types.Catalog
import Hasura.SQL.Types
-- see Note [Specialization of buildRebuildableSchemaCache] in Hasura.RQL.DDL.Schema.Cache
{-# SPECIALIZE addNonColumnFields
:: CacheBuildA
( HashMap QualifiedTable TableRawInfo
, FieldInfoMap PGColumnInfo
, [CatalogRelation]
, [CatalogComputedField]
) (FieldInfoMap FieldInfo) #-}
{-# SCC addNonColumnFields #-}
addNonColumnFields
:: ( Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
, ArrowKleisli m arr, MonadError QErr m )
=> ( HashMap QualifiedTable TableRawInfo
, FieldInfoMap PGColumnInfo
@ -97,8 +89,9 @@ mkRelationshipMetadataObject (CatalogRelation qt rn rt rDef cmnt) =
definition = toJSON $ WithTable qt $ RelDef rn rDef cmnt
in MetadataObject objectId definition
{-# SCC buildRelationship #-}
buildRelationship
:: (Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr)
:: (ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr)
=> (HashMap QualifiedTable [ForeignKey], CatalogRelation) `arr` Maybe RelInfo
buildRelationship = proc (foreignKeys, relationship) -> do
let CatalogRelation tableName rn rt rDef _ = relationship
@ -126,8 +119,9 @@ mkComputedFieldMetadataObject (CatalogComputedField column _) =
objectId = MOTableObj qt $ MTOComputedField name
in MetadataObject objectId (toJSON column)
{-# SCC buildComputedField #-}
buildComputedField
:: ( Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
:: ( ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr
, ArrowKleisli m arr, MonadError QErr m )
=> (HashSet QualifiedTable, CatalogComputedField) `arr` Maybe ComputedFieldInfo
buildComputedField = proc (trackedTableNames, computedField) -> do

13
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Permission.hs
View File

@ -23,16 +23,9 @@ import Hasura.RQL.Types
import Hasura.RQL.Types.Catalog
import Hasura.SQL.Types
-- see Note [Specialization of buildRebuildableSchemaCache] in Hasura.RQL.DDL.Schema.Cache
{-# SPECIALIZE buildTablePermissions
:: CacheBuildA
( TableCoreCache
, TableCoreInfo
, [CatalogPermission]
) RolePermInfoMap #-}
{-# SCC buildTablePermissions #-}
buildTablePermissions
:: ( Inc.ArrowCache arr, Inc.ArrowDistribute arr, ArrowKleisli m arr
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache arr, ArrowKleisli m arr
, ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m )
=> ( TableCoreCache
, TableCoreInfo
@ -86,7 +79,7 @@ withPermission f = proc (e, (permission, s)) -> do
|) metadataObject
buildPermission
:: ( Inc.ArrowCache arr, Inc.ArrowDistribute arr, ArrowKleisli m arr
:: ( ArrowChoice arr, Inc.ArrowCache arr, ArrowKleisli m arr
, ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m
, Eq a, IsPerm a, FromJSON a, Eq (PermInfo a) )
=> ( TableCoreCache

1
server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs
View File

@ -31,6 +31,7 @@ import Hasura.RQL.Types.Error
import Hasura.RQL.Types.SchemaCache
import Hasura.SQL.Types
{-# SCC fetchCatalogData #-}
fetchCatalogData :: (MonadTx m) => m CatalogMetadata
fetchCatalogData = do
-- startTime <- liftTx $ liftIO getCurrentTime

10
server/src-lib/Hasura/RQL/DDL/Schema/Table.hs
View File

@ -290,9 +290,11 @@ delTableAndDirectDeps qtn@(QualifiedObject sn tn) = do
-- | Builds an initial @'TableCache' 'PGColumnInfo'@ from catalog information. Does not fill in
-- '_tiRolePermInfoMap' or '_tiEventTriggerInfoMap' at all, and '_tiFieldInfoMap' only contains
-- columns, not relationships; those pieces of information are filled in by later stages.
{-# SCC buildTableCache #-}
buildTableCache
:: forall arr m
. (Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr, ArrowKleisli m arr, MonadTx m)
. ( ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
, ArrowKleisli m arr, MonadTx m )
=> [CatalogTable] `arr` M.HashMap QualifiedTable TableRawInfo
buildTableCache = proc catalogTables -> do
rawTableInfos <-
@ -315,6 +317,7 @@ buildTableCache = proc catalogTables -> do
_ -> throwA -< err400 AlreadyExists "duplication definition for table"
-- Step 1: Build the raw table cache from metadata information.
{-# SCC buildRawTableInfo #-}
buildRawTableInfo :: ErrorA QErr arr CatalogTable (TableCoreInfoG PGRawColumnInfo PGCol)
buildRawTableInfo = proc (CatalogTable name systemDefined isEnum config maybeInfo) -> do
catalogInfo <-
@ -365,6 +368,7 @@ buildTableCache = proc catalogTables -> do
-- Step 2: Process the raw table cache to replace Postgres column types with logical column
-- types.
{-# SCC processTableInfo #-}
processTableInfo
:: ErrorA QErr arr
( M.HashMap QualifiedTable (PrimaryKey PGCol, EnumValues)
@ -422,7 +426,3 @@ buildTableCache = proc catalogTables -> do
$ "column " <> prciName rawInfo <<> " in table " <> tableName
<<> " references multiple enum tables ("
<> T.intercalate ", " (map (dquote . erTable) $ toList enumReferences) <> ")"
-- see Note [Specialization of buildRebuildableSchemaCache] in Hasura.RQL.DDL.Schema.Cache
{-# SPECIALIZE buildTableCache
:: CacheBuildA [CatalogTable] (M.HashMap QualifiedTable TableRawInfo) #-}

1
server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs
View File

@ -79,6 +79,7 @@ withRecordInconsistency f = proc (e, (metadataObject, s)) -> do
recordInconsistency -< (metadataObject, qeError err)
returnA -< Nothing
Right v -> returnA -< Just v
{-# INLINABLE withRecordInconsistency #-}
-- ----------------------------------------------------------------------------
-- operations for triggering a schema cache rebuild

6
server/src-lib/Hasura/Server/Migrate.hs
View File

@ -32,7 +32,6 @@ import qualified Language.Haskell.TH.Syntax as TH
import Hasura.Logging (Hasura, LogLevel (..), ToEngineLog (..))
import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types
import Hasura.RQL.Types.Run
import Hasura.Server.Logging (StartupLog (..))
import Hasura.Server.Migrate.Version (latestCatalogVersion,
latestCatalogVersionString)
@ -66,9 +65,7 @@ instance ToEngineLog MigrationResult Hasura where
<> latestCatalogVersionString <> "."
}
-- see Note [Specialization of buildRebuildableSchemaCache]
{-# SPECIALIZE migrateCatalog :: UTCTime -> Run (MigrationResult, RebuildableSchemaCache Run) #-}
{-# SCC migrateCatalog #-}
migrateCatalog
:: forall m
. ( MonadIO m
@ -228,6 +225,7 @@ migrateCatalog migrationTime = do
WHERE name = $2
|] (Q.AltJ $ A.toJSON etc, name) True
{-# SCC recreateSystemMetadata #-}
recreateSystemMetadata
:: ( MonadIO m
, MonadTx m