-- 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 DerivingStrategies #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ViewPatterns       #-}

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.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.Key
import           Development.IDE.Graph.Internal.Rules
import           Development.IDE.Graph.Internal.Types
import qualified Focus
import qualified ListT
import qualified StmContainers.Map                    as SMap
import           System.IO.Unsafe
import           System.Time.Extra                    (duration, sleep)


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

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

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

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

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

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

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

-- | 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 (KeySet -> [Key]
toListKeySet -> [Key]
deps)}) -> do
        Either [(Key, Result)] (IO [(Key, Result)])
res <- Database
-> Stack
-> [Key]
-> AIO (Either [(Key, Result)] (IO [(Key, Result)]))
forall (f :: * -> *).
Traversable f =>
Database
-> Stack
-> f Key
-> AIO (Either (f (Key, Result)) (IO (f (Key, Result))))
builder Database
db Stack
stack [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 a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesChanged Maybe Result
result
                    else IO Result -> AIO (IO Result)
forall a. a -> AIO a
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 a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ 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 a. IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> AIO Result) -> IO Result -> AIO Result
forall a b. (a -> b) -> a -> b
$ Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute Database
db Stack
stack Key
key RunMode
RunDependenciesChanged Maybe Result
result

-- | Compute a key.
compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
-- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined
compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
compute db :: Database
db@Database{TheRules
TVar Step
Dynamic
Map Key KeyDetails
databaseExtra :: Database -> Dynamic
databaseRules :: Database -> TheRules
databaseStep :: Database -> TVar Step
databaseValues :: Database -> Map Key KeyDetails
databaseExtra :: Dynamic
databaseRules :: TheRules
databaseStep :: TVar Step
databaseValues :: Map Key KeyDetails
..} Stack
stack Key
key RunMode
mode Maybe Result
result = do
    let act :: Action (RunResult Value)
act = TheRules
-> Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
runRule TheRules
databaseRules Key
key ((Result -> ByteString) -> Maybe Result -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> ByteString
resultData Maybe Result
result) RunMode
mode
    IORef ResultDeps
deps <- ResultDeps -> IO (IORef ResultDeps)
forall a. a -> IO (IORef a)
newIORef ResultDeps
UnknownDeps
    (Seconds
execution, RunResult{ByteString
RunChanged
Value
runChanged :: RunChanged
runStore :: ByteString
runValue :: Value
runChanged :: forall value. RunResult value -> RunChanged
runStore :: forall value. RunResult value -> ByteString
runValue :: forall value. RunResult value -> value
..}) <-
        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 KeySet -> ResultDeps -> KeySet
getResultDepsDefault KeySet
forall a. Monoid a => a
mempty ResultDeps
actualDeps of
        KeySet
deps | Bool -> Bool
not(KeySet -> Bool
nullKeySet KeySet
deps)
            Bool -> Bool -> Bool
&& RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing
                    -> do
            -- IMPORTANT: record the reverse deps **before** marking the key Clean.
            -- If an async exception strikes before the deps have been recorded,
            -- we won't be able to accurately propagate dirtiness for this key
            -- on the next build.
            IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Key -> Database -> KeySet -> KeySet -> IO ()
updateReverseDeps Key
key Database
db
                    (KeySet -> ResultDeps -> KeySet
getResultDepsDefault KeySet
forall a. Monoid a => a
mempty ResultDeps
previousDeps)
                    KeySet
deps
        KeySet
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"compute" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Focus KeyDetails STM () -> Key -> Map Key KeyDetails -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
SMap.focus (Status -> Focus KeyDetails STM ()
forall (m :: * -> *). Monad m => Status -> Focus KeyDetails m ()
updateStatus (Status -> Focus KeyDetails STM ())
-> Status -> Focus KeyDetails STM ()
forall a b. (a -> b) -> a -> b
$ Result -> Status
Clean Result
res) Key
key Map Key KeyDetails
databaseValues
    Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
res

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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