-- 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 TypeFamilies               #-}
{-# LANGUAGE TupleSections #-}

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

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.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.Time.Extra                    (duration, sleep)
import           System.IO.Unsafe

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 (f :: * -> *) a. Applicative f => a -> f a
pure Database :: Dynamic -> TheRules -> TVar Step -> Map Key KeyDetails -> Database
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
    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
    HashSet Key
transitiveDirtyKeys <- Database -> [Key] -> IO (HashSet Key)
forall (t :: * -> *).
Foldable t =>
Database -> t Key -> IO (HashSet Key)
transitiveDirtySet Database
db [Key]
kk
    HashSet Key -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ HashSet Key
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.
(Eq key, 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.
(Eq key, 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 :: 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 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 (Result -> Maybe Result
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 key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
    => Database -> Stack -> [key] -> IO ([Key], [value])
-- build _ st k | traceShow ("build", st, k) False = undefined
build :: Database -> Stack -> [key] -> IO ([Key], [value])
build Database
db Stack
stack [key]
keys = do
    ([Key]
ids, [Result]
vs) <- AIO ([Key], [Result]) -> IO ([Key], [Result])
forall a. AIO a -> IO a
runAIO (AIO ([Key], [Result]) -> IO ([Key], [Result]))
-> AIO ([Key], [Result]) -> IO ([Key], [Result])
forall a b. (a -> b) -> a -> b
$ ([(Key, Result)] -> ([Key], [Result]))
-> AIO [(Key, Result)] -> AIO ([Key], [Result])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Key, Result)] -> ([Key], [Result])
forall a b. [(a, b)] -> ([a], [b])
unzip (AIO [(Key, Result)] -> AIO ([Key], [Result]))
-> AIO [(Key, Result)] -> AIO ([Key], [Result])
forall a b. (a -> b) -> a -> b
$ ([(Key, Result)] -> AIO [(Key, Result)])
-> (IO [(Key, Result)] -> AIO [(Key, Result)])
-> Either [(Key, Result)] (IO [(Key, Result)])
-> AIO [(Key, Result)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [(Key, Result)] -> AIO [(Key, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return IO [(Key, Result)] -> AIO [(Key, Result)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Either [(Key, Result)] (IO [(Key, Result)])
 -> AIO [(Key, Result)])
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
-> AIO [(Key, Result)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            Database
-> Stack
-> [Key]
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
builder Database
db Stack
stack ((key -> Key) -> [key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map key -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key [key]
keys)
    ([Key], [value]) -> IO ([Key], [value])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key]
ids, (Result -> value) -> [Result] -> [value]
forall a b. (a -> b) -> [a] -> [b]
map (Value -> value
asV (Value -> value) -> (Result -> Value) -> Result -> value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Value
resultValue) [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
    :: Database -> Stack -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
-- builder _ st kk | traceShow ("builder", st,kk) False = undefined
builder :: Database
-> Stack
-> [Key]
-> AIO (Either [(Key, Result)] (IO [(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 [Key]
keys = (RunInIO -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall b. (RunInIO -> AIO b) -> AIO b
withRunInIO ((RunInIO -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
 -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
-> (RunInIO -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
-> AIO (Either [(Key, Result)] (IO [(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 (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 (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
    [(Key, Result)]
results <- IO [(Key, Result)] -> AIO [(Key, Result)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Key, Result)] -> AIO [(Key, Result)])
-> IO [(Key, Result)] -> AIO [(Key, Result)]
forall a b. (a -> b) -> a -> b
$ [Key] -> (Key -> IO (Key, Result)) -> IO [(Key, Result)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Key]
keys ((Key -> IO (Key, Result)) -> IO [(Key, Result)])
-> (Key -> IO (Key, Result)) -> IO [(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.
(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 (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 (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 Wait -> [Wait] -> [Wait]
forall a. a -> [a] -> [a]
:)
                    Result -> STM Result
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.
(Eq key, 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 ()
forceWait -> [Wait] -> [Wait]
forall a. a -> [a] -> [a]
:)
                    Result -> STM Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val

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

    [Wait]
toForceList <- IO [Wait] -> AIO [Wait]
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 [(Key, Result)] (IO [(Key, Result)])
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(Key, Result)] (IO [(Key, Result)])
 -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
-> Either [(Key, Result)] (IO [(Key, Result)])
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall a b. (a -> b) -> a -> b
$ [(Key, Result)] -> Either [(Key, Result)] (IO [(Key, Result)])
forall a b. a -> Either a b
Left [(Key, Result)]
results
        [Wait]
_ -> Either [(Key, Result)] (IO [(Key, Result)])
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(Key, Result)] (IO [(Key, Result)])
 -> AIO (Either [(Key, Result)] (IO [(Key, Result)])))
-> Either [(Key, Result)] (IO [(Key, Result)])
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall a b. (a -> b) -> a -> b
$ IO [(Key, Result)] -> Either [(Key, Result)] (IO [(Key, Result)])
forall a b. b -> Either a b
Right (IO [(Key, Result)] -> Either [(Key, Result)] (IO [(Key, Result)]))
-> IO [(Key, Result)]
-> Either [(Key, Result)] (IO [(Key, Result)])
forall a b. (a -> b) -> a -> b
$ do
                IO ()
waitAll
                [(Key, Result)] -> IO [(Key, Result)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(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
_) -> 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 [Key]
deps}) -> do
        Either [(Key, Result)] (IO [(Key, Result)])
res <- Database
-> Stack
-> [Key]
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
builder Database
db Stack
stack [Key]
deps
        let isDirty :: [(Key, Result)] -> Bool
isDirty = ((Key, Result) -> Bool) -> [(Key, Result)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Key
_,Result
dep) -> Result -> Step
resultBuilt Result
me Step -> Step -> Bool
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 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 (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
                    else IO Result -> AIO (IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO Result -> AIO (IO Result)) -> IO Result -> AIO (IO 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 Maybe Result
result
            Right IO [(Key, Result)]
iores -> 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
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
_) ->
        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 (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
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 ((Result -> ByteString) -> Maybe Result -> Maybe ByteString
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
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
..}) <-
        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
built <- 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 changed :: Step
changed = if RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedRecomputeDiff then Step
built else Step -> (Result -> Step) -> Maybe Result -> Step
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Step
built Result -> Step
resultChanged Maybe Result
result
        built' :: Step
built' = if RunChanged
runChanged RunChanged -> RunChanged -> Bool
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 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
built ResultDeps
actualDeps Seconds
execution ByteString
runStore
    case [Key] -> ResultDeps -> [Key]
getResultDepsDefault [] ResultDeps
actualDeps of
        [Key]
deps | Bool -> Bool
not([Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
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 -> [Key] -> HashSet Key -> IO ()
updateReverseDeps Key
key Database
db
                    ([Key] -> ResultDeps -> [Key]
getResultDepsDefault [] ResultDeps
previousDeps)
                    ([Key] -> HashSet Key
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList [Key]
deps)
        [Key]
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"compute" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
(Eq key, 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 (f :: * -> *) a. Applicative f => a -> f a
pure Result
res

updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()
updateStatus :: 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 -> HashSet Key -> KeyDetails
KeyDetails Status
res HashSet Key
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 <- 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 (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 ann 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 (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 (m :: * -> *) a. Monad m => a -> m a
return [(Key, Int)]
keysWithVisitAge
--------------------------------------------------------------------------------
-- Lazy IO trick

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

-- | Split an IO computation into an unsafe lazy value and a forcing computation
splitIO :: IO a -> (IO (), a)
splitIO :: 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
    -> [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
    [Key] -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Key]
prev ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
d ->
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Key
d Key -> HashSet Key -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` HashSet Key
new) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (HashSet Key -> HashSet Key) -> Key -> IO ()
doOne (Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.delete Key
myId) Key
d
    [Key] -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet Key -> [Key]
forall a. HashSet a -> [a]
HSet.toList HashSet Key
new) ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        (HashSet Key -> HashSet Key) -> Key -> IO ()
doOne (Key -> HashSet Key -> HashSet Key
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 =
            (KeyDetails -> KeyDetails) -> Focus KeyDetails m ()
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 = 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.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus ((HashSet Key -> HashSet Key) -> Focus KeyDetails STM ()
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 = ((Maybe KeyDetails -> Maybe (HashSet Key))
-> STM (Maybe KeyDetails) -> STM (Maybe (HashSet Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Maybe KeyDetails -> Maybe (HashSet Key))
 -> STM (Maybe KeyDetails) -> STM (Maybe (HashSet Key)))
-> ((KeyDetails -> HashSet Key)
    -> Maybe KeyDetails -> Maybe (HashSet Key))
-> (KeyDetails -> HashSet Key)
-> STM (Maybe KeyDetails)
-> STM (Maybe (HashSet Key))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(KeyDetails -> HashSet Key)
-> Maybe KeyDetails -> Maybe (HashSet Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KeyDetails -> HashSet Key
keyReverseDeps  (STM (Maybe KeyDetails) -> STM (Maybe (HashSet Key)))
-> (Key -> STM (Maybe KeyDetails))
-> Key
-> STM (Maybe (HashSet Key))
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.
(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 :: Database -> t Key -> IO (HashSet Key)
transitiveDirtySet Database
database = (StateT (HashSet Key) IO () -> HashSet Key -> IO (HashSet Key))
-> HashSet Key -> StateT (HashSet Key) IO () -> IO (HashSet Key)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (HashSet Key) IO () -> HashSet Key -> IO (HashSet Key)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT HashSet Key
forall a. HashSet a
HSet.empty (StateT (HashSet Key) IO () -> IO (HashSet Key))
-> (t Key -> StateT (HashSet Key) IO ())
-> t Key
-> IO (HashSet Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> StateT (HashSet Key) IO ())
-> t Key -> StateT (HashSet Key) IO ()
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 <- StateT (HashSet Key) IO (HashSet Key)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
        if Key
x Key -> HashSet Key -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` HashSet Key
seen then () -> StateT (HashSet Key) IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else do
            HashSet Key -> StateT (HashSet Key) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert Key
x HashSet Key
seen)
            Maybe (HashSet Key)
next <- IO (Maybe (HashSet Key))
-> StateT (HashSet Key) IO (Maybe (HashSet Key))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe (HashSet Key))
 -> StateT (HashSet Key) IO (Maybe (HashSet Key)))
-> IO (Maybe (HashSet Key))
-> StateT (HashSet Key) IO (Maybe (HashSet Key))
forall a b. (a -> b) -> a -> b
$ STM (Maybe (HashSet Key)) -> IO (Maybe (HashSet Key))
forall a. STM a -> IO a
atomically (STM (Maybe (HashSet Key)) -> IO (Maybe (HashSet Key)))
-> STM (Maybe (HashSet Key)) -> IO (Maybe (HashSet Key))
forall a b. (a -> b) -> a -> b
$ Database -> Key -> STM (Maybe (HashSet Key))
getReverseDependencies Database
database Key
x
            (Key -> StateT (HashSet Key) IO ())
-> [Key] -> StateT (HashSet Key) IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Key -> StateT (HashSet Key) IO ()
loop ([Key] -> (HashSet Key -> [Key]) -> Maybe (HashSet Key) -> [Key]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Key]
forall a. Monoid a => a
mempty HashSet Key -> [Key]
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 { AIO a -> ReaderT (IORef [Async ()]) IO a
unAIO :: ReaderT (IORef [Async ()]) IO a }
  deriving newtype (Functor AIO
a -> AIO a
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
AIO a -> AIO b -> AIO b
AIO a -> AIO b -> AIO a
AIO (a -> b) -> AIO a -> AIO b
(a -> b -> c) -> AIO a -> AIO b -> AIO c
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
<* :: AIO a -> AIO b -> AIO a
$c<* :: forall a b. AIO a -> AIO b -> AIO a
*> :: AIO a -> AIO b -> AIO b
$c*> :: forall a b. AIO a -> AIO b -> AIO b
liftA2 :: (a -> b -> c) -> AIO a -> AIO b -> AIO c
$cliftA2 :: forall a b c. (a -> b -> c) -> AIO a -> AIO b -> AIO c
<*> :: AIO (a -> b) -> AIO a -> AIO b
$c<*> :: forall a b. AIO (a -> b) -> AIO a -> AIO b
pure :: a -> AIO a
$cpure :: forall a. a -> AIO a
$cp1Applicative :: Functor AIO
Applicative, a -> AIO b -> AIO a
(a -> b) -> AIO a -> AIO b
(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
<$ :: a -> AIO b -> AIO a
$c<$ :: forall a b. a -> AIO b -> AIO a
fmap :: (a -> b) -> AIO a -> AIO b
$cfmap :: forall a b. (a -> b) -> AIO a -> AIO b
Functor, Applicative AIO
a -> AIO a
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
AIO a -> (a -> AIO b) -> AIO b
AIO a -> AIO b -> AIO b
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 :: a -> AIO a
$creturn :: forall a. a -> AIO a
>> :: AIO a -> AIO b -> AIO b
$c>> :: forall a b. AIO a -> AIO b -> AIO b
>>= :: AIO a -> (a -> AIO b) -> AIO b
$c>>= :: forall a b. AIO a -> (a -> AIO b) -> AIO b
$cp1Monad :: Applicative AIO
Monad, Monad AIO
Monad AIO -> (forall a. IO a -> AIO a) -> MonadIO AIO
IO a -> AIO a
forall a. IO a -> AIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> AIO a
$cliftIO :: forall a. IO a -> AIO a
$cp1MonadIO :: Monad AIO
MonadIO)

-- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises
runAIO :: AIO a -> IO a
runAIO :: 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 :: 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 (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 Async () -> [Async ()] -> [Async ()]
forall a. a -> [a] -> [a]
:)
        IO a -> IO (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 :: 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 (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 :: (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 :: 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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
waitConcurrently_ [Wait
one] = IO () -> AIO ()
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 (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 (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)
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 (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 ()] -> [Async ()] -> [Async ()]
forall a. [a] -> [a] -> [a]
++)
        ([Async ()], [IO ()]) -> IO ([Async ()], [IO ()])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Async ()]
asyncs, [IO ()]
syncs)
    -- work on the sync computations
    IO () -> AIO ()
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 (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