{-# 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
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
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
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
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
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
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
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
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
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, ())
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
putLoud :: String -> Action ()
putLoud :: FilePath -> Action ()
putLoud = Verbosity -> FilePath -> Action ()
putWhen Verbosity
Loud
putNormal :: String -> Action ()
putNormal :: FilePath -> Action ()
putNormal = Verbosity -> FilePath -> Action ()
putWhen Verbosity
Normal
putQuiet :: String -> Action ()
putQuiet :: FilePath -> Action ()
putQuiet = Verbosity -> FilePath -> Action ()
putWhen Verbosity
Quiet
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
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})
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
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})
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
trackUse :: ShakeValue key => key -> Action ()
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 ()
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 ()
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 ()
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}
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
[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]
""
[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]
""
trackChange :: ShakeValue key => key -> Action ()
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 ()
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 ()
else
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, ())
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)