-- 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 DeriveFunctor              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}

module Development.IDE.Graph.Internal.Database (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.HashSet                         (HashSet)
import qualified Data.HashSet                         as HSet
import           Data.IORef.Extra
import           Data.List.NonEmpty                   (unzip)
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.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)


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

-- | 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
    forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase" forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'  (Database -> TVar Step
databaseStep Database
db) forall a b. (a -> b) -> a -> b
$ \(Step Int
i) -> Int -> Step
Step forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1
    HashSet Key
transitiveDirtyKeys <- forall (t :: * -> *).
Foldable t =>
Database -> t Key -> IO (HashSet Key)
transitiveDirtySet Database
db [Key]
kk
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ HashSet Key
transitiveDirtyKeys 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.
        forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase" forall a b. (a -> b) -> a -> b
$ forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus 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
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'  (Database -> TVar Step
databaseStep Database
db) forall a b. (a -> b) -> a -> b
$ \(Step Int
i) -> Int -> Step
Step forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1
    let list :: ListT STM (Key, KeyDetails)
list = forall key value. Map key value -> ListT STM (key, value)
SMap.listT (Database -> Map Key KeyDetails
databaseValues Database
db)
    forall a. String -> STM a -> IO a
atomicallyNamed String
"incDatabase - all " forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => (a -> m ()) -> ListT m a -> m ()
ListT.traverse_ ListT STM (Key, KeyDetails)
list forall a b. (a -> b) -> a -> b
$ \(Key
k,KeyDetails
_) ->
        forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus 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 = forall (m :: * -> *) a. Monad m => (a -> a) -> Focus a m ()
Focus.adjust forall a b. (a -> b) -> a -> b
$ \(KeyDetails Status
status HashSet Key
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 (forall a. a -> Maybe a
Just Result
x)
                  | Bool
otherwise = Status
status
            in Status -> HashSet Key -> KeyDetails
KeyDetails Status
status' HashSet Key
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 <- forall a. AIO a -> IO a
runAIO forall a b. (a -> b) -> a -> b
$ do
        Either (f (Key, Result)) (IO (f (Key, Result)))
built <- forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder Database
db Stack
stack (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key f key
keys)
        case Either (f (Key, Result)) (IO (f (Key, Result)))
built of
          Left f (Key, Result)
clean  -> forall (m :: * -> *) a. Monad m => a -> m a
return f (Key, Result)
clean
          Right IO (f (Key, Result))
dirty -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (f (Key, Result))
dirty
    let (f Key
ids, f Result
vs) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip f (Key, Result)
built
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (f Key
ids, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> value
asV 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) = 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
databaseValues :: Map Key KeyDetails
databaseStep :: TVar Step
databaseRules :: TheRules
databaseExtra :: Dynamic
databaseValues :: Database -> Map Key KeyDetails
databaseStep :: Database -> TVar Step
databaseRules :: Database -> TheRules
databaseExtra :: Database -> Dynamic
..} Stack
stack f Key
keys = forall b. (RunInIO -> AIO b) -> AIO b
withRunInIO 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO []
    Step
current <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Step
databaseStep
    f (Key, Result)
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f Key
keys 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
        forall a. String -> STM a -> IO a
atomicallyNamed String
"builder" forall a b. (a -> b) -> a -> b
$ do
            -- Spawn the id if needed
            Maybe KeyDetails
status <- forall key value.
(Eq key, 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 forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Result -> Status
Dirty forall a. Maybe a
Nothing) KeyDetails -> Status
keyStatus Maybe KeyDetails
status of
                Clean Result
r -> 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 -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Stack -> StackException
StackException Stack
stack
                  | Bool
otherwise -> do
                    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Wait]
toForce (IO () -> Wait
Wait IO ()
force forall a. a -> [a] -> [a]
:)
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val
                Dirty Maybe Result
s -> do
                    let act :: IO (IO Result)
act = 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) = forall a. IO a -> (IO (), a)
splitIO (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join IO (IO Result)
act)
                    forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus (forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus 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
                    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Wait]
toForce (IO () -> Wait
Spawn IO ()
forceforall a. a -> [a] -> [a]
:)
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val

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

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

-- | Refresh a key:
--     * 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
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
_) -> forall a e. Exception e => e -> a
throw StackException
e
    (Right Stack
stack, Just me :: Result
me@Result{resultDeps :: Result -> ResultDeps
resultDeps = ResultDeps [Key]
deps}) -> do
        Either [(Key, Result)] (IO [(Key, Result)])
res <- forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder Database
db Stack
stack [Key]
deps
        let isDirty :: [(Key, Result)] -> Bool
isDirty = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Key
_,Result
dep) -> Result -> Step
resultBuilt Result
me forall a. Ord a => a -> a -> Bool
< Result -> Step
resultChanged Result
dep)
        case Either [(Key, Result)] (IO [(Key, Result)])
res of
            Left [(Key, Result)]
res ->
                if [(Key, Result)] -> Bool
isDirty [(Key, Result)]
res
                    then forall a. AIO a -> AIO (IO a)
asyncWithCleanUp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesSame Maybe Result
result
            Right IO [(Key, Result)]
iores -> forall a. AIO a -> AIO (IO a)
asyncWithCleanUp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                [(Key, Result)]
res <- IO [(Key, Result)]
iores
                let mode :: RunMode
mode = if [(Key, Result)] -> Bool
isDirty [(Key, Result)]
res then RunMode
RunDependenciesChanged else RunMode
RunDependenciesSame
                Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
mode Maybe Result
result
    (Right Stack
stack, Maybe Result
_) ->
        forall a. AIO a -> AIO (IO a)
asyncWithCleanUp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
databaseValues :: Map Key KeyDetails
databaseStep :: TVar Step
databaseRules :: TheRules
databaseExtra :: Dynamic
databaseValues :: Database -> Map Key KeyDetails
databaseStep :: Database -> TVar Step
databaseRules :: Database -> TheRules
databaseExtra :: Database -> Dynamic
..} 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> ByteString
resultData Maybe Result
result) RunMode
mode
    IORef ResultDeps
deps <- forall a. a -> IO (IORef a)
newIORef ResultDeps
UnknownDeps
    (Seconds
execution, RunResult{ByteString
RunChanged
Value
runValue :: forall value. RunResult value -> value
runStore :: forall value. RunResult value -> ByteString
runChanged :: forall value. RunResult value -> RunChanged
runValue :: Value
runStore :: ByteString
runChanged :: RunChanged
..}) <-
        forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction Action (RunResult Value)
act) forall a b. (a -> b) -> a -> b
$ Database -> IORef ResultDeps -> Stack -> SAction
SAction Database
db IORef ResultDeps
deps Stack
stack
    Step
built <- forall a. TVar a -> IO a
readTVarIO TVar Step
databaseStep
    ResultDeps
deps <- forall a. IORef a -> IO a
readIORef IORef ResultDeps
deps
    let changed :: Step
changed = if RunChanged
runChanged forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedRecomputeDiff then Step
built else forall b a. b -> (a -> b) -> Maybe a -> b
maybe Step
built Result -> Step
resultChanged Maybe Result
result
        built' :: Step
built' = if RunChanged
runChanged forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing then Step
built else Step
changed
        -- only update the deps when the rule ran with changes
        actualDeps :: ResultDeps
actualDeps = if RunChanged
runChanged forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing then ResultDeps
deps else ResultDeps
previousDeps
        previousDeps :: ResultDeps
previousDeps= 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
built ResultDeps
actualDeps Seconds
execution ByteString
runStore
    case [Key] -> ResultDeps -> [Key]
getResultDepsDefault [] ResultDeps
actualDeps of
        [Key]
deps | Bool -> Bool
not(forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
deps)
            Bool -> Bool -> Bool
&& RunChanged
runChanged 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.
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
                Key -> Database -> [Key] -> HashSet Key -> IO ()
updateReverseDeps Key
key Database
db
                    ([Key] -> ResultDeps -> [Key]
getResultDepsDefault [] ResultDeps
previousDeps)
                    (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList [Key]
deps)
        [Key]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    forall a. String -> STM a -> IO a
atomicallyNamed String
"compute" forall a b. (a -> b) -> a -> b
$ forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus (forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus forall a b. (a -> b) -> a -> b
$ Result -> Status
Clean Result
res) Key
key Map Key KeyDetails
databaseValues
    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 = forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter
    (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Status -> HashSet Key -> KeyDetails
KeyDetails Status
res forall a. Monoid a => a
mempty)
    (\KeyDetails
it -> KeyDetails
it{keyStatus :: Status
keyStatus = Status
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 <- 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 forall a. Num a => a -> a -> a
- Int
x
        calcAgeStatus :: Status -> Maybe Int
calcAgeStatus (Dirty Maybe Result
x)=Result -> Int
calcAge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Result
x
        calcAgeStatus Status
_         = forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 <- forall a. TVar a -> IO a
readTVarIO (Database -> TVar Step
databaseStep Database
db)
    let keysWithVisitAge :: [(Key, Int)]
keysWithVisitAge = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (m :: * -> *) b b' a.
Functor m =>
(b -> m b') -> (a, b) -> m (a, b')
secondM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Int
getAge 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 forall a. Num a => a -> a -> a
- Int
s
    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 = forall a. a -> Box a
Box forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act
    let res :: Box a
res = forall a. IO a -> a
unsafePerformIO IO (Box a)
act2
    (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate Box a
res, forall a. Box a -> a
fromBox Box a
res)

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

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

getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key))
getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key))
getReverseDependencies Database
db = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KeyDetails -> HashSet Key
keyReverseDeps  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key value.
(Eq key, 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 (HashSet Key)
transitiveDirtySet :: forall (t :: * -> *).
Foldable t =>
Database -> t Key -> IO (HashSet Key)
transitiveDirtySet Database
database = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT forall a. HashSet a
HSet.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Key -> StateT (HashSet Key) IO ()
loop
  where
    loop :: Key -> StateT (HashSet Key) IO ()
loop Key
x = do
        HashSet Key
seen <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
        if Key
x forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` HashSet Key
seen then forall (f :: * -> *) a. Applicative f => a -> f a
pure () else do
            forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert Key
x HashSet Key
seen)
            Maybe (HashSet Key)
next <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ Database -> Key -> STM (Maybe (HashSet Key))
getReverseDependencies Database
database Key
x
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Key -> StateT (HashSet Key) IO ()
loop (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. HashSet a -> [a]
HSet.toList Maybe (HashSet Key)
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
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
<* :: forall a b. AIO a -> AIO b -> AIO a
$c<* :: forall a b. AIO a -> AIO b -> AIO a
*> :: forall a b. AIO a -> AIO b -> AIO b
$c*> :: forall a b. AIO a -> AIO b -> AIO b
liftA2 :: forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
$cliftA2 :: forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
<*> :: forall a b. AIO (a -> b) -> AIO a -> AIO b
$c<*> :: forall a b. AIO (a -> b) -> AIO a -> AIO b
pure :: forall a. a -> AIO a
$cpure :: forall a. a -> AIO a
Applicative, 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
<$ :: forall a b. a -> AIO b -> AIO a
$c<$ :: forall a b. a -> AIO b -> AIO a
fmap :: forall a b. (a -> b) -> AIO a -> AIO b
$cfmap :: forall a b. (a -> b) -> AIO a -> AIO b
Functor, Applicative 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
return :: forall a. a -> AIO a
$creturn :: forall a. a -> AIO a
>> :: forall a b. AIO a -> AIO b -> AIO b
$c>> :: forall a b. AIO a -> AIO b -> AIO b
>>= :: forall a b. AIO a -> (a -> AIO b) -> AIO b
$c>>= :: forall a b. AIO a -> (a -> AIO b) -> AIO b
Monad, Monad AIO
forall a. IO a -> AIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> AIO a
$cliftIO :: 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 <- forall a. a -> IO (IORef a)
newIORef []
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IORef [Async ()]) IO a
act IORef [Async ()]
asyncs forall a b. IO a -> IO b -> IO a
`onException` 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 <- forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO a
io <- forall a. AIO a -> AIO (IO a)
unliftAIO AIO a
act
    -- mask to make sure we keep track of the spawned async
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        Async a
a <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore IO a
io
        forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef [Async ()]
st (forall (f :: * -> *) a. Functor f => f a -> f ()
void Async a
a forall a. a -> [a] -> [a]
:)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 <- forall a. ReaderT (IORef [Async ()]) IO a -> AIO a
AIO forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    RunInIO -> AIO b
k forall a b. (a -> b) -> a -> b
$ (forall a. AIO a -> IO a) -> RunInIO
RunInIO (\AIO a
aio -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    [Async a]
asyncs <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Async a]
ref ([],)
    -- interrupt all the asyncs without waiting
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Async a
a -> forall e. Exception e => ThreadId -> e -> IO ()
throwTo (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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Async a]
asyncs) forall a b. (a -> b) -> a -> b
$ do
        let warnIfTakingTooLong :: IO Any
warnIfTakingTooLong = forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
                Seconds -> IO ()
sleep Seconds
10
                forall (f :: * -> *). Applicative f => String -> f ()
traceM String
"cleanupAsync: waiting for asyncs to finish"
        forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
warnIfTakingTooLong forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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)  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left IO ()
io
waitOrSpawn (Spawn IO ()
io) = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> IO (Async a)
async IO ()
io

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