{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Development.Shake.Internal.Core.Run(
run,
Action, actionOnException, actionFinally, apply, apply1, traced,
getDatabaseValue,
getShakeOptions, getProgress,
getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,
Resource, newResourceIO, withResource, newThrottleIO,
newCacheIO,
unsafeExtraThread, unsafeAllowApply,
parallel,
orderOnlyAction,
batch,
runAfter
) where
import Control.Exception
import Control.Applicative
import Data.Tuple.Extra
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Typeable.Extra
import Data.Function
import Data.Either.Extra
import Data.List.Extra
import qualified Data.HashMap.Strict as Map
import Data.Dynamic
import Data.Maybe
import Data.IORef
import System.Directory
import System.IO.Extra
import System.Time.Extra
import Numeric.Extra
import qualified Data.ByteString as BS
import Development.Shake.Classes
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Core.Pool
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Resource
import Development.Shake.Internal.Value
import Development.Shake.Internal.Profile
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Timing
import General.Extra
import General.Concurrent
import General.Cleanup
import Prelude
run :: ShakeOptions -> Rules () -> IO ()
run :: ShakeOptions -> Rules () -> IO ()
run opts :: ShakeOptions
opts@ShakeOptions{..} rs :: Rules ()
rs = (if Bool
shakeLineBuffering then IO () -> IO ()
forall a. IO a -> IO a
withLineBuffering else IO () -> IO ()
forall a. a -> a
id) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
opts :: ShakeOptions
opts@ShakeOptions{..} <- if Int
shakeThreads Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then ShakeOptions -> IO ShakeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeOptions
opts else do Int
p <- IO Int
getProcessorCount; ShakeOptions -> IO ShakeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeOptions
opts{shakeThreads :: Int
shakeThreads=Int
p}
IO Double
start <- IO (IO Double)
offsetTime
(actions :: [Action ()]
actions, ruleinfo :: HashMap TypeRep BuiltinRule
ruleinfo, userRules :: HashMap TypeRep UserRule_
userRules) <- ShakeOptions
-> Rules ()
-> IO
([Action ()], HashMap TypeRep BuiltinRule,
HashMap TypeRep UserRule_)
runRules ShakeOptions
opts Rules ()
rs
Verbosity -> String -> IO ()
outputLocked <- do
Lock
lock <- IO Lock
newLock
(Verbosity -> String -> IO ()) -> IO (Verbosity -> String -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Verbosity -> String -> IO ())
-> IO (Verbosity -> String -> IO ()))
-> (Verbosity -> String -> IO ())
-> IO (Verbosity -> String -> IO ())
forall a b. (a -> b) -> a -> b
$ \v :: Verbosity
v msg :: String
msg -> Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
v String
msg
let diagnostic :: IO String -> IO ()
diagnostic | Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
< Verbosity
Diagnostic = IO () -> IO String -> IO ()
forall a b. a -> b -> a
const (IO () -> IO String -> IO ()) -> IO () -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = \act :: IO String
act -> do String
v <- IO String
act; Verbosity -> String -> IO ()
outputLocked Verbosity
Diagnostic (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "% " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
let output :: Verbosity -> String -> IO ()
output v :: Verbosity
v = Verbosity -> String -> IO ()
outputLocked Verbosity
v (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeOptions -> String -> String
shakeAbbreviationsApply ShakeOptions
opts
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Starting run"
IORef (Maybe (String, ShakeException))
except <- Maybe (String, ShakeException)
-> IO (IORef (Maybe (String, ShakeException)))
forall a. a -> IO (IORef a)
newIORef (Maybe (String, ShakeException)
forall a. Maybe a
Nothing :: Maybe (String, ShakeException))
let raiseError :: ShakeException -> IO ()
raiseError err :: ShakeException
err
| Bool -> Bool
not Bool
shakeStaunch = ShakeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO ShakeException
err
| Bool
otherwise = do
let named :: ShakeException -> String
named = ShakeOptions -> String -> String
shakeAbbreviationsApply ShakeOptions
opts (String -> String)
-> (ShakeException -> String) -> ShakeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeException -> String
shakeExceptionTarget
IORef (Maybe (String, ShakeException))
-> (Maybe (String, ShakeException)
-> (Maybe (String, ShakeException), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (String, ShakeException))
except ((Maybe (String, ShakeException)
-> (Maybe (String, ShakeException), ()))
-> IO ())
-> (Maybe (String, ShakeException)
-> (Maybe (String, ShakeException), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \v :: Maybe (String, ShakeException)
v -> ((String, ShakeException) -> Maybe (String, ShakeException)
forall a. a -> Maybe a
Just ((String, ShakeException) -> Maybe (String, ShakeException))
-> (String, ShakeException) -> Maybe (String, ShakeException)
forall a b. (a -> b) -> a -> b
$ (String, ShakeException)
-> Maybe (String, ShakeException) -> (String, ShakeException)
forall a. a -> Maybe a -> a
fromMaybe (ShakeException -> String
named ShakeException
err, ShakeException
err) Maybe (String, ShakeException)
v, ())
String
curdir <- IO String
getCurrentDirectory
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Starting run 2"
HashMap TypeRep Dynamic -> IO ()
checkShakeExtra HashMap TypeRep Dynamic
shakeExtra
IORef [IO ()]
after <- [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
IORef [(Key, Key)]
absent <- [(Key, Key)] -> IO (IORef [(Key, Key)])
forall a. a -> IO (IORef a)
newIORef []
(Cleanup -> IO ()) -> IO ()
forall a. (Cleanup -> IO a) -> IO a
withCleanup ((Cleanup -> IO ()) -> IO ()) -> (Cleanup -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cleanup :: Cleanup
cleanup -> do
Cleanup -> IO () -> IO ()
addCleanup_ Cleanup
cleanup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeTimings Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) IO ()
printTimings
IO ()
resetTimings
Int -> IO () -> IO ()
forall a. Int -> IO a -> IO a
withNumCapabilities Int
shakeThreads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Starting run 3"
ShakeOptions
-> (IO String -> IO ())
-> Map TypeRep (BinaryOp Key)
-> (Database -> IO ())
-> IO ()
forall a.
ShakeOptions
-> (IO String -> IO ())
-> Map TypeRep (BinaryOp Key)
-> (Database -> IO a)
-> IO a
withDatabase ShakeOptions
opts IO String -> IO ()
diagnostic ((BuiltinRule -> BinaryOp Key)
-> HashMap TypeRep BuiltinRule -> Map TypeRep (BinaryOp Key)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map BuiltinRule -> BinaryOp Key
builtinKey HashMap TypeRep BuiltinRule
ruleinfo) ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \database :: Database
database -> do
Barrier ()
wait <- IO (Barrier ())
forall a. IO (Barrier a)
newBarrier
let getProgress :: IO Progress
getProgress = do
Maybe String
failure <- ((String, ShakeException) -> String)
-> Maybe (String, ShakeException) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ShakeException) -> String
forall a b. (a, b) -> a
fst (Maybe (String, ShakeException) -> Maybe String)
-> IO (Maybe (String, ShakeException)) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe (String, ShakeException))
-> IO (Maybe (String, ShakeException))
forall a. IORef a -> IO a
readIORef IORef (Maybe (String, ShakeException))
except
Progress
stats <- Database -> IO Progress
progress Database
database
Progress -> IO Progress
forall (m :: * -> *) a. Monad m => a -> m a
return Progress
stats{isFailure :: Maybe String
isFailure=Maybe String
failure}
ThreadId
tid <- (IO () -> (Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO () -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IO () -> Either SomeException () -> IO ()
forall a b. a -> b -> a
const (IO () -> Either SomeException () -> IO ())
-> IO () -> Either SomeException () -> IO ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> () -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier ()
wait ()) (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
IO Progress -> IO ()
shakeProgress IO Progress
getProgress
Cleanup -> IO () -> IO ()
addCleanup_ Cleanup
cleanup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ThreadId -> IO ()
killThread ThreadId
tid
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> IO () -> IO (Maybe ())
forall a. Double -> IO a -> IO (Maybe a)
timeout 1 (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Barrier () -> IO ()
forall a. Barrier a -> IO a
waitBarrier Barrier ()
wait
String -> IO ()
addTiming "Running rules"
Bool -> Int -> (Pool -> IO ()) -> IO ()
runPool (Int
shakeThreads Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1) Int
shakeThreads ((Pool -> IO ()) -> IO ()) -> (Pool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \pool :: Pool
pool -> do
let s0 :: Global
s0 = Database
-> Pool
-> Cleanup
-> IO Double
-> HashMap TypeRep BuiltinRule
-> (Verbosity -> String -> IO ())
-> ShakeOptions
-> (IO String -> IO ())
-> String
-> IORef [IO ()]
-> IORef [(Key, Key)]
-> IO Progress
-> HashMap TypeRep UserRule_
-> Global
Global Database
database Pool
pool Cleanup
cleanup IO Double
start HashMap TypeRep BuiltinRule
ruleinfo Verbosity -> String -> IO ()
output ShakeOptions
opts IO String -> IO ()
diagnostic String
curdir IORef [IO ()]
after IORef [(Key, Key)]
absent IO Progress
getProgress HashMap TypeRep UserRule_
userRules
let s1 :: Local
s1 = Stack -> Verbosity -> Local
newLocal Stack
emptyStack Verbosity
shakeVerbosity
[Action ()] -> (Action () -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Action ()]
actions ((Action () -> IO ()) -> IO ()) -> (Action () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \act :: Action ()
act ->
Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolStart Pool
pool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global -> Local -> Action () -> Capture (Either SomeException ())
forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
s0 Local
s1 Action ()
act Capture (Either SomeException ())
-> Capture (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ \x :: Either SomeException ()
x -> case Either SomeException ()
x of
Left e :: SomeException
e -> ShakeException -> IO ()
raiseError (ShakeException -> IO ()) -> IO ShakeException -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Global -> [String] -> SomeException -> IO ShakeException
shakeException Global
s0 ["Top-level action/want"] SomeException
e
Right x :: ()
x -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x
IO ()
-> ((String, ShakeException) -> IO ())
-> Maybe (String, ShakeException)
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ShakeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ShakeException -> IO ())
-> ((String, ShakeException) -> ShakeException)
-> (String, ShakeException)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ShakeException) -> ShakeException
forall a b. (a, b) -> b
snd) (Maybe (String, ShakeException) -> IO ())
-> IO (Maybe (String, ShakeException)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Maybe (String, ShakeException))
-> IO (Maybe (String, ShakeException))
forall a. IORef a -> IO a
readIORef IORef (Maybe (String, ShakeException))
except
Database -> IO ()
assertFinishedDatabase Database
database
let putWhen :: Verbosity -> String -> IO ()
putWhen lvl :: Verbosity
lvl msg :: String
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
lvl) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
output Verbosity
lvl String
msg
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Action ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action ()]
actions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
putWhen Verbosity
Normal "Warning: No want/action statements, nothing to do"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Lint -> Bool
forall a. Maybe a -> Bool
isJust Maybe Lint
shakeLint) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
addTiming "Lint checking"
String -> String -> IO ()
lintCurrentDirectory String
curdir "After completion"
[(Key, Key)]
absent <- IORef [(Key, Key)] -> IO [(Key, Key)]
forall a. IORef a -> IO a
readIORef IORef [(Key, Key)]
absent
Database
-> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()
checkValid Database
database (HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint HashMap TypeRep BuiltinRule
ruleinfo) [(Key, Key)]
absent
Verbosity -> String -> IO ()
putWhen Verbosity
Loud "Lint checking succeeded"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
shakeReport [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
addTiming "Profile report"
[ProfileEntry]
report <- Database -> IO [ProfileEntry]
toReport Database
database
[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
shakeReport ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \file :: String
file -> do
Verbosity -> String -> IO ()
putWhen Verbosity
Normal (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Writing report to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
String -> [ProfileEntry] -> IO ()
writeProfile String
file [ProfileEntry]
report
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
shakeLiveFiles [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
addTiming "Listing live"
[Key]
live <- Database -> IO [Key]
listLive Database
database
let specialIsFileKey :: TypeRep -> Bool
specialIsFileKey t :: TypeRep
t = TyCon -> String
forall a. Show a => a -> String
show ((TyCon, [TypeRep]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [TypeRep]) -> TyCon) -> (TyCon, [TypeRep]) -> TyCon
forall a b. (a -> b) -> a -> b
$ TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "FileQ"
let liveFiles :: [String]
liveFiles = [Key -> String
forall a. Show a => a -> String
show Key
k | Key
k <- [Key]
live, TypeRep -> Bool
specialIsFileKey (TypeRep -> Bool) -> TypeRep -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k]
[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
shakeLiveFiles ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \file :: String
file -> do
Verbosity -> String -> IO ()
putWhen Verbosity
Normal (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Writing live list to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
(if String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "-" then String -> IO ()
putStr else String -> String -> IO ()
writeFile String
file) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
liveFiles
[IO ()]
after <- IORef [IO ()] -> IO [IO ()]
forall a. IORef a -> IO a
readIORef IORef [IO ()]
after
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([IO ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IO ()]
after) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
addTiming "Running runAfter"
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> [IO ()]
forall a. [a] -> [a]
reverse [IO ()]
after
checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()
mp :: HashMap TypeRep Dynamic
mp = do
let bad :: [(TypeRep, TypeRep)]
bad = [(TypeRep
k,TypeRep
t) | (k :: TypeRep
k,v :: Dynamic
v) <- HashMap TypeRep Dynamic -> [(TypeRep, Dynamic)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep Dynamic
mp, let t :: TypeRep
t = Dynamic -> TypeRep
dynTypeRep Dynamic
v, TypeRep
t TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeRep
k]
case [(TypeRep, TypeRep)]
bad of
(k :: TypeRep
k,t :: TypeRep
t):xs :: [(TypeRep, TypeRep)]
xs -> String -> [(String, Maybe String)] -> String -> IO ()
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured "Invalid Map in shakeExtra"
[("Key",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
k),("Value type",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t)]
(if [(TypeRep, TypeRep)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TypeRep, TypeRep)]
xs then "" else "Plus " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(TypeRep, TypeRep)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TypeRep, TypeRep)]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " other keys")
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintCurrentDirectory :: FilePath -> String -> IO ()
lintCurrentDirectory :: String -> String -> IO ()
lintCurrentDirectory old :: String
old msg :: String
msg = do
String
now <- IO String
getCurrentDirectory
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
old String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
now) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> IO ()
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
"Lint checking error - current directory has changed"
[("When", String -> Maybe String
forall a. a -> Maybe a
Just String
msg)
,("Wanted",String -> Maybe String
forall a. a -> Maybe a
Just String
old)
,("Got",String -> Maybe String
forall a. a -> Maybe a
Just String
now)]
""
withLineBuffering :: IO a -> IO a
withLineBuffering :: IO a -> IO a
withLineBuffering act :: IO a
act = do
BufferMode
out <- Handle -> IO BufferMode
hGetBuffering Handle
stdout
BufferMode
err <- Handle -> IO BufferMode
hGetBuffering Handle
stderr
if BufferMode
out BufferMode -> BufferMode -> Bool
forall a. Eq a => a -> a -> Bool
== BufferMode
LineBuffering Bool -> Bool -> Bool
&& BufferMode
err BufferMode -> BufferMode -> Bool
forall a. Eq a => a -> a -> Bool
== BufferMode
LineBuffering then IO a
act else do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
IO a
act IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
out
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
err
getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Either BS.ByteString value))
getDatabaseValue :: key -> Action (Maybe (Either ByteString value))
getDatabaseValue k :: key
k = do
global :: Global
global@Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
IO (Maybe (Either ByteString value))
-> Action (Maybe (Either ByteString value))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either ByteString value))
-> Action (Maybe (Either ByteString value)))
-> IO (Maybe (Either ByteString value))
-> Action (Maybe (Either ByteString value))
forall a b. (a -> b) -> a -> b
$ (Maybe (Either ByteString Value)
-> Maybe (Either ByteString value))
-> IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either ByteString Value -> Either ByteString value)
-> Maybe (Either ByteString Value)
-> Maybe (Either ByteString value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either ByteString Value -> Either ByteString value)
-> Maybe (Either ByteString Value)
-> Maybe (Either ByteString value))
-> (Either ByteString Value -> Either ByteString value)
-> Maybe (Either ByteString Value)
-> Maybe (Either ByteString value)
forall a b. (a -> b) -> a -> b
$ (Value -> value)
-> Either ByteString Value -> Either ByteString value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> value
forall a. Typeable a => Value -> a
fromValue) (IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString value)))
-> IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString value))
forall a b. (a -> b) -> a -> b
$ Database -> Key -> IO (Maybe (Either ByteString Value))
lookupStatus Database
globalDatabase (Key -> IO (Maybe (Either ByteString Value)))
-> Key -> IO (Maybe (Either ByteString Value))
forall a b. (a -> b) -> a -> b
$ key -> Key
forall a. ShakeValue a => a -> Key
newKey key
k
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
apply :: [key] -> Action [value]
apply ([key]
ks :: [key]) = (Maybe (Action [value]) -> Action [value]) -> Action [value]
forall a. (Maybe a -> a) -> a
withResultType ((Maybe (Action [value]) -> Action [value]) -> Action [value])
-> (Maybe (Action [value]) -> Action [value]) -> Action [value]
forall a b. (a -> b) -> a -> b
$ \(Maybe (Action [value])
p :: Maybe (Action [value])) -> do
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ (key -> IO ()) -> [key] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> (key -> ()) -> key -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key -> ()
forall a. NFData a => a -> ()
rnf) [key]
ks
let tk :: TypeRep
tk = Proxy key -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy key
forall k (t :: k). Proxy t
Proxy :: Proxy key)
tv :: TypeRep
tv = Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy value
forall k (t :: k). Proxy t
Proxy :: Proxy value)
Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
Local{Maybe String
localBlockApply :: Local -> Maybe String
localBlockApply :: Maybe String
localBlockApply} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
Maybe String -> (String -> Action ()) -> Action ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe String
localBlockApply ((String -> Action ()) -> Action ())
-> (String -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> (String -> IO ()) -> String -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> Maybe String -> String -> IO ()
forall a. TypeRep -> Maybe String -> String -> IO a
errorNoApply TypeRep
tk (key -> String
forall a. Show a => a -> String
show (key -> String) -> Maybe key -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [key] -> Maybe key
forall a. [a] -> Maybe a
listToMaybe [key]
ks)
case TypeRep -> HashMap TypeRep BuiltinRule -> Maybe BuiltinRule
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeRep
tk HashMap TypeRep BuiltinRule
globalRules of
Nothing -> IO [value] -> Action [value]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [value] -> Action [value]) -> IO [value] -> Action [value]
forall a b. (a -> b) -> a -> b
$ TypeRep -> Maybe String -> Maybe TypeRep -> IO [value]
forall a. TypeRep -> Maybe String -> Maybe TypeRep -> IO a
errorNoRuleToBuildType TypeRep
tk (key -> String
forall a. Show a => a -> String
show (key -> String) -> Maybe key -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [key] -> Maybe key
forall a. [a] -> Maybe a
listToMaybe [key]
ks) (TypeRep -> Maybe TypeRep
forall a. a -> Maybe a
Just TypeRep
tv)
Just BuiltinRule{builtinResult :: BuiltinRule -> TypeRep
builtinResult=TypeRep
tv2} | TypeRep
tv TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeRep
tv2 -> String -> Action [value]
forall a. String -> a
errorInternal (String -> Action [value]) -> String -> Action [value]
forall a b. (a -> b) -> a -> b
$ "result type does not match, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ " vs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tv2
_ -> ([Value] -> [value]) -> Action [Value] -> Action [value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> value) -> [Value] -> [value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> value
forall a. Typeable a => Value -> a
fromValue) (Action [Value] -> Action [value])
-> Action [Value] -> Action [value]
forall a b. (a -> b) -> a -> b
$ [Key] -> Action [Value]
applyKeyValue ([Key] -> Action [Value]) -> [Key] -> Action [Value]
forall a b. (a -> b) -> a -> b
$ (key -> Key) -> [key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map key -> Key
forall a. ShakeValue a => a -> Key
newKey [key]
ks
applyKeyValue :: [Key] -> Action [Value]
applyKeyValue :: [Key] -> Action [Value]
applyKeyValue [] = [Value] -> Action [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []
applyKeyValue ks :: [Key]
ks = do
global :: Global
global@Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
Local{Stack
localStack :: Local -> Stack
localStack :: Stack
localStack} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
(dur :: Double
dur, dep :: Depends
dep, vs :: [Value]
vs) <- RAW Global Local (Double, Depends, [Value])
-> Action (Double, Depends, [Value])
forall a. RAW Global Local a -> Action a
Action (RAW Global Local (Double, Depends, [Value])
-> Action (Double, Depends, [Value]))
-> RAW Global Local (Double, Depends, [Value])
-> Action (Double, Depends, [Value])
forall a b. (a -> b) -> a -> b
$ Capture (Either SomeException (Double, Depends, [Value]))
-> RAW Global Local (Double, Depends, [Value])
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture (Either SomeException (Double, Depends, [Value]))
-> RAW Global Local (Double, Depends, [Value]))
-> Capture (Either SomeException (Double, Depends, [Value]))
-> RAW Global Local (Double, Depends, [Value])
forall a b. (a -> b) -> a -> b
$ Pool
-> Database
-> BuildKey
-> Stack
-> [Key]
-> Capture (Either SomeException (Double, Depends, [Value]))
build Pool
globalPool Database
globalDatabase ((Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value)))
-> BuildKey
BuildKey ((Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value)))
-> BuildKey)
-> (Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value)))
-> BuildKey
forall a b. (a -> b) -> a -> b
$ Global
-> Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value))
runKey Global
global) Stack
localStack [Key]
ks
RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localDiscount :: Double
localDiscount=Local -> Double
localDiscount Local
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dur, localDepends :: [Depends]
localDepends=Depends
dep Depends -> [Depends] -> [Depends]
forall a. a -> [a] -> [a]
: Local -> [Depends]
localDepends Local
s}
[Value] -> Action [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs
runKey :: Global -> Stack -> Step -> Key -> Maybe (Result BS.ByteString) -> Bool -> Capture (Either SomeException (Bool, BS.ByteString, Result Value))
runKey :: Global
-> Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value))
runKey global :: Global
global@Global{globalOptions :: Global -> ShakeOptions
globalOptions=ShakeOptions{..},..} stack :: Stack
stack step :: Step
step k :: Key
k r :: Maybe (Result ByteString)
r dirtyChildren :: Bool
dirtyChildren continue :: Either SomeException (Bool, ByteString, Result Value) -> IO ()
continue = do
let tk :: TypeRep
tk = Key -> TypeRep
typeKey Key
k
BuiltinRule{..} <- case TypeRep -> HashMap TypeRep BuiltinRule -> Maybe BuiltinRule
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeRep
tk HashMap TypeRep BuiltinRule
globalRules of
Nothing -> TypeRep -> Maybe String -> Maybe TypeRep -> IO BuiltinRule
forall a. TypeRep -> Maybe String -> Maybe TypeRep -> IO a
errorNoRuleToBuildType TypeRep
tk (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k) Maybe TypeRep
forall a. Maybe a
Nothing
Just r :: BuiltinRule
r -> BuiltinRule -> IO BuiltinRule
forall (m :: * -> *) a. Monad m => a -> m a
return BuiltinRule
r
let s :: Local
s = Stack -> Verbosity -> Local
newLocal Stack
stack Verbosity
shakeVerbosity
IO Double
time <- IO (IO Double)
offsetTime
Global
-> Local
-> Action (RunResult Value, Local)
-> Capture (Either SomeException (RunResult Value, Local))
forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
global Local
s (do
RunResult Value
res <- BuiltinRun Key Value
builtinRun Key
k ((Result ByteString -> ByteString)
-> Maybe (Result ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result ByteString -> ByteString
forall a. Result a -> a
result Maybe (Result ByteString)
r) Bool
dirtyChildren
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ RunResult Value -> ()
forall a. NFData a => a -> ()
rnf RunResult Value
res
Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lint -> Maybe Lint
forall a. a -> Maybe a
Just Lint
LintFSATrace Maybe Lint -> Maybe Lint -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Lint
shakeLint) Action ()
trackCheckUsed
RAW Global Local (RunResult Value, Local)
-> Action (RunResult Value, Local)
forall a. RAW Global Local a -> Action a
Action (RAW Global Local (RunResult Value, Local)
-> Action (RunResult Value, Local))
-> RAW Global Local (RunResult Value, Local)
-> Action (RunResult Value, Local)
forall a b. (a -> b) -> a -> b
$ (Local -> (RunResult Value, Local))
-> RAW Global Local Local
-> RAW Global Local (RunResult Value, Local)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) RunResult Value
res) RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW) Capture (Either SomeException (RunResult Value, Local))
-> Capture (Either SomeException (RunResult Value, Local))
forall a b. (a -> b) -> a -> b
$ \x :: Either SomeException (RunResult Value, Local)
x -> case Either SomeException (RunResult Value, Local)
x of
Left e :: SomeException
e -> do
SomeException
e <- if Maybe Lint -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Lint
shakeLint then SomeException -> IO SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return SomeException
e else (SomeException -> IO SomeException)
-> IO SomeException -> IO SomeException
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return (IO SomeException -> IO SomeException)
-> IO SomeException -> IO SomeException
forall a b. (a -> b) -> a -> b
$
do String -> String -> IO ()
lintCurrentDirectory String
globalCurDir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Running " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
k; SomeException -> IO SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return SomeException
e
Either SomeException (Bool, ByteString, Result Value) -> IO ()
continue (Either SomeException (Bool, ByteString, Result Value) -> IO ())
-> (ShakeException
-> Either SomeException (Bool, ByteString, Result Value))
-> ShakeException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException
-> Either SomeException (Bool, ByteString, Result Value)
forall a b. a -> Either a b
Left (SomeException
-> Either SomeException (Bool, ByteString, Result Value))
-> (ShakeException -> SomeException)
-> ShakeException
-> Either SomeException (Bool, ByteString, Result Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeException -> SomeException
forall e. Exception e => e -> SomeException
toException (ShakeException -> IO ()) -> IO ShakeException -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Global -> [String] -> SomeException -> IO ShakeException
shakeException Global
global (Stack -> [String]
showStack Stack
stack) SomeException
e
Right (RunResult{..}, Local{..})
| RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedNothing Bool -> Bool -> Bool
|| RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedStore, Just r :: Result ByteString
r <- Maybe (Result ByteString)
r ->
Either SomeException (Bool, ByteString, Result Value) -> IO ()
continue (Either SomeException (Bool, ByteString, Result Value) -> IO ())
-> Either SomeException (Bool, ByteString, Result Value) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Bool, ByteString, Result Value)
-> Either SomeException (Bool, ByteString, Result Value)
forall a b. b -> Either a b
Right (RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedStore, ByteString
runStore, Result ByteString
r{result :: Value
result = Value
runValue})
| Bool
otherwise -> do
Double
dur <- IO Double
time
let c :: Step
c | Just r :: Result ByteString
r <- Maybe (Result ByteString)
r, RunChanged
runChanged RunChanged -> RunChanged -> Bool
forall a. Eq a => a -> a -> Bool
== RunChanged
ChangedRecomputeSame = Result ByteString -> Step
forall a. Result a -> Step
changed Result ByteString
r
| Bool
otherwise = Step
step
Either SomeException (Bool, ByteString, Result Value) -> IO ()
continue (Either SomeException (Bool, ByteString, Result Value) -> IO ())
-> Either SomeException (Bool, ByteString, Result Value) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Bool, ByteString, Result Value)
-> Either SomeException (Bool, ByteString, Result Value)
forall a b. b -> Either a b
Right ((Bool, ByteString, Result Value)
-> Either SomeException (Bool, ByteString, Result Value))
-> (Bool, ByteString, Result Value)
-> Either SomeException (Bool, ByteString, Result Value)
forall a b. (a -> b) -> a -> b
$ (,,) Bool
True ByteString
runStore $WResult :: forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result
{result :: Value
result = Value
runValue
,changed :: Step
changed = Step
c
,built :: Step
built = Step
step
,depends :: [Depends]
depends = [Depends] -> [Depends]
nubDepends ([Depends] -> [Depends]) -> [Depends] -> [Depends]
forall a b. (a -> b) -> a -> b
$ [Depends] -> [Depends]
forall a. [a] -> [a]
reverse [Depends]
localDepends
,execution :: Float
execution = Double -> Float
doubleToFloat (Double -> Float) -> Double -> Float
forall a b. (a -> b) -> a -> b
$ Double
dur Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
localDiscount
,traces :: [Trace]
traces = [Trace] -> [Trace]
forall a. [a] -> [a]
reverse [Trace]
localTraces}
runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint :: HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint mp :: HashMap TypeRep BuiltinRule
mp k :: Key
k v :: Value
v = case TypeRep -> HashMap TypeRep BuiltinRule -> Maybe BuiltinRule
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (Key -> TypeRep
typeKey Key
k) HashMap TypeRep BuiltinRule
mp of
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just BuiltinRule{..} -> Key -> Value -> IO (Maybe String)
builtinLint Key
k Value
v
shakeException :: Global -> [String] -> SomeException -> IO ShakeException
shakeException :: Global -> [String] -> SomeException -> IO ShakeException
shakeException Global{globalOptions :: Global -> ShakeOptions
globalOptions=ShakeOptions{..},..} stk :: [String]
stk e :: SomeException
e@(SomeException inner :: e
inner) = case e -> Maybe ShakeException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
inner of
Just e :: ShakeException
e@ShakeException{} -> ShakeException -> IO ShakeException
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeException
e
Nothing -> do
ShakeException
e <- ShakeException -> IO ShakeException
forall (m :: * -> *) a. Monad m => a -> m a
return (ShakeException -> IO ShakeException)
-> ShakeException -> IO ShakeException
forall a b. (a -> b) -> a -> b
$ String -> [String] -> SomeException -> ShakeException
ShakeException ([String] -> String
forall a. [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ "Unknown call stack" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
stk) [String]
stk SomeException
e
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeStaunch Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
globalOutput Verbosity
Quiet (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeException -> String
forall a. Show a => a -> String
show ShakeException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Continuing due to staunch mode"
ShakeException -> IO ShakeException
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeException
e
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
apply1 :: key -> Action value
apply1 = ([value] -> value) -> Action [value] -> Action value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [value] -> value
forall a. [a] -> a
head (Action [value] -> Action value)
-> (key -> Action [value]) -> key -> Action value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [key] -> Action [value]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply ([key] -> Action [value])
-> (key -> [key]) -> key -> Action [value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key -> [key]
forall (m :: * -> *) a. Monad m => a -> m a
return
withResource :: Resource -> Int -> Action a -> Action a
withResource :: Resource -> Int -> Action a -> Action a
withResource r :: Resource
r i :: Int
i act :: Action a
act = do
Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " waiting to acquire " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
IO Double
offset <- IO (IO Double) -> Action (IO Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Double)
offsetTime
RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ Capture (Either SomeException ()) -> RAW Global Local ()
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture (Either SomeException ()) -> RAW Global Local ())
-> Capture (Either SomeException ()) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \continue :: Either SomeException () -> IO ()
continue -> Resource -> Pool -> Int -> IO () -> IO ()
acquireResource Resource
r Pool
globalPool Int
i (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException () -> IO ()
continue (Either SomeException () -> IO ())
-> Either SomeException () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> Either SomeException ()
forall a b. b -> Either a b
Right ()
Either SomeException a
res <- RAW Global Local (Either SomeException a)
-> Action (Either SomeException a)
forall a. RAW Global Local a -> Action a
Action (RAW Global Local (Either SomeException a)
-> Action (Either SomeException a))
-> RAW Global Local (Either SomeException a)
-> Action (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ RAW Global Local a -> RAW Global Local (Either SomeException a)
forall ro rw a. RAW ro rw a -> RAW ro rw (Either SomeException a)
tryRAW (RAW Global Local a -> RAW Global Local (Either SomeException a))
-> RAW Global Local a -> RAW Global Local (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ Action a -> RAW Global Local a
forall a. Action a -> RAW Global Local a
fromAction (Action a -> RAW Global Local a) -> Action a -> RAW Global Local a
forall a b. (a -> b) -> a -> b
$ String -> Action a -> Action a
forall a. String -> Action a -> Action a
blockApply ("Within withResource using " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Resource -> String
forall a. Show a => a -> String
show Resource
r) (Action a -> Action a) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ do
Double
offset <- IO Double -> Action Double
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Double
offset
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " acquired " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
showDuration Double
offset
RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localDiscount :: Double
localDiscount = Local -> Double
localDiscount Local
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset}
Action a
act
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Resource -> Pool -> Int -> IO ()
releaseResource Resource
r Pool
globalPool Int
i
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " released " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
RAW Global Local a -> Action a
forall a. RAW Global Local a -> Action a
Action (RAW Global Local a -> Action a) -> RAW Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ (SomeException -> RAW Global Local a)
-> (a -> RAW Global Local a)
-> Either SomeException a
-> RAW Global Local a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RAW Global Local a
forall e ro rw a. Exception e => e -> RAW ro rw a
throwRAW a -> RAW Global Local a
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException a
res
newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)
newCacheIO :: (k -> Action v) -> IO (k -> Action v)
newCacheIO (k -> Action v
act :: k -> Action v) = do
Var (HashMap k (Fence (Either SomeException ([Depends], v))))
var :: Var (Map.HashMap k (Fence (Either SomeException ([Depends],v)))) <- HashMap k (Fence (Either SomeException ([Depends], v)))
-> IO
(Var (HashMap k (Fence (Either SomeException ([Depends], v)))))
forall a. a -> IO (Var a)
newVar HashMap k (Fence (Either SomeException ([Depends], v)))
forall k v. HashMap k v
Map.empty
(k -> Action v) -> IO (k -> Action v)
forall (m :: * -> *) a. Monad m => a -> m a
return ((k -> Action v) -> IO (k -> Action v))
-> (k -> Action v) -> IO (k -> Action v)
forall a b. (a -> b) -> a -> b
$ \key :: k
key ->
Action (Action v) -> Action v
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Action (Action v) -> Action v) -> Action (Action v) -> Action v
forall a b. (a -> b) -> a -> b
$ IO (Action v) -> Action (Action v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Action v) -> Action (Action v))
-> IO (Action v) -> Action (Action v)
forall a b. (a -> b) -> a -> b
$ Var (HashMap k (Fence (Either SomeException ([Depends], v))))
-> (HashMap k (Fence (Either SomeException ([Depends], v)))
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> IO (Action v)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap k (Fence (Either SomeException ([Depends], v))))
var ((HashMap k (Fence (Either SomeException ([Depends], v)))
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> IO (Action v))
-> (HashMap k (Fence (Either SomeException ([Depends], v)))
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> IO (Action v)
forall a b. (a -> b) -> a -> b
$ \mp :: HashMap k (Fence (Either SomeException ([Depends], v)))
mp -> case k
-> HashMap k (Fence (Either SomeException ([Depends], v)))
-> Maybe (Fence (Either SomeException ([Depends], v)))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
key HashMap k (Fence (Either SomeException ([Depends], v)))
mp of
Just bar :: Fence (Either SomeException ([Depends], v))
bar -> (HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
forall a b. (a -> b) -> a -> b
$ (,) HashMap k (Fence (Either SomeException ([Depends], v)))
mp (Action v
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> Action v
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
forall a b. (a -> b) -> a -> b
$ do
Maybe (Either SomeException ([Depends], v))
res <- IO (Maybe (Either SomeException ([Depends], v)))
-> Action (Maybe (Either SomeException ([Depends], v)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either SomeException ([Depends], v)))
-> Action (Maybe (Either SomeException ([Depends], v))))
-> IO (Maybe (Either SomeException ([Depends], v)))
-> Action (Maybe (Either SomeException ([Depends], v)))
forall a b. (a -> b) -> a -> b
$ Fence (Either SomeException ([Depends], v))
-> IO (Maybe (Either SomeException ([Depends], v)))
forall a. Fence a -> IO (Maybe a)
testFence Fence (Either SomeException ([Depends], v))
bar
(res :: Either SomeException ([Depends], v)
res,offset :: Double
offset) <- case Maybe (Either SomeException ([Depends], v))
res of
Just res :: Either SomeException ([Depends], v)
res -> (Either SomeException ([Depends], v), Double)
-> Action (Either SomeException ([Depends], v), Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException ([Depends], v)
res, 0)
Nothing -> do
Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
IO Double
offset <- IO (IO Double) -> Action (IO Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Double)
offsetTime
RAW Global Local (Either SomeException ([Depends], v), Double)
-> Action (Either SomeException ([Depends], v), Double)
forall a. RAW Global Local a -> Action a
Action (RAW Global Local (Either SomeException ([Depends], v), Double)
-> Action (Either SomeException ([Depends], v), Double))
-> RAW Global Local (Either SomeException ([Depends], v), Double)
-> Action (Either SomeException ([Depends], v), Double)
forall a b. (a -> b) -> a -> b
$ Capture
(Either
SomeException (Either SomeException ([Depends], v), Double))
-> RAW Global Local (Either SomeException ([Depends], v), Double)
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture
(Either
SomeException (Either SomeException ([Depends], v), Double))
-> RAW Global Local (Either SomeException ([Depends], v), Double))
-> Capture
(Either
SomeException (Either SomeException ([Depends], v), Double))
-> RAW Global Local (Either SomeException ([Depends], v), Double)
forall a b. (a -> b) -> a -> b
$ \k :: Either SomeException (Either SomeException ([Depends], v), Double)
-> IO ()
k -> Fence (Either SomeException ([Depends], v))
-> (Either SomeException ([Depends], v) -> IO ()) -> IO ()
forall a. Fence a -> (a -> IO ()) -> IO ()
waitFence Fence (Either SomeException ([Depends], v))
bar ((Either SomeException ([Depends], v) -> IO ()) -> IO ())
-> (Either SomeException ([Depends], v) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \v :: Either SomeException ([Depends], v)
v ->
Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Double
offset <- IO Double -> IO Double
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Double
offset; Either SomeException (Either SomeException ([Depends], v), Double)
-> IO ()
k (Either SomeException (Either SomeException ([Depends], v), Double)
-> IO ())
-> Either
SomeException (Either SomeException ([Depends], v), Double)
-> IO ()
forall a b. (a -> b) -> a -> b
$ (Either SomeException ([Depends], v), Double)
-> Either
SomeException (Either SomeException ([Depends], v), Double)
forall a b. b -> Either a b
Right (Either SomeException ([Depends], v)
v,Double
offset)
case Either SomeException ([Depends], v)
res of
Left err :: SomeException
err -> RAW Global Local v -> Action v
forall a. RAW Global Local a -> Action a
Action (RAW Global Local v -> Action v) -> RAW Global Local v -> Action v
forall a b. (a -> b) -> a -> b
$ SomeException -> RAW Global Local v
forall e ro rw a. Exception e => e -> RAW ro rw a
throwRAW SomeException
err
Right (deps :: [Depends]
deps,v :: v
v) -> do
RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localDepends :: [Depends]
localDepends = [Depends]
deps [Depends] -> [Depends] -> [Depends]
forall a. [a] -> [a] -> [a]
++ Local -> [Depends]
localDepends Local
s, localDiscount :: Double
localDiscount = Local -> Double
localDiscount Local
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset}
v -> Action v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
Nothing -> do
Fence (Either SomeException ([Depends], v))
bar <- IO (Fence (Either SomeException ([Depends], v)))
forall a. IO (Fence a)
newFence
(HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
-> IO
(HashMap k (Fence (Either SomeException ([Depends], v))), Action v)
forall a b. (a -> b) -> a -> b
$ (,) (k
-> Fence (Either SomeException ([Depends], v))
-> HashMap k (Fence (Either SomeException ([Depends], v)))
-> HashMap k (Fence (Either SomeException ([Depends], v)))
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Fence (Either SomeException ([Depends], v))
bar HashMap k (Fence (Either SomeException ([Depends], v)))
mp) (Action v
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v))
-> Action v
-> (HashMap k (Fence (Either SomeException ([Depends], v))),
Action v)
forall a b. (a -> b) -> a -> b
$ do
Local{localDepends :: Local -> [Depends]
localDepends=[Depends]
pre} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
Either SomeException v
res <- RAW Global Local (Either SomeException v)
-> Action (Either SomeException v)
forall a. RAW Global Local a -> Action a
Action (RAW Global Local (Either SomeException v)
-> Action (Either SomeException v))
-> RAW Global Local (Either SomeException v)
-> Action (Either SomeException v)
forall a b. (a -> b) -> a -> b
$ RAW Global Local v -> RAW Global Local (Either SomeException v)
forall ro rw a. RAW ro rw a -> RAW ro rw (Either SomeException a)
tryRAW (RAW Global Local v -> RAW Global Local (Either SomeException v))
-> RAW Global Local v -> RAW Global Local (Either SomeException v)
forall a b. (a -> b) -> a -> b
$ Action v -> RAW Global Local v
forall a. Action a -> RAW Global Local a
fromAction (Action v -> RAW Global Local v) -> Action v -> RAW Global Local v
forall a b. (a -> b) -> a -> b
$ k -> Action v
act k
key
case Either SomeException v
res of
Left err :: SomeException
err -> do
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Fence (Either SomeException ([Depends], v))
-> Either SomeException ([Depends], v) -> IO ()
forall a. Fence a -> a -> IO ()
signalFence Fence (Either SomeException ([Depends], v))
bar (Either SomeException ([Depends], v) -> IO ())
-> Either SomeException ([Depends], v) -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException ([Depends], v)
forall a b. a -> Either a b
Left SomeException
err
RAW Global Local v -> Action v
forall a. RAW Global Local a -> Action a
Action (RAW Global Local v -> Action v) -> RAW Global Local v -> Action v
forall a b. (a -> b) -> a -> b
$ SomeException -> RAW Global Local v
forall e ro rw a. Exception e => e -> RAW ro rw a
throwRAW SomeException
err
Right v :: v
v -> do
Local{localDepends :: Local -> [Depends]
localDepends=[Depends]
post} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
let deps :: [Depends]
deps = Int -> [Depends] -> [Depends]
forall a. Int -> [a] -> [a]
take ([Depends] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Depends]
post Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Depends] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Depends]
pre) [Depends]
post
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Fence (Either SomeException ([Depends], v))
-> Either SomeException ([Depends], v) -> IO ()
forall a. Fence a -> a -> IO ()
signalFence Fence (Either SomeException ([Depends], v))
bar (Either SomeException ([Depends], v) -> IO ())
-> Either SomeException ([Depends], v) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([Depends], v) -> Either SomeException ([Depends], v)
forall a b. b -> Either a b
Right ([Depends]
deps, v
v)
v -> Action v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
unsafeExtraThread :: Action a -> Action a
act :: Action a
act = RAW Global Local a -> Action a
forall a. RAW Global Local a -> Action a
Action (RAW Global Local a -> Action a) -> RAW Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ do
Global{..} <- RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
IO ()
stop <- IO (IO ()) -> RAW Global Local (IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO ()) -> RAW Global Local (IO ()))
-> IO (IO ()) -> RAW Global Local (IO ())
forall a b. (a -> b) -> a -> b
$ Pool -> IO (IO ())
increasePool Pool
globalPool
Either SomeException a
res <- RAW Global Local a -> RAW Global Local (Either SomeException a)
forall ro rw a. RAW ro rw a -> RAW ro rw (Either SomeException a)
tryRAW (RAW Global Local a -> RAW Global Local (Either SomeException a))
-> RAW Global Local a -> RAW Global Local (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ Action a -> RAW Global Local a
forall a. Action a -> RAW Global Local a
fromAction (Action a -> RAW Global Local a) -> Action a -> RAW Global Local a
forall a b. (a -> b) -> a -> b
$ String -> Action a -> Action a
forall a. String -> Action a -> Action a
blockApply "Within unsafeExtraThread" Action a
act
IO () -> RAW Global Local ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
stop
Capture (Either SomeException a) -> RAW Global Local a
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture (Either SomeException a) -> RAW Global Local a)
-> Capture (Either SomeException a) -> RAW Global Local a
forall a b. (a -> b) -> a -> b
$ \continue :: Either SomeException a -> IO ()
continue -> (if Either SomeException a -> Bool
forall a b. Either a b -> Bool
isLeft Either SomeException a
res then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolException else Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume) Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException a -> IO ()
continue Either SomeException a
res
parallel :: [Action a] -> Action [a]
parallel :: [Action a] -> Action [a]
parallel [] = [a] -> Action [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
parallel [x :: Action a
x] = (a -> [a]) -> Action a -> Action [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Action a
x
parallel acts :: [Action a]
acts = RAW Global Local [a] -> Action [a]
forall a. RAW Global Local a -> Action a
Action (RAW Global Local [a] -> Action [a])
-> RAW Global Local [a] -> Action [a]
forall a b. (a -> b) -> a -> b
$ do
global :: Global
global@Global{..} <- RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
Local
local <- RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
Var (Maybe Int)
todo :: Var (Maybe Int) <- IO (Var (Maybe Int)) -> RAW Global Local (Var (Maybe Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Var (Maybe Int)) -> RAW Global Local (Var (Maybe Int)))
-> IO (Var (Maybe Int)) -> RAW Global Local (Var (Maybe Int))
forall a b. (a -> b) -> a -> b
$ Maybe Int -> IO (Var (Maybe Int))
forall a. a -> IO (Var a)
newVar (Maybe Int -> IO (Var (Maybe Int)))
-> Maybe Int -> IO (Var (Maybe Int))
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Action a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action a]
acts
[IORef (Maybe (Either SomeException (Local, a)))]
results :: [IORef (Maybe (Either SomeException (Local, a)))] <- IO [IORef (Maybe (Either SomeException (Local, a)))]
-> RAW
Global Local [IORef (Maybe (Either SomeException (Local, a)))]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [IORef (Maybe (Either SomeException (Local, a)))]
-> RAW
Global Local [IORef (Maybe (Either SomeException (Local, a)))])
-> IO [IORef (Maybe (Either SomeException (Local, a)))]
-> RAW
Global Local [IORef (Maybe (Either SomeException (Local, a)))]
forall a b. (a -> b) -> a -> b
$ Int
-> IO (IORef (Maybe (Either SomeException (Local, a))))
-> IO [IORef (Maybe (Either SomeException (Local, a)))]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Action a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action a]
acts) (IO (IORef (Maybe (Either SomeException (Local, a))))
-> IO [IORef (Maybe (Either SomeException (Local, a)))])
-> IO (IORef (Maybe (Either SomeException (Local, a))))
-> IO [IORef (Maybe (Either SomeException (Local, a)))]
forall a b. (a -> b) -> a -> b
$ Maybe (Either SomeException (Local, a))
-> IO (IORef (Maybe (Either SomeException (Local, a))))
forall a. a -> IO (IORef a)
newIORef Maybe (Either SomeException (Local, a))
forall a. Maybe a
Nothing
(locals :: [Local]
locals, results :: [a]
results) <- Capture (Either SomeException ([Local], [a]))
-> RAW Global Local ([Local], [a])
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture (Either SomeException ([Local], [a]))
-> RAW Global Local ([Local], [a]))
-> Capture (Either SomeException ([Local], [a]))
-> RAW Global Local ([Local], [a])
forall a b. (a -> b) -> a -> b
$ \continue :: Either SomeException ([Local], [a]) -> IO ()
continue -> do
let resume :: IO ()
resume = do
Either SomeException [(Local, a)]
res <- IO (Either SomeException [(Local, a)])
-> IO (Either SomeException [(Local, a)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException [(Local, a)])
-> IO (Either SomeException [(Local, a)]))
-> IO (Either SomeException [(Local, a)])
-> IO (Either SomeException [(Local, a)])
forall a b. (a -> b) -> a -> b
$ [Either SomeException (Local, a)]
-> Either SomeException [(Local, a)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either SomeException (Local, a)]
-> Either SomeException [(Local, a)])
-> ([Maybe (Either SomeException (Local, a))]
-> [Either SomeException (Local, a)])
-> [Maybe (Either SomeException (Local, a))]
-> Either SomeException [(Local, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Either SomeException (Local, a))]
-> [Either SomeException (Local, a)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either SomeException (Local, a))]
-> Either SomeException [(Local, a)])
-> IO [Maybe (Either SomeException (Local, a))]
-> IO (Either SomeException [(Local, a)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IORef (Maybe (Either SomeException (Local, a)))
-> IO (Maybe (Either SomeException (Local, a))))
-> [IORef (Maybe (Either SomeException (Local, a)))]
-> IO [Maybe (Either SomeException (Local, a))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IORef (Maybe (Either SomeException (Local, a)))
-> IO (Maybe (Either SomeException (Local, a)))
forall a. IORef a -> IO a
readIORef [IORef (Maybe (Either SomeException (Local, a)))]
results
Either SomeException ([Local], [a]) -> IO ()
continue (Either SomeException ([Local], [a]) -> IO ())
-> Either SomeException ([Local], [a]) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(Local, a)] -> ([Local], [a]))
-> Either SomeException [(Local, a)]
-> Either SomeException ([Local], [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Local, a)] -> ([Local], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip Either SomeException [(Local, a)]
res
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Action a, IORef (Maybe (Either SomeException (Local, a))))]
-> ((Action a, IORef (Maybe (Either SomeException (Local, a))))
-> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Action a]
-> [IORef (Maybe (Either SomeException (Local, a)))]
-> [(Action a, IORef (Maybe (Either SomeException (Local, a))))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Action a]
acts [IORef (Maybe (Either SomeException (Local, a)))]
results) (((Action a, IORef (Maybe (Either SomeException (Local, a))))
-> IO ())
-> IO ())
-> ((Action a, IORef (Maybe (Either SomeException (Local, a))))
-> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(act :: Action a
act, result :: IORef (Maybe (Either SomeException (Local, a)))
result) -> do
let act2 :: Action (Local, a)
act2 = do
Action Bool -> Action () -> Action ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int -> Bool) -> IO (Maybe Int) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var (Maybe Int) -> IO (Maybe Int)
forall a. Var a -> IO a
readVar Var (Maybe Int)
todo) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$
String -> Action ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "parallel, one has already failed"
a
res <- Action a
act
Local
old <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
(Local, a) -> Action (Local, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Local
old, a
res)
Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global
-> Local
-> Action (Local, a)
-> Capture (Either SomeException (Local, a))
forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
global (Local -> Local
localClearMutable Local
local) Action (Local, a)
act2 Capture (Either SomeException (Local, a))
-> Capture (Either SomeException (Local, a))
forall a b. (a -> b) -> a -> b
$ \res :: Either SomeException (Local, a)
res -> do
IORef (Maybe (Either SomeException (Local, a)))
-> Maybe (Either SomeException (Local, a)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Either SomeException (Local, a)))
result (Maybe (Either SomeException (Local, a)) -> IO ())
-> Maybe (Either SomeException (Local, a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException (Local, a)
-> Maybe (Either SomeException (Local, a))
forall a. a -> Maybe a
Just Either SomeException (Local, a)
res
Var (Maybe Int) -> (Maybe Int -> IO (Maybe Int)) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (Maybe Int)
todo ((Maybe Int -> IO (Maybe Int)) -> IO ())
-> (Maybe Int -> IO (Maybe Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \v :: Maybe Int
v -> case Maybe Int
v of
Nothing -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
Just i :: Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| Either SomeException (Local, a) -> Bool
forall a b. Either a b -> Bool
isLeft Either SomeException (Local, a)
res -> do IO ()
resume; Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
Just i :: Int
i -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
(Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \root :: Local
root -> Local -> [Local] -> Local
localMergeMutable Local
root [Local]
locals
[a] -> RAW Global Local [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
results
orderOnlyAction :: Action a -> Action a
orderOnlyAction :: Action a -> Action a
orderOnlyAction act :: Action a
act = RAW Global Local a -> Action a
forall a. RAW Global Local a -> Action a
Action (RAW Global Local a -> Action a) -> RAW Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ do
Local{localDepends :: Local -> [Depends]
localDepends=[Depends]
pre} <- RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
a
res <- Action a -> RAW Global Local a
forall a. Action a -> RAW Global Local a
fromAction Action a
act
(Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localDepends :: [Depends]
localDepends=[Depends]
pre}
a -> RAW Global Local a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
batch
:: Int
-> ((a -> Action ()) -> Rules ())
-> (a -> Action b)
-> ([b] -> Action ())
-> Rules ()
batch :: Int
-> ((a -> Action ()) -> Rules ())
-> (a -> Action b)
-> ([b] -> Action ())
-> Rules ()
batch mx :: Int
mx pred :: (a -> Action ()) -> Rules ()
pred one :: a -> Action b
one many :: [b] -> Action ()
many
| Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = String -> Rules ()
forall a. Partial => String -> a
error (String -> Rules ()) -> String -> Rules ()
forall a b. (a -> b) -> a -> b
$ "Can't call batchable with <= 0, you used " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mx
| Int
mx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = (a -> Action ()) -> Rules ()
pred ((a -> Action ()) -> Rules ()) -> (a -> Action ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> do b
b <- a -> Action b
one a
a; [b] -> Action ()
many [b
b]
| Bool
otherwise = do
IORef (Int, [(b, Either SomeException Local -> IO ())])
todo :: IORef (Int, [(b, Either SomeException Local -> IO ())]) <- IO (IORef (Int, [(b, Either SomeException Local -> IO ())]))
-> Rules (IORef (Int, [(b, Either SomeException Local -> IO ())]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Int, [(b, Either SomeException Local -> IO ())]))
-> Rules (IORef (Int, [(b, Either SomeException Local -> IO ())])))
-> IO (IORef (Int, [(b, Either SomeException Local -> IO ())]))
-> Rules (IORef (Int, [(b, Either SomeException Local -> IO ())]))
forall a b. (a -> b) -> a -> b
$ (Int, [(b, Either SomeException Local -> IO ())])
-> IO (IORef (Int, [(b, Either SomeException Local -> IO ())]))
forall a. a -> IO (IORef a)
newIORef (0, [])
(a -> Action ()) -> Rules ()
pred ((a -> Action ()) -> Rules ()) -> (a -> Action ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
b
b <- Action b -> RAW Global Local b
forall a. Action a -> RAW Global Local a
fromAction (Action b -> RAW Global Local b) -> Action b -> RAW Global Local b
forall a b. (a -> b) -> a -> b
$ a -> Action b
one a
a
global :: Global
global@Global{..} <- RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
Local
local <- RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
Local
local2 <- Capture (Either SomeException Local) -> RAW Global Local Local
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
captureRAW (Capture (Either SomeException Local) -> RAW Global Local Local)
-> Capture (Either SomeException Local) -> RAW Global Local Local
forall a b. (a -> b) -> a -> b
$ \k :: Either SomeException Local -> IO ()
k -> do
Int
count <- IORef (Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]), Int))
-> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Int, [(b, Either SomeException Local -> IO ())])
todo (((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]), Int))
-> IO Int)
-> ((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]), Int))
-> IO Int
forall a b. (a -> b) -> a -> b
$ \(count :: Int
count, bs :: [(b, Either SomeException Local -> IO ())]
bs) -> ((Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
+1, (b
b,Either SomeException Local -> IO ()
k)(b, Either SomeException Local -> IO ())
-> [(b, Either SomeException Local -> IO ())]
-> [(b, Either SomeException Local -> IO ())]
forall a. a -> [a] -> [a]
:[(b, Either SomeException Local -> IO ())]
bs), Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
(if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
mx then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume else if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolBatch else Pool -> IO () -> IO ()
forall (m :: * -> *) p p. Monad m => p -> p -> m ()
none)
Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global
-> Local
-> IORef (Int, [(b, Either SomeException Local -> IO ())])
-> IO ()
go Global
global (Local -> Local
localClearMutable Local
local) IORef (Int, [(b, Either SomeException Local -> IO ())])
todo
(Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \root :: Local
root -> Local -> [Local] -> Local
localMergeMutable Local
root [Local
local2]
where
none :: p -> p -> m ()
none _ _ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go :: Global
-> Local
-> IORef (Int, [(b, Either SomeException Local -> IO ())])
-> IO ()
go global :: Global
global@Global{..} local :: Local
local todo :: IORef (Int, [(b, Either SomeException Local -> IO ())])
todo = do
(now :: [(b, Either SomeException Local -> IO ())]
now, count :: Int
count) <- IORef (Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]),
([(b, Either SomeException Local -> IO ())], Int)))
-> IO ([(b, Either SomeException Local -> IO ())], Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Int, [(b, Either SomeException Local -> IO ())])
todo (((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]),
([(b, Either SomeException Local -> IO ())], Int)))
-> IO ([(b, Either SomeException Local -> IO ())], Int))
-> ((Int, [(b, Either SomeException Local -> IO ())])
-> ((Int, [(b, Either SomeException Local -> IO ())]),
([(b, Either SomeException Local -> IO ())], Int)))
-> IO ([(b, Either SomeException Local -> IO ())], Int)
forall a b. (a -> b) -> a -> b
$ \(count :: Int
count, bs :: [(b, Either SomeException Local -> IO ())]
bs) ->
if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mx then
((0, []), ([(b, Either SomeException Local -> IO ())]
bs, 0))
else
let (xs :: [(b, Either SomeException Local -> IO ())]
xs,ys :: [(b, Either SomeException Local -> IO ())]
ys) = Int
-> [(b, Either SomeException Local -> IO ())]
-> ([(b, Either SomeException Local -> IO ())],
[(b, Either SomeException Local -> IO ())])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mx [(b, Either SomeException Local -> IO ())]
bs
in ((Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mx, [(b, Either SomeException Local -> IO ())]
ys), ([(b, Either SomeException Local -> IO ())]
xs, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mx))
(if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
mx then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume else if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolBatch else Pool -> IO () -> IO ()
forall (m :: * -> *) p p. Monad m => p -> p -> m ()
none)
Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global
-> Local
-> IORef (Int, [(b, Either SomeException Local -> IO ())])
-> IO ()
go Global
global Local
local IORef (Int, [(b, Either SomeException Local -> IO ())])
todo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(b, Either SomeException Local -> IO ())] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(b, Either SomeException Local -> IO ())]
now) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Global
-> Local -> Action Local -> Capture (Either SomeException Local)
forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
global Local
local (do [b] -> Action ()
many ([b] -> Action ()) -> [b] -> Action ()
forall a b. (a -> b) -> a -> b
$ ((b, Either SomeException Local -> IO ()) -> b)
-> [(b, Either SomeException Local -> IO ())] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Either SomeException Local -> IO ()) -> b
forall a b. (a, b) -> a
fst [(b, Either SomeException Local -> IO ())]
now; RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW) Capture (Either SomeException Local)
-> Capture (Either SomeException Local)
forall a b. (a -> b) -> a -> b
$ \x :: Either SomeException Local
x ->
[(b, Either SomeException Local -> IO ())]
-> ((b, Either SomeException Local -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(b, Either SomeException Local -> IO ())]
now (((b, Either SomeException Local -> IO ()) -> IO ()) -> IO ())
-> ((b, Either SomeException Local -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(_,k :: Either SomeException Local -> IO ()
k) ->
(if Either SomeException Local -> Bool
forall a b. Either a b -> Bool
isLeft Either SomeException Local
x then Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolException else Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume) Pool
globalPool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException Local -> IO ()
k Either SomeException Local
x