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

module Development.Shake.Internal.Core.Run(
    RunState,
    open,
    reset,
    run,
    shakeRunAfter,
    liveFilesState,
    profileState,
    errorsState
    ) where

import Control.Exception
import Data.Tuple.Extra
import Control.Concurrent.Extra hiding (withNumCapabilities)
import Development.Shake.Internal.Core.Database
import Control.Monad.IO.Class
import General.Binary
import Development.Shake.Classes
import Development.Shake.Internal.Core.Storage
import Development.Shake.Internal.Core.Build
import Development.Shake.Internal.History.Shared
import Development.Shake.Internal.History.Cloud
import qualified General.TypeMap as TMap
import Control.Monad.Extra
import Data.Typeable
import Numeric.Extra
import Data.List.Extra
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.Dynamic
import Data.Maybe
import Data.IORef.Extra
import System.Directory
import System.Time.Extra
import qualified Data.ByteString as BS

import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Rules
import General.Pool
import Development.Shake.Internal.Progress
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.Thread
import General.Extra
import General.Cleanup
import Data.Monoid
import Prelude


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

data RunState = RunState
    {RunState -> ShakeOptions
opts :: ShakeOptions
    ,RunState -> HashMap TypeRep BuiltinRule
builtinRules :: Map.HashMap TypeRep BuiltinRule
    ,RunState -> Map UserRuleVersioned
userRules :: TMap.Map UserRuleVersioned
    ,RunState -> Database
database :: Database
    ,RunState -> String
curdir :: FilePath
    ,RunState -> Maybe Shared
shared :: Maybe Shared
    ,RunState -> Maybe Cloud
cloud :: Maybe Cloud
    ,RunState -> [(Stack, Action ())]
actions :: [(Stack, Action ())]
    }


open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState
open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState
open Cleanup
cleanup ShakeOptions
opts Rules ()
rs = forall a.
ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a)
-> IO a
withInit ShakeOptions
opts forall a b. (a -> b) -> a -> b
$ \opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
..} IO String -> IO ()
diagnostic Verbosity -> String -> IO ()
_ -> do
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Starting run"
    SRules{[(Stack, Action ())]
actions :: forall (list :: * -> *). SRules list -> list (Stack, Action ())
actions :: [(Stack, Action ())]
actions, HashMap TypeRep BuiltinRule
builtinRules :: forall (list :: * -> *). SRules list -> HashMap TypeRep BuiltinRule
builtinRules :: HashMap TypeRep BuiltinRule
builtinRules, Map UserRuleVersioned
userRules :: forall (list :: * -> *). SRules list -> Map UserRuleVersioned
userRules :: Map UserRuleVersioned
userRules} <- ShakeOptions -> Rules () -> IO (SRules [])
runRules ShakeOptions
opts Rules ()
rs

    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Number of actions = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Stack, Action ())]
actions)
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Number of builtin rules = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k v. HashMap k v -> Int
Map.size HashMap TypeRep BuiltinRule
builtinRules) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k v. HashMap k v -> [k]
Map.keys HashMap TypeRep BuiltinRule
builtinRules)
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Number of user rule types = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (f :: * -> *). Map f -> Int
TMap.size Map UserRuleVersioned
userRules)
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Number of user rules = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (f :: * -> *) b. (forall a. f a -> b) -> Map f -> [b]
TMap.toList (forall a. UserRule a -> Int
userRuleSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. UserRuleVersioned a -> UserRule a
userRuleContents) Map UserRuleVersioned
userRules))

    HashMap TypeRep Dynamic -> IO ()
checkShakeExtra HashMap TypeRep Dynamic
shakeExtra
    String
curdir <- IO String
getCurrentDirectory

    Database
database <- Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap TypeRep BuiltinRule
-> IO Database
usingDatabase Cleanup
cleanup ShakeOptions
opts IO String -> IO ()
diagnostic HashMap TypeRep BuiltinRule
builtinRules
    (Maybe Shared
shared, Maybe Cloud
cloud) <- forall k v.
DatabasePoly k v
-> ShakeOptions
-> HashMap TypeRep BuiltinRule
-> IO (Maybe Shared, Maybe Cloud)
loadSharedCloud Database
database ShakeOptions
opts HashMap TypeRep BuiltinRule
builtinRules
    forall (f :: * -> *) a. Applicative f => a -> f a
pure RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
cloud :: Maybe Cloud
shared :: Maybe Shared
database :: Database
curdir :: String
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
actions :: [(Stack, Action ())]
opts :: ShakeOptions
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
..}


-- Prepare for a fresh run by changing Result to Loaded
reset :: RunState -> IO ()
reset :: RunState -> IO ()
reset RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
actions :: RunState -> [(Stack, Action ())]
cloud :: RunState -> Maybe Cloud
shared :: RunState -> Maybe Shared
curdir :: RunState -> String
database :: RunState -> Database
userRules :: RunState -> Map UserRuleVersioned
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
opts :: RunState -> ShakeOptions
..} = forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
database forall a b. (a -> b) -> a -> b
$
    forall k v. DatabasePoly k v -> (v -> v) -> Locked ()
modifyAllMem Database
database Status -> Status
f
    where
        f :: Status -> Status
f (Ready Result (Value, BS_Store)
r) = Result BS_Store -> Status
Loaded (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result (Value, BS_Store)
r)
        f (Failed SomeException
_ OneShot (Maybe (Result BS_Store))
x) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Status
Missing Result BS_Store -> Status
Loaded OneShot (Maybe (Result BS_Store))
x
        f (Running NoShow
  (Either SomeException (Result (Value, BS_Store)) -> Locked ())
_ OneShot (Maybe (Result BS_Store))
x) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Status
Missing Result BS_Store -> Status
Loaded OneShot (Maybe (Result BS_Store))
x -- shouldn't ever happen, but Loaded is least worst
        f Status
x = Status
x


run :: RunState -> Bool -> [Action ()] -> IO [IO ()]
run :: RunState -> Bool -> [Action ()] -> IO [IO ()]
run RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
actions :: RunState -> [(Stack, Action ())]
cloud :: RunState -> Maybe Cloud
shared :: RunState -> Maybe Shared
curdir :: RunState -> String
database :: RunState -> Database
userRules :: RunState -> Map UserRuleVersioned
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
opts :: RunState -> ShakeOptions
..} Bool
oneshot [Action ()]
actions2 =
    forall a.
ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a)
-> IO a
withInit ShakeOptions
opts forall a b. (a -> b) -> a -> b
$ \opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} IO String -> IO ()
diagnostic Verbosity -> String -> IO ()
output -> do

        -- timings are a bit delicate, we want to make sure we clear them before we leave (so each run is fresh)
        -- but we also want to only print them if there is no exception, and have to caputre them before we clear them
        -- we use this variable to stash them away, then print after the exception handling block
        IORef (Maybe [String])
timingsToShow <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing

        [IO ()]
res <- forall a. (Cleanup -> IO a) -> IO a
withCleanup forall a b. (a -> b) -> a -> b
$ \Cleanup
cleanup -> do
            Cleanup -> IO () -> IO ReleaseKey
register Cleanup
cleanup forall a b. (a -> b) -> a -> b
$ do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeTimings Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) forall a b. (a -> b) -> a -> b
$
                    forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe [String])
timingsToShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getTimings
                IO ()
resetTimings

            IO Seconds
start <- IO (IO Seconds)
offsetTime
            IORef (Maybe (String, ShakeException))
except <- forall a. a -> IO (IORef a)
newIORef (forall a. Maybe a
Nothing :: Maybe (String, ShakeException))
            let getFailure :: IO (Maybe String)
getFailure = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Maybe (String, ShakeException))
except
            let raiseError :: ShakeException -> IO ()
raiseError ShakeException
err
                    | Bool -> Bool
not Bool
shakeStaunch = forall e a. Exception e => e -> IO a
throwIO ShakeException
err
                    | Bool
otherwise = do
                        let named :: ShakeException -> String
named = ShakeOptions -> String -> String
shakeAbbreviationsApply ShakeOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeException -> String
shakeExceptionTarget
                        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (String, ShakeException))
except forall a b. (a -> b) -> a -> b
$ \Maybe (String, ShakeException)
v -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (ShakeException -> String
named ShakeException
err, ShakeException
err) Maybe (String, ShakeException)
v, ())
                        -- no need to print exceptions here, they get printed when they are wrapped

            IORef [IO ()]
after <- forall a. a -> IO (IORef a)
newIORef []
            IORef [(Key, Key)]
absent <- forall a. a -> IO (IORef a)
newIORef []
            Step
step <- Database -> IO Step
incrementStep Database
database
            IO Progress
getProgress <- Cleanup
-> ShakeOptions
-> Database
-> Step
-> IO (Maybe String)
-> IO (IO Progress)
usingProgress Cleanup
cleanup ShakeOptions
opts Database
database Step
step IO (Maybe String)
getFailure
            String -> String -> IO ()
lintCurrentDirectory String
curdir String
"When running"

            String -> IO ()
watch <- [String] -> IO (String -> IO ())
lintWatch [String]
shakeLintWatch
            let ruleFinished :: Key -> Action ()
ruleFinished
                    | forall a. Maybe a -> Bool
isJust Maybe Lint
shakeLint = \Key
k -> do
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
lintCurrentDirectory String
curdir forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
k
                        Action ()
lintTrackFinished
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
watch forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
k
                    | Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
watch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

            String -> IO ()
addTiming String
"Running rules"
            IORef [Local]
locals <- forall a. a -> IO (IORef a)
newIORef []
            Bool -> Int -> (Pool -> IO ()) -> IO ()
runPool (Int
shakeThreads forall a. Eq a => a -> a -> Bool
== Int
1) Int
shakeThreads forall a b. (a -> b) -> a -> b
$ \Pool
pool -> do
                let global :: Global
global = ([String] -> [Key] -> Action [Value])
-> Database
-> Pool
-> Cleanup
-> IO Seconds
-> HashMap TypeRep BuiltinRule
-> (Verbosity -> String -> IO ())
-> ShakeOptions
-> (IO String -> IO ())
-> (Key -> Action ())
-> IORef [IO ()]
-> IORef [(Key, Key)]
-> IO Progress
-> Map UserRuleVersioned
-> Maybe Shared
-> Maybe Cloud
-> Step
-> Bool
-> Global
Global [String] -> [Key] -> Action [Value]
applyKeyValue Database
database Pool
pool Cleanup
cleanup IO Seconds
start HashMap TypeRep BuiltinRule
builtinRules Verbosity -> String -> IO ()
output ShakeOptions
opts IO String -> IO ()
diagnostic Key -> Action ()
ruleFinished IORef [IO ()]
after IORef [(Key, Key)]
absent IO Progress
getProgress Map UserRuleVersioned
userRules Maybe Shared
shared Maybe Cloud
cloud Step
step Bool
oneshot
                -- give each action a stack to start with!
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Stack, Action ())]
actions forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Stack
emptyStack,) [Action ()]
actions2) forall a b. (a -> b) -> a -> b
$ \(Stack
stack, Action ()
act) -> do
                    let local :: Local
local = Stack -> Verbosity -> Local
newLocal Stack
stack Verbosity
shakeVerbosity
                    forall a. PoolPriority -> Pool -> IO a -> IO ()
addPool PoolPriority
PoolStart Pool
pool forall a b. (a -> b) -> a -> b
$ forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
global Local
local (Action ()
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Action Local
getLocal) forall a b. (a -> b) -> a -> b
$ \case
                        Left SomeException
e -> ShakeException -> IO ()
raiseError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Global -> Stack -> SomeException -> IO ShakeException
shakeException Global
global Stack
stack SomeException
e
                        Right Local
local -> forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef [Local]
locals (Local
localforall a. a -> [a] -> [a]
:)

            forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall a. IORef a -> IO a
readIORef IORef (Maybe (String, ShakeException))
except) (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
            Database -> IO ()
assertFinishedDatabase Database
database
            let putWhen :: Verbosity -> String -> IO ()
putWhen Verbosity
lvl String
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
shakeVerbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
lvl) forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
output Verbosity
lvl String
msg

            [Local]
locals <- forall a. IORef a -> IO a
readIORef IORef [Local]
locals
            Seconds
end <- IO Seconds
start
            if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Stack, Action ())]
actions Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action ()]
actions2 then
                Verbosity -> String -> IO ()
putWhen Verbosity
Info String
"Warning: No want/action statements, nothing to do"
             else
                Step -> [Local] -> Seconds -> Database -> IO ()
recordRoot Step
step [Local]
locals Seconds
end Database
database

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Lint
shakeLint) forall a b. (a -> b) -> a -> b
$ do
                String -> IO ()
addTiming String
"Lint checking"
                String -> String -> IO ()
lintCurrentDirectory String
curdir String
"After completion"
                (IO String -> IO ())
-> Database
-> (Key -> Value -> IO (Maybe String))
-> [(Key, Key)]
-> IO ()
checkValid IO String -> IO ()
diagnostic Database
database (HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint HashMap TypeRep BuiltinRule
builtinRules) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef [(Key, Key)]
absent
                Verbosity -> String -> IO ()
putWhen Verbosity
Verbose String
"Lint checking succeeded"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
shakeReport forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
                String -> IO ()
addTiming String
"Profile report"
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
shakeReport forall a b. (a -> b) -> a -> b
$ \String
file -> do
                    Verbosity -> String -> IO ()
putWhen Verbosity
Info forall a b. (a -> b) -> a -> b
$ String
"Writing report to " forall a. [a] -> [a] -> [a]
++ String
file
                    String -> Database -> IO ()
writeProfile String
file Database
database
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
shakeLiveFiles forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
                String -> IO ()
addTiming String
"Listing live"
                IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Listing live keys"
                [String]
xs <- Database -> IO [String]
liveFiles Database
database
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
shakeLiveFiles forall a b. (a -> b) -> a -> b
$ \String
file -> do
                    Verbosity -> String -> IO ()
putWhen Verbosity
Info forall a b. (a -> b) -> a -> b
$ String
"Writing live list to " forall a. [a] -> [a] -> [a]
++ String
file
                    (if String
file forall a. Eq a => a -> a -> Bool
== String
"-" then String -> IO ()
putStr else String -> String -> IO ()
writeFile String
file) forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
xs

            [IO ()]
res <- forall a. IORef a -> IO a
readIORef IORef [IO ()]
after
            String -> IO ()
addTiming String
"Cleanup"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [IO ()]
res

        forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall a. IORef a -> IO a
readIORef IORef (Maybe [String])
timingsToShow) forall a b. (a -> b) -> a -> b
$
            String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [IO ()]
res


-- | Run a set of IO actions, treated as \"after\" actions, typically returned from
--   'Development.Shake.Database.shakeRunDatabase'. The actions will be run with diagnostics
--   etc as specified in the 'ShakeOptions'.
shakeRunAfter :: ShakeOptions -> [IO ()] -> IO ()
shakeRunAfter :: ShakeOptions -> [IO ()] -> IO ()
shakeRunAfter ShakeOptions
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
shakeRunAfter ShakeOptions
opts [IO ()]
after = forall a.
ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a)
-> IO a
withInit ShakeOptions
opts forall a b. (a -> b) -> a -> b
$ \ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} IO String -> IO ()
diagnostic Verbosity -> String -> IO ()
_ -> do
    let n :: String
n = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [IO ()]
after
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Running " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" after actions"
    (Seconds
time, ()
_) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO ()]
after
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeTimings Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"(+ running " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n forall a. [a] -> [a] -> [a]
++ String
" after actions in " forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
time forall a. [a] -> [a] -> [a]
++ String
")"


withInit :: ShakeOptions -> (ShakeOptions -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a) -> IO a
withInit :: forall a.
ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a)
-> IO a
withInit ShakeOptions
opts ShakeOptions
-> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a
act =
    forall a. (Cleanup -> IO a) -> IO a
withCleanup forall a b. (a -> b) -> a -> b
$ \Cleanup
cleanup -> do
        opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} <- Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions Cleanup
cleanup ShakeOptions
opts
        (IO String -> IO ()
diagnostic, Verbosity -> String -> IO ()
output) <- ShakeOptions
-> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())
outputFunctions ShakeOptions
opts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Lock
newLock
        ShakeOptions
-> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a
act ShakeOptions
opts IO String -> IO ()
diagnostic Verbosity -> String -> IO ()
output


usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions Cleanup
cleanup ShakeOptions
opts = do
    opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} <- if ShakeOptions -> Int
shakeThreads ShakeOptions
opts forall a. Eq a => a -> a -> Bool
/= Int
0 then forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeOptions
opts else do Int
p <- IO Int
getProcessorCount; forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeOptions
opts{shakeThreads :: Int
shakeThreads=Int
p}
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shakeLineBuffering forall a b. (a -> b) -> a -> b
$ Cleanup -> IO ()
usingLineBuffering Cleanup
cleanup
    Cleanup -> Int -> IO ()
usingNumCapabilities Cleanup
cleanup Int
shakeThreads
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeOptions
opts

outputFunctions :: ShakeOptions -> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())
outputFunctions :: ShakeOptions
-> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())
outputFunctions opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} Lock
outputLock = (IO String -> IO ()
diagnostic, Verbosity -> String -> IO ()
output)
    where
        outputLocked :: Verbosity -> String -> IO ()
outputLocked Verbosity
v String
msg = forall a. Lock -> IO a -> IO a
withLock Lock
outputLock forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
v String
msg

        diagnostic :: IO String -> IO ()
diagnostic | Verbosity
shakeVerbosity forall a. Ord a => a -> a -> Bool
< Verbosity
Diagnostic = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                   | Bool
otherwise = \IO String
act -> do String
v <- IO String
act; Verbosity -> String -> IO ()
outputLocked Verbosity
Diagnostic forall a b. (a -> b) -> a -> b
$ String
"% " forall a. [a] -> [a] -> [a]
++ String
v
        output :: Verbosity -> String -> IO ()
output Verbosity
v = Verbosity -> String -> IO ()
outputLocked Verbosity
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeOptions -> String -> String
shakeAbbreviationsApply ShakeOptions
opts


usingProgress :: Cleanup -> ShakeOptions -> Database -> Step -> IO (Maybe String) -> IO (IO Progress)
usingProgress :: Cleanup
-> ShakeOptions
-> Database
-> Step
-> IO (Maybe String)
-> IO (IO Progress)
usingProgress Cleanup
cleanup ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} Database
database Step
step IO (Maybe String)
getFailure = do
    let getProgress :: IO Progress
getProgress = do
            Maybe String
failure <- IO (Maybe String)
getFailure
            Progress
stats <- Database -> Step -> IO Progress
progress Database
database Step
step
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
stats{isFailure :: Maybe String
isFailure=Maybe String
failure}
    Cleanup -> IO () -> IO ()
allocateThread Cleanup
cleanup forall a b. (a -> b) -> a -> b
$ IO Progress -> IO ()
shakeProgress IO Progress
getProgress
    forall (f :: * -> *) a. Applicative f => a -> f a
pure IO Progress
getProgress

checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()
checkShakeExtra :: HashMap TypeRep Dynamic -> IO ()
checkShakeExtra HashMap TypeRep Dynamic
mp = do
    let bad :: [(TypeRep, TypeRep)]
bad = [(TypeRep
k,TypeRep
t) | (TypeRep
k,Dynamic
v) <- forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep Dynamic
mp, let t :: TypeRep
t = Dynamic -> TypeRep
dynTypeRep Dynamic
v, TypeRep
t forall a. Eq a => a -> a -> Bool
/= TypeRep
k]
    case [(TypeRep, TypeRep)]
bad of
        (TypeRep
k,TypeRep
t):[(TypeRep, TypeRep)]
xs -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured String
"Invalid Map in shakeExtra"
            [(String
"Key",forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TypeRep
k),(String
"Value type",forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TypeRep
t)]
            (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TypeRep, TypeRep)]
xs then String
"" else String
"Plus " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TypeRep, TypeRep)]
xs) forall a. [a] -> [a] -> [a]
++ String
" other keys")
        [(TypeRep, TypeRep)]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint :: HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)
runLint HashMap TypeRep BuiltinRule
mp Key
k Value
v = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (Key -> TypeRep
typeKey Key
k) HashMap TypeRep BuiltinRule
mp of
    Maybe BuiltinRule
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just BuiltinRule{String
BinaryOp Key
Ver
BuiltinRun Key Value
BuiltinIdentity Key Value
Key -> Value -> IO (Maybe String)
builtinLocation :: BuiltinRule -> String
builtinVersion :: BuiltinRule -> Ver
builtinKey :: BuiltinRule -> BinaryOp Key
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
builtinLocation :: String
builtinVersion :: Ver
builtinKey :: BinaryOp Key
builtinRun :: BuiltinRun Key Value
builtinIdentity :: BuiltinIdentity Key Value
builtinLint :: Key -> Value -> IO (Maybe String)
..} -> Key -> Value -> IO (Maybe String)
builtinLint Key
k Value
v


assertFinishedDatabase :: Database -> IO ()
assertFinishedDatabase :: Database -> IO ()
assertFinishedDatabase Database
database = do
    -- if you have anyone Waiting, and are not exiting with an error, then must have a complex recursion (see #400)
    [(Key, Status)]
status <- forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    let bad :: [Key]
bad = [Key
key | (Key
key, Running{}) <- [(Key, Status)]
status]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Key]
bad forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ [String] -> SomeException
errorComplexRecursion (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
bad)


liveFilesState :: RunState -> IO [FilePath]
liveFilesState :: RunState -> IO [String]
liveFilesState RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
actions :: RunState -> [(Stack, Action ())]
cloud :: RunState -> Maybe Cloud
shared :: RunState -> Maybe Shared
curdir :: RunState -> String
database :: RunState -> Database
userRules :: RunState -> Map UserRuleVersioned
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
opts :: RunState -> ShakeOptions
..} = Database -> IO [String]
liveFiles Database
database

profileState :: RunState -> FilePath -> IO ()
profileState :: RunState -> String -> IO ()
profileState RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
actions :: RunState -> [(Stack, Action ())]
cloud :: RunState -> Maybe Cloud
shared :: RunState -> Maybe Shared
curdir :: RunState -> String
database :: RunState -> Database
userRules :: RunState -> Map UserRuleVersioned
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
opts :: RunState -> ShakeOptions
..} String
file = String -> Database -> IO ()
writeProfile String
file Database
database

liveFiles :: Database -> IO [FilePath]
liveFiles :: Database -> IO [String]
liveFiles Database
database = do
    [(Key, Status)]
status <- forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    let specialIsFileKey :: TypeRep -> Bool
specialIsFileKey TypeRep
t = forall a. Show a => a -> String
show (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t) forall a. Eq a => a -> a -> Bool
== String
"FileQ"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. Show a => a -> String
show Key
k | (Key
k, Ready{}) <- [(Key, Status)]
status, TypeRep -> Bool
specialIsFileKey forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k]

errorsState :: RunState -> IO [(String, SomeException)]
errorsState :: RunState -> IO [(String, SomeException)]
errorsState RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
actions :: [(Stack, Action ())]
cloud :: Maybe Cloud
shared :: Maybe Shared
curdir :: String
database :: Database
userRules :: Map UserRuleVersioned
builtinRules :: HashMap TypeRep BuiltinRule
opts :: ShakeOptions
actions :: RunState -> [(Stack, Action ())]
cloud :: RunState -> Maybe Cloud
shared :: RunState -> Maybe Shared
curdir :: RunState -> String
database :: RunState -> Database
userRules :: RunState -> Map UserRuleVersioned
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
opts :: RunState -> ShakeOptions
..} = do
    [(Key, Status)]
status <- forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. Show a => a -> String
show Key
k, SomeException
e) | (Key
k, Failed SomeException
e OneShot (Maybe (Result BS_Store))
_) <- [(Key, Status)]
status]


checkValid :: (IO String -> IO ()) -> Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()
checkValid :: (IO String -> IO ())
-> Database
-> (Key -> Value -> IO (Maybe String))
-> [(Key, Key)]
-> IO ()
checkValid IO String -> IO ()
diagnostic Database
db Key -> Value -> IO (Maybe String)
check [(Key, Key)]
absent = do
    [(Key, Status)]
status <- forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
db
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Starting validity/lint checking"

    -- TEST 1: Have values changed since being depended on
    -- Do not use a forM here as you use too much stack space
    [(Key, (Value, BS_Store), String)]
bad <- (\[(Key, (Value, BS_Store), String)]
-> (Key, Status) -> IO [(Key, (Value, BS_Store), String)]
f -> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Key, (Value, BS_Store), String)]
-> (Key, Status) -> IO [(Key, (Value, BS_Store), String)]
f [] [(Key, Status)]
status) forall a b. (a -> b) -> a -> b
$ \[(Key, (Value, BS_Store), String)]
seen (Key, Status)
v -> case (Key, Status)
v of
        (Key
key, Ready Result{Float
[Depends]
[Trace]
(Value, BS_Store)
Step
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
depends :: forall a. Result a -> [Depends]
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
traces :: [Trace]
execution :: Float
depends :: [Depends]
changed :: Step
built :: Step
result :: (Value, BS_Store)
..}) -> do
            Maybe String
good <- Key -> Value -> IO (Maybe String)
check Key
key forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (Value, BS_Store)
result
            IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Checking if " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key
key forall a. [a] -> [a] -> [a]
++ String
" is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Value, BS_Store)
result forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ if forall a. Maybe a -> Bool
isNothing Maybe String
good then String
"passed" else String
"FAILED"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Key
key, (Value, BS_Store)
result, String
now) | Just String
now <- [Maybe String
good]] forall a. [a] -> [a] -> [a]
++ [(Key, (Value, BS_Store), String)]
seen
        (Key, Status)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Key, (Value, BS_Store), String)]
seen
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, (Value, BS_Store), String)]
bad) forall a b. (a -> b) -> a -> b
$ do
        let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, (Value, BS_Store), String)]
bad
        forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured
            (String
"Lint checking error - " forall a. [a] -> [a] -> [a]
++ (if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then String
"value has" else forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" values have")  forall a. [a] -> [a] -> [a]
++ String
" changed since being depended upon")
            (forall a. [a] -> [[a]] -> [a]
intercalate [(String
"",forall a. a -> Maybe a
Just String
"")] [ [(String
"Key", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
key),(String
"Old", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Value, BS_Store)
result),(String
"New", forall a. a -> Maybe a
Just String
now)]
                                        | (Key
key, (Value, BS_Store)
result, String
now) <- [(Key, (Value, BS_Store), String)]
bad])
            String
""

    -- TEST 2: Is anything from lintTrackWrite which promised not to exist actually been created
    Key -> Maybe Id
exists <- forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> IO (k -> Maybe Id)
getIdFromKey Database
db
    [(Key, Key)]
bad <- forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Key
parent,Key
key) | (Key
parent, Key
key) <- forall a. HashSet a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [(Key, Key)]
absent, forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Key -> Maybe Id
exists Key
key]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, Key)]
bad) forall a b. (a -> b) -> a -> b
$ do
        let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Key)]
bad
        forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured
            (String
"Lint checking error - " forall a. [a] -> [a] -> [a]
++ (if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then String
"value" else forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" values") forall a. [a] -> [a] -> [a]
++ String
" did not have " forall a. [a] -> [a] -> [a]
++ (if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then String
"its" else String
"their") forall a. [a] -> [a] -> [a]
++ String
" creation tracked")
            (forall a. [a] -> [[a]] -> [a]
intercalate [(String
"",forall a. a -> Maybe a
Just String
"")] [ [(String
"Rule", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
parent), (String
"Created", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
key)] | (Key
parent,Key
key) <- [(Key, Key)]
bad])
            String
""

    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Validity/lint check passed"


---------------------------------------------------------------------
-- STORAGE

usingDatabase :: Cleanup -> ShakeOptions -> (IO String -> IO ()) -> Map.HashMap TypeRep BuiltinRule -> IO Database
usingDatabase :: Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap TypeRep BuiltinRule
-> IO Database
usingDatabase Cleanup
cleanup ShakeOptions
opts IO String -> IO ()
diagnostic HashMap TypeRep BuiltinRule
owitness = do
    let step :: (TypeRep, (Ver, BinaryOp Key))
step = (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy StepKey), (Int -> Ver
Ver Int
0, forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) (forall a b. a -> b -> a
const Key
stepKey)))
    let root :: (TypeRep, (Ver, BinaryOp Key))
root = (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy Root), (Int -> Ver
Ver Int
0, forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) (forall a b. a -> b -> a
const Key
rootKey)))
    HashMap QTypeRep (Ver, BinaryOp (Key, Status))
witness<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
        [ (TypeRep -> QTypeRep
QTypeRep TypeRep
t, (Ver
version, forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp ((Key -> Builder) -> (Key, Status) -> Builder
putDatabase Key -> Builder
putOp) ((BS_Store -> Key) -> BS_Store -> (Key, Status)
getDatabase BS_Store -> Key
getOp)))
        | (TypeRep
t,(Ver
version, BinaryOp{BS_Store -> Key
Key -> Builder
getOp :: forall v. BinaryOp v -> BS_Store -> v
putOp :: forall v. BinaryOp v -> v -> Builder
getOp :: BS_Store -> Key
putOp :: Key -> Builder
..})) <- (TypeRep, (Ver, BinaryOp Key))
step forall a. a -> [a] -> [a]
: (TypeRep, (Ver, BinaryOp Key))
root forall a. a -> [a] -> [a]
: forall k v. HashMap k v -> [(k, v)]
Map.toList (forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (\BuiltinRule{String
BinaryOp Key
Ver
BuiltinRun Key Value
BuiltinIdentity Key Value
Key -> Value -> IO (Maybe String)
builtinLocation :: String
builtinVersion :: Ver
builtinKey :: BinaryOp Key
builtinRun :: BuiltinRun Key Value
builtinIdentity :: BuiltinIdentity Key Value
builtinLint :: Key -> Value -> IO (Maybe String)
builtinLocation :: BuiltinRule -> String
builtinVersion :: BuiltinRule -> Ver
builtinKey :: BuiltinRule -> BinaryOp Key
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
..} -> (Ver
builtinVersion, BinaryOp Key
builtinKey)) HashMap TypeRep BuiltinRule
owitness)]
    (Ids (Key, Status)
status, QTypeRep -> Id -> (Key, Status) -> IO ()
journal) <- forall k v.
(Show k, Eq k, Hashable k, NFData k, Show v, NFData v) =>
Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap k (Ver, BinaryOp v)
-> IO (Ids v, k -> Id -> v -> IO ())
usingStorage Cleanup
cleanup ShakeOptions
opts IO String -> IO ()
diagnostic HashMap QTypeRep (Ver, BinaryOp (Key, Status))
witness
    Id -> Key -> Status -> IO ()
journal<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Id
i Key
k Status
v -> QTypeRep -> Id -> (Key, Status) -> IO ()
journal (TypeRep -> QTypeRep
QTypeRep forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k) Id
i (Key
k, Status
v)
    forall k v.
(Eq k, Hashable k) =>
Ids (k, v) -> (Id -> k -> v -> IO ()) -> v -> IO (DatabasePoly k v)
createDatabase Ids (Key, Status)
status Id -> Key -> Status -> IO ()
journal Status
Missing


incrementStep :: Database -> IO Step
incrementStep :: Database -> IO Step
incrementStep Database
db = forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
db forall a b. (a -> b) -> a -> b
$ do
    Id
stepId <- forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> Locked Id
mkId Database
db Key
stepKey
    Maybe (Key, Status)
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall k v. DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId Database
db Id
stepId
    Step
step <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ case Maybe (Key, Status)
v of
        Just (Key
_, Loaded Result BS_Store
r) -> Step -> Step
incStep forall a b. (a -> b) -> a -> b
$ Result BS_Store -> Step
fromStepResult Result BS_Store
r
        Maybe (Key, Status)
_ -> Word32 -> Step
Step Word32
1
    let stepRes :: Result (Value, BS_Store)
stepRes = Step -> Result (Value, BS_Store)
toStepResult Step
step
    forall k v. DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database
db Id
stepId Key
stepKey forall a b. (a -> b) -> a -> b
$ Result (Value, BS_Store) -> Status
Ready Result (Value, BS_Store)
stepRes
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk Database
db Id
stepId Key
stepKey forall a b. (a -> b) -> a -> b
$ Result BS_Store -> Status
Loaded forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Result (Value, BS_Store)
stepRes
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
step

toStepResult :: Step -> Result (Value, BS_Store)
toStepResult :: Step -> Result (Value, BS_Store)
toStepResult Step
i = forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result (forall a. (Typeable a, Show a, NFData a) => a -> Value
newValue Step
i, Builder -> BS_Store
runBuilder forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx Step
i) Step
i Step
i [] Float
0 []

fromStepResult :: Result BS_Store -> Step
fromStepResult :: Result BS_Store -> Step
fromStepResult = forall a. BinaryEx a => BS_Store -> a
getEx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Result a -> a
result


recordRoot :: Step -> [Local] -> Seconds -> Database -> IO ()
recordRoot :: Step -> [Local] -> Seconds -> Database -> IO ()
recordRoot Step
step [Local]
locals (Seconds -> Float
doubleToFloat -> Float
end) Database
db = forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
db forall a b. (a -> b) -> a -> b
$ do
    Id
rootId <- forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> Locked Id
mkId Database
db Key
rootKey
    let local :: Local
local = Local -> [Local] -> Local
localMergeMutable (Stack -> Verbosity -> Local
newLocal Stack
emptyStack Verbosity
Info) [Local]
locals
    let rootRes :: Result (Value, BS_Store)
rootRes = Result
            {result :: (Value, BS_Store)
result = (forall a. (Typeable a, Show a, NFData a) => a -> Value
newValue (), BS_Store
BS.empty)
            ,changed :: Step
changed = Step
step
            ,built :: Step
built = Step
step
            ,depends :: [Depends]
depends = DependsList -> [Depends]
flattenDepends forall a b. (a -> b) -> a -> b
$ Local -> DependsList
localDepends Local
local
            ,execution :: Float
execution = Float
0
            ,traces :: [Trace]
traces = Traces -> [Trace]
flattenTraces forall a b. (a -> b) -> a -> b
$ Traces -> Trace -> Traces
addTrace (Local -> Traces
localTraces Local
local) forall a b. (a -> b) -> a -> b
$ BS_Store -> Float -> Float -> Trace
Trace BS_Store
BS.empty Float
end Float
end}
    forall k v. DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database
db Id
rootId Key
rootKey forall a b. (a -> b) -> a -> b
$ Result (Value, BS_Store) -> Status
Ready Result (Value, BS_Store)
rootRes
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk Database
db Id
rootId Key
rootKey forall a b. (a -> b) -> a -> b
$ Result BS_Store -> Status
Loaded forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Result (Value, BS_Store)
rootRes


loadSharedCloud :: DatabasePoly k v -> ShakeOptions -> Map.HashMap TypeRep BuiltinRule -> IO (Maybe Shared, Maybe Cloud)
loadSharedCloud :: forall k v.
DatabasePoly k v
-> ShakeOptions
-> HashMap TypeRep BuiltinRule
-> IO (Maybe Shared, Maybe Cloud)
loadSharedCloud DatabasePoly k v
var ShakeOptions
opts HashMap TypeRep BuiltinRule
owitness = do
    let mp :: HashMap String BuiltinRule
mp = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a a' b. (a -> a') -> (a, b) -> (a', b)
first forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> QTypeRep
QTypeRep) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep BuiltinRule
owitness
    let wit :: BinaryOp (String, Key)
wit = forall a b. BinaryEx a => (a -> BinaryOp b) -> BinaryOp (a, b)
binaryOpMap forall a b. (a -> b) -> a -> b
$ \String
a -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Partial => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"loadSharedCloud, couldn't find map for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
a) BuiltinRule -> BinaryOp Key
builtinKey forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup String
a HashMap String BuiltinRule
mp
    let wit2 :: BinaryOp Key
wit2 = forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (\Key
k -> forall v. BinaryOp v -> v -> Builder
putOp BinaryOp (String, Key)
wit (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TypeRep -> QTypeRep
QTypeRep forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k, Key
k)) (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. BinaryOp v -> BS_Store -> v
getOp BinaryOp (String, Key)
wit)
    let keyVers :: [(TypeRep, Ver)]
keyVers = [(TypeRep
k, BuiltinRule -> Ver
builtinVersion BuiltinRule
v) | (TypeRep
k,BuiltinRule
v) <- forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep BuiltinRule
owitness]
    let ver :: Ver
ver = String -> Ver
makeVer forall a b. (a -> b) -> a -> b
$ ShakeOptions -> String
shakeVersion ShakeOptions
opts

    Maybe Shared
shared <- case ShakeOptions -> Maybe String
shakeShare ShakeOptions
opts of
        Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just String
x -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> BinaryOp Key -> Ver -> String -> IO Shared
newShared (ShakeOptions -> Bool
shakeSymlink ShakeOptions
opts) BinaryOp Key
wit2 Ver
ver String
x
    Maybe Cloud
cloud <- case (Locked () -> IO ())
-> HashMap TypeRep (BinaryOp Key)
-> Ver
-> [(TypeRep, Ver)]
-> [String]
-> Maybe (IO Cloud)
newCloud (forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked DatabasePoly k v
var) (forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map BuiltinRule -> BinaryOp Key
builtinKey HashMap TypeRep BuiltinRule
owitness) Ver
ver [(TypeRep, Ver)]
keyVers forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeCloud ShakeOptions
opts of
        Maybe (IO Cloud)
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeCloud ShakeOptions
opts -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Maybe (IO Cloud)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"shakeCloud set but Shake not compiled for cloud operation"
        Just IO Cloud
res -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Cloud
res
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Shared
shared, Maybe Cloud
cloud)


putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)
putDatabase :: (Key -> Builder) -> (Key, Status) -> Builder
putDatabase Key -> Builder
putKey (Key
key, Loaded (Result BS_Store
x1 Step
x2 Step
x3 [Depends]
x4 Float
x5 [Trace]
x6)) =
    Builder -> Builder
putExN (Key -> Builder
putKey Key
key) forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN (forall a. BinaryEx a => a -> Builder
putEx BS_Store
x1) forall a. Semigroup a => a -> a -> a
<> forall a. BinaryEx a => a -> Builder
putEx Step
x2 forall a. Semigroup a => a -> a -> a
<> forall a. BinaryEx a => a -> Builder
putEx Step
x3 forall a. Semigroup a => a -> a -> a
<> forall a. BinaryEx a => a -> Builder
putEx Float
x5 forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN (forall a. BinaryEx a => a -> Builder
putEx [Depends]
x4) forall a. Semigroup a => a -> a -> a
<> forall a. BinaryEx a => a -> Builder
putEx [Trace]
x6
putDatabase Key -> Builder
_ (Key
_, Status
x) = forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal forall a b. (a -> b) -> a -> b
$ String
"putWith, Cannot write Status with constructor " forall a. [a] -> [a] -> [a]
++ Status -> String
statusType Status
x


getDatabase :: (BS.ByteString -> Key) -> BS.ByteString -> (Key, Status)
getDatabase :: (BS_Store -> Key) -> BS_Store -> (Key, Status)
getDatabase BS_Store -> Key
getKey BS_Store
bs
    | (BS_Store
key, BS_Store
bs) <- BS_Store -> (BS_Store, BS_Store)
getExN BS_Store
bs
    , (BS_Store
x1, BS_Store
bs) <- BS_Store -> (BS_Store, BS_Store)
getExN BS_Store
bs
    , (Step
x2, Step
x3, Float
x5, BS_Store
bs) <- forall a b c.
(Storable a, Storable b, Storable c) =>
BS_Store -> (a, b, c, BS_Store)
binarySplit3 BS_Store
bs
    , (BS_Store
x4, BS_Store
x6) <- BS_Store -> (BS_Store, BS_Store)
getExN BS_Store
bs
    = (BS_Store -> Key
getKey BS_Store
key, Result BS_Store -> Status
Loaded (forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result BS_Store
x1 Step
x2 Step
x3 (forall a. BinaryEx a => BS_Store -> a
getEx BS_Store
x4) Float
x5 (forall a. BinaryEx a => BS_Store -> a
getEx BS_Store
x6)))