{-# 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
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 <- 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)
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
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
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
| 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
]
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
:: (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)