Action.hs

{-# 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 f m = Action $ do
    s <- 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{globalOptions=ShakeOptions{..},..} stk e = case fromException e of
    Just (e :: ShakeException) -> pure e
    Nothing -> do
        e<- pure $ exceptionStack stk 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 runOnSuccess alloc free act = do
    Global{..} <- Action getRO
    (v, key) <- liftIO $ mask_ $ do
        v <- alloc
        key <- liftIO $ register globalCleanup $ void $ free v
        pure (v, key)
    res <- Action $ catchRAW (fromAction $ act v) $ \e -> liftIO (release key) >> throwRAW 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.
actionOnException :: Action a -> IO b -> Action a
actionOnException act free = actionBracketEx False (pure ()) (const free) (const act)

-- | After an 'Action', perform some 'IO', even if there is an exception.
actionFinally :: Action a -> IO b -> Action a
actionFinally act free = actionBracket (pure ()) (const free) (const act)

-- | Like `bracket`, but where the inner operation is of type 'Action'. Usually used as
--   @'actionBracket' alloc free use@.
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket = actionBracketEx 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 act hdl = Action $ catchRAW (fromAction act) $ \e ->
    case () of
        _ | not $ isAsyncException e
          , Nothing <- fromException e :: Maybe ShakeException
          , Just e <- fromException e
          -> fromAction $ hdl e
        _ -> throwRAW 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 i act
    | i <= 0 = fail $ "actionRetry first argument must be positive, got " ++ show i
    | i == 1 = act
    | otherwise = Action $ catchRAW (fromAction act) $ \_ -> fromAction $ actionRetry (i-1) act


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

-- | Get the initial 'ShakeOptions', these will not change during the build process.
getShakeOptions :: Action ShakeOptions
getShakeOptions = Action $ globalOptions <$> getRO


-- | Get the current 'Progress' structure, as would be returned by 'shakeProgress'.
getProgress :: Action Progress
getProgress = do
    Global{..} <- Action getRO
    liftIO globalProgress

-- | Specify an action to be run after the database has been closed, if building completes successfully.
runAfter :: IO () -> Action ()
runAfter op = do
    Global{..} <- Action getRO
    liftIO $ atomicModifyIORef_ globalAfter (op:)


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

putWhen :: Verbosity -> String -> Action ()
putWhen v msg = do
    Global{..} <- Action 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 = putWhen 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 = putWhen 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 = putWhen 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 = putWhen 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 $ localVerbosity <$> 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 new = actionThenUndoLocal $ \s0 ->
    (s0{localVerbosity=new}, \s -> 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 = withVerbosity Error


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

unsafeAllowApply :: Action a -> Action a
unsafeAllowApply  = applyBlockedBy Nothing

blockApply :: String -> Action a -> Action a
blockApply = applyBlockedBy . Just

applyBlockedBy :: Maybe String -> Action a -> Action a
applyBlockedBy reason = actionThenUndoLocal $ \s0 ->
    (s0{localBlockApply=reason}, \s -> 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 msg act = do
    Global{..} <- Action getRO
    Local{localStack} <- Action getRW
    start <- liftIO globalTimestamp
    let key = showTopStack localStack
    putInfo $ "# " ++ msg ++ " (for " ++ key ++ ")"
    res <- liftIO $
        (shakeTrace globalOptions key msg True >> act)
            `finally` shakeTrace globalOptions key msg False
    stop <- liftIO globalTimestamp
    let trace = newTrace msg start stop
    liftIO $ evaluate $ rnf trace
    Action $ modifyRW $ \s -> 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 ks = do
    Global{..} <- Action getRO
    when (isJust $ shakeLint globalOptions) $ do
        l@Local{..} <- Action getRW
        deps <- liftIO $ concatMapM (listDepends globalDatabase) $ enumerateDepends localDepends
        let top = topStack localStack

        let condition1 k = top == Just k
        let condition2 k = k `elem` deps
        let condition3 k = any ($ k) localTrackAllows
        let condition4 = filter (\k -> not $ condition1 k || condition2 k || condition3 k) $ map newKey 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 ks = do
    Global{..} <- Action getRO
    when (isJust $ shakeLint globalOptions) $ do
        l@Local{..} <- Action getRW
        let top = topStack localStack

        let condition1 k = Just k == top
        let condition2 k = any ($ k) localTrackAllows
        let condition3 = filter (\k -> not $ condition1 k || condition2 k) $ map newKey ks
        unless (null condition3) $
            Action $ putRW l{localTrackWrite = condition3 ++ localTrackWrite}


lintTrackFinished :: Action ()
lintTrackFinished = do
    -- only called when isJust shakeLint
    Global{..} <- Action getRO
    Local{..} <- Action getRW
    liftIO $ do
        let top = topStack localStack
        -- must apply the ignore at the end, because we might have merged in more ignores that
        -- apply to other branches
        let ignore k = any ($ k) localTrackAllows

        -- Read stuff
        deps <- concatMapM (listDepends globalDatabase) $ enumerateDepends localDepends
        let used = Set.filter (not . ignore) $ Set.fromList localTrackRead

        -- check Read 4a
        bad<- pure $ Set.toList $ used `Set.difference` Set.fromList deps
        unless (null bad) $ do
            let n = length 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) $ \k -> not . null <$> lookupDependencies globalDatabase k
        unless (null bad) $ do
            let n = length 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 (test :: key -> Bool) = do
    Global{..} <- Action getRO
    when (isJust $ shakeLint globalOptions) $
        Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}
    where
        tk = typeRep (Proxy :: Proxy key)
        f k = typeKey k == tk && test (fromKey k)


lintCurrentDirectory :: FilePath -> String -> IO ()
lintCurrentDirectory old msg = do
    now <- 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 [] = pure $ const $ pure ()
lintWatch pats = do
    let op = getDirectoryFiles "." pats -- cache parsing of the pats
    let record = do xs <- op; forM xs $ \x -> (x,) <$> getFileInfo False (fileNameFromString x)
    old <- record
    pure $ \msg -> do
        now <- 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 old now =
            [("Created", Just x) | x <- Map.keys $ Map.difference now old] ++
            [("Deleted", Just x) | x <- Map.keys $ Map.difference old now] ++
            [("Changed", Just x) | x <- Map.keys $ Map.filter id $ Map.intersectionWith (/=) old now]


listDepends :: Database -> Depends -> IO [Key]
listDepends db (Depends xs) = mapM (fmap (fst . fromJust) . getKeyValueFromId db) xs


lookupDependencies :: Database -> Key -> IO [Depends]
lookupDependencies db k = do
    Just (Ready r) <- getValueFromKey db 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 $ modifyRW $ \s -> s{localHistory = False}


-- | A version of 'produces' that checks the files actually exist
producesChecked :: [FilePath] -> Action ()
producesChecked xs = Action $ modifyRW $ \s -> s{localProduces = map (True,) (reverse xs) ++ localProduces s}

-- | A version of 'produces' that does not check.
producesUnchecked :: [FilePath] -> Action ()
producesUnchecked xs = Action $ modifyRW $ \s -> s{localProduces = map (False,) (reverse xs) ++ localProduces s}

producesCheck :: Action ()
producesCheck = do
    Local{localProduces} <- Action 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 act = Action $ do
    Local{localDepends=pre} <- getRW
    res <- fromAction act
    modifyRW $ \s -> 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 (act :: k -> Action v) = do
    var :: Var (Map.HashMap k (Fence IO (Either SomeException (DependsList,v)))) <- newVar Map.empty
    pure $ \key ->
        join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of
            Just bar -> pure $ (,) mp $ do
                (offset, (deps, v)) <- actionFenceRequeue bar
                Action $ modifyRW $ \s -> addDiscount offset $ s{localDepends = addDepends (localDepends s) deps}
                pure v
            Nothing -> do
                bar <- newFence
                pure $ (Map.insert key bar mp,) $ do
                    Local{localDepends=pre} <- Action getRW
                    Action $ modifyRW $ \s -> s{localDepends = newDepends []}
                    res <- Action $ tryRAW $ fromAction $ act key
                    case res of
                        Left err -> do
                            liftIO $ signalFence bar $ Left err
                            Action $ throwRAW err
                        Right v -> do
                            Local{localDepends=deps} <- Action getRW
                            Action $ modifyRW $ \s -> 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 act = do
    Global{..} <- Action 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 [] = pure []
parallel [x] = pure <$> x
parallel acts = do
    Global{..} <- Action getRO

    done <- liftIO $ newIORef False
    waits <- forM acts $ \act ->
        addPoolWait PoolResume $ do
            whenM (liftIO $ readIORef done) $
                fail "parallel, one has already failed"
            Action $ modifyRW localClearMutable
            res <- act
            old <- Action getRW
            pure (old, res)
    (wait, res) <- actionFenceSteal =<< liftIO (exceptFence waits)
    liftIO $ atomicWriteIORef done True
    let (waits, locals, results) = unzip3 $ map (\(a,(b,c)) -> (a,b,c)) res
    Action $ modifyRW $ \root -> addDiscount (wait - sum waits) $ localMergeMutable root 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 mx pred one many
    | mx <= 0 = error $ "Can't call batchable with <= 0, you used " ++ show mx
    | mx == 1 = pred $ \a -> do b <- one a; many [b]
    | otherwise = do
        todo :: IORef (Int, [(b, Local, Fence IO (Either SomeException (Seconds, Local)))]) <- liftIO $ newIORef (0, [])
        pred $ \a -> do
            b <- one a
            fence <- liftIO newFence
            -- add one to the batch
            local <- Action getRW
            count <- liftIO $ atomicModifyIORef todo $ \(count, bs) -> let i = count+1 in ((i, (b,local,fence):bs), i)
            requeue todo (==) count
            (wait, (cost, local2)) <- actionFenceRequeue fence
            Action $ modifyRW $ \root -> addDiscount (wait - cost) $ localMergeMutable root [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 todo trigger count
            | count `trigger` mx = addPoolWait_ PoolResume $ go todo
            | count `trigger` 1  = addPoolWait_ PoolBatch  $ go todo
            | otherwise = pure ()

        go todo = do
            -- delete at most mx from the batch
            (now, count) <- liftIO $ atomicModifyIORef todo $ \(count, bs) ->
                let (now,later) = splitAt mx bs
                    count2 = if count > mx then count - mx else 0
                in ((count2, later), (now, 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 $ head 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 = end - localDiscount rw
                    let n = intToDouble (length 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 x = do
    (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ pure ()
    Action $ modifyRW $ addDiscount wait


getCurrentKey :: Action (Maybe Key)
getCurrentKey = Action $ topStack . localStack <$> getRW

getLocal :: Action Local
getLocal = Action getRW

-- | Hooked up to --share-remove
actionShareRemove :: [String] -> Action ()
actionShareRemove substrs = do
    Global{..} <- Action getRO
    case globalShared of
        Nothing -> throwM $ errorInternal "actionShareRemove with no shared"
        Just x -> liftIO $ removeShared x $ \k -> any (`isInfixOf` show k) substrs

-- | Hooked up to --share-list
actionShareList :: Action ()
actionShareList = do
    Global{..} <- Action getRO
    case globalShared of
        Nothing -> throwM $ errorInternal "actionShareList with no shared"
        Just x -> liftIO $ listShared x

-- | Hooked up to --share-sanity
actionShareSanity :: Action ()
actionShareSanity = do
    Global{..} <- Action getRO
    case globalShared of
        Nothing -> throwM $ errorInternal "actionShareSanity with no shared"
        Just x -> liftIO $ sanityShared x