{-# language CPP #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language GADTs #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TupleSections #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
module Rock.Core where

import Control.Concurrent.Lifted
import Control.Exception.Lifted
import Data.IORef.Lifted
import Control.Monad.Base
import Control.Monad.Cont
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader
import qualified Control.Monad.RWS.Lazy as Lazy
import qualified Control.Monad.RWS.Strict as Strict
import qualified Control.Monad.State.Lazy as Lazy
import qualified Control.Monad.State.Strict as Strict
import Control.Monad.Trans.Control
import Control.Monad.Trans.Maybe
import qualified Control.Monad.Writer.Lazy as Lazy
import qualified Control.Monad.Writer.Strict as Strict
import Data.Bifunctor
import Data.Constraint.Extras
import Data.Dependent.HashMap (DHashMap)
import qualified Data.Dependent.HashMap as DHashMap
import Data.Dependent.Sum
import Data.Foldable
import Data.Functor.Const
import Data.GADT.Compare (GEq, GCompare, geq, gcompare, GOrdering(..))
import Data.GADT.Show (GShow)
import Data.Hashable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Maybe
import Data.Typeable
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Data.Some

import Rock.Traces(Traces)
import qualified Rock.Traces as Traces

-------------------------------------------------------------------------------
-- * Types

-- | A function which, given an @f@ query, returns a 'Task' allowed to make @f@
-- queries to compute its result.
type Rules f = GenRules f f

-- | A function which, given an @f@ query, returns a 'Task' allowed to make @g@
-- queries to compute its result.
type GenRules f g = forall a. f a -> Task g a

-- | An @IO@ action that is allowed to make @f@ queries using the 'fetch'
-- method from its 'MonadFetch' instance.
newtype Task f a = Task { Task f a -> ReaderT (Fetch f) IO a
unTask :: ReaderT (Fetch f) IO a }
  deriving
    (a -> Task f b -> Task f a
(a -> b) -> Task f a -> Task f b
(forall a b. (a -> b) -> Task f a -> Task f b)
-> (forall a b. a -> Task f b -> Task f a) -> Functor (Task f)
forall a b. a -> Task f b -> Task f a
forall a b. (a -> b) -> Task f a -> Task f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a b. a -> Task f b -> Task f a
forall (f :: * -> *) a b. (a -> b) -> Task f a -> Task f b
<$ :: a -> Task f b -> Task f a
$c<$ :: forall (f :: * -> *) a b. a -> Task f b -> Task f a
fmap :: (a -> b) -> Task f a -> Task f b
$cfmap :: forall (f :: * -> *) a b. (a -> b) -> Task f a -> Task f b
Functor, Functor (Task f)
a -> Task f a
Functor (Task f)
-> (forall a. a -> Task f a)
-> (forall a b. Task f (a -> b) -> Task f a -> Task f b)
-> (forall a b c.
    (a -> b -> c) -> Task f a -> Task f b -> Task f c)
-> (forall a b. Task f a -> Task f b -> Task f b)
-> (forall a b. Task f a -> Task f b -> Task f a)
-> Applicative (Task f)
Task f a -> Task f b -> Task f b
Task f a -> Task f b -> Task f a
Task f (a -> b) -> Task f a -> Task f b
(a -> b -> c) -> Task f a -> Task f b -> Task f c
forall a. a -> Task f a
forall a b. Task f a -> Task f b -> Task f a
forall a b. Task f a -> Task f b -> Task f b
forall a b. Task f (a -> b) -> Task f a -> Task f b
forall a b c. (a -> b -> c) -> Task f a -> Task f b -> Task f c
forall (f :: * -> *). Functor (Task f)
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
forall (f :: * -> *) a. a -> Task f a
forall (f :: * -> *) a b. Task f a -> Task f b -> Task f a
forall (f :: * -> *) a b. Task f a -> Task f b -> Task f b
forall (f :: * -> *) a b. Task f (a -> b) -> Task f a -> Task f b
forall (f :: * -> *) a b c.
(a -> b -> c) -> Task f a -> Task f b -> Task f c
<* :: Task f a -> Task f b -> Task f a
$c<* :: forall (f :: * -> *) a b. Task f a -> Task f b -> Task f a
*> :: Task f a -> Task f b -> Task f b
$c*> :: forall (f :: * -> *) a b. Task f a -> Task f b -> Task f b
liftA2 :: (a -> b -> c) -> Task f a -> Task f b -> Task f c
$cliftA2 :: forall (f :: * -> *) a b c.
(a -> b -> c) -> Task f a -> Task f b -> Task f c
<*> :: Task f (a -> b) -> Task f a -> Task f b
$c<*> :: forall (f :: * -> *) a b. Task f (a -> b) -> Task f a -> Task f b
pure :: a -> Task f a
$cpure :: forall (f :: * -> *) a. a -> Task f a
$cp1Applicative :: forall (f :: * -> *). Functor (Task f)
Applicative, Applicative (Task f)
a -> Task f a
Applicative (Task f)
-> (forall a b. Task f a -> (a -> Task f b) -> Task f b)
-> (forall a b. Task f a -> Task f b -> Task f b)
-> (forall a. a -> Task f a)
-> Monad (Task f)
Task f a -> (a -> Task f b) -> Task f b
Task f a -> Task f b -> Task f b
forall a. a -> Task f a
forall a b. Task f a -> Task f b -> Task f b
forall a b. Task f a -> (a -> Task f b) -> Task f b
forall (f :: * -> *). Applicative (Task f)
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
forall (f :: * -> *) a. a -> Task f a
forall (f :: * -> *) a b. Task f a -> Task f b -> Task f b
forall (f :: * -> *) a b. Task f a -> (a -> Task f b) -> Task f b
return :: a -> Task f a
$creturn :: forall (f :: * -> *) a. a -> Task f a
>> :: Task f a -> Task f b -> Task f b
$c>> :: forall (f :: * -> *) a b. Task f a -> Task f b -> Task f b
>>= :: Task f a -> (a -> Task f b) -> Task f b
$c>>= :: forall (f :: * -> *) a b. Task f a -> (a -> Task f b) -> Task f b
$cp1Monad :: forall (f :: * -> *). Applicative (Task f)
Monad, Monad (Task f)
Monad (Task f) -> (forall a. IO a -> Task f a) -> MonadIO (Task f)
IO a -> Task f a
forall a. IO a -> Task f a
forall (f :: * -> *). Monad (Task f)
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (f :: * -> *) a. IO a -> Task f a
liftIO :: IO a -> Task f a
$cliftIO :: forall (f :: * -> *) a. IO a -> Task f a
$cp1MonadIO :: forall (f :: * -> *). Monad (Task f)
MonadIO, MonadBase IO, Monad (Task f)
Monad (Task f)
-> (forall a. (a -> Task f a) -> Task f a) -> MonadFix (Task f)
(a -> Task f a) -> Task f a
forall a. (a -> Task f a) -> Task f a
forall (f :: * -> *). Monad (Task f)
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (f :: * -> *) a. (a -> Task f a) -> Task f a
mfix :: (a -> Task f a) -> Task f a
$cmfix :: forall (f :: * -> *) a. (a -> Task f a) -> Task f a
$cp1MonadFix :: forall (f :: * -> *). Monad (Task f)
MonadFix)

newtype Fetch f = Fetch (forall a. f a -> IO a)

-------------------------------------------------------------------------------
-- * Fetch class

-- | Monads that can make @f@ queries by 'fetch'ing them.
class Monad m => MonadFetch f m | m -> f where
  fetch :: f a -> m a
  default fetch
    :: (MonadTrans t, MonadFetch f m1, m ~ t m1)
    => f a
    -> m a
  fetch = m1 a -> t m1 a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m1 a -> t m1 a) -> (f a -> m1 a) -> f a -> t m1 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> m1 a
forall (f :: * -> *) (m :: * -> *) a. MonadFetch f m => f a -> m a
fetch

instance MonadFetch f m => MonadFetch f (ContT r m)
instance MonadFetch f m => MonadFetch f (ExceptT e m)
instance MonadFetch f m => MonadFetch f (IdentityT m)
instance MonadFetch f m => MonadFetch f (MaybeT m)
instance MonadFetch f m => MonadFetch f (ReaderT r m)
instance (MonadFetch f m, Monoid w) => MonadFetch f (Strict.RWST r w s m)
instance (MonadFetch f m, Monoid w) => MonadFetch f (Lazy.RWST r w s m)
instance MonadFetch f m => MonadFetch f (Strict.StateT s m)
instance MonadFetch f m => MonadFetch f (Lazy.StateT s m)
instance (Monoid w, MonadFetch f m) => MonadFetch f (Strict.WriterT w m)
instance (Monoid w, MonadFetch f m) => MonadFetch f (Lazy.WriterT w m)

-------------------------------------------------------------------------------
-- Instances

instance MonadFetch f (Task f) where
  {-# INLINE fetch #-}
  fetch :: f a -> Task f a
fetch f a
key = ReaderT (Fetch f) IO a -> Task f a
forall (f :: * -> *) a. ReaderT (Fetch f) IO a -> Task f a
Task (ReaderT (Fetch f) IO a -> Task f a)
-> ReaderT (Fetch f) IO a -> Task f a
forall a b. (a -> b) -> a -> b
$ do
    IO a
io <- (Fetch f -> IO a) -> ReaderT (Fetch f) IO (IO a)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (\(Fetch forall a. f a -> IO a
fetch_) -> f a -> IO a
forall a. f a -> IO a
fetch_ f a
key)
    IO a -> ReaderT (Fetch f) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io

instance MonadBaseControl IO (Task f) where
  type StM (Task f) a = StM (ReaderT (Fetch f) IO) a
  liftBaseWith :: (RunInBase (Task f) IO -> IO a) -> Task f a
liftBaseWith RunInBase (Task f) IO -> IO a
k = ReaderT (Fetch f) IO a -> Task f a
forall (f :: * -> *) a. ReaderT (Fetch f) IO a -> Task f a
Task (ReaderT (Fetch f) IO a -> Task f a)
-> ReaderT (Fetch f) IO a -> Task f a
forall a b. (a -> b) -> a -> b
$ (RunInBase (ReaderT (Fetch f) IO) IO -> IO a)
-> ReaderT (Fetch f) IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase (ReaderT (Fetch f) IO) IO -> IO a)
 -> ReaderT (Fetch f) IO a)
-> (RunInBase (ReaderT (Fetch f) IO) IO -> IO a)
-> ReaderT (Fetch f) IO a
forall a b. (a -> b) -> a -> b
$ \RunInBase (ReaderT (Fetch f) IO) IO
ma -> RunInBase (Task f) IO -> IO a
k (RunInBase (Task f) IO -> IO a) -> RunInBase (Task f) IO -> IO a
forall a b. (a -> b) -> a -> b
$ ReaderT (Fetch f) IO a -> IO a
RunInBase (ReaderT (Fetch f) IO) IO
ma (ReaderT (Fetch f) IO a -> IO a)
-> (Task f a -> ReaderT (Fetch f) IO a) -> Task f a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task f a -> ReaderT (Fetch f) IO a
forall (f :: * -> *) a. Task f a -> ReaderT (Fetch f) IO a
unTask
  restoreM :: StM (Task f) a -> Task f a
restoreM = ReaderT (Fetch f) IO a -> Task f a
forall (f :: * -> *) a. ReaderT (Fetch f) IO a -> Task f a
Task (ReaderT (Fetch f) IO a -> Task f a)
-> (a -> ReaderT (Fetch f) IO a) -> a -> Task f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT (Fetch f) IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM

-------------------------------------------------------------------------------
-- * Transformations

-- | Transform the type of queries that a 'Task' performs.
transFetch
  :: (forall b. f b -> Task f' b)
  -> Task f a
  -> Task f' a
transFetch :: (forall b. f b -> Task f' b) -> Task f a -> Task f' a
transFetch forall b. f b -> Task f' b
f (Task ReaderT (Fetch f) IO a
task) =
  ReaderT (Fetch f') IO a -> Task f' a
forall (f :: * -> *) a. ReaderT (Fetch f) IO a -> Task f a
Task (ReaderT (Fetch f') IO a -> Task f' a)
-> ReaderT (Fetch f') IO a -> Task f' a
forall a b. (a -> b) -> a -> b
$ (Fetch f' -> IO a) -> ReaderT (Fetch f') IO a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Fetch f' -> IO a) -> ReaderT (Fetch f') IO a)
-> (Fetch f' -> IO a) -> ReaderT (Fetch f') IO a
forall a b. (a -> b) -> a -> b
$ \Fetch f'
fetch_ ->
    ReaderT (Fetch f) IO a -> Fetch f -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Fetch f) IO a
task (Fetch f -> IO a) -> Fetch f -> IO a
forall a b. (a -> b) -> a -> b
$ (forall a. f a -> IO a) -> Fetch f
forall (f :: * -> *). (forall a. f a -> IO a) -> Fetch f
Fetch ((forall a. f a -> IO a) -> Fetch f)
-> (forall a. f a -> IO a) -> Fetch f
forall a b. (a -> b) -> a -> b
$ \f a
key ->
      ReaderT (Fetch f') IO a -> Fetch f' -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Task f' a -> ReaderT (Fetch f') IO a
forall (f :: * -> *) a. Task f a -> ReaderT (Fetch f) IO a
unTask (Task f' a -> ReaderT (Fetch f') IO a)
-> Task f' a -> ReaderT (Fetch f') IO a
forall a b. (a -> b) -> a -> b
$ f a -> Task f' a
forall b. f b -> Task f' b
f f a
key) Fetch f'
fetch_

-------------------------------------------------------------------------------
-- * Running tasks

-- | Perform a 'Task', fetching dependency queries from the given 'Rules'
-- function.
runTask :: Rules f -> Task f a -> IO a
runTask :: Rules f -> Task f a -> IO a
runTask Rules f
rules (Task ReaderT (Fetch f) IO a
task) =
  ReaderT (Fetch f) IO a -> Fetch f -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Fetch f) IO a
task (Fetch f -> IO a) -> Fetch f -> IO a
forall a b. (a -> b) -> a -> b
$ (forall a. f a -> IO a) -> Fetch f
forall (f :: * -> *). (forall a. f a -> IO a) -> Fetch f
Fetch ((forall a. f a -> IO a) -> Fetch f)
-> (forall a. f a -> IO a) -> Fetch f
forall a b. (a -> b) -> a -> b
$ Rules f -> Task f a -> IO a
forall (f :: * -> *) a. Rules f -> Task f a -> IO a
runTask Rules f
rules (Task f a -> IO a) -> (f a -> Task f a) -> f a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Task f a
Rules f
rules

-------------------------------------------------------------------------------
-- * Task combinators

-- | Track the query dependencies of a 'Task' in a 'DHashMap'.
track
  :: forall f g a. (GEq f, Hashable (Some f))
  => (forall a'. f a' -> a' -> g a')
  -> Task f a
  -> Task f (a, DHashMap f g)
track :: (forall a'. f a' -> a' -> g a')
-> Task f a -> Task f (a, DHashMap f g)
track forall a'. f a' -> a' -> g a'
f =
  (forall a'. f a' -> a' -> Task f (g a'))
-> Task f a -> Task f (a, DHashMap f g)
forall (f :: * -> *) (g :: * -> *) a.
(GEq f, Hashable (Some f)) =>
(forall a'. f a' -> a' -> Task f (g a'))
-> Task f a -> Task f (a, DHashMap f g)
trackM ((forall a'. f a' -> a' -> Task f (g a'))
 -> Task f a -> Task f (a, DHashMap f g))
-> (forall a'. f a' -> a' -> Task f (g a'))
-> Task f a
-> Task f (a, DHashMap f g)
forall a b. (a -> b) -> a -> b
$ \f a'
key -> g a' -> Task f (g a')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (g a' -> Task f (g a')) -> (a' -> g a') -> a' -> Task f (g a')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a' -> a' -> g a'
forall a'. f a' -> a' -> g a'
f f a'
key

-- | Track the query dependencies of a 'Task' in a 'DHashMap'. Monadic version.
trackM
  :: forall f g a. (GEq f, Hashable (Some f))
  => (forall a'. f a' -> a' -> Task f (g a'))
  -> Task f a
  -> Task f (a, DHashMap f g)
trackM :: (forall a'. f a' -> a' -> Task f (g a'))
-> Task f a -> Task f (a, DHashMap f g)
trackM forall a'. f a' -> a' -> Task f (g a')
f Task f a
task = do
  IORef (DHashMap f g)
depsVar <- DHashMap f g -> Task f (IORef (DHashMap f g))
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef DHashMap f g
forall a. Monoid a => a
mempty
  let
    record :: f b -> Task f b
    record :: f b -> Task f b
record f b
key = do
      b
value <- f b -> Task f b
forall (f :: * -> *) (m :: * -> *) a. MonadFetch f m => f a -> m a
fetch f b
key
      g b
g <- f b -> b -> Task f (g b)
forall a'. f a' -> a' -> Task f (g a')
f f b
key b
value
      IORef (DHashMap f g)
-> (DHashMap f g -> (DHashMap f g, ())) -> Task f ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (DHashMap f g)
depsVar ((DHashMap f g -> (DHashMap f g, ())) -> Task f ())
-> (DHashMap f g -> (DHashMap f g, ())) -> Task f ()
forall a b. (a -> b) -> a -> b
$ (, ()) (DHashMap f g -> (DHashMap f g, ()))
-> (DHashMap f g -> DHashMap f g)
-> DHashMap f g
-> (DHashMap f g, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f b -> g b -> DHashMap f g -> DHashMap f g
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> v a -> DHashMap k v -> DHashMap k v
DHashMap.insert f b
key g b
g
      b -> Task f b
forall (m :: * -> *) a. Monad m => a -> m a
return b
value
  a
result <- (forall b. f b -> Task f b) -> Task f a -> Task f a
forall (f :: * -> *) (f' :: * -> *) a.
(forall b. f b -> Task f' b) -> Task f a -> Task f' a
transFetch forall b. f b -> Task f b
record Task f a
task
  DHashMap f g
deps <- IORef (DHashMap f g) -> Task f (DHashMap f g)
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef (DHashMap f g)
depsVar
  (a, DHashMap f g) -> Task f (a, DHashMap f g)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, DHashMap f g
deps)

-- | Remember what @f@ queries have already been performed and their results in
-- a 'DHashMap', and reuse them if a query is performed again a second time.
--
-- The 'DHashMap' should typically not be reused if there has been some change that
-- might make a query return a different result.
memoise
  :: forall f g
  . (GEq f, Hashable (Some f))
  => IORef (DHashMap f MVar)
  -> GenRules f g
  -> GenRules f g
memoise :: IORef (DHashMap f MVar) -> GenRules f g -> GenRules f g
memoise IORef (DHashMap f MVar)
startedVar GenRules f g
rules (f a
key :: f a) = do
  Maybe (MVar a)
maybeValueVar <- f a -> DHashMap f MVar -> Maybe (MVar a)
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> DHashMap k v -> Maybe (v a)
DHashMap.lookup f a
key (DHashMap f MVar -> Maybe (MVar a))
-> Task g (DHashMap f MVar) -> Task g (Maybe (MVar a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (DHashMap f MVar) -> Task g (DHashMap f MVar)
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef (DHashMap f MVar)
startedVar
  case Maybe (MVar a)
maybeValueVar of
    Maybe (MVar a)
Nothing -> do
      MVar a
valueVar <- Task g (MVar a)
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
      Task g (Task g a) -> Task g a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Task g (Task g a) -> Task g a) -> Task g (Task g a) -> Task g a
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f MVar)
-> (DHashMap f MVar -> (DHashMap f MVar, Task g a))
-> Task g (Task g a)
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (DHashMap f MVar)
startedVar ((DHashMap f MVar -> (DHashMap f MVar, Task g a))
 -> Task g (Task g a))
-> (DHashMap f MVar -> (DHashMap f MVar, Task g a))
-> Task g (Task g a)
forall a b. (a -> b) -> a -> b
$ \DHashMap f MVar
started ->
        case (Maybe (MVar a) -> Maybe (MVar a))
-> f a -> DHashMap f MVar -> (Maybe (MVar a), DHashMap f MVar)
forall (k :: * -> *) (v :: * -> *) a.
(GEq k, Hashable (Some k)) =>
(Maybe (v a) -> Maybe (v a))
-> k a -> DHashMap k v -> (Maybe (v a), DHashMap k v)
DHashMap.alterLookup (MVar a -> Maybe (MVar a)
forall a. a -> Maybe a
Just (MVar a -> Maybe (MVar a))
-> (Maybe (MVar a) -> MVar a) -> Maybe (MVar a) -> Maybe (MVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> Maybe (MVar a) -> MVar a
forall a. a -> Maybe a -> a
fromMaybe MVar a
valueVar) f a
key DHashMap f MVar
started of
          (Maybe (MVar a)
Nothing, DHashMap f MVar
started') ->
            ( DHashMap f MVar
started'
            , do
              a
value <- f a -> Task g a
GenRules f g
rules f a
key
              MVar a -> a -> Task g ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar a
valueVar a
value
              a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value
            )

          (Just MVar a
valueVar', DHashMap f MVar
_started') ->
            (DHashMap f MVar
started, MVar a -> Task g a
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar a
valueVar')

    Just MVar a
valueVar ->
      MVar a -> Task g a
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar a
valueVar

newtype Cyclic f = Cyclic (Some f)
  deriving Int -> Cyclic f -> ShowS
[Cyclic f] -> ShowS
Cyclic f -> String
(Int -> Cyclic f -> ShowS)
-> (Cyclic f -> String) -> ([Cyclic f] -> ShowS) -> Show (Cyclic f)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *). GShow f => Int -> Cyclic f -> ShowS
forall (f :: * -> *). GShow f => [Cyclic f] -> ShowS
forall (f :: * -> *). GShow f => Cyclic f -> String
showList :: [Cyclic f] -> ShowS
$cshowList :: forall (f :: * -> *). GShow f => [Cyclic f] -> ShowS
show :: Cyclic f -> String
$cshow :: forall (f :: * -> *). GShow f => Cyclic f -> String
showsPrec :: Int -> Cyclic f -> ShowS
$cshowsPrec :: forall (f :: * -> *). GShow f => Int -> Cyclic f -> ShowS
Show

instance (GShow f, Typeable f) => Exception (Cyclic f)

data MemoEntry a
  = Started !ThreadId !(MVar (Maybe a)) !(MVar (Maybe [ThreadId]))
  | Done !a

-- | Like 'memoise', but throw @'Cyclic' f@ if a query depends on itself, directly or
-- indirectly.
--
-- The 'HashMap' represents dependencies between threads and should not be
-- reused between invocations.
memoiseWithCycleDetection
  :: forall f g
  . (Typeable f, GShow f, GEq f, Hashable (Some f))
  => IORef (DHashMap f MemoEntry)
  -> IORef (HashMap ThreadId ThreadId)
  -> GenRules f g
  -> GenRules f g
memoiseWithCycleDetection :: IORef (DHashMap f MemoEntry)
-> IORef (HashMap ThreadId ThreadId)
-> GenRules f g
-> GenRules f g
memoiseWithCycleDetection IORef (DHashMap f MemoEntry)
startedVar IORef (HashMap ThreadId ThreadId)
depsVar GenRules f g
rules =
  f a -> Task g a
rules'
  where
    rules' :: f a -> Task g a
rules' (f a
key :: f a) = do
      Maybe (MemoEntry a)
maybeEntry <- f a -> DHashMap f MemoEntry -> Maybe (MemoEntry a)
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> DHashMap k v -> Maybe (v a)
DHashMap.lookup f a
key (DHashMap f MemoEntry -> Maybe (MemoEntry a))
-> Task g (DHashMap f MemoEntry) -> Task g (Maybe (MemoEntry a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (DHashMap f MemoEntry) -> Task g (DHashMap f MemoEntry)
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef (DHashMap f MemoEntry)
startedVar
      case Maybe (MemoEntry a)
maybeEntry of
        Maybe (MemoEntry a)
Nothing -> do
          ThreadId
threadId <- Task g ThreadId
forall (m :: * -> *). MonadBase IO m => m ThreadId
myThreadId
          MVar (Maybe a)
valueVar <- Task g (MVar (Maybe a))
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
          MVar (Maybe [ThreadId])
waitVar <- Maybe [ThreadId] -> Task g (MVar (Maybe [ThreadId]))
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar (Maybe [ThreadId] -> Task g (MVar (Maybe [ThreadId])))
-> Maybe [ThreadId] -> Task g (MVar (Maybe [ThreadId]))
forall a b. (a -> b) -> a -> b
$ [ThreadId] -> Maybe [ThreadId]
forall a. a -> Maybe a
Just []
          Task g (Task g a) -> Task g a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Task g (Task g a) -> Task g a) -> Task g (Task g a) -> Task g a
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
-> Task g (Task g a)
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
 -> Task g (Task g a))
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
-> Task g (Task g a)
forall a b. (a -> b) -> a -> b
$ \DHashMap f MemoEntry
started ->
            case (Maybe (MemoEntry a) -> Maybe (MemoEntry a))
-> f a
-> DHashMap f MemoEntry
-> (Maybe (MemoEntry a), DHashMap f MemoEntry)
forall (k :: * -> *) (v :: * -> *) a.
(GEq k, Hashable (Some k)) =>
(Maybe (v a) -> Maybe (v a))
-> k a -> DHashMap k v -> (Maybe (v a), DHashMap k v)
DHashMap.alterLookup (MemoEntry a -> Maybe (MemoEntry a)
forall a. a -> Maybe a
Just (MemoEntry a -> Maybe (MemoEntry a))
-> (Maybe (MemoEntry a) -> MemoEntry a)
-> Maybe (MemoEntry a)
-> Maybe (MemoEntry a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoEntry a -> Maybe (MemoEntry a) -> MemoEntry a
forall a. a -> Maybe a -> a
fromMaybe (ThreadId
-> MVar (Maybe a) -> MVar (Maybe [ThreadId]) -> MemoEntry a
forall a.
ThreadId
-> MVar (Maybe a) -> MVar (Maybe [ThreadId]) -> MemoEntry a
Started ThreadId
threadId MVar (Maybe a)
valueVar MVar (Maybe [ThreadId])
waitVar)) f a
key DHashMap f MemoEntry
started of
              (Maybe (MemoEntry a)
Nothing, DHashMap f MemoEntry
started') ->
                ( DHashMap f MemoEntry
started'
                , (do
                    a
value <- f a -> Task g a
GenRules f g
rules f a
key
                    Task g (Task g ()) -> Task g ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Task g (Task g ()) -> Task g ())
-> Task g (Task g ()) -> Task g ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe [ThreadId])
-> (Maybe [ThreadId] -> Task g (Maybe [ThreadId], Task g ()))
-> Task g (Task g ())
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Maybe [ThreadId])
waitVar ((Maybe [ThreadId] -> Task g (Maybe [ThreadId], Task g ()))
 -> Task g (Task g ()))
-> (Maybe [ThreadId] -> Task g (Maybe [ThreadId], Task g ()))
-> Task g (Task g ())
forall a b. (a -> b) -> a -> b
$ \Maybe [ThreadId]
maybeWaitingThreads -> do
                      case Maybe [ThreadId]
maybeWaitingThreads of
                        Maybe [ThreadId]
Nothing ->
                          String -> Task g (Maybe [ThreadId], Task g ())
forall a. HasCallStack => String -> a
error String
"impossible"

                        Just [ThreadId]
waitingThreads ->
                          (Maybe [ThreadId], Task g ())
-> Task g (Maybe [ThreadId], Task g ())
forall (m :: * -> *) a. Monad m => a -> m a
return
                            ( Maybe [ThreadId]
forall a. Maybe a
Nothing
                            , IORef (HashMap ThreadId ThreadId)
-> (HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
-> Task g ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (HashMap ThreadId ThreadId)
depsVar ((HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
 -> Task g ())
-> (HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
-> Task g ()
forall a b. (a -> b) -> a -> b
$ \HashMap ThreadId ThreadId
deps ->
                              ( (HashMap ThreadId ThreadId
 -> ThreadId -> HashMap ThreadId ThreadId)
-> HashMap ThreadId ThreadId
-> [ThreadId]
-> HashMap ThreadId ThreadId
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((ThreadId
 -> HashMap ThreadId ThreadId -> HashMap ThreadId ThreadId)
-> HashMap ThreadId ThreadId
-> ThreadId
-> HashMap ThreadId ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> HashMap ThreadId ThreadId -> HashMap ThreadId ThreadId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete) HashMap ThreadId ThreadId
deps [ThreadId]
waitingThreads
                              , ()
                              )
                            )
                    IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ()))
-> Task g ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> Task g ())
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ()))
-> Task g ()
forall a b. (a -> b) -> a -> b
$ \DHashMap f MemoEntry
started'' ->
                      (f a -> MemoEntry a -> DHashMap f MemoEntry -> DHashMap f MemoEntry
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> v a -> DHashMap k v -> DHashMap k v
DHashMap.insert f a
key (a -> MemoEntry a
forall a. a -> MemoEntry a
Done a
value) DHashMap f MemoEntry
started'', ())
                    MVar (Maybe a) -> Maybe a -> Task g ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar (Maybe a)
valueVar (Maybe a -> Task g ()) -> Maybe a -> Task g ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
value
                    a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value
                  ) Task g a -> (Cyclic f -> Task g a) -> Task g a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(Cyclic f
e :: Cyclic f) -> do
                    IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ()))
-> Task g ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> Task g ())
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ()))
-> Task g ()
forall a b. (a -> b) -> a -> b
$ \DHashMap f MemoEntry
started'' ->
                      (f a -> DHashMap f MemoEntry -> DHashMap f MemoEntry
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> DHashMap k v -> DHashMap k v
DHashMap.delete f a
key DHashMap f MemoEntry
started'', ())
                    MVar (Maybe a) -> Maybe a -> Task g ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar (Maybe a)
valueVar Maybe a
forall a. Maybe a
Nothing
                    Cyclic f -> Task g a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO Cyclic f
e
                )

              (Just MemoEntry a
entry, DHashMap f MemoEntry
_started') ->
                (DHashMap f MemoEntry
started, MemoEntry a -> Task g a
waitFor MemoEntry a
entry)

        Just MemoEntry a
entry ->
          MemoEntry a -> Task g a
waitFor MemoEntry a
entry
      where
        waitFor :: MemoEntry a -> Task g a
waitFor MemoEntry a
entry =
          case MemoEntry a
entry of
            Started ThreadId
onThread MVar (Maybe a)
valueVar MVar (Maybe [ThreadId])
waitVar -> do
              ThreadId
threadId <- Task g ThreadId
forall (m :: * -> *). MonadBase IO m => m ThreadId
myThreadId
              MVar (Maybe [ThreadId])
-> (Maybe [ThreadId] -> Task g (Maybe [ThreadId])) -> Task g ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Maybe [ThreadId])
waitVar ((Maybe [ThreadId] -> Task g (Maybe [ThreadId])) -> Task g ())
-> (Maybe [ThreadId] -> Task g (Maybe [ThreadId])) -> Task g ()
forall a b. (a -> b) -> a -> b
$ \Maybe [ThreadId]
maybeWaitingThreads -> do
                case Maybe [ThreadId]
maybeWaitingThreads of
                  Maybe [ThreadId]
Nothing ->
                    Maybe [ThreadId] -> Task g (Maybe [ThreadId])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [ThreadId]
maybeWaitingThreads
                  Just [ThreadId]
waitingThreads -> do
                    Task g (Task g ()) -> Task g ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Task g (Task g ()) -> Task g ())
-> Task g (Task g ()) -> Task g ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap ThreadId ThreadId)
-> (HashMap ThreadId ThreadId
    -> (HashMap ThreadId ThreadId, Task g ()))
-> Task g (Task g ())
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (HashMap ThreadId ThreadId)
depsVar ((HashMap ThreadId ThreadId
  -> (HashMap ThreadId ThreadId, Task g ()))
 -> Task g (Task g ()))
-> (HashMap ThreadId ThreadId
    -> (HashMap ThreadId ThreadId, Task g ()))
-> Task g (Task g ())
forall a b. (a -> b) -> a -> b
$ \HashMap ThreadId ThreadId
deps -> do
                      let deps' :: HashMap ThreadId ThreadId
deps' = ThreadId
-> ThreadId
-> HashMap ThreadId ThreadId
-> HashMap ThreadId ThreadId
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert ThreadId
threadId ThreadId
onThread HashMap ThreadId ThreadId
deps
                      if ThreadId -> HashMap ThreadId ThreadId -> Bool
forall t. Hashable t => t -> HashMap t t -> Bool
detectCycle ThreadId
threadId HashMap ThreadId ThreadId
deps' then
                        ( HashMap ThreadId ThreadId
deps
                        , Cyclic f -> Task g ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (Cyclic f -> Task g ()) -> Cyclic f -> Task g ()
forall a b. (a -> b) -> a -> b
$ Some f -> Cyclic f
forall (f :: * -> *). Some f -> Cyclic f
Cyclic (Some f -> Cyclic f) -> Some f -> Cyclic f
forall a b. (a -> b) -> a -> b
$ f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some f a
key
                        )
                      else
                        ( HashMap ThreadId ThreadId
deps'
                        , () -> Task g ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        )
                    Maybe [ThreadId] -> Task g (Maybe [ThreadId])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ThreadId] -> Task g (Maybe [ThreadId]))
-> Maybe [ThreadId] -> Task g (Maybe [ThreadId])
forall a b. (a -> b) -> a -> b
$ [ThreadId] -> Maybe [ThreadId]
forall a. a -> Maybe a
Just ([ThreadId] -> Maybe [ThreadId]) -> [ThreadId] -> Maybe [ThreadId]
forall a b. (a -> b) -> a -> b
$ ThreadId
threadId ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
waitingThreads
              Maybe a
maybeValue <- MVar (Maybe a) -> Task g (Maybe a)
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar (Maybe a)
valueVar
              Task g a -> (a -> Task g a) -> Maybe a -> Task g a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (f a -> Task g a
rules' f a
key) a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
maybeValue

            Done a
value ->
              a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value

    detectCycle :: t -> HashMap t t -> Bool
detectCycle t
threadId HashMap t t
deps =
      t -> Bool
go t
threadId
      where
        go :: t -> Bool
go t
tid =
          case t -> HashMap t t -> Maybe t
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup t
tid HashMap t t
deps of
            Maybe t
Nothing -> Bool
False
            Just t
dep
              | t
dep t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
threadId -> Bool
True
              | Bool
otherwise -> t -> Bool
go t
dep

-- | Remember the results of previous @f@ queries and what their dependencies
-- were then.
--
-- If all dependencies of a 'NonInput' query are the same, reuse the old result.
-- 'Input' queries are not reused.
verifyTraces
  :: forall f dep
  . (Hashable (Some f), GEq f, Has' Eq f dep, Typeable f, GShow f)
  => IORef (Traces f dep)
  -> (forall a. f a -> a -> Task f (dep a))
  -> GenRules (Writer TaskKind f) f
  -> Rules f
verifyTraces :: IORef (Traces f dep)
-> (forall a. f a -> a -> Task f (dep a))
-> GenRules (Writer TaskKind f) f
-> Rules f
verifyTraces IORef (Traces f dep)
tracesVar forall a. f a -> a -> Task f (dep a)
createDependencyRecord GenRules (Writer TaskKind f) f
rules f a
key = do
  Traces f dep
traces <- IORef (Traces f dep) -> Task f (Traces f dep)
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef (Traces f dep)
tracesVar
  Maybe a
maybeValue <- case f a -> Traces f dep -> Maybe (ValueDeps f dep a)
forall (k :: * -> *) a (v :: * -> *).
(GEq k, Hashable (Some k)) =>
k a -> DHashMap k v -> Maybe (v a)
DHashMap.lookup f a
key Traces f dep
traces of
    Maybe (ValueDeps f dep a)
Nothing -> Maybe a -> Task f (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just ValueDeps f dep a
oldValueDeps ->
      Rules f
-> (forall a. f a -> a -> Task f (dep a))
-> ValueDeps f dep a
-> Task f (Maybe a)
forall (m :: * -> *) (f :: * -> *) (dep :: * -> *) a.
(MonadIO m, GEq f, Has' Eq f dep) =>
(forall a'. f a' -> m a')
-> (forall a'. f a' -> a' -> m (dep a'))
-> ValueDeps f dep a
-> m (Maybe a)
Traces.verifyDependencies Rules f
forall (f :: * -> *) (m :: * -> *) a. MonadFetch f m => f a -> m a
fetch forall a. f a -> a -> Task f (dep a)
createDependencyRecord ValueDeps f dep a
oldValueDeps Task f (Maybe a)
-> (Cyclic f -> Task f (Maybe a)) -> Task f (Maybe a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(Cyclic f
_ :: Cyclic f) ->
        Maybe a -> Task f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  case Maybe a
maybeValue of
    Maybe a
Nothing -> do
      ((a
value, TaskKind
taskKind), DHashMap f dep
deps) <- (forall a. f a -> a -> Task f (dep a))
-> Task f (a, TaskKind) -> Task f ((a, TaskKind), DHashMap f dep)
forall (f :: * -> *) (g :: * -> *) a.
(GEq f, Hashable (Some f)) =>
(forall a'. f a' -> a' -> Task f (g a'))
-> Task f a -> Task f (a, DHashMap f g)
trackM forall a. f a -> a -> Task f (dep a)
createDependencyRecord (Task f (a, TaskKind) -> Task f ((a, TaskKind), DHashMap f dep))
-> Task f (a, TaskKind) -> Task f ((a, TaskKind), DHashMap f dep)
forall a b. (a -> b) -> a -> b
$ Writer TaskKind f (a, TaskKind) -> Task f (a, TaskKind)
GenRules (Writer TaskKind f) f
rules (Writer TaskKind f (a, TaskKind) -> Task f (a, TaskKind))
-> Writer TaskKind f (a, TaskKind) -> Task f (a, TaskKind)
forall a b. (a -> b) -> a -> b
$ f a -> Writer TaskKind f (a, TaskKind)
forall (f :: * -> *) a w. f a -> Writer w f (a, w)
Writer f a
key
      case TaskKind
taskKind of
        TaskKind
Input ->
          () -> Task f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        TaskKind
NonInput ->
          IORef (Traces f dep)
-> (Traces f dep -> (Traces f dep, ())) -> Task f ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (Traces f dep)
tracesVar
            ((Traces f dep -> (Traces f dep, ())) -> Task f ())
-> (Traces f dep -> (Traces f dep, ())) -> Task f ()
forall a b. (a -> b) -> a -> b
$ (, ()) (Traces f dep -> (Traces f dep, ()))
-> (Traces f dep -> Traces f dep)
-> Traces f dep
-> (Traces f dep, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a -> DHashMap f dep -> Traces f dep -> Traces f dep
forall (f :: * -> *) a (g :: * -> *).
(GEq f, Hashable (Some f)) =>
f a -> a -> DHashMap f g -> Traces f g -> Traces f g
Traces.record f a
key a
value DHashMap f dep
deps
      a -> Task f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value
    Just a
value -> a -> Task f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value

data TaskKind
  = Input -- ^ Used for tasks whose results can change independently of their fetched dependencies, i.e. inputs.
  | NonInput -- ^ Used for task whose results only depend on fetched dependencies.

-- | A query that returns a @w@ alongside the ordinary @a@.
data Writer w f a where
  Writer :: f a -> Writer w f (a, w)

instance GEq f => GEq (Writer w f) where
  geq :: Writer w f a -> Writer w f b -> Maybe (a :~: b)
geq (Writer f a
f) (Writer f a
g) = case f a -> f a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
geq f a
f f a
g of
    Maybe (a :~: a)
Nothing -> Maybe (a :~: b)
forall a. Maybe a
Nothing
    Just a :~: a
Refl -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl

instance GCompare f => GCompare (Writer w f) where
  gcompare :: Writer w f a -> Writer w f b -> GOrdering a b
gcompare (Writer f a
f) (Writer f a
g) = case f a -> f a -> GOrdering a a
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare f a
f f a
g of
    GOrdering a a
GLT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GLT
    GOrdering a a
GEQ -> GOrdering a b
forall k (a :: k). GOrdering a a
GEQ
    GOrdering a a
GGT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GGT

-- | @'writer' write rules@ runs @write w@ each time a @w@ is returned from a
-- rule in @rules@.
writer
  :: forall f w g
  . (forall a. f a -> w -> Task g ())
  -> GenRules (Writer w f) g
  -> GenRules f g
writer :: (forall a. f a -> w -> Task g ())
-> GenRules (Writer w f) g -> GenRules f g
writer forall a. f a -> w -> Task g ()
write GenRules (Writer w f) g
rules f a
key = do
  (a
res, w
w) <- Writer w f (a, w) -> Task g (a, w)
GenRules (Writer w f) g
rules (Writer w f (a, w) -> Task g (a, w))
-> Writer w f (a, w) -> Task g (a, w)
forall a b. (a -> b) -> a -> b
$ f a -> Writer w f (a, w)
forall (f :: * -> *) a w. f a -> Writer w f (a, w)
Writer f a
key
  f a -> w -> Task g ()
forall a. f a -> w -> Task g ()
write f a
key w
w
  a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | @'traceFetch' before after rules@ runs @before q@ before a query is
-- performed from @rules@, and @after q result@ every time a query returns with
-- result @result@. 
traceFetch
  :: (forall a. f a -> Task g ())
  -> (forall a. f a -> a -> Task g ())
  -> GenRules f g
  -> GenRules f g
traceFetch :: (forall a. f a -> Task g ())
-> (forall a. f a -> a -> Task g ())
-> GenRules f g
-> GenRules f g
traceFetch forall a. f a -> Task g ()
before forall a. f a -> a -> Task g ()
after GenRules f g
rules f a
key = do
  f a -> Task g ()
forall a. f a -> Task g ()
before f a
key
  a
result <- f a -> Task g a
GenRules f g
rules f a
key
  f a -> a -> Task g ()
forall a. f a -> a -> Task g ()
after f a
key a
result
  a -> Task g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

type ReverseDependencies f = HashMap (Some f) (HashSet (Some f))

-- | Write reverse dependencies to the 'IORef.
trackReverseDependencies
  :: (GEq f, Hashable (Some f))
  => IORef (ReverseDependencies f)
  -> Rules f
  -> Rules f
trackReverseDependencies :: IORef (ReverseDependencies f) -> Rules f -> Rules f
trackReverseDependencies IORef (ReverseDependencies f)
reverseDepsVar Rules f
rules f a
key = do
  (a
res, DHashMap f (Const ())
deps) <- (forall a'. f a' -> a' -> Const () a')
-> Task f a -> Task f (a, DHashMap f (Const ()))
forall (f :: * -> *) (g :: * -> *) a.
(GEq f, Hashable (Some f)) =>
(forall a'. f a' -> a' -> g a')
-> Task f a -> Task f (a, DHashMap f g)
track (\f a'
_ a'
_ -> () -> Const () a'
forall k a (b :: k). a -> Const a b
Const ()) (Task f a -> Task f (a, DHashMap f (Const ())))
-> Task f a -> Task f (a, DHashMap f (Const ()))
forall a b. (a -> b) -> a -> b
$ f a -> Task f a
Rules f
rules f a
key
  Bool -> Task f () -> Task f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DHashMap f (Const ()) -> Bool
forall (k :: * -> *) (v :: * -> *). DHashMap k v -> Bool
DHashMap.null DHashMap f (Const ())
deps) (Task f () -> Task f ()) -> Task f () -> Task f ()
forall a b. (a -> b) -> a -> b
$ do
    let newReverseDeps :: ReverseDependencies f
newReverseDeps = (HashSet (Some f) -> HashSet (Some f) -> HashSet (Some f))
-> [(Some f, HashSet (Some f))] -> ReverseDependencies f
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith HashSet (Some f) -> HashSet (Some f) -> HashSet (Some f)
forall a. Semigroup a => a -> a -> a
(<>)
          [ (f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some f a
depKey, Some f -> HashSet (Some f)
forall a. Hashable a => a -> HashSet a
HashSet.singleton (Some f -> HashSet (Some f)) -> Some f -> HashSet (Some f)
forall a b. (a -> b) -> a -> b
$ f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some f a
key)
          | f a
depKey :=> Const () <- DHashMap f (Const ()) -> [DSum f (Const ())]
forall (k :: * -> *) (v :: * -> *). DHashMap k v -> [DSum k v]
DHashMap.toList DHashMap f (Const ())
deps
          ]
    IORef (ReverseDependencies f)
-> (ReverseDependencies f -> (ReverseDependencies f, ()))
-> Task f ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (ReverseDependencies f)
reverseDepsVar ((ReverseDependencies f -> (ReverseDependencies f, ()))
 -> Task f ())
-> (ReverseDependencies f -> (ReverseDependencies f, ()))
-> Task f ()
forall a b. (a -> b) -> a -> b
$ (, ()) (ReverseDependencies f -> (ReverseDependencies f, ()))
-> (ReverseDependencies f -> ReverseDependencies f)
-> ReverseDependencies f
-> (ReverseDependencies f, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashSet (Some f) -> HashSet (Some f) -> HashSet (Some f))
-> ReverseDependencies f
-> ReverseDependencies f
-> ReverseDependencies f
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith HashSet (Some f) -> HashSet (Some f) -> HashSet (Some f)
forall a. Semigroup a => a -> a -> a
(<>) ReverseDependencies f
newReverseDeps
  a -> Task f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | @'reachableReverseDependencies' key@ returns all keys reachable, by
-- reverse dependency, from @key@ from the input 'DHashMap'. It also returns the
-- reverse dependency map with those same keys removed.
reachableReverseDependencies
  :: (GEq f, Hashable (Some f))
  => f a
  -> ReverseDependencies f
  -> (DHashMap f (Const ()), ReverseDependencies f)
reachableReverseDependencies :: f a
-> ReverseDependencies f
-> (DHashMap f (Const ()), ReverseDependencies f)
reachableReverseDependencies f a
key ReverseDependencies f
reverseDeps =
  ((DHashMap f (Const ()), ReverseDependencies f)
 -> Some f -> (DHashMap f (Const ()), ReverseDependencies f))
-> (DHashMap f (Const ()), ReverseDependencies f)
-> [Some f]
-> (DHashMap f (Const ()), ReverseDependencies f)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    (\(DHashMap f (Const ())
m', ReverseDependencies f
reverseDeps') (Some f a
key') -> (DHashMap f (Const ()) -> DHashMap f (Const ()))
-> (DHashMap f (Const ()), ReverseDependencies f)
-> (DHashMap f (Const ()), ReverseDependencies f)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (DHashMap f (Const ())
-> DHashMap f (Const ()) -> DHashMap f (Const ())
forall a. Semigroup a => a -> a -> a
<> DHashMap f (Const ())
m') ((DHashMap f (Const ()), ReverseDependencies f)
 -> (DHashMap f (Const ()), ReverseDependencies f))
-> (DHashMap f (Const ()), ReverseDependencies f)
-> (DHashMap f (Const ()), ReverseDependencies f)
forall a b. (a -> b) -> a -> b
$ f a
-> ReverseDependencies f
-> (DHashMap f (Const ()), ReverseDependencies f)
forall (f :: * -> *) a.
(GEq f, Hashable (Some f)) =>
f a
-> ReverseDependencies f
-> (DHashMap f (Const ()), ReverseDependencies f)
reachableReverseDependencies f a
key' ReverseDependencies f
reverseDeps')
    (f a -> Const () a -> DHashMap f (Const ())
forall (k :: * -> *) a (v :: * -> *).
Hashable (Some k) =>
k a -> v a -> DHashMap k v
DHashMap.singleton f a
key (Const () a -> DHashMap f (Const ()))
-> Const () a -> DHashMap f (Const ())
forall a b. (a -> b) -> a -> b
$ () -> Const () a
forall k a (b :: k). a -> Const a b
Const (), Some f -> ReverseDependencies f -> ReverseDependencies f
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete (f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some f a
key) ReverseDependencies f
reverseDeps)
    (HashSet (Some f) -> [Some f]
forall a. HashSet a -> [a]
HashSet.toList (HashSet (Some f) -> [Some f]) -> HashSet (Some f) -> [Some f]
forall a b. (a -> b) -> a -> b
$ HashSet (Some f)
-> Some f -> ReverseDependencies f -> HashSet (Some f)
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault HashSet (Some f)
forall a. Monoid a => a
mempty (f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some f a
key) ReverseDependencies f
reverseDeps)