{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}

module Hasura.Incremental.Internal.Cache
  ( ArrowCache (..),
    DependT,
    MonadDepend (..),
  )
where

import Control.Arrow.Extended
import Control.Monad.Unique
import Hasura.Incremental.Internal.Dependency
import Hasura.Incremental.Internal.Rule
import Hasura.Incremental.Select
import Hasura.Prelude

class (ArrowKleisli m arr) => ArrowCache m arr | arr -> m where
  -- | 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 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 the given arrow are cached.__ If an arrow
  -- provides access to values through a side-channel, they will __not__ participate in caching.
  cache :: (Cacheable a) => arr a b -> arr a b

  -- | Creates a new 'Dependency', which allows fine-grained caching of composite values; see the
  -- documentation for 'Dependency' for more details.
  newDependency :: arr a (Dependency a)

  -- | Extract the value from a 'Dependency', incurring a dependency on its entirety. To depend on
  -- only a portion of the value, use 'selectD' or 'selectKeyD' before passing it to 'dependOn'.
  dependOn :: (Cacheable a) => arr (Dependency a) a

  -- | Run a monadic sub-computation with the ability to access dependencies; see 'MonadDepend' for
  -- more details.
  bindDepend :: arr (DependT m a) a

instance (ArrowChoice arr, ArrowCache m arr) => ArrowCache m (ErrorA e arr) where
  cache :: ErrorA e arr a b -> ErrorA e arr a b
cache (ErrorA arr a (Either e b)
f) = arr a (Either e b) -> ErrorA e arr a b
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (arr a (Either e b) -> arr a (Either e b)
forall (m :: * -> *) (arr :: * -> * -> *) a b.
(ArrowCache m arr, Cacheable a) =>
arr a b -> arr a b
cache arr a (Either e b)
f)
  {-# INLINE cache #-}
  newDependency :: ErrorA e arr a (Dependency a)
newDependency = arr a (Dependency a) -> ErrorA e arr a (Dependency a)
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr a (Dependency a)
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowCache m arr =>
arr a (Dependency a)
newDependency
  {-# INLINE newDependency #-}
  dependOn :: ErrorA e arr (Dependency a) a
dependOn = arr (Dependency a) a -> ErrorA e arr (Dependency a) a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr (Dependency a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
(ArrowCache m arr, Cacheable a) =>
arr (Dependency a) a
dependOn
  {-# INLINE dependOn #-}
  bindDepend :: ErrorA e arr (DependT m a) a
bindDepend = arr (DependT m a) a -> ErrorA e arr (DependT m a) a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr (DependT m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowCache m arr =>
arr (DependT m a) a
bindDepend
  {-# INLINE bindDepend #-}

instance (Monoid w, ArrowCache m arr) => ArrowCache m (WriterA w arr) where
  cache :: WriterA w arr a b -> WriterA w arr a b
cache (WriterA arr a (b, w)
f) = arr a (b, w) -> WriterA w arr a b
forall w (arr :: * -> * -> *) a b.
(Monoid w, Arrow arr) =>
arr a (b, w) -> WriterA w arr a b
WriterA (arr a (b, w) -> arr a (b, w)
forall (m :: * -> *) (arr :: * -> * -> *) a b.
(ArrowCache m arr, Cacheable a) =>
arr a b -> arr a b
cache arr a (b, w)
f)
  {-# INLINE cache #-}
  newDependency :: WriterA w arr a (Dependency a)
newDependency = arr a (Dependency a) -> WriterA w arr a (Dependency a)
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr a (Dependency a)
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowCache m arr =>
arr a (Dependency a)
newDependency
  {-# INLINE newDependency #-}
  dependOn :: WriterA w arr (Dependency a) a
dependOn = arr (Dependency a) a -> WriterA w arr (Dependency a) a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr (Dependency a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
(ArrowCache m arr, Cacheable a) =>
arr (Dependency a) a
dependOn
  {-# INLINE dependOn #-}
  bindDepend :: WriterA w arr (DependT m a) a
bindDepend = arr (DependT m a) a -> WriterA w arr (DependT m a) a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr (DependT m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowCache m arr =>
arr (DependT m a) a
bindDepend
  {-# INLINE bindDepend #-}

instance (MonadUnique m) => ArrowCache m (Rule m) where
  cache :: Rule m a b -> Rule m a b
cache Rule m a b
r0 = (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 -> do
    let Rule forall r.
Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
r = Rule m a b -> Rule m a (b, Accesses)
forall a b. Rule m a b -> Rule m a (b, Accesses)
listenAccesses Rule m a b
r0
    Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
forall r.
Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
r Accesses
s a
a \Accesses
s' (b
b, Accesses
accesses) Rule m a (b, Accesses)
r' -> Accesses -> b -> Rule m a b -> m r
k Accesses
s' b
b (Accesses -> a -> b -> Rule m a (b, Accesses) -> Rule m a b
forall a b (m :: * -> *).
Cacheable a =>
Accesses -> a -> b -> Rule m a (b, Accesses) -> Rule m a b
cached Accesses
accesses a
a b
b Rule m a (b, Accesses)
r')
    where
      listenAccesses :: Rule m a b -> Rule m a (b, Accesses)
      listenAccesses :: Rule m a b -> Rule m a (b, Accesses)
listenAccesses (Rule forall r.
Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r
r) = (forall r.
 Accesses
 -> a
 -> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
 -> m r)
-> Rule m a (b, Accesses)
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, Accesses) -> Rule m a (b, Accesses) -> m r
k -> Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r
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
s' b
b Rule m a b
r' ->
        (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r
k (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r
forall a b. (a -> b) -> a -> b
$! (Accesses
s Accesses -> Accesses -> Accesses
forall a. Semigroup a => a -> a -> a
<> Accesses
s')) (b
b, Accesses
s') (Rule m a b -> Rule m a (b, Accesses)
forall a b. Rule m a b -> Rule m a (b, Accesses)
listenAccesses Rule m a b
r')

      cached :: Accesses -> a -> b -> Rule m a (b, Accesses) -> Rule m a b
cached Accesses
accesses a
a b
b (Rule forall r.
Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
r) = (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 ->
        if
            | Accesses -> a -> a -> Bool
forall a. Cacheable a => Accesses -> a -> a -> Bool
unchanged Accesses
accesses a
a a
a' -> (Accesses -> b -> Rule m a b -> m r
k (Accesses -> b -> Rule m a b -> m r)
-> Accesses -> b -> Rule m a b -> m r
forall a b. (a -> b) -> a -> b
$! (Accesses
s Accesses -> Accesses -> Accesses
forall a. Semigroup a => a -> a -> a
<> Accesses
accesses)) b
b (Accesses -> a -> b -> Rule m a (b, Accesses) -> Rule m a b
cached Accesses
accesses a
a b
b ((forall r.
 Accesses
 -> a
 -> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
 -> m r)
-> Rule m a (b, Accesses)
forall (m :: * -> *) a b.
(forall r.
 Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
-> Rule m a b
Rule forall r.
Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
r))
            | Bool
otherwise -> Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
forall r.
Accesses
-> a
-> (Accesses -> (b, Accesses) -> Rule m a (b, Accesses) -> m r)
-> m r
r Accesses
s a
a' \Accesses
s' (b', accesses') Rule m a (b, Accesses)
r' -> Accesses -> b -> Rule m a b -> m r
k Accesses
s' b
b' (Accesses -> a -> b -> Rule m a (b, Accesses) -> Rule m a b
cached Accesses
accesses' a
a' b
b' Rule m a (b, Accesses)
r')

  newDependency :: Rule m a (Dependency a)
newDependency = (forall r.
 Accesses
 -> a
 -> (Accesses -> Dependency a -> Rule m a (Dependency a) -> m r)
 -> m r)
-> Rule m a (Dependency 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 -> Dependency a -> Rule m a (Dependency a) -> m r
k -> do
    DependencyKey a
key <- UniqueS a -> DependencyKey a
forall a. UniqueS a -> DependencyKey a
DependencyRoot (UniqueS a -> DependencyKey a)
-> m (UniqueS a) -> m (DependencyKey a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (UniqueS a)
forall (m :: * -> *) a. MonadUnique m => m (UniqueS a)
newUniqueS
    Accesses -> Dependency a -> Rule m a (Dependency a) -> m r
k Accesses
s (DependencyKey a -> a -> Dependency a
forall a. DependencyKey a -> a -> Dependency a
Dependency DependencyKey a
key a
a) ((a -> Dependency a) -> Rule m a (Dependency a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (DependencyKey a -> a -> Dependency a
forall a. DependencyKey a -> a -> Dependency a
Dependency DependencyKey a
key))
  {-# INLINEABLE newDependency #-}

  dependOn :: Rule m (Dependency a) a
dependOn = (forall r.
 Accesses
 -> Dependency a
 -> (Accesses -> a -> Rule m (Dependency a) a -> m r)
 -> m r)
-> Rule m (Dependency 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 (Dependency key v) Accesses -> a -> Rule m (Dependency a) a -> m r
k -> (Accesses -> a -> Rule m (Dependency a) a -> m r
k (Accesses -> a -> Rule m (Dependency a) a -> m r)
-> Accesses -> a -> Rule m (Dependency a) a -> m r
forall a b. (a -> b) -> a -> b
$! DependencyKey a -> Access a -> Accesses -> Accesses
forall a. DependencyKey a -> Access a -> Accesses -> Accesses
recordAccess DependencyKey a
key Access a
forall a. Cacheable a => Access a
AccessedAll Accesses
s) a
v Rule m (Dependency a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
(ArrowCache m arr, Cacheable a) =>
arr (Dependency a) a
dependOn

  bindDepend :: Rule m (DependT m a) a
bindDepend = (forall r.
 Accesses
 -> DependT m a
 -> (Accesses -> a -> Rule m (DependT m a) a -> m r)
 -> m r)
-> Rule m (DependT 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 DependT m a
m Accesses -> a -> Rule m (DependT m a) a -> m r
k -> StateT Accesses m a -> Accesses -> m (a, Accesses)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (DependT m a -> StateT Accesses m a
forall (m :: * -> *) a. DependT m a -> StateT Accesses m a
unDependT DependT m a
m) Accesses
s m (a, Accesses) -> ((a, Accesses) -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
v, Accesses
s') -> Accesses -> a -> Rule m (DependT m a) a -> m r
k Accesses
s' a
v Rule m (DependT m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowCache m arr =>
arr (DependT m a) a
bindDepend

-- | A restricted, monadic variant of 'ArrowCache' that can only read dependencies, not create new
-- ones or add local caching. This serves as a limited adapter between arrow and monadic code.
class (Monad m) => MonadDepend m where
  dependOnM :: (Cacheable a) => Dependency a -> m a

instance (MonadDepend m) => MonadDepend (ExceptT e m) where
  dependOnM :: Dependency a -> ExceptT e m a
dependOnM = m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptT e m a)
-> (Dependency a -> m a) -> Dependency a -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency a -> m a
forall (m :: * -> *) a.
(MonadDepend m, Cacheable a) =>
Dependency a -> m a
dependOnM

newtype DependT m a = DependT {DependT m a -> StateT Accesses m a
unDependT :: StateT Accesses m a}
  deriving (a -> DependT m b -> DependT m a
(a -> b) -> DependT m a -> DependT m b
(forall a b. (a -> b) -> DependT m a -> DependT m b)
-> (forall a b. a -> DependT m b -> DependT m a)
-> Functor (DependT m)
forall a b. a -> DependT m b -> DependT m a
forall a b. (a -> b) -> DependT m a -> DependT m b
forall (m :: * -> *) a b.
Functor m =>
a -> DependT m b -> DependT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DependT m a -> DependT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DependT m b -> DependT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> DependT m b -> DependT m a
fmap :: (a -> b) -> DependT m a -> DependT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DependT m a -> DependT m b
Functor, Functor (DependT m)
a -> DependT m a
Functor (DependT m)
-> (forall a. a -> DependT m a)
-> (forall a b. DependT m (a -> b) -> DependT m a -> DependT m b)
-> (forall a b c.
    (a -> b -> c) -> DependT m a -> DependT m b -> DependT m c)
-> (forall a b. DependT m a -> DependT m b -> DependT m b)
-> (forall a b. DependT m a -> DependT m b -> DependT m a)
-> Applicative (DependT m)
DependT m a -> DependT m b -> DependT m b
DependT m a -> DependT m b -> DependT m a
DependT m (a -> b) -> DependT m a -> DependT m b
(a -> b -> c) -> DependT m a -> DependT m b -> DependT m c
forall a. a -> DependT m a
forall a b. DependT m a -> DependT m b -> DependT m a
forall a b. DependT m a -> DependT m b -> DependT m b
forall a b. DependT m (a -> b) -> DependT m a -> DependT m b
forall a b c.
(a -> b -> c) -> DependT m a -> DependT m b -> DependT m c
forall (m :: * -> *). Monad m => Functor (DependT m)
forall (m :: * -> *) a. Monad m => a -> DependT m a
forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m a
forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m b
forall (m :: * -> *) a b.
Monad m =>
DependT m (a -> b) -> DependT m a -> DependT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DependT m a -> DependT m b -> DependT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DependT m a -> DependT m b -> DependT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m a
*> :: DependT m a -> DependT m b -> DependT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m b
liftA2 :: (a -> b -> c) -> DependT m a -> DependT m b -> DependT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DependT m a -> DependT m b -> DependT m c
<*> :: DependT m (a -> b) -> DependT m a -> DependT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
DependT m (a -> b) -> DependT m a -> DependT m b
pure :: a -> DependT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> DependT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (DependT m)
Applicative, Applicative (DependT m)
a -> DependT m a
Applicative (DependT m)
-> (forall a b. DependT m a -> (a -> DependT m b) -> DependT m b)
-> (forall a b. DependT m a -> DependT m b -> DependT m b)
-> (forall a. a -> DependT m a)
-> Monad (DependT m)
DependT m a -> (a -> DependT m b) -> DependT m b
DependT m a -> DependT m b -> DependT m b
forall a. a -> DependT m a
forall a b. DependT m a -> DependT m b -> DependT m b
forall a b. DependT m a -> (a -> DependT m b) -> DependT m b
forall (m :: * -> *). Monad m => Applicative (DependT m)
forall (m :: * -> *) a. Monad m => a -> DependT m a
forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m b
forall (m :: * -> *) a b.
Monad m =>
DependT m a -> (a -> DependT m b) -> DependT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DependT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> DependT m a
>> :: DependT m a -> DependT m b -> DependT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
DependT m a -> DependT m b -> DependT m b
>>= :: DependT m a -> (a -> DependT m b) -> DependT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
DependT m a -> (a -> DependT m b) -> DependT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (DependT m)
Monad, m a -> DependT m a
(forall (m :: * -> *) a. Monad m => m a -> DependT m a)
-> MonadTrans DependT
forall (m :: * -> *) a. Monad m => m a -> DependT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> DependT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> DependT m a
MonadTrans, MonadError e)

instance (Monad m) => MonadDepend (DependT m) where
  dependOnM :: Dependency a -> DependT m a
dependOnM (Dependency DependencyKey a
key a
v) = StateT Accesses m a -> DependT m a
forall (m :: * -> *) a. StateT Accesses m a -> DependT m a
DependT ((Accesses -> Accesses) -> StateT Accesses m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (DependencyKey a -> Access a -> Accesses -> Accesses
forall a. DependencyKey a -> Access a -> Accesses -> Accesses
recordAccess DependencyKey a
key Access a
forall a. Cacheable a => Access a
AccessedAll) StateT Accesses m () -> a -> StateT Accesses m a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
v)