{-# 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
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
..}
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
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
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, ())
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
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
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 ()
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
[(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)]
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"
[(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
""
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"
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)))