{-# 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
..}
incDatabase :: Database -> Maybe [Key] -> IO ()
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
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
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
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
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
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
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 :: 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 :: 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
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
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
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
data Box a = Box {Box a -> a
fromBox :: a}
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)
updateReverseDeps
:: Id
-> Database
-> [Id]
-> IntSet
-> 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)
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