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

module Development.Shake.Internal.Core.Action(
    runAction, actionOnException, actionFinally,
    getShakeOptions, getProgress, runAfter,
    trackUse, trackChange, trackAllow, trackCheckUsed,
    getVerbosity, putWhen, putLoud, putNormal, putQuiet, withVerbosity, quietly,
    blockApply, unsafeAllowApply,
    traced
    ) where

import Control.Exception
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.DeepSeq
import Data.Typeable.Extra
import Data.Function
import Data.Either.Extra
import Data.Maybe
import Data.IORef
import Data.List
import System.IO.Extra

import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Value
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Cleanup
import Prelude


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

runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)
runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)
runAction g :: Global
g l :: Local
l (Action x :: RAW Global Local a
x) = Global
-> Local -> RAW Global Local a -> Capture (Either SomeException a)
forall ro rw a.
ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)
runRAW Global
g Local
l RAW Global Local a
x

-- | 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.
actionBracket :: (Local -> (Local, Local -> Local)) -> Action a -> Action a
actionBracket :: (Local -> (Local, Local -> Local)) -> Action a -> Action a
actionBracket f :: Local -> (Local, Local -> Local)
f m :: Action a
m = RAW Global Local a -> Action a
forall a. RAW Global Local a -> Action a
Action (RAW Global Local a -> Action a) -> RAW Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ do
    Local
s <- RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
    let (s2 :: Local
s2,undo :: Local -> Local
undo) = Local -> (Local, Local -> Local)
f Local
s
    Local -> RAW Global Local ()
forall rw ro. rw -> RAW ro rw ()
putRW Local
s2
    a
res <- Action a -> RAW Global Local a
forall a. Action a -> RAW Global Local a
fromAction Action a
m
    (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW Local -> Local
undo
    a -> RAW Global Local a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res


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

actionBoom :: Bool -> Action a -> IO b -> Action a
actionBoom :: Bool -> Action a -> IO b -> Action a
actionBoom runOnSuccess :: Bool
runOnSuccess act :: Action a
act clean :: IO b
clean = do
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    IO ()
undo <- IO (IO ()) -> Action (IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO ()) -> Action (IO ())) -> IO (IO ()) -> Action (IO ())
forall a b. (a -> b) -> a -> b
$ Cleanup -> IO () -> IO (IO ())
addCleanup Cleanup
globalCleanup (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO b
clean
    -- important to mask_ the undo/clean combo so either both happen or neither
    a
res <- RAW Global Local a -> Action a
forall a. RAW Global Local a -> Action a
Action (RAW Global Local a -> Action a) -> RAW Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ RAW Global Local a
-> (SomeException -> RAW Global Local a) -> RAW Global Local a
forall ro rw a.
RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a
catchRAW (Action a -> RAW Global Local a
forall a. Action a -> RAW Global Local a
fromAction Action a
act) ((SomeException -> RAW Global Local a) -> RAW Global Local a)
-> (SomeException -> RAW Global Local a) -> RAW Global Local a
forall a b. (a -> b) -> a -> b
$ \e :: SomeException
e -> IO b -> RAW Global Local b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> IO b
forall a. IO a -> IO a
mask_ (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ IO ()
undo IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
clean) RAW Global Local b -> RAW Global Local a -> RAW Global Local a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> RAW Global Local a
forall e ro rw a. Exception e => e -> RAW ro rw a
throwRAW SomeException
e
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
undo IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
runOnSuccess (IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO b
clean)
    a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | If an exception is raised by the 'Action', perform some 'IO'.
actionOnException :: Action a -> IO b -> Action a
actionOnException :: Action a -> IO b -> Action a
actionOnException = Bool -> Action a -> IO b -> Action a
forall a b. Bool -> Action a -> IO b -> Action a
actionBoom Bool
False

-- | After an 'Action', perform some 'IO', even if there is an exception.
actionFinally :: Action a -> IO b -> Action a
actionFinally :: Action a -> IO b -> Action a
actionFinally = Bool -> Action a -> IO b -> Action a
forall a b. Bool -> Action a -> IO b -> Action a
actionBoom Bool
True


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

-- | Get the initial 'ShakeOptions', these will not change during the build process.
getShakeOptions :: Action ShakeOptions
getShakeOptions :: Action ShakeOptions
getShakeOptions = RAW Global Local ShakeOptions -> Action ShakeOptions
forall a. RAW Global Local a -> Action a
Action (RAW Global Local ShakeOptions -> Action ShakeOptions)
-> RAW Global Local ShakeOptions -> Action ShakeOptions
forall a b. (a -> b) -> a -> b
$ Global -> ShakeOptions
globalOptions (Global -> ShakeOptions)
-> RAW Global Local Global -> RAW Global Local ShakeOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW Global Local Global
forall ro rw. RAW 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 Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    IO Progress -> Action Progress
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Progress
globalProgress

-- | Specify an action to be run after the database has been closed, if building completes successfully.
runAfter :: IO () -> Action ()
runAfter :: IO () -> Action ()
runAfter op :: IO ()
op = do
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [IO ()]
globalAfter (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ops :: [IO ()]
ops -> (IO ()
opIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:[IO ()]
ops, ())


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

putWhen :: Verbosity -> String -> Action ()
putWhen :: Verbosity -> FilePath -> Action ()
putWhen v :: Verbosity
v msg :: FilePath
msg = do
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    Verbosity
verb <- Action Verbosity
getVerbosity
    Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
v) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
globalOutput Verbosity
v FilePath
msg


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

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

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


-- | Get the current verbosity level, originally set by 'shakeVerbosity'. If you
--   want to output information to the console, you are recommended to use
--   'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are
--   not interleaved. The verbosity can be modified locally by 'withVerbosity'.
getVerbosity :: Action Verbosity
getVerbosity :: Action Verbosity
getVerbosity = RAW Global Local Verbosity -> Action Verbosity
forall a. RAW Global Local a -> Action a
Action (RAW Global Local Verbosity -> Action Verbosity)
-> RAW Global Local Verbosity -> Action Verbosity
forall a b. (a -> b) -> a -> b
$ Local -> Verbosity
localVerbosity (Local -> Verbosity)
-> RAW Global Local Local -> RAW Global Local Verbosity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW Global Local Local
forall ro rw. RAW 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 :: Verbosity -> Action a -> Action a
withVerbosity new :: Verbosity
new = (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a.
(Local -> (Local, Local -> Local)) -> Action a -> Action a
actionBracket ((Local -> (Local, Local -> Local)) -> Action a -> Action a)
-> (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ \s0 :: Local
s0 ->
    (Local
s0{localVerbosity :: Verbosity
localVerbosity=Verbosity
new}, \s :: Local
s -> Local
s{localVerbosity :: Verbosity
localVerbosity=Local -> Verbosity
localVerbosity Local
s0})


-- | Run an action with 'Quiet' 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 :: Action a -> Action a
quietly = Verbosity -> Action a -> Action a
forall a. Verbosity -> Action a -> Action a
withVerbosity Verbosity
Quiet


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

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

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

applyBlockedBy :: Maybe String -> Action a -> Action a
applyBlockedBy :: Maybe FilePath -> Action a -> Action a
applyBlockedBy reason :: Maybe FilePath
reason = (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a.
(Local -> (Local, Local -> Local)) -> Action a -> Action a
actionBracket ((Local -> (Local, Local -> Local)) -> Action a -> Action a)
-> (Local -> (Local, Local -> Local)) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ \s0 :: Local
s0 ->
    (Local
s0{localBlockApply :: Maybe FilePath
localBlockApply=Maybe FilePath
reason}, \s :: Local
s -> Local
s{localBlockApply :: Maybe FilePath
localBlockApply=Local -> Maybe FilePath
localBlockApply Local
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'.
--   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 'putNormal'), use the 'quietly' combinator.
traced :: String -> IO a -> Action a
traced :: FilePath -> IO a -> Action a
traced msg :: FilePath
msg act :: IO a
act = do
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    Local{Stack
localStack :: Local -> Stack
localStack :: Stack
localStack} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
    Seconds
start <- IO Seconds -> Action Seconds
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
globalTimestamp
    FilePath -> Action ()
putNormal (FilePath -> Action ()) -> FilePath -> Action ()
forall a b. (a -> b) -> a -> b
$ "# " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " (for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Stack -> FilePath
showTopStack Stack
localStack FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")"
    a
res <- IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
act
    Seconds
stop <- IO Seconds -> Action Seconds
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
globalTimestamp
    let trace :: Trace
trace = FilePath -> Seconds -> Seconds -> Trace
newTrace FilePath
msg Seconds
start Seconds
stop
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Trace -> ()
forall a. NFData a => a -> ()
rnf Trace
trace
    RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localTraces :: [Trace]
localTraces = Trace
trace Trace -> [Trace] -> [Trace]
forall a. a -> [a] -> [a]
: Local -> [Trace]
localTraces Local
s}
    a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res


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

-- | Track that a key has been used by the action preceeding it.
trackUse :: 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)
trackUse :: key -> Action ()
trackUse key :: key
key = do
    let k :: Key
k = key -> Key
forall a. ShakeValue a => a -> Key
newKey key
key
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    l :: Local
l@Local{..} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
    [Key]
deps <- IO [Key] -> Action [Key]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Key] -> Action [Key]) -> IO [Key] -> Action [Key]
forall a b. (a -> b) -> a -> b
$ (Depends -> IO [Key]) -> [Depends] -> IO [Key]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Database -> Depends -> IO [Key]
listDepends Database
globalDatabase) [Depends]
localDepends
    let top :: Maybe Key
top = Stack -> Maybe Key
topStack Stack
localStack
    if 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 then
        () -> Action ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- condition 1
     else if Key
k Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
deps then
        () -> Action ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- condition 2
     else if ((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 then
        () -> Action ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- condition 3
     else
        RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ Local -> RAW Global Local ()
forall rw ro. rw -> RAW ro rw ()
putRW Local
l{localTrackUsed :: [Key]
localTrackUsed = Key
k Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
localTrackUsed} -- condition 4


trackCheckUsed :: Action ()
trackCheckUsed :: Action ()
trackCheckUsed = do
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    Local{..} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        [Key]
deps <- (Depends -> IO [Key]) -> [Depends] -> IO [Key]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Database -> Depends -> IO [Key]
listDepends Database
globalDatabase) [Depends]
localDepends

        -- check 3a
        [Key]
bad <- [Key] -> IO [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Key] -> IO [Key]) -> [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ [Key]
localTrackUsed [Key] -> [Key] -> [Key]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Key]
deps
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let n :: Int
n = [Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
bad
            FilePath -> [(FilePath, Maybe FilePath)] -> FilePath -> IO ()
forall a.
FilePath -> [(FilePath, Maybe FilePath)] -> FilePath -> IO a
errorStructured
                ("Lint checking error - " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then "value was" else Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " values were") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " used but not depended upon")
                [("Used", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Key -> FilePath
forall a. Show a => a -> FilePath
show Key
x) | Key
x <- [Key]
bad]
                ""

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


-- | Track that a key has been changed by the action preceding it.
trackChange :: 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
trackChange :: key -> Action ()
trackChange key :: key
key = do
    let k :: Key
k = key -> Key
forall a. ShakeValue a => a -> Key
newKey key
key
    Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
    Local{..} <- RAW Global Local Local -> Action Local
forall a. RAW Global Local a -> Action a
Action RAW Global Local Local
forall ro rw. RAW ro rw rw
getRW
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        let top :: Maybe Key
top = Stack -> Maybe Key
topStack Stack
localStack
        if 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 then
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- condition 1
         else if ((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 then
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- condition 2
         else
            -- condition 3
            IORef [(Key, Key)] -> ([(Key, Key)] -> ([(Key, Key)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [(Key, Key)]
globalTrackAbsent (([(Key, Key)] -> ([(Key, Key)], ())) -> IO ())
-> ([(Key, Key)] -> ([(Key, Key)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ks :: [(Key, Key)]
ks -> ((Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe Key
k Maybe Key
top, Key
k)(Key, Key) -> [(Key, Key)] -> [(Key, Key)]
forall a. a -> [a] -> [a]
:[(Key, Key)]
ks, ())


-- | Allow any matching key to violate the tracking rules.
trackAllow :: ShakeValue key => (key -> Bool) -> Action ()
trackAllow :: (key -> Bool) -> Action ()
trackAllow (key -> Bool
test :: key -> Bool) = RAW Global Local () -> Action ()
forall a. RAW Global Local a -> Action a
Action (RAW Global Local () -> Action ())
-> RAW Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW Global Local ()
forall rw ro. (rw -> rw) -> RAW ro rw ()
modifyRW ((Local -> Local) -> RAW Global Local ())
-> (Local -> Local) -> RAW Global Local ()
forall a b. (a -> b) -> a -> b
$ \s :: Local
s -> Local
s{localTrackAllows :: [Key -> Bool]
localTrackAllows = Key -> Bool
f (Key -> Bool) -> [Key -> Bool] -> [Key -> Bool]
forall a. a -> [a] -> [a]
: Local -> [Key -> Bool]
localTrackAllows Local
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 k :: 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)