{-# 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
import Control.Exception.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.IORef
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
type Rules f = GenRules f f
type GenRules f g = forall a. f a -> Task g a
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)
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)
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
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_
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
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
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 <- IO (IORef (DHashMap f g)) -> Task f (IORef (DHashMap f g))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (DHashMap f g)) -> Task f (IORef (DHashMap f g)))
-> IO (IORef (DHashMap f g)) -> Task f (IORef (DHashMap f g))
forall a b. (a -> b) -> a -> b
$ DHashMap f g -> IO (IORef (DHashMap f g))
forall a. a -> IO (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
IO () -> Task f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Task f ()) -> IO () -> Task f ()
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f g)
-> (DHashMap f g -> (DHashMap f g, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (DHashMap f g)
depsVar ((DHashMap f g -> (DHashMap f g, ())) -> IO ())
-> (DHashMap f g -> (DHashMap f g, ())) -> IO ()
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 <- IO (DHashMap f g) -> Task f (DHashMap f g)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DHashMap f g) -> Task f (DHashMap f g))
-> IO (DHashMap f g) -> Task f (DHashMap f g)
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f g) -> IO (DHashMap f g)
forall a. IORef a -> IO 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)
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
<$> IO (DHashMap f MVar) -> Task g (DHashMap f MVar)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (DHashMap f MVar) -> IO (DHashMap f MVar)
forall a. IORef a -> IO a
readIORef IORef (DHashMap f MVar)
startedVar)
case Maybe (MVar a)
maybeValueVar of
Maybe (MVar a)
Nothing -> do
MVar a
valueVar <- IO (MVar a) -> Task g (MVar a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar a)
forall a. IO (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
$ IO (Task g a) -> Task g (Task g a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Task g a) -> Task g (Task g a))
-> IO (Task g a) -> Task g (Task g a)
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f MVar)
-> (DHashMap f MVar -> (DHashMap f MVar, Task g a))
-> IO (Task g a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (DHashMap f MVar)
startedVar ((DHashMap f MVar -> (DHashMap f MVar, Task g a)) -> IO (Task g a))
-> (DHashMap f MVar -> (DHashMap f MVar, Task g a))
-> IO (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
IO () -> Task g ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Task g ()) -> IO () -> Task g ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
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, IO a -> Task g a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Task g a) -> IO a -> Task g a
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
valueVar')
Just MVar a
valueVar ->
IO a -> Task g a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Task g a) -> IO a -> Task g a
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO 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))
| Done !a
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
<$> IO (DHashMap f MemoEntry) -> Task g (DHashMap f MemoEntry)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (DHashMap f MemoEntry) -> IO (DHashMap f MemoEntry)
forall a. IORef a -> IO a
readIORef IORef (DHashMap f MemoEntry)
startedVar)
case Maybe (MemoEntry a)
maybeEntry of
Maybe (MemoEntry a)
Nothing -> do
ThreadId
threadId <- IO ThreadId -> Task g ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
MVar (Maybe a)
valueVar <- IO (MVar (Maybe a)) -> Task g (MVar (Maybe a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe a))
forall a. IO (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
$ IO (Task g a) -> Task g (Task g a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Task g a) -> Task g (Task g a))
-> IO (Task g a) -> Task g (Task g a)
forall a b. (a -> b) -> a -> b
$ IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
-> IO (Task g a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
-> IO (Task g a))
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, Task g a))
-> IO (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) -> MemoEntry a
forall a. ThreadId -> MVar (Maybe a) -> MemoEntry a
Started ThreadId
threadId MVar (Maybe a)
valueVar)) 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
IO a -> Task g a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Task g a) -> IO a -> Task g a
forall a b. (a -> b) -> a -> b
$ do
IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ())
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ()
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 -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
valueVar (Maybe a -> IO ()) -> Maybe a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
value
a -> IO 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) ->
(IO a -> Task g a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Task g a) -> IO a -> Task g a
forall a b. (a -> b) -> a -> b
$ do
IORef (DHashMap f MemoEntry)
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (DHashMap f MemoEntry)
startedVar ((DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ())
-> (DHashMap f MemoEntry -> (DHashMap f MemoEntry, ())) -> IO ()
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 -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
valueVar Maybe a
forall a. Maybe a
Nothing
Cyclic f -> IO 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 -> do
ThreadId
threadId <- IO ThreadId -> Task g ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
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
$ IO (Task g a) -> Task g (Task g a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Task g a) -> Task g (Task g a))
-> IO (Task g a) -> Task g (Task g a)
forall a b. (a -> b) -> a -> b
$ IORef (HashMap ThreadId ThreadId)
-> (HashMap ThreadId ThreadId
-> (HashMap ThreadId ThreadId, Task g a))
-> IO (Task g a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap ThreadId ThreadId)
depsVar ((HashMap ThreadId ThreadId
-> (HashMap ThreadId ThreadId, Task g a))
-> IO (Task g a))
-> (HashMap ThreadId ThreadId
-> (HashMap ThreadId ThreadId, Task g a))
-> IO (Task g a)
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. (Eq t, Hashable t) => t -> HashMap t t -> Bool
detectCycle ThreadId
threadId HashMap ThreadId ThreadId
deps' then
( HashMap ThreadId ThreadId
deps
, Cyclic f -> Task g a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (Cyclic f -> Task g a) -> Cyclic f -> Task g a
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'
, do
Maybe a
maybeValue <- IO (Maybe a) -> Task g (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> Task g (Maybe a))
-> IO (Maybe a) -> Task g (Maybe a)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
valueVar
IO () -> Task g ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Task g ()) -> IO () -> Task g ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap ThreadId ThreadId)
-> (HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap ThreadId ThreadId)
depsVar ((HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
-> IO ())
-> (HashMap ThreadId ThreadId -> (HashMap ThreadId ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap ThreadId ThreadId
deps'' -> (ThreadId -> HashMap ThreadId ThreadId -> HashMap ThreadId ThreadId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete ThreadId
threadId HashMap ThreadId ThreadId
deps'', ())
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
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 <- IO (Traces f dep) -> Task f (Traces f dep)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Traces f dep) -> Task f (Traces f dep))
-> IO (Traces f dep) -> Task f (Traces f dep)
forall a b. (a -> b) -> a -> b
$ IORef (Traces f dep) -> IO (Traces f dep)
forall a. IORef a -> IO 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 ->
IO () -> Task f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Task f ()) -> IO () -> Task f ()
forall a b. (a -> b) -> a -> b
$ IORef (Traces f dep)
-> (Traces f dep -> (Traces f dep, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Traces f dep)
tracesVar
((Traces f dep -> (Traces f dep, ())) -> IO ())
-> (Traces f dep -> (Traces f dep, ())) -> IO ()
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
| NonInput
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
:: 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
:: (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))
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
]
IO () -> Task f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Task f ()) -> IO () -> Task f ()
forall a b. (a -> b) -> a -> b
$ IORef (ReverseDependencies f)
-> (ReverseDependencies f -> (ReverseDependencies f, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (ReverseDependencies f)
reverseDepsVar ((ReverseDependencies f -> (ReverseDependencies f, ())) -> IO ())
-> (ReverseDependencies f -> (ReverseDependencies f, ())) -> IO ()
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
:: (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)