{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds, TupleSections #-}

module Development.Shake.Internal.Core.Action(
    actionOnException, actionFinally, actionBracket, actionCatch, actionRetry,
    getShakeOptions, getProgress, runAfter,
    lintTrackRead, lintTrackWrite, lintTrackAllow,
    getVerbosity, putWhen, putVerbose, putInfo, putWarn, putError, withVerbosity, quietly,
    orderOnlyAction,
    newCacheIO,
    unsafeExtraThread,
    parallel,
    batch,
    reschedule,
    historyDisable,
    traced,
    -- Internal only
    producesChecked, producesUnchecked, producesCheck, lintCurrentDirectory, lintWatch,
    blockApply, unsafeAllowApply, shakeException, lintTrackFinished,
    getCurrentKey, getLocal,
    actionShareList, actionShareRemove, actionShareSanity
    ) where

import Control.Exception
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.DeepSeq
import Data.Typeable
import System.Directory
import System.FilePattern
import System.FilePattern.Directory
import System.Time.Extra
import Control.Concurrent.Extra
import Data.Maybe
import Data.Tuple.Extra
import Data.IORef.Extra
import Data.List.Extra
import Numeric.Extra
import General.Extra
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set

import Development.Shake.Classes
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.History.Shared
import General.Pool
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Core.Pool
import Development.Shake.Internal.Value
import Development.Shake.Internal.FileInfo
import Development.Shake.Internal.FileName
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Cleanup
import General.Fence


---------------------------------------------------------------------
-- RAW WRAPPERS

-- | Apply a modification, run an action, then run an undo action after.
--   Doesn't actually require exception handling because we don't have the ability to catch exceptions to the user.
actionThenUndoLocal :: (Local -> (Local, Local -> Local)) -> Action a -> Action a
actionThenUndoLocal :: forall a.
(Local -> (Local, Local -> Local)) -> Action a -> Action a
actionThenUndoLocal Local -> (Local, Local -> Local)
f Action a
m = RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local a -> Action a)
-> RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ do
    s <- RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW
    let (s2,undo) = f s
    putRW s2
    res <- fromAction m
    modifyRW undo
    pure res


---------------------------------------------------------------------
-- EXCEPTION HANDLING

-- | 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 -> Stack -> SomeException -> IO ShakeException
shakeException :: Global -> Stack -> SomeException -> IO ShakeException
shakeException Global{globalOptions :: Global -> ShakeOptions
globalOptions=ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Double
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Double
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Double
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..},Bool
Maybe Shared
Maybe Cloud
IO Double
IO Progress
IORef [IO ()]
IORef [(Key, Key)]
HashMap TypeRep BuiltinRule
Cleanup
Database
Pool
Map UserRuleVersioned
Step
[String] -> [Key] -> Action [Value]
IO String -> IO ()
Key -> Action ()
Verbosity -> String -> IO ()
globalBuild :: [String] -> [Key] -> Action [Value]
globalDatabase :: Database
globalPool :: Pool
globalCleanup :: Cleanup
globalTimestamp :: IO Double
globalRules :: HashMap TypeRep BuiltinRule
globalOutput :: Verbosity -> String -> IO ()
globalDiagnostic :: IO String -> IO ()
globalRuleFinished :: Key -> Action ()
globalAfter :: IORef [IO ()]
globalTrackAbsent :: IORef [(Key, Key)]
globalProgress :: IO Progress
globalUserRules :: Map UserRuleVersioned
globalShared :: Maybe Shared
globalCloud :: Maybe Cloud
globalStep :: Step
globalOneShot :: Bool
globalOneShot :: Global -> Bool
globalStep :: Global -> Step
globalCloud :: Global -> Maybe Cloud
globalShared :: Global -> Maybe Shared
globalUserRules :: Global -> Map UserRuleVersioned
globalProgress :: Global -> IO Progress
globalTrackAbsent :: Global -> IORef [(Key, Key)]
globalAfter :: Global -> IORef [IO ()]
globalRuleFinished :: Global -> Key -> Action ()
globalDiagnostic :: Global -> IO String -> IO ()
globalOutput :: Global -> Verbosity -> String -> IO ()
globalRules :: Global -> HashMap TypeRep BuiltinRule
globalTimestamp :: Global -> IO Double
globalCleanup :: Global -> Cleanup
globalPool :: Global -> Pool
globalDatabase :: Global -> Database
globalBuild :: Global -> [String] -> [Key] -> Action [Value]
..} Stack
stk SomeException
e = case SomeException -> Maybe ShakeException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just (ShakeException
e :: ShakeException) -> ShakeException -> IO ShakeException
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeException
e
    Maybe ShakeException
Nothing -> do
        e<- ShakeException -> IO ShakeException
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeException -> IO ShakeException)
-> ShakeException -> IO ShakeException
forall a b. (a -> b) -> a -> b
$ Stack -> SomeException -> ShakeException
exceptionStack Stack
stk SomeException
e
        when (shakeStaunch && shakeVerbosity >= Error) $
            globalOutput Error $ show e ++ "Continuing due to staunch mode"
        pure e


actionBracketEx :: Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracketEx :: forall a b c.
Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracketEx Bool
runOnSuccess IO a
alloc a -> IO b
free a -> Action c
act = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    (v, key) <- liftIO $ mask_ $ do
        v <- alloc
        key <- liftIO $ register globalCleanup $ void $ free v
        pure (v, key)
    res <- Action $ catchRAW (fromAction $ act v) $ \SomeException
e -> IO () -> RAW ([String], [Key]) [Value] Global Local ()
forall a. IO a -> RAW ([String], [Key]) [Value] Global Local a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ReleaseKey -> IO ()
release ReleaseKey
key) RAW ([String], [Key]) [Value] Global Local ()
-> RAW ([String], [Key]) [Value] Global Local c
-> RAW ([String], [Key]) [Value] Global Local c
forall a b.
RAW ([String], [Key]) [Value] Global Local a
-> RAW ([String], [Key]) [Value] Global Local b
-> RAW ([String], [Key]) [Value] Global Local b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> RAW ([String], [Key]) [Value] Global Local c
forall e k v ro rw a. Exception e => e -> RAW k v ro rw a
throwRAW SomeException
e
    liftIO $ if runOnSuccess then release key else unprotect key
    pure res

-- | If an exception is raised by the 'Action', perform some 'IO' then reraise the exception.
--   This function is implemented using 'actionBracket'.
actionOnException :: Action a -> IO b -> Action a
actionOnException :: forall a b. Action a -> IO b -> Action a
actionOnException Action a
act IO b
free = Bool -> IO () -> (() -> IO b) -> (() -> Action a) -> Action a
forall a b c.
Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracketEx Bool
False (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO b -> () -> IO b
forall a b. a -> b -> a
const IO b
free) (Action a -> () -> Action a
forall a b. a -> b -> a
const Action a
act)

-- | After an 'Action', perform some 'IO', even if there is an exception.
--   This function is implemented using 'actionBracket'.
actionFinally :: Action a -> IO b -> Action a
actionFinally :: forall a b. Action a -> IO b -> Action a
actionFinally Action a
act IO b
free = IO () -> (() -> IO b) -> (() -> Action a) -> Action a
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO b -> () -> IO b
forall a b. a -> b -> a
const IO b
free) (Action a -> () -> Action a
forall a b. a -> b -> a
const Action a
act)

-- | Like 'bracket', but where the inner operation is of type 'Action'. Usually used as
--   @'actionBracket' alloc free use@.
--
--   The @free@ action will be run masked. The cost of 'actionBracket' is _O(n log n)_
--   in the number of simultaneous 'actionBracket' calls active in the program.
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket :: forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket = Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c
forall a b c.
Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracketEx Bool
True


-- | If a syncronous exception is raised by the 'Action', perform some handler.
--   Note that there is no guarantee that the handler will run on shutdown (use 'actionFinally' for that),
--   and that 'actionCatch' /cannot/ catch exceptions thrown by dependencies, e.g. raised by 'need'
--   (to do so would allow untracked dependencies on failure conditions).
actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
actionCatch :: forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action a
act e -> Action a
hdl = RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local a -> Action a)
-> RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ RAW ([String], [Key]) [Value] Global Local a
-> (SomeException -> RAW ([String], [Key]) [Value] Global Local a)
-> RAW ([String], [Key]) [Value] Global Local a
forall k v ro rw a.
RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW (Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction Action a
act) ((SomeException -> RAW ([String], [Key]) [Value] Global Local a)
 -> RAW ([String], [Key]) [Value] Global Local a)
-> (SomeException -> RAW ([String], [Key]) [Value] Global Local a)
-> RAW ([String], [Key]) [Value] Global Local a
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
    case () of
        ()
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isAsyncException SomeException
e
          , Maybe ShakeException
Nothing <- SomeException -> Maybe ShakeException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe ShakeException
          , Just e
e <- SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
          -> Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction (Action a -> RAW ([String], [Key]) [Value] Global Local a)
-> Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a b. (a -> b) -> a -> b
$ e -> Action a
hdl e
e
        ()
_ -> SomeException -> RAW ([String], [Key]) [Value] Global Local a
forall e k v ro rw a. Exception e => e -> RAW k v ro rw a
throwRAW SomeException
e


-- | Retry an 'Action' if it throws an exception, at most /n/ times (where /n/ must be positive).
--   If you need to call this function, you should probably try and fix the underlying cause (but you also probably know that).
actionRetry :: Int -> Action a -> Action a
actionRetry :: forall a. Int -> Action a -> Action a
actionRetry Int
i Action a
act
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Action a
forall a. String -> Action a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action a) -> String -> Action a
forall a b. (a -> b) -> a -> b
$ String
"actionRetry first argument must be positive, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Action a
act
    | Bool
otherwise = RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local a -> Action a)
-> RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ RAW ([String], [Key]) [Value] Global Local a
-> (SomeException -> RAW ([String], [Key]) [Value] Global Local a)
-> RAW ([String], [Key]) [Value] Global Local a
forall k v ro rw a.
RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW (Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction Action a
act) ((SomeException -> RAW ([String], [Key]) [Value] Global Local a)
 -> RAW ([String], [Key]) [Value] Global Local a)
-> (SomeException -> RAW ([String], [Key]) [Value] Global Local a)
-> RAW ([String], [Key]) [Value] Global Local a
forall a b. (a -> b) -> a -> b
$ \SomeException
_ -> Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction (Action a -> RAW ([String], [Key]) [Value] Global Local a)
-> Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a b. (a -> b) -> a -> b
$ Int -> Action a -> Action a
forall a. Int -> Action a -> Action a
actionRetry (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Action a
act


---------------------------------------------------------------------
-- QUERIES

-- | Get the initial 'ShakeOptions', these will not change during the build process.
getShakeOptions :: Action ShakeOptions
getShakeOptions :: Action ShakeOptions
getShakeOptions = RAW ([String], [Key]) [Value] Global Local ShakeOptions
-> Action ShakeOptions
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local ShakeOptions
 -> Action ShakeOptions)
-> RAW ([String], [Key]) [Value] Global Local ShakeOptions
-> Action ShakeOptions
forall a b. (a -> b) -> a -> b
$ Global -> ShakeOptions
globalOptions (Global -> ShakeOptions)
-> RAW ([String], [Key]) [Value] Global Local Global
-> RAW ([String], [Key]) [Value] Global Local ShakeOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO


-- | Get the current 'Progress' structure, as would be returned by 'shakeProgress'.
getProgress :: Action Progress
getProgress :: Action Progress
getProgress = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    liftIO globalProgress

-- | Specify an action to be run after the database has been closed, if building completes successfully.
runAfter :: IO () -> Action ()
runAfter :: IO () -> Action ()
runAfter IO ()
op = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    liftIO $ atomicModifyIORef_ globalAfter (op:)


---------------------------------------------------------------------
-- VERBOSITY

putWhen :: Verbosity -> String -> Action ()
putWhen :: Verbosity -> String -> Action ()
putWhen Verbosity
v String
msg = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    verb <- getVerbosity
    when (verb >= v) $
        liftIO $ globalOutput v msg


-- | Write an unimportant message to the output, only shown when 'shakeVerbosity' is higher than normal ('Verbose' or above).
--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).
putVerbose :: String -> Action ()
putVerbose :: String -> Action ()
putVerbose = Verbosity -> String -> Action ()
putWhen Verbosity
Verbose

-- | Write a normal priority message to the output, only suppressed when 'shakeVerbosity' is 'Error', 'Warn' or 'Silent'.
--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).
putInfo :: String -> Action ()
putInfo :: String -> Action ()
putInfo = Verbosity -> String -> Action ()
putWhen Verbosity
Info

-- | Write a semi important message to the output, only suppressed when 'shakeVerbosity' is 'Error' or 'Silent'.
--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).
putWarn :: String -> Action ()
putWarn :: String -> Action ()
putWarn = Verbosity -> String -> Action ()
putWhen Verbosity
Warn

-- | Write an important message to the output, only suppressed when 'shakeVerbosity' is 'Silent'.
--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).
putError :: String -> Action ()
putError :: String -> Action ()
putError = Verbosity -> String -> Action ()
putWhen Verbosity
Error


-- | Get the current verbosity level, originally set by 'shakeVerbosity'. If you
--   want to output information to the console, you are recommended to use
--   'putVerbose' \/ 'putInfo' \/ 'putError', which ensures multiple messages are
--   not interleaved. The verbosity can be modified locally by 'withVerbosity'.
getVerbosity :: Action Verbosity
getVerbosity :: Action Verbosity
getVerbosity = RAW ([String], [Key]) [Value] Global Local Verbosity
-> Action Verbosity
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local Verbosity
 -> Action Verbosity)
-> RAW ([String], [Key]) [Value] Global Local Verbosity
-> Action Verbosity
forall a b. (a -> b) -> a -> b
$ Local -> Verbosity
localVerbosity (Local -> Verbosity)
-> RAW ([String], [Key]) [Value] Global Local Local
-> RAW ([String], [Key]) [Value] Global Local Verbosity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW


-- | Run an action with a particular verbosity level.
--   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will
--   not have any impact on 'Diagnostic' tracing.
withVerbosity :: Verbosity -> Action a -> Action a
withVerbosity :: forall a. Verbosity -> Action a -> Action a
withVerbosity Verbosity
new = (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a.
(Local -> (Local, Local -> Local)) -> Action a -> Action a
actionThenUndoLocal ((Local -> (Local, Local -> Local)) -> Action a -> Action a)
-> (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ \Local
s0 ->
    (Local
s0{localVerbosity=new}, \Local
s -> Local
s{localVerbosity=localVerbosity s0})


-- | Run an action with 'Error' verbosity, in particular messages produced by 'traced'
--   (including from 'Development.Shake.cmd' or 'Development.Shake.command') will not be printed to the screen.
--   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will
--   not turn off any 'Diagnostic' tracing.
quietly :: Action a -> Action a
quietly :: forall a. Action a -> Action a
quietly = Verbosity -> Action a -> Action a
forall a. Verbosity -> Action a -> Action a
withVerbosity Verbosity
Error


---------------------------------------------------------------------
-- BLOCK APPLY

unsafeAllowApply :: Action a -> Action a
unsafeAllowApply :: forall a. Action a -> Action a
unsafeAllowApply  = Maybe String -> Action a -> Action a
forall a. Maybe String -> Action a -> Action a
applyBlockedBy Maybe String
forall a. Maybe a
Nothing

blockApply :: String -> Action a -> Action a
blockApply :: forall a. String -> Action a -> Action a
blockApply = Maybe String -> Action a -> Action a
forall a. Maybe String -> Action a -> Action a
applyBlockedBy (Maybe String -> Action a -> Action a)
-> (String -> Maybe String) -> String -> Action a -> Action a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just

applyBlockedBy :: Maybe String -> Action a -> Action a
applyBlockedBy :: forall a. Maybe String -> Action a -> Action a
applyBlockedBy Maybe String
reason = (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a.
(Local -> (Local, Local -> Local)) -> Action a -> Action a
actionThenUndoLocal ((Local -> (Local, Local -> Local)) -> Action a -> Action a)
-> (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ \Local
s0 ->
    (Local
s0{localBlockApply=reason}, \Local
s -> Local
s{localBlockApply=localBlockApply s0})


---------------------------------------------------------------------
-- TRACING

-- | Write an action to the trace list, along with the start/end time of running the IO action.
--   The 'Development.Shake.cmd' and 'Development.Shake.command' functions automatically call 'traced'
--   with the name of the executable. The trace list is used for profile reports (see 'shakeReport').
--
--   By default 'traced' prints some useful extra context about what
--   Shake is building, e.g.:
--
-- > # traced message (for myobject.o)
--
--   To suppress the output of 'traced' (for example you want more control
--   over the message using 'putInfo'), use the 'quietly' combinator.
--
--   It is recommended that the string passed to 'traced' is short and that only a small number of unique strings
--   are used (makes profiling work better).
--   The string does not need to make sense on its own, only in conjunction with the target it is building.
traced :: String -> IO a -> Action a
traced :: forall a. String -> IO a -> Action a
traced String
msg IO a
act = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    Local{localStack} <- Action getRW
    start <- liftIO globalTimestamp
    let key = Stack -> String
showTopStack Stack
localStack
    putInfo $ "# " ++ msg ++ " (for " ++ key ++ ")"
    res <- liftIO $
        (shakeTrace globalOptions key msg True >> act)
            `finally` shakeTrace globalOptions key msg False
    stop <- liftIO globalTimestamp
    let trace = String -> Double -> Double -> Trace
newTrace String
msg Double
start Double
stop
    liftIO $ evaluate $ rnf trace
    Action $ modifyRW $ \Local
s -> Local
s{localTraces = addTrace (localTraces s) trace}
    pure res


---------------------------------------------------------------------
-- TRACKING

-- | Track that a key has been used/read by the action preceding it when 'shakeLint' is active.
lintTrackRead :: ShakeValue key => [key] -> Action ()
-- One of the following must be true:
-- 1) you are the one building this key (e.g. key == topStack)
-- 2) you have already been used by apply, and are on the dependency list
-- 3) someone explicitly gave you permission with trackAllow
-- 4) at the end of the rule, a) you are now on the dependency list, and b) this key itself has no dependencies (is source file)
lintTrackRead :: forall key. ShakeValue key => [key] -> Action ()
lintTrackRead [key]
ks = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    when (isJust $ shakeLint globalOptions) $ do
        l@Local{..} <- Action getRW
        deps <- liftIO $ concatMapM (listDepends globalDatabase) $ enumerateDepends localDepends
        let top = Stack -> Maybe Key
topStack Stack
localStack

        let condition1 Key
k = Maybe Key
top Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
        let condition2 Key
k = Key
k Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
deps
        let condition3 Key
k = ((Key -> Bool) -> Bool) -> [Key -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Key -> Bool) -> Key -> Bool
forall a b. (a -> b) -> a -> b
$ Key
k) [Key -> Bool]
localTrackAllows
        let condition4 = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Key
k -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> Bool
condition1 Key
k Bool -> Bool -> Bool
|| Key -> Bool
condition2 Key
k Bool -> Bool -> Bool
|| Key -> Bool
condition3 Key
k) ([Key] -> [Key]) -> [Key] -> [Key]
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
        unless (null condition4) $
            Action $ putRW l{localTrackRead = condition4 ++ localTrackRead}


-- | Track that a key has been changed/written by the action preceding it when 'shakeLint' is active.
lintTrackWrite :: ShakeValue key => [key] -> Action ()
-- One of the following must be true:
-- 1) you are the one building this key (e.g. key == topStack)
-- 2) someone explicitly gave you permission with trackAllow
-- 3) this file is never known to the build system, at the end it is not in the database
lintTrackWrite :: forall key. ShakeValue key => [key] -> Action ()
lintTrackWrite [key]
ks = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    when (isJust $ shakeLint globalOptions) $ do
        l@Local{..} <- Action getRW
        let top = Stack -> Maybe Key
topStack Stack
localStack

        let condition1 Key
k = Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Key
top
        let condition2 Key
k = ((Key -> Bool) -> Bool) -> [Key -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Key -> Bool) -> Key -> Bool
forall a b. (a -> b) -> a -> b
$ Key
k) [Key -> Bool]
localTrackAllows
        let condition3 = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Key
k -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> Bool
condition1 Key
k Bool -> Bool -> Bool
|| Key -> Bool
condition2 Key
k) ([Key] -> [Key]) -> [Key] -> [Key]
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
        unless (null condition3) $
            Action $ putRW l{localTrackWrite = condition3 ++ localTrackWrite}


lintTrackFinished :: Action ()
lintTrackFinished :: Action ()
lintTrackFinished = do
    -- only called when isJust shakeLint
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    Local{..} <- Action getRW
    liftIO $ do
        let top = Stack -> Maybe Key
topStack Stack
localStack
        -- must apply the ignore at the end, because we might have merged in more ignores that
        -- apply to other branches
        let ignore Key
k = ((Key -> Bool) -> Bool) -> [Key -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Key -> Bool) -> Key -> Bool
forall a b. (a -> b) -> a -> b
$ Key
k) [Key -> Bool]
localTrackAllows

        -- Read stuff
        deps <- concatMapM (listDepends globalDatabase) $ enumerateDepends localDepends
        let used = (Key -> Bool) -> HashSet Key -> HashSet Key
forall a. (a -> Bool) -> HashSet a -> HashSet a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Bool
ignore) (HashSet Key -> HashSet Key) -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ [Key] -> HashSet Key
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [Key]
localTrackRead

        -- check Read 4a
        bad<- pure $ Set.toList $ used `Set.difference` Set.fromList deps
        unless (null bad) $ do
            let n = [Key] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
bad
            throwM $ errorStructured
                ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")
                [("Used", Just $ show x) | x <- bad]
                ""

        -- check Read 4b
        bad <- flip filterM (Set.toList used) $ \Key
k -> Bool -> Bool
not (Bool -> Bool) -> ([Depends] -> Bool) -> [Depends] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Depends] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Depends] -> Bool) -> IO [Depends] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> Key -> IO [Depends]
lookupDependencies Database
globalDatabase Key
k
        unless (null bad) $ do
            let n = [Key] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
bad
            throwM $ errorStructured
                ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")
                [("Used", Just $ show x) | x <- bad]
                ""

        -- check Write 3
        bad<- pure $ filter (not . ignore) $ Set.toList $ Set.fromList localTrackWrite
        unless (null bad) $
            liftIO $ atomicModifyIORef_ globalTrackAbsent ([(fromMaybe k top, k) | k <- bad] ++)


-- | Allow any matching key recorded with 'lintTrackRead' or 'lintTrackWrite' in this action,
--   after this call, to violate the tracking rules.
lintTrackAllow :: ShakeValue key => (key -> Bool) -> Action ()
lintTrackAllow :: forall key. ShakeValue key => (key -> Bool) -> Action ()
lintTrackAllow (key -> Bool
test :: key -> Bool) = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    when (isJust $ shakeLint globalOptions) $
        Action $ modifyRW $ \Local
s -> Local
s{localTrackAllows = f : localTrackAllows s}
    where
        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)
        f :: Key -> Bool
f Key
k = Key -> TypeRep
typeKey Key
k TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
tk Bool -> Bool -> Bool
&& key -> Bool
test (Key -> key
forall a. Typeable a => Key -> a
fromKey Key
k)


lintCurrentDirectory :: FilePath -> String -> IO ()
lintCurrentDirectory :: String -> String -> IO ()
lintCurrentDirectory String
old String
msg = do
    now <- IO String
getCurrentDirectory
    when (old /= now) $ throwIO $ errorStructured
        "Lint checking error - current directory has changed"
        [("When", Just msg)
        ,("Wanted",Just old)
        ,("Got",Just now)]
        ""

lintWatch :: [FilePattern] -> IO (String -> IO ())
lintWatch :: [String] -> IO (String -> IO ())
lintWatch [] = (String -> IO ()) -> IO (String -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
lintWatch [String]
pats = do
    let op :: IO [String]
op = String -> [String] -> IO [String]
getDirectoryFiles String
"." [String]
pats -- cache parsing of the pats
    let record :: IO [(String, Maybe (ModTime, FileSize))]
record = do xs <- IO [String]
op; forM xs $ \String
x -> (String
x,) (Maybe (ModTime, FileSize) -> (String, Maybe (ModTime, FileSize)))
-> IO (Maybe (ModTime, FileSize))
-> IO (String, Maybe (ModTime, FileSize))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> FileName -> IO (Maybe (ModTime, FileSize))
getFileInfo Bool
False (String -> FileName
fileNameFromString String
x)
    old <- IO [(String, Maybe (ModTime, FileSize))]
record
    pure $ \String
msg -> do
        now <- IO [(String, Maybe (ModTime, FileSize))]
record
        when (old /= now) $ throwIO $ errorStructured
            "Lint checking error - watched files have changed"
            (("When", Just msg) : changes (Map.fromList old) (Map.fromList now))
            ""
    where
        changes :: HashMap t v2 -> HashMap t v2 -> [(String, Maybe t)]
changes HashMap t v2
old HashMap t v2
now =
            [(String
"Created", t -> Maybe t
forall a. a -> Maybe a
Just t
x) | t
x <- HashMap t v2 -> [t]
forall k v. HashMap k v -> [k]
Map.keys (HashMap t v2 -> [t]) -> HashMap t v2 -> [t]
forall a b. (a -> b) -> a -> b
$ HashMap t v2 -> HashMap t v2 -> HashMap t v2
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
Map.difference HashMap t v2
now HashMap t v2
old] [(String, Maybe t)] -> [(String, Maybe t)] -> [(String, Maybe t)]
forall a. [a] -> [a] -> [a]
++
            [(String
"Deleted", t -> Maybe t
forall a. a -> Maybe a
Just t
x) | t
x <- HashMap t v2 -> [t]
forall k v. HashMap k v -> [k]
Map.keys (HashMap t v2 -> [t]) -> HashMap t v2 -> [t]
forall a b. (a -> b) -> a -> b
$ HashMap t v2 -> HashMap t v2 -> HashMap t v2
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
Map.difference HashMap t v2
old HashMap t v2
now] [(String, Maybe t)] -> [(String, Maybe t)] -> [(String, Maybe t)]
forall a. [a] -> [a] -> [a]
++
            [(String
"Changed", t -> Maybe t
forall a. a -> Maybe a
Just t
x) | t
x <- HashMap t Bool -> [t]
forall k v. HashMap k v -> [k]
Map.keys (HashMap t Bool -> [t]) -> HashMap t Bool -> [t]
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> HashMap t Bool -> HashMap t Bool
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter Bool -> Bool
forall a. a -> a
id (HashMap t Bool -> HashMap t Bool)
-> HashMap t Bool -> HashMap t Bool
forall a b. (a -> b) -> a -> b
$ (v2 -> v2 -> Bool)
-> HashMap t v2 -> HashMap t v2 -> HashMap t Bool
forall k v1 v2 v3.
Eq k =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
Map.intersectionWith v2 -> v2 -> Bool
forall a. Eq a => a -> a -> Bool
(/=) HashMap t v2
old HashMap t v2
now]


listDepends :: Database -> Depends -> IO [Key]
listDepends :: Database -> Depends -> IO [Key]
listDepends Database
db (Depends [Id]
xs) = (Id -> IO Key) -> [Id] -> IO [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Maybe (Key, Status) -> Key) -> IO (Maybe (Key, Status)) -> IO Key
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key, Status) -> Key
forall a b. (a, b) -> a
fst ((Key, Status) -> Key)
-> (Maybe (Key, Status) -> (Key, Status))
-> Maybe (Key, Status)
-> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Key, Status) -> (Key, Status)
forall a. Partial => Maybe a -> a
fromJust) (IO (Maybe (Key, Status)) -> IO Key)
-> (Id -> IO (Maybe (Key, Status))) -> Id -> IO Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Id -> IO (Maybe (Key, Status))
forall k v. DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId Database
db) [Id]
xs


lookupDependencies :: Database -> Key -> IO [Depends]
lookupDependencies :: Database -> Key -> IO [Depends]
lookupDependencies Database
db Key
k = do
    Just (Ready r) <- Database -> Key -> IO (Maybe Status)
forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey Database
db Key
k
    pure $ depends r


-- | This rule should not be saved to shared/cloud storage via 'shakeShare'.
--   There are usually two reasons to call this function:
--
--   1. It makes use of untracked dependencies that are specific to this machine,
--      e.g. files in a system directory or items on the @$PATH@.
--   2. The rule is trivial to compute locally, so there is no point sharing it.
--
--   If you want the rule to not be cached at all, use 'alwaysRerun'.
historyDisable :: Action ()
historyDisable :: Action ()
historyDisable = RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local () -> Action ())
-> RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW ((Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ())
-> (Local -> Local)
-> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ \Local
s -> Local
s{localHistory = False}


-- | A version of 'produces' that checks the files actually exist
producesChecked :: [FilePath] -> Action ()
producesChecked :: [String] -> Action ()
producesChecked [String]
xs = RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local () -> Action ())
-> RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW ((Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ())
-> (Local -> Local)
-> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ \Local
s -> Local
s{localProduces = map (True,) (reverse xs) ++ localProduces s}

-- | A version of 'produces' that does not check.
producesUnchecked :: [FilePath] -> Action ()
producesUnchecked :: [String] -> Action ()
producesUnchecked [String]
xs = RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local () -> Action ())
-> RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW ((Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ())
-> (Local -> Local)
-> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ \Local
s -> Local
s{localProduces = map (False,) (reverse xs) ++ localProduces s}

producesCheck :: Action ()
producesCheck :: Action ()
producesCheck = do
    Local{localProduces} <- RAW ([String], [Key]) [Value] Global Local Local -> Action Local
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW
    missing <- liftIO $ filterM (notM . doesFileExist_) $ map snd $ filter fst localProduces
    when (missing /= []) $ throwM $ errorStructured
        "Files declared by 'produces' not produced"
        [("File " ++ show i, Just x) | (i,x) <- zipFrom 1 missing]
        ""


-- | Run an action but do not depend on anything the action uses.
--   A more general version of 'orderOnly'.
orderOnlyAction :: Action a -> Action a
orderOnlyAction :: forall a. Action a -> Action a
orderOnlyAction Action a
act = RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local a -> Action a)
-> RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ do
    Local{localDepends=pre} <- RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW
    res <- fromAction act
    modifyRW $ \Local
s -> Local
s{localDepends=pre}
    pure res


---------------------------------------------------------------------
-- MORE COMPLEX

-- | 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 :: forall k v.
(Eq k, Hashable k) =>
(k -> Action v) -> IO (k -> Action v)
newCacheIO (k -> Action v
act :: k -> Action v) = do
    var :: Var (Map.HashMap k (Fence IO (Either SomeException (DependsList,v)))) <- HashMap k (Fence IO (Either SomeException (DependsList, v)))
-> IO
     (Var
        (HashMap k (Fence IO (Either SomeException (DependsList, v)))))
forall a. a -> IO (Var a)
newVar HashMap k (Fence IO (Either SomeException (DependsList, v)))
forall k v. HashMap k v
Map.empty
    pure $ \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 a. IO a -> Action a
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 IO (Either SomeException (DependsList, v))))
-> (HashMap k (Fence IO (Either SomeException (DependsList, v)))
    -> IO
         (HashMap k (Fence IO (Either SomeException (DependsList, v))),
          Action v))
-> IO (Action v)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap k (Fence IO (Either SomeException (DependsList, v))))
var ((HashMap k (Fence IO (Either SomeException (DependsList, v)))
  -> IO
       (HashMap k (Fence IO (Either SomeException (DependsList, v))),
        Action v))
 -> IO (Action v))
-> (HashMap k (Fence IO (Either SomeException (DependsList, v)))
    -> IO
         (HashMap k (Fence IO (Either SomeException (DependsList, v))),
          Action v))
-> IO (Action v)
forall a b. (a -> b) -> a -> b
$ \HashMap k (Fence IO (Either SomeException (DependsList, v)))
mp -> case k
-> HashMap k (Fence IO (Either SomeException (DependsList, v)))
-> Maybe (Fence IO (Either SomeException (DependsList, v)))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
key HashMap k (Fence IO (Either SomeException (DependsList, v)))
mp of
            Just Fence IO (Either SomeException (DependsList, v))
bar -> (HashMap k (Fence IO (Either SomeException (DependsList, v))),
 Action v)
-> IO
     (HashMap k (Fence IO (Either SomeException (DependsList, v))),
      Action v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((HashMap k (Fence IO (Either SomeException (DependsList, v))),
  Action v)
 -> IO
      (HashMap k (Fence IO (Either SomeException (DependsList, v))),
       Action v))
-> (HashMap k (Fence IO (Either SomeException (DependsList, v))),
    Action v)
-> IO
     (HashMap k (Fence IO (Either SomeException (DependsList, v))),
      Action v)
forall a b. (a -> b) -> a -> b
$ (,) HashMap k (Fence IO (Either SomeException (DependsList, v)))
mp (Action v
 -> (HashMap k (Fence IO (Either SomeException (DependsList, v))),
     Action v))
-> Action v
-> (HashMap k (Fence IO (Either SomeException (DependsList, v))),
    Action v)
forall a b. (a -> b) -> a -> b
$ do
                (offset, (deps, v)) <- Fence IO (Either SomeException (DependsList, v))
-> Action (Double, (DependsList, v))
forall b. Fence IO (Either SomeException b) -> Action (Double, b)
actionFenceRequeue Fence IO (Either SomeException (DependsList, v))
bar
                Action $ modifyRW $ \Local
s -> Double -> Local -> Local
addDiscount Double
offset (Local -> Local) -> Local -> Local
forall a b. (a -> b) -> a -> b
$ Local
s{localDepends = addDepends (localDepends s) deps}
                pure v
            Maybe (Fence IO (Either SomeException (DependsList, v)))
Nothing -> do
                bar <- IO (Fence IO (Either SomeException (DependsList, v)))
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
                pure $ (Map.insert key bar mp,) $ do
                    Local{localDepends=pre} <- Action getRW
                    Action $ modifyRW $ \Local
s -> Local
s{localDepends = newDepends []}
                    res <- Action $ tryRAW $ fromAction $ act key
                    case res of
                        Left SomeException
err -> do
                            IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Fence IO (Either SomeException (DependsList, v))
-> Either SomeException (DependsList, v) -> IO ()
forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence IO (Either SomeException (DependsList, v))
bar (Either SomeException (DependsList, v) -> IO ())
-> Either SomeException (DependsList, v) -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (DependsList, v)
forall a b. a -> Either a b
Left SomeException
err
                            RAW ([String], [Key]) [Value] Global Local v -> Action v
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local v -> Action v)
-> RAW ([String], [Key]) [Value] Global Local v -> Action v
forall a b. (a -> b) -> a -> b
$ SomeException -> RAW ([String], [Key]) [Value] Global Local v
forall e k v ro rw a. Exception e => e -> RAW k v ro rw a
throwRAW SomeException
err
                        Right v
v -> do
                            Local{localDepends=deps} <- RAW ([String], [Key]) [Value] Global Local Local -> Action Local
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW
                            Action $ modifyRW $ \Local
s -> Local
s{localDepends = addDepends pre deps}
                            liftIO $ signalFence bar $ Right (deps, v)
                            pure 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 :: forall a. Action a -> Action a
unsafeExtraThread Action a
act = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    stop <- liftIO $ increasePool globalPool
    res <- Action $ tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act
    liftIO stop
    -- we start a new thread, giving up ours, to ensure the thread count goes down
    (wait, res) <- actionAlwaysRequeue res
    Action $ modifyRW $ addDiscount wait
    pure res


-- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism.
--   If the two types of 'Action' are different dependencies which ultimately boil down to 'apply',
--   using 'Applicative' operations will still ensure the dependencies occur in parallel.
--   The main use of this function is to run work that happens in an 'Action' in parallel.
parallel :: [Action a] -> Action [a]
-- Note: There is no parallel_ unlike sequence_ because there is no stack benefit to doing so
parallel :: forall a. [Action a] -> Action [a]
parallel [] = [a] -> Action [a]
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parallel [Action a
x] = a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> Action a -> Action [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
x
parallel [Action a]
acts = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO

    done <- liftIO $ newIORef False
    waits <- forM acts $ \Action a
act ->
        PoolPriority
-> Action (Local, a)
-> Action (Fence IO (Either SomeException (Double, (Local, a))))
forall a.
PoolPriority
-> Action a -> Action (Fence IO (Either SomeException (Double, a)))
addPoolWait PoolPriority
PoolResume (Action (Local, a)
 -> Action (Fence IO (Either SomeException (Double, (Local, a)))))
-> Action (Local, a)
-> Action (Fence IO (Either SomeException (Double, (Local, a))))
forall a b. (a -> b) -> a -> b
$ do
            Action Bool -> Action () -> Action ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> Action Bool
forall a. IO a -> Action a
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
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
done) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$
                String -> Action ()
forall a. String -> Action a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parallel, one has already failed"
            RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local () -> Action ())
-> RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW Local -> Local
localClearMutable
            res <- Action a
act
            old <- Action getRW
            pure (old, res)
    (wait, res) <- actionFenceSteal =<< liftIO (exceptFence waits)
    liftIO $ atomicWriteIORef done True
    let (waits, locals, results) = unzip3 $ map (\(Double
a,(Local
b,a
c)) -> (Double
a,Local
b,a
c)) res
    Action $ modifyRW $ \Local
root -> Double -> Local -> Local
addDiscount (Double
wait Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
waits) (Local -> Local) -> Local -> Local
forall a b. (a -> b) -> a -> b
$ Local -> [Local] -> Local
localMergeMutable Local
root [Local]
locals
    pure results


-- | 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\"]; pure 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   -- ^ Maximum number to run in a single batch, e.g. @3@, must be positive.
    -> ((a -> Action ()) -> Rules ()) -- ^ Way to match an entry, e.g. @\"*.ext\" '%>'@.
    -> (a -> Action b)  -- ^ Preparation to run individually on each, e.g. using 'need'.
    -> ([b] -> Action ())  -- ^ Combination action to run on all, e.g. using 'cmd'.
    -> Rules ()
batch :: forall a b.
Int
-> ((a -> Action ()) -> Rules ())
-> (a -> Action b)
-> ([b] -> Action ())
-> Rules ()
batch Int
mx (a -> Action ()) -> Rules ()
pred a -> Action b
one [b] -> Action ()
many
    | Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Rules ()
forall a. Partial => String -> a
error (String -> Rules ()) -> String -> Rules ()
forall a b. (a -> b) -> a -> b
$ String
"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
== Int
1 = (a -> Action ()) -> Rules ()
pred ((a -> Action ()) -> Rules ()) -> (a -> Action ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \a
a -> do b <- a -> Action b
one a
a; many [b]
    | Bool
otherwise = do
        todo :: IORef (Int, [(b, Local, Fence IO (Either SomeException (Seconds, Local)))]) <- IO
  (IORef
     (Int,
      [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
-> Rules
     (IORef
        (Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (IORef
      (Int,
       [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
 -> Rules
      (IORef
         (Int,
          [(b, Local, Fence IO (Either SomeException (Double, Local)))])))
-> IO
     (IORef
        (Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
-> Rules
     (IORef
        (Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
forall a b. (a -> b) -> a -> b
$ (Int,
 [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> IO
     (IORef
        (Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]))
forall a. a -> IO (IORef a)
newIORef (Int
0, [])
        pred $ \a
a -> do
            b <- a -> Action b
one a
a
            fence <- liftIO newFence
            -- add one to the batch
            local <- Action getRW
            count <- liftIO $ atomicModifyIORef todo $ \(Int
count, [(b, Local, Fence IO (Either SomeException (Double, Local)))]
bs) -> let i :: Int
i = Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in ((Int
i, (b
b,Local
local,Fence IO (Either SomeException (Double, Local))
fence)(b, Local, Fence IO (Either SomeException (Double, Local)))
-> [(b, Local, Fence IO (Either SomeException (Double, Local)))]
-> [(b, Local, Fence IO (Either SomeException (Double, Local)))]
forall a. a -> [a] -> [a]
:[(b, Local, Fence IO (Either SomeException (Double, Local)))]
bs), Int
i)
            requeue todo (==) count
            (wait, (cost, local2)) <- actionFenceRequeue fence
            Action $ modifyRW $ \Local
root -> Double -> Local -> Local
addDiscount (Double
wait Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cost) (Local -> Local) -> Local -> Local
forall a b. (a -> b) -> a -> b
$ Local -> [Local] -> Local
localMergeMutable Local
root [Local
local2]
    where
        -- When changing by one, only trigger on (==) so we don't have lots of waiting pool entries
        -- When changing by many, trigger on (>=) because we don't hit all edges
        requeue :: IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> (Int -> Int -> Bool) -> Int -> Action ()
requeue IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
todo Int -> Int -> Bool
trigger Int
count
            | Int
count Int -> Int -> Bool
`trigger` Int
mx = PoolPriority -> Action () -> Action ()
forall a. PoolPriority -> Action a -> Action ()
addPoolWait_ PoolPriority
PoolResume (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> Action ()
go IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
todo
            | Int
count Int -> Int -> Bool
`trigger` Int
1  = PoolPriority -> Action () -> Action ()
forall a. PoolPriority -> Action a -> Action ()
addPoolWait_ PoolPriority
PoolBatch  (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> Action ()
go IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
todo
            | Bool
otherwise = () -> Action ()
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        go :: IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> Action ()
go IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
todo = do
            -- delete at most mx from the batch
            (now, count) <- IO
  ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
   Int)
-> Action
     ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
      Int)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
    Int)
 -> Action
      ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
       Int))
-> IO
     ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
      Int)
-> Action
     ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
      Int)
forall a b. (a -> b) -> a -> b
$ IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
-> ((Int,
     [(b, Local, Fence IO (Either SomeException (Double, Local)))])
    -> ((Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]),
        ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
         Int)))
-> IO
     ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
      Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef
  (Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
todo (((Int,
   [(b, Local, Fence IO (Either SomeException (Double, Local)))])
  -> ((Int,
       [(b, Local, Fence IO (Either SomeException (Double, Local)))]),
      ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
       Int)))
 -> IO
      ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
       Int))
-> ((Int,
     [(b, Local, Fence IO (Either SomeException (Double, Local)))])
    -> ((Int,
         [(b, Local, Fence IO (Either SomeException (Double, Local)))]),
        ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
         Int)))
-> IO
     ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
      Int)
forall a b. (a -> b) -> a -> b
$ \(Int
count, [(b, Local, Fence IO (Either SomeException (Double, Local)))]
bs) ->
                let ([(b, Local, Fence IO (Either SomeException (Double, Local)))]
now,[(b, Local, Fence IO (Either SomeException (Double, Local)))]
later) = Int
-> [(b, Local, Fence IO (Either SomeException (Double, Local)))]
-> ([(b, Local, Fence IO (Either SomeException (Double, Local)))],
    [(b, Local, Fence IO (Either SomeException (Double, Local)))])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mx [(b, Local, Fence IO (Either SomeException (Double, Local)))]
bs
                    count2 :: Int
count2 = if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mx then Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mx else Int
0
                in ((Int
count2, [(b, Local, Fence IO (Either SomeException (Double, Local)))]
later), ([(b, Local, Fence IO (Either SomeException (Double, Local)))]
now, Int
count2))
            requeue todo (>=) count

            unless (null now) $ do
                res <- Action $ tryRAW $ do
                    -- make sure we are using one of the local's that we are computing
                    -- we things like stack, blockApply etc. work as expected
                    modifyRW $ const $ localClearMutable $ snd3 $ headErr now
                    start <- liftIO offsetTime
                    fromAction $ many $ map fst3 now
                    end <- liftIO start

                    -- accounting for time is tricky, we spend time T, over N jobs
                    -- so want to charge everyone for T / N time
                    -- but that also means we need to subtract localDiscount so we don't apply that to all
                    rw <- getRW
                    let t = Double
end Double -> Double -> Double
forall a. Num a => a -> a -> a
- Local -> Double
localDiscount Local
rw
                    let n = Int -> Double
intToDouble ([(b, Local, Fence IO (Either SomeException (Double, Local)))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(b, Local, Fence IO (Either SomeException (Double, Local)))]
now)
                    pure (t / n, rw{localDiscount = 0})
                liftIO $ mapM_ (flip signalFence res . thd3) now


-- | Given a running task, reschedule so it only continues after all other pending tasks,
--   and all rescheduled tasks with a higher pool priority. Note that due to parallelism there is no guarantee
--   that all actions of a higher pool priority will have /completed/ before the action resumes.
--   Only useful if the results are being interactively reported or consumed.
reschedule :: Double -> Action ()
reschedule :: Double -> Action ()
reschedule Double
x = do
    (wait, _) <- PoolPriority -> Either SomeException () -> Action (Double, ())
forall a.
PoolPriority -> Either SomeException a -> Action (Double, a)
actionAlwaysRequeuePriority (Double -> PoolPriority
PoolDeprioritize (Double -> PoolPriority) -> Double -> PoolPriority
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Num a => a -> a
negate Double
x) (Either SomeException () -> Action (Double, ()))
-> Either SomeException () -> Action (Double, ())
forall a b. (a -> b) -> a -> b
$ () -> Either SomeException ()
forall a. a -> Either SomeException a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Action $ modifyRW $ addDiscount wait


getCurrentKey :: Action (Maybe Key)
getCurrentKey :: Action (Maybe Key)
getCurrentKey = RAW ([String], [Key]) [Value] Global Local (Maybe Key)
-> Action (Maybe Key)
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local (Maybe Key)
 -> Action (Maybe Key))
-> RAW ([String], [Key]) [Value] Global Local (Maybe Key)
-> Action (Maybe Key)
forall a b. (a -> b) -> a -> b
$ Stack -> Maybe Key
topStack (Stack -> Maybe Key) -> (Local -> Stack) -> Local -> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local -> Stack
localStack (Local -> Maybe Key)
-> RAW ([String], [Key]) [Value] Global Local Local
-> RAW ([String], [Key]) [Value] Global Local (Maybe Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW

getLocal :: Action Local
getLocal :: Action Local
getLocal = RAW ([String], [Key]) [Value] Global Local Local -> Action Local
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Local
forall k v ro rw. RAW k v ro rw rw
getRW

-- | Hooked up to --share-remove
actionShareRemove :: [String] -> Action ()
actionShareRemove :: [String] -> Action ()
actionShareRemove [String]
substrs = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    case globalShared of
        Maybe Shared
Nothing -> SomeException -> Action ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> Action ()) -> SomeException -> Action ()
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal String
"actionShareRemove with no shared"
        Just Shared
x -> IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Shared -> (Key -> Bool) -> IO ()
removeShared Shared
x ((Key -> Bool) -> IO ()) -> (Key -> Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
k -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` Key -> String
forall a. Show a => a -> String
show Key
k) [String]
substrs

-- | Hooked up to --share-list
actionShareList :: Action ()
actionShareList :: Action ()
actionShareList = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    case globalShared of
        Maybe Shared
Nothing -> SomeException -> Action ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> Action ()) -> SomeException -> Action ()
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal String
"actionShareList with no shared"
        Just Shared
x -> IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Shared -> IO ()
listShared Shared
x

-- | Hooked up to --share-sanity
actionShareSanity :: Action ()
actionShareSanity :: Action ()
actionShareSanity = do
    Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
    case globalShared of
        Maybe Shared
Nothing -> SomeException -> Action ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> Action ()) -> SomeException -> Action ()
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal String
"actionShareSanity with no shared"
        Just Shared
x -> IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Shared -> IO ()
sanityShared Shared
x