-- We deliberately want to ensure the function we add to the rule database
-- has the constraints we need on it when we get it out.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

{-# LANGUAGE CPP                #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TypeFamilies       #-}

module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where

import           Prelude                              hiding (unzip)

import           Control.Concurrent.Async
import           Control.Concurrent.Extra
import           Control.Concurrent.STM.Stats         (STM, atomically,
                                                       atomicallyNamed,
                                                       modifyTVar', newTVarIO,
                                                       readTVarIO)
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class               (MonadIO (liftIO))
import           Control.Monad.Trans.Class            (lift)
import           Control.Monad.Trans.Reader
import qualified Control.Monad.Trans.State.Strict     as State
import           Data.Dynamic
import           Data.Either
import           Data.Foldable                        (for_, traverse_)
import           Data.IORef.Extra
import           Data.Maybe
import           Data.Traversable                     (for)
import           Data.Tuple.Extra
import           Debug.Trace                          (traceM)
import           Development.IDE.Graph.Classes
import           Development.IDE.Graph.Internal.Key
import           Development.IDE.Graph.Internal.Rules
import           Development.IDE.Graph.Internal.Types
import qualified Focus
import qualified ListT
import qualified StmContainers.Map                    as SMap
import           System.IO.Unsafe
import           System.Time.Extra                    (duration, sleep)

#if MIN_VERSION_base(4,19,0)
import           Data.Functor                         (unzip)
#else
import           Data.List.NonEmpty                   (unzip)
#endif


newDatabase :: Dynamic -> TheRules -> IO Database
newDatabase :: Dynamic -> TheRules -> IO Database
newDatabase Dynamic
databaseExtra TheRules
databaseRules = do
    TVar Step
databaseStep <- Step -> IO (TVar Step)
forall a. a -> IO (TVar a)
newTVarIO (Step -> IO (TVar Step)) -> Step -> IO (TVar Step)
forall a b. (a -> b) -> a -> b
$ Int -> Step
Step Int
0
    Map Key KeyDetails
databaseValues <- STM (Map Key KeyDetails) -> IO (Map Key KeyDetails)
forall a. STM a -> IO a
atomically STM (Map Key KeyDetails)
forall key value. STM (Map key value)
SMap.new
    Database -> IO Database
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Database{TheRules
TVar Step
Dynamic
Map Key KeyDetails
databaseExtra :: Dynamic
databaseRules :: TheRules
databaseStep :: TVar Step
databaseValues :: Map Key KeyDetails
databaseExtra :: Dynamic
databaseRules :: TheRules
databaseStep :: TVar Step
databaseValues :: Map Key KeyDetails
..}

-- | Increment the step and mark dirty.
--   Assumes that the database is not running a build
incDatabase :: Database -> Maybe [Key] -> IO ()
-- only some keys are dirty
incDatabase :: Database -> Maybe [Key] -> IO ()
incDatabase Database
db (Just [Key]
kk) = do
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Step -> (Step -> Step) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'  (Database -> TVar Step
databaseStep Database
db) ((Step -> Step) -> STM ()) -> (Step -> Step) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(Step Int
i) -> Int -> Step
Step (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    KeySet
transitiveDirtyKeys <- Database -> [Key] -> IO KeySet
forall (t :: * -> *). Foldable t => Database -> t Key -> IO KeySet
transitiveDirtySet Database
db [Key]
kk
    [Key] -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (KeySet -> [Key]
toListKeySet KeySet
transitiveDirtyKeys) ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
k ->
        -- Updating all the keys atomically is not necessary
        -- since we assume that no build is mutating the db.
        -- Therefore run one transaction per key to minimise contention.
        String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus Focus KeyDetails STM ()
forall (m :: * -> *). Monad m => Focus KeyDetails m ()
updateDirty Key
k (Database -> Map Key KeyDetails
databaseValues Database
db)

-- all keys are dirty
incDatabase Database
db Maybe [Key]
Nothing = do
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Step -> (Step -> Step) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'  (Database -> TVar Step
databaseStep Database
db) ((Step -> Step) -> STM ()) -> (Step -> Step) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(Step Int
i) -> Int -> Step
Step (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    let list :: ListT STM (Key, KeyDetails)
list = Map Key KeyDetails -> ListT STM (Key, KeyDetails)
forall key value. Map key value -> ListT STM (key, value)
SMap.listT (Database -> Map Key KeyDetails
databaseValues Database
db)
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase - all " (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ (((Key, KeyDetails) -> STM ())
 -> ListT STM (Key, KeyDetails) -> STM ())
-> ListT STM (Key, KeyDetails)
-> ((Key, KeyDetails) -> STM ())
-> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Key, KeyDetails) -> STM ())
-> ListT STM (Key, KeyDetails) -> STM ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ListT m a -> m ()
ListT.traverse_ ListT STM (Key, KeyDetails)
list (((Key, KeyDetails) -> STM ()) -> STM ())
-> ((Key, KeyDetails) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(Key
k,KeyDetails
_) ->
        Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus Focus KeyDetails STM ()
forall (m :: * -> *). Monad m => Focus KeyDetails m ()
updateDirty Key
k (Database -> Map Key KeyDetails
databaseValues Database
db)

updateDirty :: Monad m => Focus.Focus KeyDetails m ()
updateDirty :: forall (m :: * -> *). Monad m => Focus KeyDetails m ()
updateDirty = (KeyDetails -> KeyDetails) -> Focus KeyDetails m ()
forall (m :: * -> *) a. Monad m => (a -> a) -> Focus a m ()
Focus.adjust ((KeyDetails -> KeyDetails) -> Focus KeyDetails m ())
-> (KeyDetails -> KeyDetails) -> Focus KeyDetails m ()
forall a b. (a -> b) -> a -> b
$ \(KeyDetails Status
status KeySet
rdeps) ->
            let status' :: Status
status'
                  | Running Step
_ IO ()
_ Result
_ Maybe Result
x <- Status
status = Maybe Result -> Status
Dirty Maybe Result
x
                  | Clean Result
x <- Status
status = Maybe Result -> Status
Dirty (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
x)
                  | Bool
otherwise = Status
status
            in Status -> KeySet -> KeyDetails
KeyDetails Status
status' KeySet
rdeps
-- | Unwrap and build a list of keys in parallel
build
    :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
    => Database -> Stack -> f key -> IO (f Key, f value)
-- build _ st k | traceShow ("build", st, k) False = undefined
build :: forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, Typeable key, Show key,
 Hashable key, Eq key, Typeable value) =>
Database -> Stack -> f key -> IO (f Key, f value)
build Database
db Stack
stack f key
keys = do
    f (Key, Result)
built <- AIO (f (Key, Result)) -> IO (f (Key, Result))
forall a. AIO a -> IO a
runAIO (AIO (f (Key, Result)) -> IO (f (Key, Result)))
-> AIO (f (Key, Result)) -> IO (f (Key, Result))
forall a b. (a -> b) -> a -> b
$ do
        Either (f (Key, Result)) (IO (f (Key, Result)))
built <- Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder Database
db Stack
stack ((key -> Key) -> f key -> f Key
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap key -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey f key
keys)
        case Either (f (Key, Result)) (IO (f (Key, Result)))
built of
          Left f (Key, Result)
clean  -> f (Key, Result) -> AIO (f (Key, Result))
forall a. a -> AIO a
forall (m :: * -> *) a. Monad m => a -> m a
return f (Key, Result)
clean
          Right IO (f (Key, Result))
dirty -> IO (f (Key, Result)) -> AIO (f (Key, Result))
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (f (Key, Result))
dirty
    let (f Key
ids, f Result
vs) = f (Key, Result) -> (f Key, f Result)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip f (Key, Result)
built
    (f Key, f value) -> IO (f Key, f value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f Key
ids, (Result -> value) -> f Result -> f value
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> value
asV (Value -> value) -> (Result -> Value) -> Result -> value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Value
resultValue) f Result
vs)
    where
        asV :: Value -> value
        asV :: Value -> value
asV (Value Dynamic
x) = Dynamic -> value
forall a. Typeable a => Dynamic -> a
unwrapDynamic Dynamic
x

-- | Build a list of keys and return their results.
--  If none of the keys are dirty, we can return the results immediately.
--  Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock.
builder
    :: Traversable f => Database -> Stack -> f Key -> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
-- builder _ st kk | traceShow ("builder", st,kk) False = undefined
builder :: forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder db :: Database
db@Database{TheRules
TVar Step
Dynamic
Map Key KeyDetails
databaseExtra :: Database -> Dynamic
databaseRules :: Database -> TheRules
databaseStep :: Database -> TVar Step
databaseValues :: Database -> Map Key KeyDetails
databaseExtra :: Dynamic
databaseRules :: TheRules
databaseStep :: TVar Step
databaseValues :: Map Key KeyDetails
..} Stack
stack f Key
keys = (RunInIO -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall b. (RunInIO -> AIO b) -> AIO b
withRunInIO ((RunInIO -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
 -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
-> (RunInIO
    -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall a b. (a -> b) -> a -> b
$ \(RunInIO forall a. AIO a -> IO a
run) -> do
    -- Things that I need to force before my results are ready
    TVar [Wait]
toForce <- IO (TVar [Wait]) -> AIO (TVar [Wait])
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar [Wait]) -> AIO (TVar [Wait]))
-> IO (TVar [Wait]) -> AIO (TVar [Wait])
forall a b. (a -> b) -> a -> b
$ [Wait] -> IO (TVar [Wait])
forall a. a -> IO (TVar a)
newTVarIO []
    Step
current <- IO Step -> AIO Step
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Step -> AIO Step) -> IO Step -> AIO Step
forall a b. (a -> b) -> a -> b
$ TVar Step -> IO Step
forall a. TVar a -> IO a
readTVarIO TVar Step
databaseStep
    f (Key, Result)
results <- IO (f (Key, Result)) -> AIO (f (Key, Result))
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (f (Key, Result)) -> AIO (f (Key, Result)))
-> IO (f (Key, Result)) -> AIO (f (Key, Result))
forall a b. (a -> b) -> a -> b
$ f Key -> (Key -> IO (Key, Result)) -> IO (f (Key, Result))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f Key
keys ((Key -> IO (Key, Result)) -> IO (f (Key, Result)))
-> (Key -> IO (Key, Result)) -> IO (f (Key, Result))
forall a b. (a -> b) -> a -> b
$ \Key
id ->
        -- Updating the status of all the dependencies atomically is not necessary.
        -- Therefore, run one transaction per dep. to avoid contention
        String -> STM (Key, Result) -> IO (Key, Result)
forall a. String -> STM a -> IO a
atomicallyNamed String
"builder" (STM (Key, Result) -> IO (Key, Result))
-> STM (Key, Result) -> IO (Key, Result)
forall a b. (a -> b) -> a -> b
$ do
            -- Spawn the id if needed
            Maybe KeyDetails
status <- Key -> Map Key KeyDetails -> STM (Maybe KeyDetails)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
SMap.lookup Key
id Map Key KeyDetails
databaseValues
            Result
val <- case Step -> Status -> Status
viewDirty Step
current (Status -> Status) -> Status -> Status
forall a b. (a -> b) -> a -> b
$ Status -> (KeyDetails -> Status) -> Maybe KeyDetails -> Status
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Result -> Status
Dirty Maybe Result
forall a. Maybe a
Nothing) KeyDetails -> Status
keyStatus Maybe KeyDetails
status of
                Clean Result
r -> Result -> STM Result
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
                Running Step
_ IO ()
force Result
val Maybe Result
_
                  | Key -> Stack -> Bool
memberStack Key
id Stack
stack -> StackException -> STM Result
forall a e. Exception e => e -> a
throw (StackException -> STM Result) -> StackException -> STM Result
forall a b. (a -> b) -> a -> b
$ Stack -> StackException
StackException Stack
stack
                  | Bool
otherwise -> do
                    TVar [Wait] -> ([Wait] -> [Wait]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Wait]
toForce (IO () -> Wait
Wait IO ()
force :)
                    Result -> STM Result
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val
                Dirty Maybe Result
s -> do
                    let act :: IO (IO Result)
act = AIO (IO Result) -> IO (IO Result)
forall a. AIO a -> IO a
run (Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
refresh Database
db Stack
stack Key
id Maybe Result
s)
                        (IO ()
force, Result
val) = IO Result -> (IO (), Result)
forall a. IO a -> (IO (), a)
splitIO (IO (IO Result) -> IO Result
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join IO (IO Result)
act)
                    Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus (Status -> Focus KeyDetails STM ()
forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus (Status -> Focus KeyDetails STM ())
-> Status -> Focus KeyDetails STM ()
forall a b. (a -> b) -> a -> b
$ Step -> IO () -> Result -> Maybe Result -> Status
Running Step
current IO ()
force Result
val Maybe Result
s) Key
id Map Key KeyDetails
databaseValues
                    TVar [Wait] -> ([Wait] -> [Wait]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Wait]
toForce (IO () -> Wait
Spawn IO ()
force:)
                    Result -> STM Result
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val

            (Key, Result) -> STM (Key, Result)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key
id, Result
val)

    [Wait]
toForceList <- IO [Wait] -> AIO [Wait]
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Wait] -> AIO [Wait]) -> IO [Wait] -> AIO [Wait]
forall a b. (a -> b) -> a -> b
$ TVar [Wait] -> IO [Wait]
forall a. TVar a -> IO a
readTVarIO TVar [Wait]
toForce
    let waitAll :: IO ()
waitAll = AIO () -> IO ()
forall a. AIO a -> IO a
run (AIO () -> IO ()) -> AIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Wait] -> AIO ()
waitConcurrently_ [Wait]
toForceList
    case [Wait]
toForceList of
        [] -> Either (f (Key, Result)) (IO (f (Key, Result)))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall a. a -> AIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (f (Key, Result)) (IO (f (Key, Result)))
 -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
-> Either (f (Key, Result)) (IO (f (Key, Result)))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall a b. (a -> b) -> a -> b
$ f (Key, Result) -> Either (f (Key, Result)) (IO (f (Key, Result)))
forall a b. a -> Either a b
Left f (Key, Result)
results
        [Wait]
_ -> Either (f (Key, Result)) (IO (f (Key, Result)))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall a. a -> AIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (f (Key, Result)) (IO (f (Key, Result)))
 -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))))
-> Either (f (Key, Result)) (IO (f (Key, Result)))
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
forall a b. (a -> b) -> a -> b
$ IO (f (Key, Result))
-> Either (f (Key, Result)) (IO (f (Key, Result)))
forall a b. b -> Either a b
Right (IO (f (Key, Result))
 -> Either (f (Key, Result)) (IO (f (Key, Result))))
-> IO (f (Key, Result))
-> Either (f (Key, Result)) (IO (f (Key, Result)))
forall a b. (a -> b) -> a -> b
$ do
                IO ()
waitAll
                f (Key, Result) -> IO (f (Key, Result))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f (Key, Result)
results


-- | isDirty
-- only dirty when it's build time is older than the changed time of one of its dependencies
isDirty :: Foldable t => Result -> t (a, Result) -> Bool
isDirty :: forall (t :: * -> *) a.
Foldable t =>
Result -> t (a, Result) -> Bool
isDirty Result
me = ((a, Result) -> Bool) -> t (a, Result) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
_,Result
dep) -> Result -> Step
resultBuilt Result
me Step -> Step -> Bool
forall a. Ord a => a -> a -> Bool
< Result -> Step
resultChanged Result
dep)

-- | Refresh dependencies for a key and compute the key:
-- The refresh the deps linearly(last computed order of the deps for the key).
-- If any of the deps is dirty in the process, we jump to the actual computation of the key
-- and shortcut the refreshing of the rest of the deps.
-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
--   This assumes that the implementation will be a lookup
-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
refreshDeps :: KeySet
-> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
refreshDeps KeySet
visited Database
db Stack
stack Key
key Result
result = \case
    -- no more deps to refresh
    [] -> IO Result -> AIO Result
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesSame (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
result)
    (KeySet
dep:[KeySet]
deps) -> do
        let newVisited :: KeySet
newVisited = KeySet
dep KeySet -> KeySet -> KeySet
forall a. Semigroup a => a -> a -> a
<> KeySet
visited
        Either [(Key, Result)] (IO [(Key, Result)])
res <- Database
-> Stack
-> [Key]
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder Database
db Stack
stack (KeySet -> [Key]
toListKeySet (KeySet
dep KeySet -> KeySet -> KeySet
`differenceKeySet` KeySet
visited))
        case Either [(Key, Result)] (IO [(Key, Result)])
res of
            Left [(Key, Result)]
res ->  if Result -> [(Key, Result)] -> Bool
forall (t :: * -> *) a.
Foldable t =>
Result -> t (a, Result) -> Bool
isDirty Result
result [(Key, Result)]
res
                -- restart the computation if any of the deps are dirty
                then IO Result -> AIO Result
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesChanged (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
result)
                -- else kick the rest of the deps
                else KeySet
-> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
refreshDeps KeySet
newVisited Database
db Stack
stack Key
key Result
result [KeySet]
deps
            Right IO [(Key, Result)]
iores -> do
                [(Key, Result)]
res <- IO [(Key, Result)] -> AIO [(Key, Result)]
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(Key, Result)]
iores
                if Result -> [(Key, Result)] -> Bool
forall (t :: * -> *) a.
Foldable t =>
Result -> t (a, Result) -> Bool
isDirty Result
result [(Key, Result)]
res
                    then IO Result -> AIO Result
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesChanged (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
result)
                    else KeySet
-> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
refreshDeps KeySet
newVisited Database
db Stack
stack Key
key Result
result [KeySet]
deps

-- | Refresh a key:
refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
refresh Database
db Stack
stack Key
key Maybe Result
result = case (Key -> Stack -> Either StackException Stack
addStack Key
key Stack
stack, Maybe Result
result) of
    (Left StackException
e, Maybe Result
_) -> StackException -> AIO (IO Result)
forall a e. Exception e => e -> a
throw StackException
e
    (Right Stack
stack, Just me :: Result
me@Result{resultDeps :: Result -> ResultDeps
resultDeps = ResultDeps [KeySet]
deps}) -> AIO Result -> AIO (IO Result)
forall a. AIO a -> AIO (IO a)
asyncWithCleanUp (AIO Result -> AIO (IO Result)) -> AIO Result -> AIO (IO Result)
forall a b. (a -> b) -> a -> b
$ KeySet
-> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
refreshDeps KeySet
forall a. Monoid a => a
mempty Database
db Stack
stack Key
key Result
me ([KeySet] -> [KeySet]
forall a. [a] -> [a]
reverse [KeySet]
deps)
    (Right Stack
stack, Maybe Result
_) ->
        AIO Result -> AIO (IO Result)
forall a. AIO a -> AIO (IO a)
asyncWithCleanUp (AIO Result -> AIO (IO Result)) -> AIO Result -> AIO (IO Result)
forall a b. (a -> b) -> a -> b
$ IO Result -> AIO Result
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesChanged Maybe Result
result

-- | Compute a key.
compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
-- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined
compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute db :: Database
db@Database{TheRules
TVar Step
Dynamic
Map Key KeyDetails
databaseExtra :: Database -> Dynamic
databaseRules :: Database -> TheRules
databaseStep :: Database -> TVar Step
databaseValues :: Database -> Map Key KeyDetails
databaseExtra :: Dynamic
databaseRules :: TheRules
databaseStep :: TVar Step
databaseValues :: Map Key KeyDetails
..} Stack
stack Key
key RunMode
mode Maybe Result
result = do
    let act :: Action (RunResult Value)
act = TheRules
-> Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
runRule TheRules
databaseRules Key
key ((Result -> ByteString) -> Maybe Result -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> ByteString
resultData Maybe Result
result) RunMode
mode
    IORef ResultDeps
deps <- ResultDeps -> IO (IORef ResultDeps)
forall a. a -> IO (IORef a)
newIORef ResultDeps
UnknownDeps
    (Seconds
execution, RunResult{ByteString
STM ()
RunChanged
Value
runChanged :: RunChanged
runStore :: ByteString
runValue :: Value
runHook :: STM ()
runChanged :: forall value. RunResult value -> RunChanged
runStore :: forall value. RunResult value -> ByteString
runValue :: forall value. RunResult value -> value
runHook :: forall value. RunResult value -> STM ()
..}) <-
        IO (RunResult Value) -> IO (Seconds, RunResult Value)
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO (RunResult Value) -> IO (Seconds, RunResult Value))
-> IO (RunResult Value) -> IO (Seconds, RunResult Value)
forall a b. (a -> b) -> a -> b
$ ReaderT SAction IO (RunResult Value)
-> SAction -> IO (RunResult Value)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action (RunResult Value) -> ReaderT SAction IO (RunResult Value)
forall a. Action a -> ReaderT SAction IO a
fromAction Action (RunResult Value)
act) (SAction -> IO (RunResult Value))
-> SAction -> IO (RunResult Value)
forall a b. (a -> b) -> a -> b
$ Database -> IORef ResultDeps -> Stack -> SAction
SAction Database
db IORef ResultDeps
deps Stack
stack
    Step
curStep <- TVar Step -> IO Step
forall a. TVar a -> IO a
readTVarIO TVar Step
databaseStep
    ResultDeps
deps <- IORef ResultDeps -> IO ResultDeps
forall a. IORef a -> IO a
readIORef IORef ResultDeps
deps
    let lastChanged :: Step
lastChanged = Step -> (Result -> Step) -> Maybe Result -> Step
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Step
curStep Result -> Step
resultChanged Maybe Result
result
    let lastBuild :: Step
lastBuild = Step -> (Result -> Step) -> Maybe Result -> Step
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Step
curStep Result -> Step
resultBuilt Maybe Result
result
    -- changed time is always older than or equal to build time
    let (Step
changed, Step
built) =  case RunChanged
runChanged of
            -- some thing changed
            RunChanged
ChangedRecomputeDiff -> (Step
curStep, Step
curStep)
            -- recomputed is the same
            RunChanged
ChangedRecomputeSame -> (Step
lastChanged, Step
curStep)
            -- nothing changed
            RunChanged
ChangedNothing       -> (Step
lastChanged, Step
lastBuild)
    let -- only update the deps when the rule ran with changes
        actualDeps :: ResultDeps
actualDeps = if RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing then ResultDeps
deps else ResultDeps
previousDeps
        previousDeps :: ResultDeps
previousDeps= ResultDeps -> (Result -> ResultDeps) -> Maybe Result -> ResultDeps
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResultDeps
UnknownDeps Result -> ResultDeps
resultDeps Maybe Result
result
    let res :: Result
res = Value
-> Step
-> Step
-> Step
-> ResultDeps
-> Seconds
-> ByteString
-> Result
Result Value
runValue Step
built Step
changed Step
curStep ResultDeps
actualDeps Seconds
execution ByteString
runStore
    case KeySet -> ResultDeps -> KeySet
getResultDepsDefault KeySet
forall a. Monoid a => a
mempty ResultDeps
actualDeps of
        KeySet
deps | Bool -> Bool
not (KeySet -> Bool
nullKeySet KeySet
deps)
            Bool -> Bool -> Bool
&& RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing
                    -> do
            -- IMPORTANT: record the reverse deps **before** marking the key Clean.
            -- If an async exception strikes before the deps have been recorded,
            -- we won't be able to accurately propagate dirtiness for this key
            -- on the next build.
            IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Key -> Database -> KeySet -> KeySet -> IO ()
updateReverseDeps Key
key Database
db
                    (KeySet -> ResultDeps -> KeySet
getResultDepsDefault KeySet
forall a. Monoid a => a
mempty ResultDeps
previousDeps)
                    KeySet
deps
        KeySet
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"compute and run hook" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        STM ()
runHook
        Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus (Status -> Focus KeyDetails STM ()
forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus (Status -> Focus KeyDetails STM ())
-> Status -> Focus KeyDetails STM ()
forall a b. (a -> b) -> a -> b
$ Result -> Status
Clean Result
res) Key
key Map Key KeyDetails
databaseValues
    Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
res

updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()
updateStatus :: forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus Status
res = (Maybe KeyDetails -> Maybe KeyDetails) -> Focus KeyDetails m ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter
    (KeyDetails -> Maybe KeyDetails
forall a. a -> Maybe a
Just (KeyDetails -> Maybe KeyDetails)
-> (Maybe KeyDetails -> KeyDetails)
-> Maybe KeyDetails
-> Maybe KeyDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyDetails
-> (KeyDetails -> KeyDetails) -> Maybe KeyDetails -> KeyDetails
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Status -> KeySet -> KeyDetails
KeyDetails Status
res KeySet
forall a. Monoid a => a
mempty)
    (\KeyDetails
it -> KeyDetails
it{keyStatus = res}))

-- | Returns the set of dirty keys annotated with their age (in # of builds)
getDirtySet :: Database -> IO [(Key, Int)]
getDirtySet :: Database -> IO [(Key, Int)]
getDirtySet Database
db = do
    Step Int
curr <- TVar Step -> IO Step
forall a. TVar a -> IO a
readTVarIO (Database -> TVar Step
databaseStep Database
db)
    [(Key, Status)]
dbContents <- Database -> IO [(Key, Status)]
getDatabaseValues Database
db
    let calcAge :: Result -> Int
calcAge Result{resultBuilt :: Result -> Step
resultBuilt = Step Int
x} = Int
curr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x
        calcAgeStatus :: Status -> Maybe Int
calcAgeStatus (Dirty Maybe Result
x)=Result -> Int
calcAge (Result -> Int) -> Maybe Result -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Result
x
        calcAgeStatus Status
_         = Maybe Int
forall a. Maybe a
Nothing
    [(Key, Int)] -> IO [(Key, Int)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Key, Int)] -> IO [(Key, Int)])
-> [(Key, Int)] -> IO [(Key, Int)]
forall a b. (a -> b) -> a -> b
$ ((Key, Status) -> Maybe (Key, Int))
-> [(Key, Status)] -> [(Key, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Status -> Maybe Int) -> (Key, Status) -> Maybe (Key, Int)
forall (m :: * -> *) b b' a.
Functor m =>
(b -> m b') -> (a, b) -> m (a, b')
secondM Status -> Maybe Int
calcAgeStatus) [(Key, Status)]
dbContents

-- | Returns an approximation of the database keys,
--   annotated with how long ago (in # builds) they were visited
getKeysAndVisitAge :: Database -> IO [(Key, Int)]
getKeysAndVisitAge :: Database -> IO [(Key, Int)]
getKeysAndVisitAge Database
db = do
    [(Key, Status)]
values <- Database -> IO [(Key, Status)]
getDatabaseValues Database
db
    Step Int
curr <- TVar Step -> IO Step
forall a. TVar a -> IO a
readTVarIO (Database -> TVar Step
databaseStep Database
db)
    let keysWithVisitAge :: [(Key, Int)]
keysWithVisitAge = ((Key, Status) -> Maybe (Key, Int))
-> [(Key, Status)] -> [(Key, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Status -> Maybe Int) -> (Key, Status) -> Maybe (Key, Int)
forall (m :: * -> *) b b' a.
Functor m =>
(b -> m b') -> (a, b) -> m (a, b')
secondM ((Result -> Int) -> Maybe Result -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Int
getAge (Maybe Result -> Maybe Int)
-> (Status -> Maybe Result) -> Status -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Maybe Result
getResult)) [(Key, Status)]
values
        getAge :: Result -> Int
getAge Result{resultVisited :: Result -> Step
resultVisited = Step Int
s} = Int
curr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s
    [(Key, Int)] -> IO [(Key, Int)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Key, Int)]
keysWithVisitAge
--------------------------------------------------------------------------------
-- Lazy IO trick

data Box a = Box {forall a. Box a -> a
fromBox :: a}

-- | Split an IO computation into an unsafe lazy value and a forcing computation
splitIO :: IO a -> (IO (), a)
splitIO :: forall a. IO a -> (IO (), a)
splitIO IO a
act = do
    let act2 :: IO (Box a)
act2 = a -> Box a
forall a. a -> Box a
Box (a -> Box a) -> IO a -> IO (Box a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act
    let res :: Box a
res = IO (Box a) -> Box a
forall a. IO a -> a
unsafePerformIO IO (Box a)
act2
    (IO (Box a) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Box a) -> IO ()) -> IO (Box a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Box a -> IO (Box a)
forall a. a -> IO a
evaluate Box a
res, Box a -> a
forall a. Box a -> a
fromBox Box a
res)

--------------------------------------------------------------------------------
-- Reverse dependencies

-- | Update the reverse dependencies of an Id
updateReverseDeps
    :: Key        -- ^ Id
    -> Database
    -> KeySet -- ^ Previous direct dependencies of Id
    -> KeySet -- ^ Current direct dependencies of Id
    -> IO ()
-- mask to ensure that all the reverse dependencies are updated
updateReverseDeps :: Key -> Database -> KeySet -> KeySet -> IO ()
updateReverseDeps Key
myId Database
db KeySet
prev KeySet
new = do
    [Key] -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (KeySet -> [Key]
toListKeySet (KeySet -> [Key]) -> KeySet -> [Key]
forall a b. (a -> b) -> a -> b
$ KeySet
prev KeySet -> KeySet -> KeySet
`differenceKeySet` KeySet
new) ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
d ->
         (KeySet -> KeySet) -> Key -> IO ()
doOne (Key -> KeySet -> KeySet
deleteKeySet Key
myId) Key
d
    [Key] -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (KeySet -> [Key]
toListKeySet KeySet
new) ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        (KeySet -> KeySet) -> Key -> IO ()
doOne (Key -> KeySet -> KeySet
insertKeySet Key
myId)
    where
        alterRDeps :: (KeySet -> KeySet) -> Focus KeyDetails m ()
alterRDeps KeySet -> KeySet
f =
            (KeyDetails -> KeyDetails) -> Focus KeyDetails m ()
forall (m :: * -> *) a. Monad m => (a -> a) -> Focus a m ()
Focus.adjust ((KeySet -> KeySet) -> KeyDetails -> KeyDetails
onKeyReverseDeps KeySet -> KeySet
f)
        -- updating all the reverse deps atomically is not needed.
        -- Therefore, run individual transactions for each update
        -- in order to avoid contention
        doOne :: (KeySet -> KeySet) -> Key -> IO ()
doOne KeySet -> KeySet
f Key
id = String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"updateReverseDeps" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus ((KeySet -> KeySet) -> Focus KeyDetails STM ()
forall {m :: * -> *}.
Monad m =>
(KeySet -> KeySet) -> Focus KeyDetails m ()
alterRDeps KeySet -> KeySet
f) Key
id (Database -> Map Key KeyDetails
databaseValues Database
db)

getReverseDependencies :: Database -> Key -> STM (Maybe KeySet)
getReverseDependencies :: Database -> Key -> STM (Maybe KeySet)
getReverseDependencies Database
db = ((Maybe KeyDetails -> Maybe KeySet)
-> STM (Maybe KeyDetails) -> STM (Maybe KeySet)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Maybe KeyDetails -> Maybe KeySet)
 -> STM (Maybe KeyDetails) -> STM (Maybe KeySet))
-> ((KeyDetails -> KeySet) -> Maybe KeyDetails -> Maybe KeySet)
-> (KeyDetails -> KeySet)
-> STM (Maybe KeyDetails)
-> STM (Maybe KeySet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(KeyDetails -> KeySet) -> Maybe KeyDetails -> Maybe KeySet
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KeyDetails -> KeySet
keyReverseDeps  (STM (Maybe KeyDetails) -> STM (Maybe KeySet))
-> (Key -> STM (Maybe KeyDetails)) -> Key -> STM (Maybe KeySet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Map Key KeyDetails -> STM (Maybe KeyDetails))
-> Map Key KeyDetails -> Key -> STM (Maybe KeyDetails)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> Map Key KeyDetails -> STM (Maybe KeyDetails)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
SMap.lookup (Database -> Map Key KeyDetails
databaseValues Database
db)

transitiveDirtySet :: Foldable t => Database -> t Key -> IO KeySet
transitiveDirtySet :: forall (t :: * -> *). Foldable t => Database -> t Key -> IO KeySet
transitiveDirtySet Database
database = (StateT KeySet IO () -> KeySet -> IO KeySet)
-> KeySet -> StateT KeySet IO () -> IO KeySet
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT KeySet IO () -> KeySet -> IO KeySet
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT KeySet
forall a. Monoid a => a
mempty (StateT KeySet IO () -> IO KeySet)
-> (t Key -> StateT KeySet IO ()) -> t Key -> IO KeySet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> StateT KeySet IO ()) -> t Key -> StateT KeySet IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Key -> StateT KeySet IO ()
loop
  where
    loop :: Key -> StateT KeySet IO ()
loop Key
x = do
        KeySet
seen <- StateT KeySet IO KeySet
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
        if Key
x Key -> KeySet -> Bool
`memberKeySet` KeySet
seen then () -> StateT KeySet IO ()
forall a. a -> StateT KeySet IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else do
            KeySet -> StateT KeySet IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Key -> KeySet -> KeySet
insertKeySet Key
x KeySet
seen)
            Maybe KeySet
next <- IO (Maybe KeySet) -> StateT KeySet IO (Maybe KeySet)
forall (m :: * -> *) a. Monad m => m a -> StateT KeySet m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe KeySet) -> StateT KeySet IO (Maybe KeySet))
-> IO (Maybe KeySet) -> StateT KeySet IO (Maybe KeySet)
forall a b. (a -> b) -> a -> b
$ STM (Maybe KeySet) -> IO (Maybe KeySet)
forall a. STM a -> IO a
atomically (STM (Maybe KeySet) -> IO (Maybe KeySet))
-> STM (Maybe KeySet) -> IO (Maybe KeySet)
forall a b. (a -> b) -> a -> b
$ Database -> Key -> STM (Maybe KeySet)
getReverseDependencies Database
database Key
x
            (Key -> StateT KeySet IO ()) -> [Key] -> StateT KeySet IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Key -> StateT KeySet IO ()
loop ([Key] -> (KeySet -> [Key]) -> Maybe KeySet -> [Key]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Key]
forall a. Monoid a => a
mempty KeySet -> [Key]
toListKeySet Maybe KeySet
next)

--------------------------------------------------------------------------------
-- Asynchronous computations with cancellation

-- | A simple monad to implement cancellation on top of 'Async',
--   generalizing 'withAsync' to monadic scopes.
newtype AIO a = AIO { forall a. AIO a -> ReaderT (IORef [Async ()]) IO a
unAIO :: ReaderT (IORef [Async ()]) IO a }
  deriving newtype (Functor AIO
Functor AIO =>
(forall a. a -> AIO a)
-> (forall a b. AIO (a -> b) -> AIO a -> AIO b)
-> (forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c)
-> (forall a b. AIO a -> AIO b -> AIO b)
-> (forall a b. AIO a -> AIO b -> AIO a)
-> Applicative AIO
forall a. a -> AIO a
forall a b. AIO a -> AIO b -> AIO a
forall a b. AIO a -> AIO b -> AIO b
forall a b. AIO (a -> b) -> AIO a -> AIO b
forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> AIO a
pure :: forall a. a -> AIO a
$c<*> :: forall a b. AIO (a -> b) -> AIO a -> AIO b
<*> :: forall a b. AIO (a -> b) -> AIO a -> AIO b
$cliftA2 :: forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
liftA2 :: forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
$c*> :: forall a b. AIO a -> AIO b -> AIO b
*> :: forall a b. AIO a -> AIO b -> AIO b
$c<* :: forall a b. AIO a -> AIO b -> AIO a
<* :: forall a b. AIO a -> AIO b -> AIO a
Applicative, (forall a b. (a -> b) -> AIO a -> AIO b)
-> (forall a b. a -> AIO b -> AIO a) -> Functor AIO
forall a b. a -> AIO b -> AIO a
forall a b. (a -> b) -> AIO a -> AIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AIO a -> AIO b
fmap :: forall a b. (a -> b) -> AIO a -> AIO b
$c<$ :: forall a b. a -> AIO b -> AIO a
<$ :: forall a b. a -> AIO b -> AIO a
Functor, Applicative AIO
Applicative AIO =>
(forall a b. AIO a -> (a -> AIO b) -> AIO b)
-> (forall a b. AIO a -> AIO b -> AIO b)
-> (forall a. a -> AIO a)
-> Monad AIO
forall a. a -> AIO a
forall a b. AIO a -> AIO b -> AIO b
forall a b. AIO a -> (a -> AIO b) -> AIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. AIO a -> (a -> AIO b) -> AIO b
>>= :: forall a b. AIO a -> (a -> AIO b) -> AIO b
$c>> :: forall a b. AIO a -> AIO b -> AIO b
>> :: forall a b. AIO a -> AIO b -> AIO b
$creturn :: forall a. a -> AIO a
return :: forall a. a -> AIO a
Monad, Monad AIO
Monad AIO => (forall a. IO a -> AIO a) -> MonadIO AIO
forall a. IO a -> AIO a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> AIO a
liftIO :: forall a. IO a -> AIO a
MonadIO)

-- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises
runAIO :: AIO a -> IO a
runAIO :: forall a. AIO a -> IO a
runAIO (AIO ReaderT (IORef [Async ()]) IO a
act) = do
    IORef [Async ()]
asyncs <- [Async ()] -> IO (IORef [Async ()])
forall a. a -> IO (IORef a)
newIORef []
    ReaderT (IORef [Async ()]) IO a -> IORef [Async ()] -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IORef [Async ()]) IO a
act IORef [Async ()]
asyncs IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` IORef [Async ()] -> IO ()
forall a. IORef [Async a] -> IO ()
cleanupAsync IORef [Async ()]
asyncs

-- | Like 'async' but with built-in cancellation.
--   Returns an IO action to wait on the result.
asyncWithCleanUp :: AIO a -> AIO (IO a)
asyncWithCleanUp :: forall a. AIO a -> AIO (IO a)
asyncWithCleanUp AIO a
act = do
    IORef [Async ()]
st <- ReaderT (IORef [Async ()]) IO (IORef [Async ()])
-> AIO (IORef [Async ()])
forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO ReaderT (IORef [Async ()]) IO (IORef [Async ()])
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO a
io <- AIO a -> AIO (IO a)
forall a. AIO a -> AIO (IO a)
unliftAIO AIO a
act
    -- mask to make sure we keep track of the spawned async
    IO (IO a) -> AIO (IO a)
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO a) -> AIO (IO a)) -> IO (IO a) -> AIO (IO a)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO (IO a)) -> IO (IO a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO (IO a)) -> IO (IO a))
-> ((forall a. IO a -> IO a) -> IO (IO a)) -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        Async a
a <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
restore IO a
io
        IORef [Async ()] -> ([Async ()] -> [Async ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef [Async ()]
st (Async a -> Async ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Async a
a :)
        IO a -> IO (IO a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall a. Async a -> IO a
wait Async a
a

unliftAIO :: AIO a -> AIO (IO a)
unliftAIO :: forall a. AIO a -> AIO (IO a)
unliftAIO AIO a
act = do
    IORef [Async ()]
st <- ReaderT (IORef [Async ()]) IO (IORef [Async ()])
-> AIO (IORef [Async ()])
forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO ReaderT (IORef [Async ()]) IO (IORef [Async ()])
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO a -> AIO (IO a)
forall a. a -> AIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> AIO (IO a)) -> IO a -> AIO (IO a)
forall a b. (a -> b) -> a -> b
$ ReaderT (IORef [Async ()]) IO a -> IORef [Async ()] -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AIO a -> ReaderT (IORef [Async ()]) IO a
forall a. AIO a -> ReaderT (IORef [Async ()]) IO a
unAIO AIO a
act) IORef [Async ()]
st

newtype RunInIO = RunInIO (forall a. AIO a -> IO a)

withRunInIO :: (RunInIO -> AIO b) -> AIO b
withRunInIO :: forall b. (RunInIO -> AIO b) -> AIO b
withRunInIO RunInIO -> AIO b
k = do
    IORef [Async ()]
st <- ReaderT (IORef [Async ()]) IO (IORef [Async ()])
-> AIO (IORef [Async ()])
forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO ReaderT (IORef [Async ()]) IO (IORef [Async ()])
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    RunInIO -> AIO b
k (RunInIO -> AIO b) -> RunInIO -> AIO b
forall a b. (a -> b) -> a -> b
$ (forall a. AIO a -> IO a) -> RunInIO
RunInIO (\AIO a
aio -> ReaderT (IORef [Async ()]) IO a -> IORef [Async ()] -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AIO a -> ReaderT (IORef [Async ()]) IO a
forall a. AIO a -> ReaderT (IORef [Async ()]) IO a
unAIO AIO a
aio) IORef [Async ()]
st)

cleanupAsync :: IORef [Async a] -> IO ()
-- mask to make sure we interrupt all the asyncs
cleanupAsync :: forall a. IORef [Async a] -> IO ()
cleanupAsync IORef [Async a]
ref = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    [Async a]
asyncs <- IORef [Async a]
-> ([Async a] -> ([Async a], [Async a])) -> IO [Async a]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Async a]
ref ([],)
    -- interrupt all the asyncs without waiting
    (Async a -> IO ()) -> [Async a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Async a
a -> ThreadId -> AsyncCancelled -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo (Async a -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async a
a) AsyncCancelled
AsyncCancelled) [Async a]
asyncs
    -- Wait until all the asyncs are done
    -- But if it takes more than 10 seconds, log to stderr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Async a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Async a]
asyncs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let warnIfTakingTooLong :: IO Any
warnIfTakingTooLong = IO Any -> IO Any
forall a. IO a -> IO a
unmask (IO Any -> IO Any) -> IO Any -> IO Any
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
                Seconds -> IO ()
sleep Seconds
10
                String -> IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM String
"cleanupAsync: waiting for asyncs to finish"
        IO Any -> (Async Any -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
warnIfTakingTooLong ((Async Any -> IO ()) -> IO ()) -> (Async Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
            (Async a -> IO (Either SomeException a)) -> [Async a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async a -> IO (Either SomeException a)
forall a. Async a -> IO (Either SomeException a)
waitCatch [Async a]
asyncs

data Wait
    = Wait {Wait -> IO ()
justWait :: !(IO ())}
    | Spawn {justWait :: !(IO ())}

fmapWait :: (IO () -> IO ()) -> Wait -> Wait
fmapWait :: (IO () -> IO ()) -> Wait -> Wait
fmapWait IO () -> IO ()
f (Wait IO ()
io)  = IO () -> Wait
Wait (IO () -> IO ()
f IO ()
io)
fmapWait IO () -> IO ()
f (Spawn IO ()
io) = IO () -> Wait
Spawn (IO () -> IO ()
f IO ()
io)

waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ()))
waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ()))
waitOrSpawn (Wait IO ()
io)  = Either (IO ()) (Async ()) -> IO (Either (IO ()) (Async ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ()) (Async ()) -> IO (Either (IO ()) (Async ())))
-> Either (IO ()) (Async ()) -> IO (Either (IO ()) (Async ()))
forall a b. (a -> b) -> a -> b
$ IO () -> Either (IO ()) (Async ())
forall a b. a -> Either a b
Left IO ()
io
waitOrSpawn (Spawn IO ()
io) = Async () -> Either (IO ()) (Async ())
forall a b. b -> Either a b
Right (Async () -> Either (IO ()) (Async ()))
-> IO (Async ()) -> IO (Either (IO ()) (Async ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
io

waitConcurrently_ :: [Wait] -> AIO ()
waitConcurrently_ :: [Wait] -> AIO ()
waitConcurrently_ [] = () -> AIO ()
forall a. a -> AIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
waitConcurrently_ [Wait
one] = IO () -> AIO ()
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ Wait -> IO ()
justWait Wait
one
waitConcurrently_ [Wait]
many = do
    IORef [Async ()]
ref <- ReaderT (IORef [Async ()]) IO (IORef [Async ()])
-> AIO (IORef [Async ()])
forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO ReaderT (IORef [Async ()]) IO (IORef [Async ()])
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    -- spawn the async computations.
    -- mask to make sure we keep track of all the asyncs.
    ([Async ()]
asyncs, [IO ()]
syncs) <- IO ([Async ()], [IO ()]) -> AIO ([Async ()], [IO ()])
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Async ()], [IO ()]) -> AIO ([Async ()], [IO ()]))
-> IO ([Async ()], [IO ()]) -> AIO ([Async ()], [IO ()])
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ([Async ()], [IO ()]))
-> IO ([Async ()], [IO ()])
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO ([Async ()], [IO ()]))
 -> IO ([Async ()], [IO ()]))
-> ((forall a. IO a -> IO a) -> IO ([Async ()], [IO ()]))
-> IO ([Async ()], [IO ()])
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
        [Either (IO ()) (Async ())]
waits <- IO [Either (IO ()) (Async ())] -> IO [Either (IO ()) (Async ())]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either (IO ()) (Async ())] -> IO [Either (IO ()) (Async ())])
-> IO [Either (IO ()) (Async ())] -> IO [Either (IO ()) (Async ())]
forall a b. (a -> b) -> a -> b
$ (Wait -> IO (Either (IO ()) (Async ())))
-> [Wait] -> IO [Either (IO ()) (Async ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Wait -> IO (Either (IO ()) (Async ()))
waitOrSpawn (Wait -> IO (Either (IO ()) (Async ())))
-> (Wait -> Wait) -> Wait -> IO (Either (IO ()) (Async ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> Wait -> Wait
fmapWait IO () -> IO ()
forall a. IO a -> IO a
unmask) [Wait]
many
        let ([IO ()]
syncs, [Async ()]
asyncs) = [Either (IO ()) (Async ())] -> ([IO ()], [Async ()])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (IO ()) (Async ())]
waits
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [Async ()] -> ([Async ()] -> [Async ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef [Async ()]
ref ([Async ()]
asyncs ++)
        ([Async ()], [IO ()]) -> IO ([Async ()], [IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Async ()]
asyncs, [IO ()]
syncs)
    -- work on the sync computations
    IO () -> AIO ()
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
syncs
    -- wait for the async computations before returning
    IO () -> AIO ()
forall a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ (Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall a. Async a -> IO a
wait [Async ()]
asyncs