-- 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 LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}

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

import           Control.Concurrent.Async
import           Control.Concurrent.Extra
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                         (traverse_)
import           Data.IORef.Extra
import           Data.IntSet                           (IntSet)
import qualified Data.IntSet                           as Set
import           Data.Maybe
import           Data.Tuple.Extra
import           Development.IDE.Graph.Classes
import qualified Development.IDE.Graph.Internal.Ids    as Ids
import           Development.IDE.Graph.Internal.Intern
import qualified Development.IDE.Graph.Internal.Intern as Intern
import           Development.IDE.Graph.Internal.Rules
import           Development.IDE.Graph.Internal.Types
import           System.IO.Unsafe
import           System.Time.Extra                     (duration)

newDatabase :: Dynamic -> TheRules -> IO Database
newDatabase :: Dynamic -> TheRules -> IO Database
newDatabase Dynamic
databaseExtra TheRules
databaseRules = do
    IORef Step
databaseStep <- Step -> IO (IORef Step)
forall a. a -> IO (IORef a)
newIORef (Step -> IO (IORef Step)) -> Step -> IO (IORef Step)
forall a b. (a -> b) -> a -> b
$ Int -> Step
Step Int
0
    Lock
databaseLock <- IO Lock
newLock
    IORef (Intern Key)
databaseIds <- Intern Key -> IO (IORef (Intern Key))
forall a. a -> IO (IORef a)
newIORef Intern Key
forall a. Intern a
Intern.empty
    Ids (Key, Status)
databaseValues <- IO (Ids (Key, Status))
forall a. IO (Ids a)
Ids.empty
    Ids IntSet
databaseReverseDeps <- IO (Ids IntSet)
forall a. IO (Ids a)
Ids.empty
    Lock
databaseReverseDepsLock <- IO Lock
newLock
    Database -> IO Database
forall (f :: * -> *) a. Applicative f => a -> f a
pure Database :: Dynamic
-> TheRules
-> IORef Step
-> Lock
-> IORef (Intern Key)
-> Ids (Key, Status)
-> Ids IntSet
-> Lock
-> Database
Database{TheRules
Dynamic
IORef (Intern Key)
IORef Step
Lock
Ids (Key, Status)
Ids IntSet
databaseReverseDepsLock :: Lock
databaseReverseDeps :: Ids IntSet
databaseValues :: Ids (Key, Status)
databaseIds :: IORef (Intern Key)
databaseLock :: Lock
databaseStep :: IORef Step
databaseRules :: TheRules
databaseExtra :: Dynamic
databaseReverseDepsLock :: Lock
databaseReverseDeps :: Ids IntSet
databaseValues :: Ids (Key, Status)
databaseIds :: IORef (Intern Key)
databaseLock :: Lock
databaseStep :: IORef Step
databaseRules :: TheRules
databaseExtra :: Dynamic
..}

-- | Increment the step and mark dirty
incDatabase :: Database -> Maybe [Key] -> IO ()
-- all keys are dirty
incDatabase :: Database -> Maybe [Key] -> IO ()
incDatabase Database
db Maybe [Key]
Nothing = do
    IORef Step -> (Step -> Step) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Database -> IORef Step
databaseStep Database
db) ((Step -> Step) -> IO ()) -> (Step -> Step) -> IO ()
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
    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock (Database -> Lock
databaseLock Database
db) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ids (Key, Status)
-> (Int -> (Key, Status) -> (Key, Status)) -> IO ()
forall a. Ids a -> (Int -> a -> a) -> IO ()
Ids.forMutate (Database -> Ids (Key, Status)
databaseValues Database
db) ((Int -> (Key, Status) -> (Key, Status)) -> IO ())
-> (Int -> (Key, Status) -> (Key, Status)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> (Status -> Status) -> (Key, Status) -> (Key, Status)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ((Status -> Status) -> (Key, Status) -> (Key, Status))
-> (Status -> Status) -> (Key, Status) -> (Key, Status)
forall a b. (a -> b) -> a -> b
$ \case
            Clean Result
x       -> Maybe Result -> Status
Dirty (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
x)
            Dirty Maybe Result
x       -> Maybe Result -> Status
Dirty Maybe Result
x
            Running IO ()
_ Result
_ Maybe Result
x -> Maybe Result -> Status
Dirty Maybe Result
x
-- only some keys are dirty
incDatabase Database
db (Just [Key]
kk) = do
    IORef Step -> (Step -> Step) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Database -> IORef Step
databaseStep Database
db) ((Step -> Step) -> IO ()) -> (Step -> Step) -> IO ()
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
    Intern Key
intern <- IORef (Intern Key) -> IO (Intern Key)
forall a. IORef a -> IO a
readIORef (Database -> IORef (Intern Key)
databaseIds Database
db)
    let dirtyIds :: [Int]
dirtyIds = (Key -> Maybe Int) -> [Key] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key -> Intern Key -> Maybe Int
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Int
`Intern.lookup` Intern Key
intern) [Key]
kk
    IntSet
transitiveDirtyIds <- Database -> [Int] -> IO IntSet
forall (t :: * -> *). Foldable t => Database -> t Int -> IO IntSet
transitiveDirtySet Database
db [Int]
dirtyIds
    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock (Database -> Lock
databaseLock Database
db) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ids (Key, Status)
-> (Int -> (Key, Status) -> (Key, Status)) -> IO ()
forall a. Ids a -> (Int -> a -> a) -> IO ()
Ids.forMutate (Database -> Ids (Key, Status)
databaseValues Database
db) ((Int -> (Key, Status) -> (Key, Status)) -> IO ())
-> (Int -> (Key, Status) -> (Key, Status)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> \case
            (Key
k, Running IO ()
_ Result
_ Maybe Result
x) -> (Key
k, Maybe Result -> Status
Dirty Maybe Result
x)
            (Key
k, Clean Result
x) | Int
i Int -> IntSet -> Bool
`Set.member` IntSet
transitiveDirtyIds ->
                (Key
k, Maybe Result -> Status
Dirty (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
x))
            (Key, Status)
other -> (Key, Status)
other


-- | 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 -> [key] -> IO ([Id], [value])
build :: Database -> [key] -> IO ([Int], [value])
build Database
db [key]
keys = do
    ([Int]
ids, [Result]
vs) <- AIO ([Int], [Result]) -> IO ([Int], [Result])
forall a. AIO a -> IO a
runAIO (AIO ([Int], [Result]) -> IO ([Int], [Result]))
-> AIO ([Int], [Result]) -> IO ([Int], [Result])
forall a b. (a -> b) -> a -> b
$ ([(Int, Result)] -> ([Int], [Result]))
-> AIO [(Int, Result)] -> AIO ([Int], [Result])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, Result)] -> ([Int], [Result])
forall a b. [(a, b)] -> ([a], [b])
unzip (AIO [(Int, Result)] -> AIO ([Int], [Result]))
-> AIO [(Int, Result)] -> AIO ([Int], [Result])
forall a b. (a -> b) -> a -> b
$ ([(Int, Result)] -> AIO [(Int, Result)])
-> (IO [(Int, Result)] -> AIO [(Int, Result)])
-> Either [(Int, Result)] (IO [(Int, Result)])
-> AIO [(Int, Result)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [(Int, Result)] -> AIO [(Int, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return IO [(Int, Result)] -> AIO [(Int, Result)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Either [(Int, Result)] (IO [(Int, Result)])
 -> AIO [(Int, Result)])
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
-> AIO [(Int, Result)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Database
-> [Either Int Key]
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
builder Database
db ((key -> Either Int Key) -> [key] -> [Either Int Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key -> Either Int Key
forall a b. b -> Either a b
Right (Key -> Either Int Key) -> (key -> Key) -> key -> Either Int Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key) [key]
keys)
    ([Int], [value]) -> IO ([Int], [value])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
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 -> [Either Id Key] -> AIO (Either [(Id, Result)] (IO [(Id, Result)]))
builder :: Database
-> [Either Int Key]
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
builder db :: Database
db@Database{TheRules
Dynamic
IORef (Intern Key)
IORef Step
Lock
Ids (Key, Status)
Ids IntSet
databaseReverseDepsLock :: Lock
databaseReverseDeps :: Ids IntSet
databaseValues :: Ids (Key, Status)
databaseIds :: IORef (Intern Key)
databaseLock :: Lock
databaseStep :: IORef Step
databaseRules :: TheRules
databaseExtra :: Dynamic
databaseReverseDepsLock :: Database -> Lock
databaseReverseDeps :: Database -> Ids IntSet
databaseValues :: Database -> Ids (Key, Status)
databaseIds :: Database -> IORef (Intern Key)
databaseLock :: Database -> Lock
databaseStep :: Database -> IORef Step
databaseRules :: Database -> TheRules
databaseExtra :: Database -> Dynamic
..} [Either Int Key]
keys = do
        -- Things that I need to force before my results are ready
        IORef [Wait (IO ())]
toForce <- IO (IORef [Wait (IO ())]) -> AIO (IORef [Wait (IO ())])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [Wait (IO ())]) -> AIO (IORef [Wait (IO ())]))
-> IO (IORef [Wait (IO ())]) -> AIO (IORef [Wait (IO ())])
forall a b. (a -> b) -> a -> b
$ [Wait (IO ())] -> IO (IORef [Wait (IO ())])
forall a. a -> IO (IORef a)
newIORef []

        [(Int, Result)]
results <- Lock -> AIO [(Int, Result)] -> AIO [(Int, Result)]
forall a. Lock -> AIO a -> AIO a
withLockAIO Lock
databaseLock (AIO [(Int, Result)] -> AIO [(Int, Result)])
-> AIO [(Int, Result)] -> AIO [(Int, Result)]
forall a b. (a -> b) -> a -> b
$ do
            ((Either Int Key -> AIO (Int, Result))
 -> [Either Int Key] -> AIO [(Int, Result)])
-> [Either Int Key]
-> (Either Int Key -> AIO (Int, Result))
-> AIO [(Int, Result)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either Int Key -> AIO (Int, Result))
-> [Either Int Key] -> AIO [(Int, Result)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Either Int Key]
keys ((Either Int Key -> AIO (Int, Result)) -> AIO [(Int, Result)])
-> (Either Int Key -> AIO (Int, Result)) -> AIO [(Int, Result)]
forall a b. (a -> b) -> a -> b
$ \Either Int Key
idKey -> do
                -- Resolve the id
                Int
id <- case Either Int Key
idKey of
                    Left Int
id -> Int -> AIO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
id
                    Right Key
key -> IO Int -> AIO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> AIO Int) -> IO Int -> AIO Int
forall a b. (a -> b) -> a -> b
$ do
                        Intern Key
ids <- IORef (Intern Key) -> IO (Intern Key)
forall a. IORef a -> IO a
readIORef IORef (Intern Key)
databaseIds
                        case Key -> Intern Key -> Maybe Int
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Int
Intern.lookup Key
key Intern Key
ids of
                            Just Int
v -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
v
                            Maybe Int
Nothing -> do
                                (Intern Key
ids, Int
id) <- (Intern Key, Int) -> IO (Intern Key, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Intern Key, Int) -> IO (Intern Key, Int))
-> (Intern Key, Int) -> IO (Intern Key, Int)
forall a b. (a -> b) -> a -> b
$ Key -> Intern Key -> (Intern Key, Int)
forall a. (Eq a, Hashable a) => a -> Intern a -> (Intern a, Int)
Intern.add Key
key Intern Key
ids
                                IORef (Intern Key) -> Intern Key -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef (Intern Key)
databaseIds Intern Key
ids
                                Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
id

                -- Spawn the id if needed
                Maybe (Key, Status)
status <- IO (Maybe (Key, Status)) -> AIO (Maybe (Key, Status))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Key, Status)) -> AIO (Maybe (Key, Status)))
-> IO (Maybe (Key, Status)) -> AIO (Maybe (Key, Status))
forall a b. (a -> b) -> a -> b
$ Ids (Key, Status) -> Int -> IO (Maybe (Key, Status))
forall a. Ids a -> Int -> IO (Maybe a)
Ids.lookup Ids (Key, Status)
databaseValues Int
id
                Result
val <- case (Key, Status) -> Maybe (Key, Status) -> (Key, Status)
forall a. a -> Maybe a -> a
fromMaybe (Key -> Either Int Key -> Key
forall b a. b -> Either a b -> b
fromRight Key
forall a. HasCallStack => a
undefined Either Int Key
idKey, Maybe Result -> Status
Dirty Maybe Result
forall a. Maybe a
Nothing) Maybe (Key, Status)
status of
                    (Key
_, Clean Result
r) -> Result -> AIO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
                    (Key
_, Running IO ()
force Result
val Maybe Result
_) -> do
                        IO () -> AIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ IORef [Wait (IO ())] -> ([Wait (IO ())] -> [Wait (IO ())]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Wait (IO ())]
toForce (IO () -> Wait (IO ())
forall a. a -> Wait a
Wait IO ()
force Wait (IO ()) -> [Wait (IO ())] -> [Wait (IO ())]
forall a. a -> [a] -> [a]
:)
                        Result -> AIO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val
                    (Key
key, Dirty Maybe Result
s) -> do
                        IO (IO Result)
act <- AIO (IO Result) -> AIO (IO (IO Result))
forall a. AIO a -> AIO (IO a)
unliftAIO (Database -> Key -> Int -> Maybe Result -> AIO (IO Result)
refresh Database
db Key
key Int
id Maybe Result
s)
                        let (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)
                        IO () -> AIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ Ids (Key, Status) -> Int -> (Key, Status) -> IO ()
forall a. Ids a -> Int -> a -> IO ()
Ids.insert Ids (Key, Status)
databaseValues Int
id (Key
key, IO () -> Result -> Maybe Result -> Status
Running IO ()
force Result
val Maybe Result
s)
                        IO () -> AIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ IORef [Wait (IO ())] -> ([Wait (IO ())] -> [Wait (IO ())]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Wait (IO ())]
toForce (IO () -> Wait (IO ())
forall a. a -> Wait a
Spawn IO ()
forceWait (IO ()) -> [Wait (IO ())] -> [Wait (IO ())]
forall a. a -> [a] -> [a]
:)
                        Result -> AIO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
val

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

        [Wait (IO ())]
toForceList <- IO [Wait (IO ())] -> AIO [Wait (IO ())]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Wait (IO ())] -> AIO [Wait (IO ())])
-> IO [Wait (IO ())] -> AIO [Wait (IO ())]
forall a b. (a -> b) -> a -> b
$ IORef [Wait (IO ())] -> IO [Wait (IO ())]
forall a. IORef a -> IO a
readIORef IORef [Wait (IO ())]
toForce
        IO ()
waitAll <- AIO () -> AIO (IO ())
forall a. AIO a -> AIO (IO a)
unliftAIO (AIO () -> AIO (IO ())) -> AIO () -> AIO (IO ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> [Wait (IO ())] -> AIO ()
forall a. (a -> IO ()) -> [Wait a] -> AIO ()
mapConcurrentlyAIO_ IO () -> IO ()
forall a. a -> a
id [Wait (IO ())]
toForceList
        case [Wait (IO ())]
toForceList of
            [] -> Either [(Int, Result)] (IO [(Int, Result)])
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(Int, Result)] (IO [(Int, Result)])
 -> AIO (Either [(Int, Result)] (IO [(Int, Result)])))
-> Either [(Int, Result)] (IO [(Int, Result)])
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
forall a b. (a -> b) -> a -> b
$ [(Int, Result)] -> Either [(Int, Result)] (IO [(Int, Result)])
forall a b. a -> Either a b
Left [(Int, Result)]
results
            [Wait (IO ())]
_ -> Either [(Int, Result)] (IO [(Int, Result)])
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(Int, Result)] (IO [(Int, Result)])
 -> AIO (Either [(Int, Result)] (IO [(Int, Result)])))
-> Either [(Int, Result)] (IO [(Int, Result)])
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
forall a b. (a -> b) -> a -> b
$ IO [(Int, Result)] -> Either [(Int, Result)] (IO [(Int, Result)])
forall a b. b -> Either a b
Right (IO [(Int, Result)] -> Either [(Int, Result)] (IO [(Int, Result)]))
-> IO [(Int, Result)]
-> Either [(Int, Result)] (IO [(Int, Result)])
forall a b. (a -> b) -> a -> b
$ do
                    IO ()
waitAll
                    [(Int, Result)] -> IO [(Int, Result)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Int, 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 -> Key -> Id -> Maybe Result -> AIO (IO Result)
refresh :: Database -> Key -> Int -> Maybe Result -> AIO (IO Result)
refresh Database
db Key
key Int
id result :: Maybe Result
result@(Just me :: Result
me@Result{resultDeps :: Result -> ResultDeps
resultDeps = ResultDeps [Int]
deps}) = do
    Either [(Int, Result)] (IO [(Int, Result)])
res <- Database
-> [Either Int Key]
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
builder Database
db ([Either Int Key]
 -> AIO (Either [(Int, Result)] (IO [(Int, Result)])))
-> [Either Int Key]
-> AIO (Either [(Int, Result)] (IO [(Int, Result)]))
forall a b. (a -> b) -> a -> b
$ (Int -> Either Int Key) -> [Int] -> [Either Int Key]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Either Int Key
forall a b. a -> Either a b
Left [Int]
deps
    case Either [(Int, Result)] (IO [(Int, Result)])
res of
      Left [(Int, Result)]
res ->
        if [(Int, Result)] -> Bool
isDirty [(Int, 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 -> Key -> Int -> RunMode -> Maybe Result -> IO Result
compute Database
db Key
key Int
id 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 -> Key -> Int -> RunMode -> Maybe Result -> IO Result
compute Database
db Key
key Int
id RunMode
RunDependenciesSame Maybe Result
result
      Right IO [(Int, 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
        [(Int, Result)]
res <- IO [(Int, Result)]
iores
        let mode :: RunMode
mode = if [(Int, Result)] -> Bool
isDirty [(Int, Result)]
res then RunMode
RunDependenciesChanged else RunMode
RunDependenciesSame
        Database -> Key -> Int -> RunMode -> Maybe Result -> IO Result
compute Database
db Key
key Int
id RunMode
mode Maybe Result
result
    where
        isDirty :: [(Int, Result)] -> Bool
isDirty = ((Int, Result) -> Bool) -> [(Int, Result)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
_,Result
dep) -> Result -> Step
resultBuilt Result
me Step -> Step -> Bool
forall a. Ord a => a -> a -> Bool
< Result -> Step
resultChanged Result
dep)

refresh Database
db Key
key Int
id Maybe Result
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 -> Key -> Int -> RunMode -> Maybe Result -> IO Result
compute Database
db Key
key Int
id RunMode
RunDependenciesChanged Maybe Result
result


-- | Compute a key.
compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result
compute :: Database -> Key -> Int -> RunMode -> Maybe Result -> IO Result
compute db :: Database
db@Database{TheRules
Dynamic
IORef (Intern Key)
IORef Step
Lock
Ids (Key, Status)
Ids IntSet
databaseReverseDepsLock :: Lock
databaseReverseDeps :: Ids IntSet
databaseValues :: Ids (Key, Status)
databaseIds :: IORef (Intern Key)
databaseLock :: Lock
databaseStep :: IORef Step
databaseRules :: TheRules
databaseExtra :: Dynamic
databaseReverseDepsLock :: Database -> Lock
databaseReverseDeps :: Database -> Ids IntSet
databaseValues :: Database -> Ids (Key, Status)
databaseIds :: Database -> IORef (Intern Key)
databaseLock :: Database -> Lock
databaseStep :: Database -> IORef Step
databaseRules :: Database -> TheRules
databaseExtra :: Database -> Dynamic
..} Key
key Int
id 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 -> SAction
SAction Database
db IORef ResultDeps
deps
    Step
built <- IORef Step -> IO Step
forall a. IORef a -> IO a
readIORef IORef 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 [Int] -> ResultDeps -> [Int]
getResultDepsDefault [] ResultDeps
actualDeps of
        [Int]
deps | Bool -> Bool
not([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
deps)
            Bool -> Bool -> Bool
&& RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
/= RunChanged
ChangedNothing
                    -> do
            IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
                Int -> Database -> [Int] -> IntSet -> IO ()
updateReverseDeps Int
id Database
db ([Int] -> ResultDeps -> [Int]
getResultDepsDefault [] ResultDeps
previousDeps) ([Int] -> IntSet
Set.fromList [Int]
deps)
        [Int]
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
databaseLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ids (Key, Status) -> Int -> (Key, Status) -> IO ()
forall a. Ids a -> Int -> a -> IO ()
Ids.insert Ids (Key, Status)
databaseValues Int
id (Key
key, Result -> Status
Clean Result
res)
    Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
res

-- | Returns the set of dirty keys annotated with their age (in # of builds)
getDirtySet :: Database -> IO [(Id,(Key, Int))]
getDirtySet :: Database -> IO [(Int, (Key, Int))]
getDirtySet Database
db = do
    Step Int
curr <- IORef Step -> IO Step
forall a. IORef a -> IO a
readIORef (Database -> IORef Step
databaseStep Database
db)
    [(Int, (Key, Status))]
dbContents <- Ids (Key, Status) -> IO [(Int, (Key, Status))]
forall a. Ids a -> IO [(Int, a)]
Ids.toList (Database -> Ids (Key, Status)
databaseValues 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
    [(Int, (Key, Int))] -> IO [(Int, (Key, Int))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, (Key, Int))] -> IO [(Int, (Key, Int))])
-> [(Int, (Key, Int))] -> IO [(Int, (Key, Int))]
forall a b. (a -> b) -> a -> b
$ ((Int, (Key, Status)) -> Maybe (Int, (Key, Int)))
-> [(Int, (Key, Status))] -> [(Int, (Key, Int))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((((Key, Status) -> Maybe (Key, Int))
-> (Int, (Key, Status)) -> Maybe (Int, (Key, Int))
forall (m :: * -> *) b b' a.
Functor m =>
(b -> m b') -> (a, b) -> m (a, b')
secondM(((Key, Status) -> Maybe (Key, Int))
 -> (Int, (Key, Status)) -> Maybe (Int, (Key, Int)))
-> ((Status -> Maybe Int) -> (Key, Status) -> Maybe (Key, Int))
-> (Status -> Maybe Int)
-> (Int, (Key, Status))
-> Maybe (Int, (Key, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(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) [(Int, (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 <- Ids (Key, Status) -> IO [(Key, Status)]
forall a. Ids a -> IO [a]
Ids.elems (Database -> Ids (Key, Status)
databaseValues Database
db)
    Step Int
curr <- IORef Step -> IO Step
forall a. IORef a -> IO a
readIORef (Database -> IORef 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
    :: Id         -- ^ Id
    -> Database
    -> [Id] -- ^ Previous direct dependencies of Id
    -> IntSet     -- ^ Current direct dependencies of Id
    -> IO ()
updateReverseDeps :: Int -> Database -> [Int] -> IntSet -> IO ()
updateReverseDeps Int
myId Database
db [Int]
prev IntSet
new = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock (Database -> Lock
databaseReverseDepsLock Database
db) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
prev ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
d ->
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
d Int -> IntSet -> Bool
`Set.member` IntSet
new) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (IntSet -> IntSet) -> Int -> IO ()
doOne (Int -> IntSet -> IntSet
Set.delete Int
myId) Int
d
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [Int]
Set.elems IntSet
new) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        (IntSet -> IntSet) -> Int -> IO ()
doOne (Int -> IntSet -> IntSet
Set.insert Int
myId)
    where
        doOne :: (IntSet -> IntSet) -> Int -> IO ()
doOne IntSet -> IntSet
f Int
id = do
            Maybe IntSet
rdeps <- Database -> Int -> IO (Maybe IntSet)
getReverseDependencies Database
db Int
id
            Ids IntSet -> Int -> IntSet -> IO ()
forall a. Ids a -> Int -> a -> IO ()
Ids.insert (Database -> Ids IntSet
databaseReverseDeps Database
db) Int
id (IntSet -> IntSet
f (IntSet -> IntSet) -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
forall a. Monoid a => a
mempty Maybe IntSet
rdeps)

getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet))
getReverseDependencies :: Database -> Int -> IO (Maybe IntSet)
getReverseDependencies Database
db = Ids IntSet -> Int -> IO (Maybe IntSet)
forall a. Ids a -> Int -> IO (Maybe a)
Ids.lookup (Database -> Ids IntSet
databaseReverseDeps Database
db)

transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet
transitiveDirtySet :: Database -> t Int -> IO IntSet
transitiveDirtySet Database
database = (StateT IntSet IO () -> IntSet -> IO IntSet)
-> IntSet -> StateT IntSet IO () -> IO IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT IntSet IO () -> IntSet -> IO IntSet
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT IntSet
Set.empty (StateT IntSet IO () -> IO IntSet)
-> (t Int -> StateT IntSet IO ()) -> t Int -> IO IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> StateT IntSet IO ()) -> t Int -> StateT IntSet IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> StateT IntSet IO ()
loop
  where
    loop :: Int -> StateT IntSet IO ()
loop Int
x = do
        IntSet
seen <- StateT IntSet IO IntSet
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
        if Int
x Int -> IntSet -> Bool
`Set.member` IntSet
seen then () -> StateT IntSet IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else do
            IntSet -> StateT IntSet IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Int -> IntSet -> IntSet
Set.insert Int
x IntSet
seen)
            Maybe IntSet
next <- IO (Maybe IntSet) -> StateT IntSet IO (Maybe IntSet)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe IntSet) -> StateT IntSet IO (Maybe IntSet))
-> IO (Maybe IntSet) -> StateT IntSet IO (Maybe IntSet)
forall a b. (a -> b) -> a -> b
$ Database -> Int -> IO (Maybe IntSet)
getReverseDependencies Database
database Int
x
            (Int -> StateT IntSet IO ()) -> [Int] -> StateT IntSet IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> StateT IntSet IO ()
loop ([Int] -> (IntSet -> [Int]) -> Maybe IntSet -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int]
forall a. Monoid a => a
mempty IntSet -> [Int]
Set.toList Maybe IntSet
next)

-- | IO extended to track created asyncs to clean them up when the thread is killed,
--   generalizing 'withAsync'
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)

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

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
    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

withLockAIO :: Lock -> AIO a -> AIO a
withLockAIO :: Lock -> AIO a -> AIO a
withLockAIO Lock
lock AIO a
act = do
    IO a
io <- AIO a -> AIO (IO a)
forall a. AIO a -> AIO (IO a)
unliftAIO AIO a
act
    IO a -> AIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> AIO a) -> IO a -> AIO a
forall a b. (a -> b) -> a -> b
$ Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
withLock Lock
lock IO a
io

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

cleanupAsync :: IORef [Async a] -> IO ()
cleanupAsync :: IORef [Async a] -> IO ()
cleanupAsync IORef [Async a]
ref = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Async a]
asyncs <- IORef [Async a] -> IO [Async a]
forall a. IORef a -> IO a
readIORef IORef [Async a]
ref
    (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
    (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 a
    = Wait {Wait a -> a
justWait :: !a}
    | Spawn {justWait :: !a}
    deriving a -> Wait b -> Wait a
(a -> b) -> Wait a -> Wait b
(forall a b. (a -> b) -> Wait a -> Wait b)
-> (forall a b. a -> Wait b -> Wait a) -> Functor Wait
forall a b. a -> Wait b -> Wait a
forall a b. (a -> b) -> Wait a -> Wait b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Wait b -> Wait a
$c<$ :: forall a b. a -> Wait b -> Wait a
fmap :: (a -> b) -> Wait a -> Wait b
$cfmap :: forall a b. (a -> b) -> Wait a -> Wait b
Functor

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

mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO ()
mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO ()
mapConcurrentlyAIO_ a -> IO ()
_ [] = () -> AIO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mapConcurrentlyAIO_ a -> IO ()
f [Wait a
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 ()) -> IO ()
forall a. Wait a -> a
justWait (Wait (IO ()) -> IO ()) -> Wait (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (a -> IO ()) -> Wait a -> Wait (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IO ()
f Wait a
one
mapConcurrentlyAIO_ a -> IO ()
f [Wait a]
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
    [Either (IO ()) (Async ())]
waits <- IO [Either (IO ()) (Async ())] -> AIO [Either (IO ()) (Async ())]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either (IO ()) (Async ())] -> AIO [Either (IO ()) (Async ())])
-> IO [Either (IO ()) (Async ())]
-> AIO [Either (IO ()) (Async ())]
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO [Either (IO ()) (Async ())])
-> IO [Either (IO ()) (Async ())]
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO [Either (IO ()) (Async ())])
 -> IO [Either (IO ()) (Async ())])
-> ((forall a. IO a -> IO a) -> IO [Either (IO ()) (Async ())])
-> IO [Either (IO ()) (Async ())]
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> 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 a -> IO (Either (IO ()) (Async ())))
-> [Wait a] -> IO [Either (IO ()) (Async ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Wait (IO ()) -> IO (Either (IO ()) (Async ()))
forall a. Wait (IO a) -> IO (Either (IO a) (Async a))
waitOrSpawn (Wait (IO ()) -> IO (Either (IO ()) (Async ())))
-> (Wait a -> Wait (IO ()))
-> Wait a
-> IO (Either (IO ()) (Async ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IO ()) -> Wait a -> Wait (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> (a -> IO ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO ()
f)) [Wait a]
many
        let asyncs :: [Async ()]
asyncs = [Either (IO ()) (Async ())] -> [Async ()]
forall a b. [Either a b] -> [b]
rights [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]
++)
        [Either (IO ()) (Async ())] -> IO [Either (IO ()) (Async ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [Either (IO ()) (Async ())]
waits
    IO () -> AIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AIO ()) -> IO () -> AIO ()
forall a b. (a -> b) -> a -> b
$ (Either (IO ()) (Async ()) -> IO ())
-> [Either (IO ()) (Async ())] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((IO () -> IO ())
-> (Async () -> IO ()) -> Either (IO ()) (Async ()) -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IO () -> IO ()
forall a. a -> a
id Async () -> IO ()
forall a. Async a -> IO a
wait) [Either (IO ()) (Async ())]
waits