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

module Development.Shake.Internal.Core.Run(
    run,
    Action, actionOnException, actionFinally, apply, apply1, traced,
    getDatabaseValue,
    getShakeOptions, getProgress,
    getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,
    Resource, newResourceIO, withResource, newThrottleIO,
    newCacheIO,
    unsafeExtraThread, unsafeAllowApply,
    parallel,
    orderOnlyAction,
    batch,
    runAfter
    ) where

import Control.Exception
import Control.Applicative
import Data.Tuple.Extra
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Typeable.Extra
import Data.Function
import Data.Either.Extra
import Data.List.Extra
import qualified Data.HashMap.Strict as Map
import Data.Dynamic
import Data.Maybe
import Data.IORef
import System.Directory
import System.IO.Extra
import System.Time.Extra
import Numeric.Extra
import qualified Data.ByteString as BS

import Development.Shake.Classes
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Core.Pool
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Resource
import Development.Shake.Internal.Value
import Development.Shake.Internal.Profile
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Timing
import General.Extra
import General.Concurrent
import General.Cleanup
import Prelude

---------------------------------------------------------------------
-- MAKE

-- | Internal main function (not exported publicly)
run :: ShakeOptions -> Rules () -> IO ()
run opts@ShakeOptions{..} rs = (if shakeLineBuffering then withLineBuffering else id) $ do
    opts@ShakeOptions{..} <- if shakeThreads /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}

    start <- offsetTime
    (actions, ruleinfo, userRules) <- runRules opts rs

    outputLocked <- do
        lock <- newLock
        return $ \v msg -> withLock lock $ shakeOutput v msg

    let diagnostic | shakeVerbosity < Diagnostic = const $ return ()
                   | otherwise = \act -> do v <- act; outputLocked Diagnostic $ "% " ++ v
    let output v = outputLocked v . shakeAbbreviationsApply opts
    diagnostic $ return "Starting run"

    except <- newIORef (Nothing :: Maybe (String, ShakeException))
    let raiseError err
            | not shakeStaunch = throwIO err
            | otherwise = do
                let named = shakeAbbreviationsApply opts . shakeExceptionTarget
                atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())
                -- no need to print exceptions here, they get printed when they are wrapped

    curdir <- getCurrentDirectory
    diagnostic $ return "Starting run 2"
    checkShakeExtra shakeExtra

    after <- newIORef []
    absent <- newIORef []
    withCleanup $ \cleanup -> do
        addCleanup_ cleanup $ do
            when (shakeTimings && shakeVerbosity >= Normal) printTimings
            resetTimings -- so we don't leak memory
        withNumCapabilities shakeThreads $ do
            diagnostic $ return "Starting run 3"
            withDatabase opts diagnostic (Map.map builtinKey ruleinfo) $ \database -> do
                wait <- newBarrier
                let getProgress = do
                        failure <- fmap fst <$> readIORef except
                        stats <- progress database
                        return stats{isFailure=failure}
                tid <- flip forkFinally (const $ signalBarrier wait ()) $
                    shakeProgress getProgress
                addCleanup_ cleanup $ do
                    killThread tid
                    void $ timeout 1 $ waitBarrier wait

                addTiming "Running rules"
                runPool (shakeThreads == 1) shakeThreads $ \pool -> do
                    let s0 = Global database pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules
                    let s1 = newLocal emptyStack shakeVerbosity
                    forM_ actions $ \act ->
                        addPoolStart pool $ runAction s0 s1 act $ \x -> case x of
                            Left e -> raiseError =<< shakeException s0 ["Top-level action/want"] e
                            Right x -> return x
                maybe (return ()) (throwIO . snd) =<< readIORef except
                assertFinishedDatabase database

                let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg

                when (null actions) $
                    putWhen Normal "Warning: No want/action statements, nothing to do"

                when (isJust shakeLint) $ do
                    addTiming "Lint checking"
                    lintCurrentDirectory curdir "After completion"
                    absent <- readIORef absent
                    checkValid database (runLint ruleinfo) absent
                    putWhen Loud "Lint checking succeeded"
                when (shakeReport /= []) $ do
                    addTiming "Profile report"
                    report <- toReport database
                    forM_ shakeReport $ \file -> do
                        putWhen Normal $ "Writing report to " ++ file
                        writeProfile file report
                when (shakeLiveFiles /= []) $ do
                    addTiming "Listing live"
                    live <- listLive database
                    let specialIsFileKey t = show (fst $ splitTyConApp t) == "FileQ"
                    let liveFiles = [show k | k <- live, specialIsFileKey $ typeKey k]
                    forM_ shakeLiveFiles $ \file -> do
                        putWhen Normal $ "Writing live list to " ++ file
                        (if file == "-" then putStr else writeFile file) $ unlines liveFiles
            after <- readIORef after
            unless (null after) $ do
                addTiming "Running runAfter"
                sequence_ $ reverse after


checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()
checkShakeExtra mp = do
    let bad = [(k,t) | (k,v) <- Map.toList mp, let t = dynTypeRep v, t /= k]
    case bad of
        (k,t):xs -> errorStructured "Invalid Map in shakeExtra"
            [("Key",Just $ show k),("Value type",Just $ show t)]
            (if null xs then "" else "Plus " ++ show (length xs) ++ " other keys")
        _ -> return ()


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


withLineBuffering :: IO a -> IO a
withLineBuffering act = do
    -- instead of withBuffering avoid two finally handlers and stack depth
    out <- hGetBuffering stdout
    err <- hGetBuffering stderr
    if out == LineBuffering && err == LineBuffering then act else do
        hSetBuffering stdout LineBuffering
        hSetBuffering stderr LineBuffering
        act `finally` do
            hSetBuffering stdout out
            hSetBuffering stderr err


getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Either BS.ByteString value))
getDatabaseValue k = do
    global@Global{..} <- Action getRO
    liftIO $ fmap (fmap $ fmap fromValue) $ lookupStatus globalDatabase $ newKey k


-- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.
--   This function requires that appropriate rules have been added with 'addUserRule'.
--   All @key@ values passed to 'apply' become dependencies of the 'Action'.
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
-- Don't short-circuit [] as we still want error messages
apply (ks :: [key]) = withResultType $ \(p :: Maybe (Action [value])) -> do
    -- this is the only place a user can inject a key into our world, so check they aren't throwing
    -- in unevaluated bottoms
    liftIO $ mapM_ (evaluate . rnf) ks

    let tk = typeRep (Proxy :: Proxy key)
        tv = typeRep (Proxy :: Proxy value)
    Global{..} <- Action getRO
    Local{localBlockApply} <- Action getRW
    whenJust localBlockApply $ liftIO . errorNoApply tk (show <$> listToMaybe ks)
    case Map.lookup tk globalRules of
        Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv)
        Just BuiltinRule{builtinResult=tv2} | tv /= tv2 -> errorInternal $ "result type does not match, " ++ show tv ++ " vs " ++ show tv2
        _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks


applyKeyValue :: [Key] -> Action [Value]
applyKeyValue [] = return []
applyKeyValue ks = do
    global@Global{..} <- Action getRO
    Local{localStack} <- Action getRW
    (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (BuildKey $ runKey global) localStack ks
    Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}
    return vs


runKey :: Global -> Stack -> Step -> Key -> Maybe (Result BS.ByteString) -> Bool -> Capture (Either SomeException (Bool, BS.ByteString, Result Value))
runKey global@Global{globalOptions=ShakeOptions{..},..} stack step k r dirtyChildren continue = do
    let tk = typeKey k
    BuiltinRule{..} <- case Map.lookup tk globalRules of
        Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing
        Just r -> return r

    let s = newLocal stack shakeVerbosity
    time <- offsetTime
    runAction global s (do
        res <- builtinRun k (fmap result r) dirtyChildren
        liftIO $ evaluate $ rnf res
        when (Just LintFSATrace == shakeLint) trackCheckUsed
        Action $ fmap ((,) res) getRW) $ \x -> case x of
            Left e -> do
                e <- if isNothing shakeLint then return e else handle return $
                    do lintCurrentDirectory globalCurDir $ "Running " ++ show k; return e
                continue . Left . toException =<< shakeException global (showStack stack) e
            Right (RunResult{..}, Local{..})
                | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->
                    continue $ Right (runChanged == ChangedStore, runStore, r{result = runValue})
                | otherwise -> do
                    dur <- time
                    let c | Just r <- r, runChanged == ChangedRecomputeSame = changed r
                          | otherwise = step
                    continue $ Right $ (,,) True runStore Result
                        {result = runValue
                        ,changed = c
                        ,built = step
                        ,depends = nubDepends $ reverse localDepends
                        ,execution = doubleToFloat $ dur - localDiscount
                        ,traces = reverse localTraces}


runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint mp k v = case Map.lookup (typeKey k) mp of
    Nothing -> return Nothing
    Just BuiltinRule{..} -> builtinLint k v


-- | 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 -> [String] -> SomeException -> IO ShakeException
shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of
    Just e@ShakeException{} -> return e
    Nothing -> do
        e <- return $ ShakeException (last $ "Unknown call stack" : stk) stk e
        when (shakeStaunch && shakeVerbosity >= Quiet) $
            globalOutput Quiet $ show e ++ "Continuing due to staunch mode"
        return e


-- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,
--   use 'apply' to allow parallelism.
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
apply1 = fmap head . apply . return


---------------------------------------------------------------------
-- RESOURCES

-- | Run an action which uses part of a finite resource. For more details see 'Resource'.
--   You cannot depend on a rule (e.g. 'need') while a resource is held.
withResource :: Resource -> Int -> Action a -> Action a
withResource r i act = do
    Global{..} <- Action getRO
    liftIO $ globalDiagnostic $ return $ show r ++ " waiting to acquire " ++ show i
    offset <- liftIO offsetTime
    Action $ captureRAW $ \continue -> acquireResource r globalPool i $ continue $ Right ()
    res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) $ do
        offset <- liftIO offset
        liftIO $ globalDiagnostic $ return $ show r ++ " acquired " ++ show i ++ " in " ++ showDuration offset
        Action $ modifyRW $ \s -> s{localDiscount = localDiscount s + offset}
        act
    liftIO $ releaseResource r globalPool i
    liftIO $ globalDiagnostic $ return $ show r ++ " released " ++ show i
    Action $ either throwRAW return res


-- | 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 (Either SomeException ([Depends],v)))) <- newVar Map.empty
    return $ \key ->
        join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of
            Just bar -> return $ (,) mp $ do
                res <- liftIO $ testFence bar
                (res,offset) <- case res of
                    Just res -> return (res, 0)
                    Nothing -> do
                        Global{..} <- Action getRO
                        offset <- liftIO offsetTime
                        Action $ captureRAW $ \k -> waitFence bar $ \v ->
                            addPoolResume globalPool $ do offset <- liftIO offset; k $ Right (v,offset)
                case res of
                    Left err -> Action $ throwRAW err
                    Right (deps,v) -> do
                        Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends s, localDiscount = localDiscount s + offset}
                        return v
            Nothing -> do
                bar <- newFence
                return $ (,) (Map.insert key bar mp) $ do
                    Local{localDepends=pre} <- Action getRW
                    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=post} <- Action getRW
                            let deps = take (length post - length pre) post
                            liftIO $ signalFence bar $ Right (deps, v)
                            return 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 = Action $ do
    Global{..} <- getRO
    stop <- liftIO $ increasePool globalPool
    res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act
    liftIO stop
    captureRAW $ \continue -> (if isLeft res then addPoolException else addPoolResume) globalPool $ continue res


-- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism.
parallel :: [Action a] -> Action [a]
-- Note: There is no parallel_ unlike sequence_ because there is no stack benefit to doing so
parallel [] = return []
parallel [x] = fmap return x
parallel acts = Action $ do
    global@Global{..} <- getRO
    local <- getRW
    -- number of items still to complete, or Nothing for has completed (by either failure or completion)
    todo :: Var (Maybe Int) <- liftIO $ newVar $ Just $ length acts
    -- a list of refs where the results go
    results :: [IORef (Maybe (Either SomeException (Local, a)))] <- liftIO $ replicateM (length acts) $ newIORef Nothing

    (locals, results) <- captureRAW $ \continue -> do
        let resume = do
                res <- liftIO $ sequence . catMaybes <$> mapM readIORef results
                continue $ fmap unzip res

        liftIO $ forM_ (zip acts results) $ \(act, result) -> do
            let act2 = do
                    whenM (liftIO $ isNothing <$> readVar todo) $
                        fail "parallel, one has already failed"
                    res <- act
                    old <- Action getRW
                    return (old, res)
            addPoolResume globalPool $ runAction global (localClearMutable local) act2 $ \res -> do
                writeIORef result $ Just res
                modifyVar_ todo $ \v -> case v of
                    Nothing -> return Nothing
                    Just i | i == 1 || isLeft res -> do resume; return Nothing
                    Just i -> return $ Just $ i - 1

    modifyRW $ \root -> localMergeMutable root locals
    return results


-- | 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}
    return res


-- | 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\"]; return 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
    -> ((a -> Action ()) -> Rules ())
    -> (a -> Action b)
    -> ([b] -> Action ())
    -> 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, Either SomeException Local -> IO ())]) <- liftIO $ newIORef (0, [])
        pred $ \a -> Action $ do
            b <- fromAction $ one a
            -- optimisation would be to avoid taking the continuation if count >= mx
            -- but it only saves one pool requeue per mx, which is likely to be trivial
            -- and the code becomes a lot more special cases
            global@Global{..} <- getRO
            local <- getRW
            local2 <- captureRAW $ \k -> do
                count <- atomicModifyIORef todo $ \(count, bs) -> ((count+1, (b,k):bs), count+1)
                -- only trigger on the edge so we don't have lots of waiting pool entries
                (if count == mx then addPoolResume else if count == 1 then addPoolBatch else none)
                    globalPool $ go global (localClearMutable local) todo
            modifyRW $ \root -> localMergeMutable root [local2]
    where
        none _ _ = return ()

        go global@Global{..} local todo = do
            (now, count) <- atomicModifyIORef todo $ \(count, bs) ->
                if count <= mx then
                    ((0, []), (bs, 0))
                else
                    let (xs,ys) = splitAt mx bs
                    in ((count - mx, ys), (xs, count - mx))
            (if count >= mx then addPoolResume else if count > 0 then addPoolBatch else none)
                    globalPool $ go global local todo
            unless (null now) $
                runAction global local (do many $ map fst now; Action getRW) $ \x ->
                    forM_ now $ \(_,k) ->
                        (if isLeft x then addPoolException else addPoolResume) globalPool $ k x