    {-# 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 g l (Action x) = runRAW g l 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 f m = Action $ do
        s <- getRW
        let (s2,undo) = f s
        putRW s2
        res <- fromAction m
        modifyRW undo
        return res

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

    actionBoom :: Bool -> Action a -> IO b -> Action a
    actionBoom runOnSuccess act clean = do
        Global{..} <- Action getRO
        undo <- liftIO $ addCleanup globalCleanup $ void clean
        -- important to mask_ the undo/clean combo so either both happen or neither
        res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (mask_ $ undo >> clean) >> throwRAW e
        liftIO $ mask_ $ undo >> when runOnSuccess (void clean)
        return res

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

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

    ---------------------------------------------------------------------
    -- 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 $ \ops -> (op:ops, ())

    ---------------------------------------------------------------------
    -- 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 ('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 = putWhen 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 = putWhen 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 = putWhen 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 $ 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 = actionBracket $ \s0 ->
        (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity 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 = withVerbosity Quiet

    ---------------------------------------------------------------------
    -- 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 = actionBracket $ \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'.
    --   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 msg act = do
        Global{..} <- Action getRO
        Local{localStack} <- Action getRW
        start <- liftIO globalTimestamp
        putNormal $ "# " ++ msg ++ " (for " ++ showTopStack localStack ++ ")"
        res <- liftIO act
        stop <- liftIO globalTimestamp
        let trace = newTrace msg start stop
        liftIO $ evaluate $ rnf trace
        Action $ modifyRW $ \s -> s{localTraces = trace : localTraces s}
        return 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 = do
        let k = newKey key
        Global{..} <- Action getRO
        l@Local{..} <- Action getRW
        deps <- liftIO $ concatMapM (listDepends globalDatabase) localDepends
        let top = topStack localStack
        if top == Just k then
            return () -- condition 1
         else if k `elem` deps then
            return () -- condition 2
         else if any ($ k) localTrackAllows then
            return () -- condition 3
         else
            Action $ putRW l{localTrackUsed = k : localTrackUsed} -- condition 4

    trackCheckUsed :: Action ()
    trackCheckUsed = do
        Global{..} <- Action getRO
        Local{..} <- Action getRW
        liftIO $ do
            deps <- concatMapM (listDepends globalDatabase) localDepends

            -- check 3a
            bad <- return $ localTrackUsed \\ deps
            unless (null bad) $ do
                let n = length bad
                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 3b
            bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k
            unless (null bad) $ do
                let n = length bad
                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]
                    ""

    -- | 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 = do
        let k = newKey key
        Global{..} <- Action getRO
        Local{..} <- Action getRW
        liftIO $ do
            let top = topStack localStack
            if top == Just k then
                return () -- condition 1
             else if any ($ k) localTrackAllows then
                return () -- condition 2
             else
                -- condition 3
                atomicModifyIORef globalTrackAbsent $ \ks -> ((fromMaybe k top, k):ks, ())

    -- | Allow any matching key to violate the tracking rules.
    trackAllow :: ShakeValue key => (key -> Bool) -> Action ()
    trackAllow (test :: key -> Bool) = Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}
        where
            tk = typeRep (Proxy :: Proxy key)
            f k = typeKey k == tk && test (fromKey k)