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

---------------------------------------------------------------------
-- MAKE

-- | Internal main function (not exported publicly)
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, ())
                -- no need to print exceptions here, they get printed when they are wrapped

    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 -- so we don't leak memory
        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 ()
checkShakeExtra :: HashMap TypeRep Dynamic -> IO ()
checkShakeExtra 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
    -- instead of withBuffering avoid two finally handlers and stack depth
    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


-- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.
--   This function requires that appropriate rules have been added with 'addUserRule'.
--   All @key@ values passed to 'apply' become dependencies of the 'Action'.
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
-- Don't short-circuit [] as we still want error messages
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
    -- this is the only place a user can inject a key into our world, so check they aren't throwing
    -- in unevaluated bottoms
    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


-- | Turn a normal exception into a ShakeException, giving it a stack and printing it out if in staunch mode.
--   If the exception is already a ShakeException (e.g. it's a child of ours who failed and we are rethrowing)
--   then do nothing with it.
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


-- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,
--   use 'apply' to allow parallelism.
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


---------------------------------------------------------------------
-- RESOURCES

-- | Run an action which uses part of a finite resource. For more details see 'Resource'.
--   You cannot depend on a rule (e.g. 'need') while a resource is held.
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


-- | A version of 'Development.Shake.newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.
--   Most people should use 'Development.Shake.newCache' instead.
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


-- | Run an action without counting to the thread limit, typically used for actions that execute
--   on remote machines using barely any local CPU resources.
--   Unsafe as it allows the 'shakeThreads' limit to be exceeded.
--   You cannot depend on a rule (e.g. 'need') while the extra thread is executing.
--   If the rule blocks (e.g. calls 'withResource') then the extra thread may be used by some other action.
--   Only really suitable for calling 'cmd' / 'command'.
unsafeExtraThread :: Action a -> Action a
unsafeExtraThread :: Action a -> Action a
unsafeExtraThread 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


-- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism.
parallel :: [Action a] -> Action [a]
-- Note: There is no parallel_ unlike sequence_ because there is no stack benefit to doing so
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
    -- number of items still to complete, or Nothing for has completed (by either failure or completion)
    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
    -- a list of refs where the results go
    [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


-- | Run an action but do not depend on anything the action uses.
--   A more general version of 'orderOnly'.
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 different outputs into a single 'Action', typically useful when a command has a high
--   startup cost - e.g. @apt-get install foo bar baz@ is a lot cheaper than three separate
--   calls to @apt-get install@. As an example, if we have a standard build rule:
--
-- @
-- \"*.out\" 'Development.Shake.%>' \\out -> do
--     'Development.Shake.need' [out '-<.>' \"in\"]
--     'Development.Shake.cmd' "build-multiple" [out '-<.>' \"in\"]
-- @
--
--   Assuming that @build-multiple@ can compile multiple files in a single run,
--   and that the cost of doing so is a lot less than running each individually,
--   we can write:
--
-- @
-- 'batch' 3 (\"*.out\" 'Development.Shake.%>')
--     (\\out -> do 'Development.Shake.need' [out '-<.>' \"in\"]; return out)
--     (\\outs -> 'Development.Shake.cmd' "build-multiple" [out '-<.>' \"in\" | out \<- outs])
-- @
--
--   In constrast to the normal call, we have specified a maximum batch size of 3,
--   an action to run on each output individually (typically all the 'need' dependencies),
--   and an action that runs on multiple files at once. If we were to require lots of
--   @*.out@ files, they would typically be built in batches of 3.
--
--   If Shake ever has nothing else to do it will run batches before they are at the maximum,
--   so you may see much smaller batches, especially at high parallelism settings.
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
            -- optimisation would be to avoid taking the continuation if count >= mx
            -- but it only saves one pool requeue per mx, which is likely to be trivial
            -- and the code becomes a lot more special cases
            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)
                -- only trigger on the edge so we don't have lots of waiting pool entries
                (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