{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
module Hasura.Incremental.Internal.Rule
( ArrowDistribute (..),
Result (rebuildRule, result),
Rule (..),
build,
rebuild,
)
where
import Control.Arrow.Extended
import Control.Category
import Data.HashMap.Strict qualified as HM
import Data.Profunctor
import Data.Tuple (swap)
import Hasura.Incremental.Internal.Dependency
import Hasura.Prelude hiding (id, (.))
newtype Rule m a b
=
Rule (forall r. Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
build :: (Applicative m) => Rule m a b -> a -> m (Result m a b)
build :: Rule m a b -> a -> m (Result m a b)
build (Rule forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r
r) a
a = Accesses
-> a
-> (Accesses -> b -> Rule m a b -> m (Result m a b))
-> m (Result m a b)
forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r
r Accesses
forall a. Monoid a => a
mempty a
a \Accesses
_ b
b Rule m a b
r' -> Result m a b -> m (Result m a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result m a b -> m (Result m a b))
-> Result m a b -> m (Result m a b)
forall a b. (a -> b) -> a -> b
$ b -> Rule m a b -> Result m a b
forall (m :: * -> *) a b. b -> Rule m a b -> Result m a b
Result b
b Rule m a b
r'
{-# INLINE build #-}
data Result m a b = Result
{ Result m a b -> b
result :: !b,
Result m a b -> Rule m a b
rebuildRule :: !(Rule m a b)
}
deriving (a -> Result m a b -> Result m a a
(a -> b) -> Result m a a -> Result m a b
(forall a b. (a -> b) -> Result m a a -> Result m a b)
-> (forall a b. a -> Result m a b -> Result m a a)
-> Functor (Result m a)
forall a b. a -> Result m a b -> Result m a a
forall a b. (a -> b) -> Result m a a -> Result m a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a a b. a -> Result m a b -> Result m a a
forall (m :: * -> *) a a b.
(a -> b) -> Result m a a -> Result m a b
<$ :: a -> Result m a b -> Result m a a
$c<$ :: forall (m :: * -> *) a a b. a -> Result m a b -> Result m a a
fmap :: (a -> b) -> Result m a a -> Result m a b
$cfmap :: forall (m :: * -> *) a a b.
(a -> b) -> Result m a a -> Result m a b
Functor)
rebuild :: (Applicative m) => Result m a b -> a -> m (Result m a b)
rebuild :: Result m a b -> a -> m (Result m a b)
rebuild = Rule m a b -> a -> m (Result m a b)
forall (m :: * -> *) a b.
Applicative m =>
Rule m a b -> a -> m (Result m a b)
build (Rule m a b -> a -> m (Result m a b))
-> (Result m a b -> Rule m a b)
-> Result m a b
-> a
-> m (Result m a b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Result m a b -> Rule m a b
forall (m :: * -> *) a b. Result m a b -> Rule m a b
rebuildRule
{-# INLINE rebuild #-}
rComp :: Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
Rule forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
f rComp :: Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
`rComp` Rule forall r.
Accesses -> a2 -> (Accesses -> a1 -> Rule m a2 a1 -> m r) -> m r
g = (forall r.
Accesses -> a2 -> (Accesses -> b -> Rule m a2 b -> m r) -> m r)
-> Rule m a2 b
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a2
a Accesses -> b -> Rule m a2 b -> m r
k -> Accesses -> a2 -> (Accesses -> a1 -> Rule m a2 a1 -> m r) -> m r
forall r.
Accesses -> a2 -> (Accesses -> a1 -> Rule m a2 a1 -> m r) -> m r
g Accesses
s a2
a \Accesses
s' a1
b Rule m a2 a1
g' -> Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
f Accesses
s' a1
b \Accesses
s'' b
c Rule m a1 b
f' -> Accesses -> b -> Rule m a2 b -> m r
k Accesses
s'' b
c (Rule m a1 b
f' Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
forall (m :: * -> *) a1 b a2.
Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
`rComp` Rule m a2 a1
g')
{-# INLINEABLE [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 m a a
rId = (forall r.
Accesses -> a -> (Accesses -> a -> Rule m a a -> m r) -> m r)
-> Rule m a a
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a
a Accesses -> a -> Rule m a a -> m r
k -> Accesses -> a -> Rule m a a -> m r
k Accesses
s a
a Rule m a a
forall (m :: * -> *) a. Rule m a a
rId
{-# INLINEABLE [0] rId #-}
#ifndef __HLINT__
{-# RULES
"f/id" forall f. f `rComp` rId = f
"id/f" forall f. rId `rComp` f = f
#-}
#endif
rArr :: (a -> b) -> Rule m a b
rArr :: (a -> b) -> Rule m a b
rArr a -> b
f = (forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a
a Accesses -> b -> Rule m a b -> m r
k -> Accesses -> b -> Rule m a b -> m r
k Accesses
s (a -> b
f a
a) ((a -> b) -> Rule m a b
forall a b (m :: * -> *). (a -> b) -> Rule m a b
rArr a -> b
f)
{-# INLINEABLE [0] rArr #-}
#ifndef __HLINT__
{-# 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)
#-}
#endif
rArrM :: (Monad m) => (a -> m b) -> Rule m a b
rArrM :: (a -> m b) -> Rule m a b
rArrM a -> m b
f = (forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a
a Accesses -> b -> Rule m a b -> m r
k -> a -> m b
f a
a m b -> (b -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b -> Accesses -> b -> Rule m a b -> m r
k Accesses
s b
b ((a -> m b) -> Rule m a b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Rule m a b
rArrM a -> m b
f)
{-# INLINEABLE [0] rArrM #-}
#ifndef __HLINT__
{-# 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)
#-}
#endif
rFirst :: Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst :: Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst (Rule forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
r) = (forall r.
Accesses
-> (a, b2)
-> (Accesses -> (b1, b2) -> Rule m (a, b2) (b1, b2) -> m r)
-> m r)
-> Rule m (a, b2) (b1, b2)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s (a, c) Accesses -> (b1, b2) -> Rule m (a, b2) (b1, b2) -> m r
k -> Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
r Accesses
s a
a \Accesses
s' b1
b Rule m a b1
r' -> Accesses -> (b1, b2) -> Rule m (a, b2) (b1, b2) -> m r
k Accesses
s' (b1
b, b2
c) (Rule m a b1 -> Rule m (a, b2) (b1, b2)
forall (m :: * -> *) a b1 b2.
Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst Rule m a b1
r')
{-# INLINEABLE [0] rFirst #-}
#ifndef __HLINT__
{-# RULES
"first/id" rFirst rId = rId
"first/arr" forall f. rFirst (rArr f) = rArr (first 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)
#-}
#endif
rLeft :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
rLeft :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
rLeft Rule m a b1
r0 = Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
go Rule m a b1
r0
where
go :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
go (Rule forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
r) = (forall r.
Accesses
-> Either a b2
-> (Accesses
-> Either b1 b2 -> Rule m (Either a b2) (Either b1 b2) -> m r)
-> m r)
-> Rule m (Either a b2) (Either b1 b2)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s Either a b2
e Accesses
-> Either b1 b2 -> Rule m (Either a b2) (Either b1 b2) -> m r
k -> case Either a b2
e of
Left a -> Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
r Accesses
s a
a \Accesses
s' b1
b Rule m a b1
r' -> Accesses
-> Either b1 b2 -> Rule m (Either a b2) (Either b1 b2) -> m r
k Accesses
s' (b1 -> Either b1 b2
forall a b. a -> Either a b
Left b1
b) (Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
go Rule m a b1
r')
Right c -> Accesses
-> Either b1 b2 -> Rule m (Either a b2) (Either b1 b2) -> m r
k Accesses
s (b2 -> Either b1 b2
forall a b. b -> Either a b
Right b2
c) (Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
go Rule m a b1
r0)
{-# INLINEABLE [0] rLeft #-}
#ifndef __HLINT__
{-# 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)
#-}
#endif
rPure :: b -> Rule m a b
rPure :: b -> Rule m a b
rPure b
a = (forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a
_ Accesses -> b -> Rule m a b -> m r
k -> Accesses -> b -> Rule m a b -> m r
k Accesses
s b
a (b -> Rule m a b
forall b (m :: * -> *) a. b -> Rule m a b
rPure b
a)
{-# INLINEABLE [0] rPure #-}
{-# RULES "pure/push" [~1] rPure = rArr . const #-}
rSecond :: Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond :: Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond (Rule forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
r) = (forall r.
Accesses
-> (a2, a1)
-> (Accesses -> (a2, b) -> Rule m (a2, a1) (a2, b) -> m r)
-> m r)
-> Rule m (a2, a1) (a2, b)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s (c, a) Accesses -> (a2, b) -> Rule m (a2, a1) (a2, b) -> m r
k -> Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
r Accesses
s a1
a \Accesses
s' b
b Rule m a1 b
r' -> Accesses -> (a2, b) -> Rule m (a2, a1) (a2, b) -> m r
k Accesses
s' (a2
c, b
b) (Rule m a1 b -> Rule m (a2, a1) (a2, b)
forall (m :: * -> *) a1 b a2.
Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond Rule m a1 b
r')
{-# INLINEABLE [0] rSecond #-}
{-# RULES "second/push" [~1] forall f. rSecond f = rArr swap . rFirst f . rArr swap #-}
swapEither :: Either a b -> Either b a
swapEither :: Either a b -> Either b a
swapEither = (a -> Either b a) -> (b -> Either b a) -> Either a b -> Either b a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Either b a
forall a b. b -> Either a b
Right b -> Either b a
forall a b. a -> Either a b
Left
{-# INLINE [0] swapEither #-}
rRight :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
rRight :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
rRight Rule m a1 b
r0 = Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
go Rule m a1 b
r0
where
go :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
go (Rule forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
r) = (forall r.
Accesses
-> Either a2 a1
-> (Accesses
-> Either a2 b -> Rule m (Either a2 a1) (Either a2 b) -> m r)
-> m r)
-> Rule m (Either a2 a1) (Either a2 b)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s Either a2 a1
e Accesses
-> Either a2 b -> Rule m (Either a2 a1) (Either a2 b) -> m r
k -> case Either a2 a1
e of
Left c -> Accesses
-> Either a2 b -> Rule m (Either a2 a1) (Either a2 b) -> m r
k Accesses
s (a2 -> Either a2 b
forall a b. a -> Either a b
Left a2
c) (Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
go Rule m a1 b
r0)
Right a -> Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
r Accesses
s a1
a \Accesses
s' b
b Rule m a1 b
r' -> Accesses
-> Either a2 b -> Rule m (Either a2 a1) (Either a2 b) -> m r
k Accesses
s' (b -> Either a2 b
forall a b. b -> Either a b
Right b
b) (Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
go Rule m a1 b
r')
{-# INLINEABLE [0] rRight #-}
{-# 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 forall r.
Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
f rSplit :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
`rSplit` Rule forall r.
Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
g =
(forall r.
Accesses
-> (a1, a2)
-> (Accesses -> (b1, b2) -> Rule m (a1, a2) (b1, b2) -> m r)
-> m r)
-> Rule m (a1, a2) (b1, b2)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s (a, b) Accesses -> (b1, b2) -> Rule m (a1, a2) (b1, b2) -> m r
k -> Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
f Accesses
s a1
a \Accesses
s' b1
c Rule m a1 b1
f' -> Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
forall r.
Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
g Accesses
s' a2
b \Accesses
s'' b2
d Rule m a2 b2
g' -> Accesses -> (b1, b2) -> Rule m (a1, a2) (b1, b2) -> m r
k Accesses
s'' (b1
c, b2
d) (Rule m a1 b1
f' Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
forall (m :: * -> *) a1 b1 a2 b2.
Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
`rSplit` Rule m a2 b2
g')
{-# INLINEABLE [0] rSplit #-}
{-# 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 forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
f rFanout :: Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
`rFanout` Rule forall r.
Accesses -> a -> (Accesses -> b2 -> Rule m a b2 -> m r) -> m r
g =
(forall r.
Accesses
-> a -> (Accesses -> (b1, b2) -> Rule m a (b1, b2) -> m r) -> m r)
-> Rule m a (b1, b2)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s a
a Accesses -> (b1, b2) -> Rule m a (b1, b2) -> m r
k -> Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
forall r.
Accesses -> a -> (Accesses -> b1 -> Rule m a b1 -> m r) -> m r
f Accesses
s a
a \Accesses
s' b1
b Rule m a b1
f' -> Accesses -> a -> (Accesses -> b2 -> Rule m a b2 -> m r) -> m r
forall r.
Accesses -> a -> (Accesses -> b2 -> Rule m a b2 -> m r) -> m r
g Accesses
s' a
a \Accesses
s'' b2
c Rule m a b2
g' -> Accesses -> (b1, b2) -> Rule m a (b1, b2) -> m r
k Accesses
s'' (b1
b, b2
c) (Rule m a b1
f' Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
forall (m :: * -> *) a b1 b2.
Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
`rFanout` Rule m a b2
g')
{-# INLINEABLE [0] rFanout #-}
{-# 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)
Rule m a1 b1
f0 rFork :: Rule m a1 b1
-> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
`rFork` Rule m a2 b2
g0 = Rule m a1 b1
-> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
go Rule m a1 b1
f0 Rule m a2 b2
g0
where
go :: Rule m a1 b1
-> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
go (Rule forall r.
Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
f) (Rule forall r.
Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
g) = (forall r.
Accesses
-> Either a1 a2
-> (Accesses
-> Either b1 b2 -> Rule m (Either a1 a2) (Either b1 b2) -> m r)
-> m r)
-> Rule m (Either a1 a2) (Either b1 b2)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s Either a1 a2
e Accesses
-> Either b1 b2 -> Rule m (Either a1 a2) (Either b1 b2) -> m r
k -> case Either a1 a2
e of
Left a -> Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b1 -> Rule m a1 b1 -> m r) -> m r
f Accesses
s a1
a \Accesses
s' b1
b Rule m a1 b1
f' -> Accesses
-> Either b1 b2 -> Rule m (Either a1 a2) (Either b1 b2) -> m r
k Accesses
s' (b1 -> Either b1 b2
forall a b. a -> Either a b
Left b1
b) (Rule m a1 b1
-> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
go Rule m a1 b1
f' Rule m a2 b2
g0)
Right a -> Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
forall r.
Accesses -> a2 -> (Accesses -> b2 -> Rule m a2 b2 -> m r) -> m r
g Accesses
s a2
a \Accesses
s' b2
b Rule m a2 b2
g' -> Accesses
-> Either b1 b2 -> Rule m (Either a1 a2) (Either b1 b2) -> m r
k Accesses
s' (b2 -> Either b1 b2
forall a b. b -> Either a b
Right b2
b) (Rule m a1 b1
-> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
go Rule m a1 b1
f0 Rule m a2 b2
g')
{-# INLINEABLE [0] rFork #-}
{-# RULES "+++/push" [~1] forall f g. f `rFork` g = rRight g . rLeft f #-}
fromEither :: Either a a -> a
fromEither :: Either a a -> a
fromEither = (a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE [0] fromEither #-}
rFanin :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
Rule m a1 b
f0 rFanin :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
`rFanin` Rule m a2 b
g0 = Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
go Rule m a1 b
f0 Rule m a2 b
g0
where
go :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
go (Rule forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
f) (Rule forall r.
Accesses -> a2 -> (Accesses -> b -> Rule m a2 b -> m r) -> m r
g) = (forall r.
Accesses
-> Either a1 a2
-> (Accesses -> b -> Rule m (Either a1 a2) b -> m r)
-> m r)
-> Rule m (Either a1 a2) b
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s Either a1 a2
e Accesses -> b -> Rule m (Either a1 a2) b -> m r
k -> case Either a1 a2
e of
Left a -> Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
forall r.
Accesses -> a1 -> (Accesses -> b -> Rule m a1 b -> m r) -> m r
f Accesses
s a1
a \Accesses
s' b
b Rule m a1 b
f' -> Accesses -> b -> Rule m (Either a1 a2) b -> m r
k Accesses
s' b
b (Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
go Rule m a1 b
f' Rule m a2 b
g0)
Right a -> Accesses -> a2 -> (Accesses -> b -> Rule m a2 b -> m r) -> m r
forall r.
Accesses -> a2 -> (Accesses -> b -> Rule m a2 b -> m r) -> m r
g Accesses
s a2
a \Accesses
s' b
b Rule m a2 b
g' -> Accesses -> b -> Rule m (Either a1 a2) b -> m r
k Accesses
s' b
b (Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
go Rule m a1 b
f0 Rule m a2 b
g')
{-# INLINEABLE [0] rFanin #-}
{-# RULES "|||/push" [~1] forall f g. f `rFanin` g = rArr fromEither . (f +++ g) #-}
instance Functor (Rule m a) where
fmap :: (a -> b) -> Rule m a a -> Rule m a b
fmap a -> b
f Rule m a a
r = (a -> b) -> Rule m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f Rule m a b -> Rule m a a -> Rule m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Rule m a a
r
{-# INLINE fmap #-}
instance Applicative (Rule m a) where
pure :: a -> Rule m a a
pure = a -> Rule m a a
forall b (m :: * -> *) a. b -> Rule m a b
rPure
{-# INLINE pure #-}
<*> :: Rule m a (a -> b) -> Rule m a a -> Rule m a b
(<*>) = ((a -> b) -> a -> b)
-> Rule m a (a -> b) -> Rule m a a -> Rule m a b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)
{-# INLINE (<*>) #-}
liftA2 :: (a -> b -> c) -> Rule m a a -> Rule m a b -> Rule m a c
liftA2 a -> b -> c
f Rule m a a
g Rule m a b
h = ((a, b) -> c) -> Rule m (a, b) c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> b -> c) -> (a, b) -> c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> c
f) Rule m (a, b) c -> Rule m a (a, b) -> Rule m a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Rule m a a
g Rule m a a -> Rule m a b -> Rule m a (a, b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Rule m a b
h)
{-# INLINE liftA2 #-}
instance Profunctor (Rule m) where
dimap :: (a -> b) -> (c -> d) -> Rule m b c -> Rule m a d
dimap a -> b
f c -> d
g Rule m b c
r = (c -> d) -> Rule m c d
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g Rule m c d -> Rule m a c -> Rule m a d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Rule m b c
r Rule m b c -> Rule m a b -> Rule m a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> b) -> Rule m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f
{-# INLINE dimap #-}
lmap :: (a -> b) -> Rule m b c -> Rule m a c
lmap a -> b
f Rule m b c
r = Rule m b c
r Rule m b c -> Rule m a b -> Rule m a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> b) -> Rule m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f
{-# INLINE lmap #-}
rmap :: (b -> c) -> Rule m a b -> Rule m a c
rmap = (b -> c) -> Rule m a b -> Rule m a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
{-# INLINE rmap #-}
instance Strong (Rule m) where
first' :: Rule m a b -> Rule m (a, c) (b, c)
first' = Rule m a b -> Rule m (a, c) (b, c)
forall (m :: * -> *) a b1 b2.
Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst
{-# INLINE first' #-}
second' :: Rule m a b -> Rule m (c, a) (c, b)
second' = Rule m a b -> Rule m (c, a) (c, b)
forall (m :: * -> *) a1 b a2.
Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond
{-# INLINE second' #-}
instance Choice (Rule m) where
left' :: Rule m a b -> Rule m (Either a c) (Either b c)
left' = Rule m a b -> Rule m (Either a c) (Either b c)
forall (m :: * -> *) a b c.
Rule m a b -> Rule m (Either a c) (Either b c)
rLeft
{-# INLINE left' #-}
right' :: Rule m a b -> Rule m (Either c a) (Either c b)
right' = Rule m a b -> Rule m (Either c a) (Either c b)
forall (m :: * -> *) a b c.
Rule m a b -> Rule m (Either c a) (Either c b)
rRight
{-# INLINE right' #-}
instance Category (Rule m) where
id :: Rule m a a
id = Rule m a a
forall (m :: * -> *) a. Rule m a a
rId
{-# INLINE id #-}
. :: Rule m b c -> Rule m a b -> Rule m a c
(.) = Rule m b c -> Rule m a b -> Rule m a c
forall (m :: * -> *) a1 b a2.
Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
rComp
{-# INLINE (.) #-}
instance Arrow (Rule m) where
arr :: (b -> c) -> Rule m b c
arr = (b -> c) -> Rule m b c
forall a b (m :: * -> *). (a -> b) -> Rule m a b
rArr
{-# INLINE arr #-}
first :: Rule m b c -> Rule m (b, d) (c, d)
first = Rule m b c -> Rule m (b, d) (c, d)
forall (m :: * -> *) a b1 b2.
Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst
{-# INLINE first #-}
second :: Rule m b c -> Rule m (d, b) (d, c)
second = Rule m b c -> Rule m (d, b) (d, c)
forall (m :: * -> *) a1 b a2.
Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond
{-# INLINE second #-}
*** :: Rule m b c -> Rule m b' c' -> Rule m (b, b') (c, c')
(***) = Rule m b c -> Rule m b' c' -> Rule m (b, b') (c, c')
forall (m :: * -> *) a1 b1 a2 b2.
Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
rSplit
{-# INLINE (***) #-}
&&& :: Rule m b c -> Rule m b c' -> Rule m b (c, c')
(&&&) = Rule m b c -> Rule m b c' -> Rule m b (c, c')
forall (m :: * -> *) a b1 b2.
Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
rFanout
{-# INLINE (&&&) #-}
instance ArrowChoice (Rule m) where
left :: Rule m b c -> Rule m (Either b d) (Either c d)
left = Rule m b c -> Rule m (Either b d) (Either c d)
forall (m :: * -> *) a b c.
Rule m a b -> Rule m (Either a c) (Either b c)
rLeft
{-# INLINE left #-}
right :: Rule m b c -> Rule m (Either d b) (Either d c)
right = Rule m b c -> Rule m (Either d b) (Either d c)
forall (m :: * -> *) a b c.
Rule m a b -> Rule m (Either c a) (Either c b)
rRight
{-# INLINE right #-}
+++ :: Rule m b c -> Rule m b' c' -> Rule m (Either b b') (Either c c')
(+++) = Rule m b c -> Rule m b' c' -> Rule m (Either b b') (Either c c')
forall (m :: * -> *) b c b' c'.
Rule m b c -> Rule m b' c' -> Rule m (Either b b') (Either c c')
rFork
{-# INLINE (+++) #-}
||| :: Rule m b d -> Rule m c d -> Rule m (Either b c) d
(|||) = Rule m b d -> Rule m c d -> Rule m (Either b c) d
forall (m :: * -> *) b d c.
Rule m b d -> Rule m c d -> Rule m (Either b c) d
rFanin
{-# INLINE (|||) #-}
instance (Monad m) => ArrowKleisli m (Rule m) where
arrM :: (a -> m b) -> Rule m a b
arrM = (a -> m b) -> Rule m a b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Rule m a b
rArrM
{-# INLINE arrM #-}
class (Arrow arr) => ArrowDistribute arr where
keyed ::
(Eq k, Hashable k) =>
arr (e, (k, (a, s))) b ->
arr (e, (HashMap k a, s)) (HashMap k b)
instance (Monoid w, ArrowDistribute arr) => ArrowDistribute (WriterA w arr) where
keyed :: WriterA w arr (e, (k, (a, s))) b
-> WriterA w arr (e, (HashMap k a, s)) (HashMap k b)
keyed (WriterA arr (e, (k, (a, s))) (b, w)
f) = arr (e, (HashMap k a, s)) (HashMap k b, w)
-> WriterA w arr (e, (HashMap k a, s)) (HashMap k b)
forall w (arr :: * -> * -> *) a b.
(Monoid w, Arrow arr) =>
arr a (b, w) -> WriterA w arr a b
WriterA ((HashMap k (b, w) -> (HashMap k b, w))
-> arr (HashMap k (b, w)) (HashMap k b, w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((w, HashMap k b) -> (HashMap k b, w)
forall a b. (a, b) -> (b, a)
swap ((w, HashMap k b) -> (HashMap k b, w))
-> (HashMap k (b, w) -> (w, HashMap k b))
-> HashMap k (b, w)
-> (HashMap k b, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((b, w) -> (w, b)) -> HashMap k (b, w) -> (w, HashMap k b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (b, w) -> (w, b)
forall a b. (a, b) -> (b, a)
swap) arr (HashMap k (b, w)) (HashMap k b, w)
-> arr (e, (HashMap k a, s)) (HashMap k (b, w))
-> arr (e, (HashMap k a, s)) (HashMap k b, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (e, (k, (a, s))) (b, w)
-> arr (e, (HashMap k a, s)) (HashMap k (b, w))
forall (arr :: * -> * -> *) k e a s b.
(ArrowDistribute arr, Eq k, Hashable k) =>
arr (e, (k, (a, s))) b -> arr (e, (HashMap k a, s)) (HashMap k b)
keyed arr (e, (k, (a, s))) (b, w)
f)
{-# INLINE keyed #-}
instance ArrowDistribute (Rule m) where
keyed ::
forall a b k e s.
(Eq k, Hashable k) =>
Rule m (e, (k, (a, s))) b ->
Rule m (e, (HashMap k a, s)) (HashMap k b)
keyed :: Rule m (e, (k, (a, s))) b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyed Rule m (e, (k, (a, s))) b
r0 = HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith HashMap k (Rule m (e, (k, (a, s))) b)
forall k v. HashMap k v
HM.empty
where
keyedWith ::
HashMap k (Rule m (e, (k, (a, s))) b) ->
Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith :: HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith !HashMap k (Rule m (e, (k, (a, s))) b)
rs = (forall r.
Accesses
-> (e, (HashMap k a, s))
-> (Accesses
-> HashMap k b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
-> m r)
-> m r)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
forall (m :: * -> *) a b.
(forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule \Accesses
s (e, (vs, sk)) Accesses
-> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r
c ->
(k
-> a
-> (Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r)
-> (Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> HashMap k a
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey (HashMap k (Rule m (e, (k, (a, s))) b)
-> e
-> s
-> k
-> a
-> (Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
forall r.
HashMap k (Rule m (e, (k, (a, s))) b)
-> e
-> s
-> k
-> a
-> (Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
process HashMap k (Rule m (e, (k, (a, s))) b)
rs e
e s
sk) ((Accesses
-> HashMap k b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
-> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
forall r.
(Accesses
-> HashMap k b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
-> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
finish Accesses
-> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r
c) HashMap k a
vs Accesses
s HashMap k b
forall k v. HashMap k v
HM.empty HashMap k (Rule m (e, (k, (a, s))) b)
forall k v. HashMap k v
HM.empty
process ::
HashMap k (Rule m (e, (k, (a, s))) b) ->
e ->
s ->
k ->
a ->
(Accesses -> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r) ->
Accesses ->
HashMap k b ->
HashMap k (Rule m (e, (k, (a, s))) b) ->
m r
process :: HashMap k (Rule m (e, (k, (a, s))) b)
-> e
-> s
-> k
-> a
-> (Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
process HashMap k (Rule m (e, (k, (a, s))) b)
rs e
e s
sk k
k a
a Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
c Accesses
s !HashMap k b
vs' !HashMap k (Rule m (e, (k, (a, s))) b)
rs' =
let Rule forall r.
Accesses
-> (e, (k, (a, s)))
-> (Accesses -> b -> Rule m (e, (k, (a, s))) b -> m r)
-> m r
r = Rule m (e, (k, (a, s))) b
-> k
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (k, (a, s))) b
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.lookupDefault Rule m (e, (k, (a, s))) b
r0 k
k HashMap k (Rule m (e, (k, (a, s))) b)
rs
in Accesses
-> (e, (k, (a, s)))
-> (Accesses -> b -> Rule m (e, (k, (a, s))) b -> m r)
-> m r
forall r.
Accesses
-> (e, (k, (a, s)))
-> (Accesses -> b -> Rule m (e, (k, (a, s))) b -> m r)
-> m r
r Accesses
s (e
e, (k
k, (a
a, s
sk))) \Accesses
s' b
b Rule m (e, (k, (a, s))) b
r' -> Accesses
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
c Accesses
s' (k -> b -> HashMap k b -> HashMap k b
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert k
k b
b HashMap k b
vs') (k
-> Rule m (e, (k, (a, s))) b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> HashMap k (Rule m (e, (k, (a, s))) b)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert k
k Rule m (e, (k, (a, s))) b
r' HashMap k (Rule m (e, (k, (a, s))) b)
rs')
finish ::
(Accesses -> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r) ->
Accesses ->
HashMap k b ->
HashMap k (Rule m (e, (k, (a, s))) b) ->
m r
finish :: (Accesses
-> HashMap k b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
-> m r)
-> Accesses
-> HashMap k b
-> HashMap k (Rule m (e, (k, (a, s))) b)
-> m r
finish Accesses
-> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r
c Accesses
s !HashMap k b
vs' !HashMap k (Rule m (e, (k, (a, s))) b)
rs' = Accesses
-> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r
c Accesses
s HashMap k b
vs' (HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith HashMap k (Rule m (e, (k, (a, s))) b)
rs')
{-# INLINEABLE keyed #-}