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

    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Number of actions = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(Stack, Action ())] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Stack, Action ())]
actions)
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Number of builtin rules = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (HashMap TypeRep BuiltinRule -> Int
forall k v. HashMap k v -> Int
Map.size HashMap TypeRep BuiltinRule
builtinRules) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TypeRep] -> String
forall a. Show a => a -> String
show (HashMap TypeRep BuiltinRule -> [TypeRep]
forall k v. HashMap k v -> [k]
Map.keys HashMap TypeRep BuiltinRule
builtinRules)
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Number of user rule types = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Map UserRuleVersioned -> Int
forall (f :: * -> *). Map f -> Int
TMap.size Map UserRuleVersioned
userRules)
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Number of user rules = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((forall a. UserRuleVersioned a -> Int)
-> Map UserRuleVersioned -> [Int]
forall (f :: * -> *) b. (forall a. f a -> b) -> Map f -> [b]
TMap.toList (UserRule a -> Int
forall a. UserRule a -> Int
userRuleSize (UserRule a -> Int)
-> (UserRuleVersioned a -> UserRule a)
-> UserRuleVersioned a
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserRuleVersioned a -> UserRule a
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) <- Database
-> ShakeOptions
-> HashMap TypeRep BuiltinRule
-> IO (Maybe Shared, Maybe 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
    RunState -> IO RunState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RunState{String
[(Stack, Action ())]
Maybe Shared
Maybe Cloud
HashMap TypeRep BuiltinRule
ShakeOptions
Database
Map UserRuleVersioned
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
opts :: ShakeOptions
actions :: [(Stack, Action ())]
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
curdir :: String
database :: Database
shared :: Maybe Shared
cloud :: Maybe Cloud
..}


-- 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
opts :: RunState -> ShakeOptions
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
userRules :: RunState -> Map UserRuleVersioned
database :: RunState -> Database
curdir :: RunState -> String
shared :: RunState -> Maybe Shared
cloud :: RunState -> Maybe Cloud
actions :: RunState -> [(Stack, Action ())]
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
..} = Database -> Locked () -> IO ()
forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
database (Locked () -> IO ()) -> Locked () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Database -> (Status -> Status) -> Locked ()
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 ((Value, BS_Store) -> BS_Store
forall a b. (a, b) -> b
snd ((Value, BS_Store) -> BS_Store)
-> Result (Value, BS_Store) -> Result BS_Store
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) = Status
-> (Result BS_Store -> Status)
-> OneShot (Maybe (Result BS_Store))
-> Status
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) = Status
-> (Result BS_Store -> Status)
-> OneShot (Maybe (Result BS_Store))
-> Status
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
opts :: RunState -> ShakeOptions
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
userRules :: RunState -> Map UserRuleVersioned
database :: RunState -> Database
curdir :: RunState -> String
shared :: RunState -> Maybe Shared
cloud :: RunState -> Maybe Cloud
actions :: RunState -> [(Stack, Action ())]
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
..} Bool
oneshot [Action ()]
actions2 =
    ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ())
    -> (Verbosity -> String -> IO ())
    -> IO [IO ()])
-> IO [IO ()]
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 [IO ()])
 -> IO [IO ()])
-> (ShakeOptions
    -> (IO String -> IO ())
    -> (Verbosity -> String -> IO ())
    -> IO [IO ()])
-> IO [IO ()]
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} 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 <- Maybe [String] -> IO (IORef (Maybe [String]))
forall a. a -> IO (IORef a)
newIORef Maybe [String]
forall a. Maybe a
Nothing

        [IO ()]
res <- (Cleanup -> IO [IO ()]) -> IO [IO ()]
forall a. (Cleanup -> IO a) -> IO a
withCleanup ((Cleanup -> IO [IO ()]) -> IO [IO ()])
-> (Cleanup -> IO [IO ()]) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \Cleanup
cleanup -> do
            Cleanup -> IO () -> IO ReleaseKey
register Cleanup
cleanup (IO () -> IO ReleaseKey) -> IO () -> IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeTimings Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    IORef (Maybe [String]) -> Maybe [String] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe [String])
timingsToShow (Maybe [String] -> IO ())
-> ([String] -> Maybe [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> IO ()) -> IO [String] -> IO ()
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 <- Maybe (String, ShakeException)
-> IO (IORef (Maybe (String, ShakeException)))
forall a. a -> IO (IORef a)
newIORef (Maybe (String, ShakeException)
forall a. Maybe a
Nothing :: Maybe (String, ShakeException))
            let getFailure :: IO (Maybe String)
getFailure = ((String, ShakeException) -> String)
-> Maybe (String, ShakeException) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ShakeException) -> String
forall a b. (a, b) -> a
fst (Maybe (String, ShakeException) -> Maybe String)
-> IO (Maybe (String, ShakeException)) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe (String, ShakeException))
-> IO (Maybe (String, ShakeException))
forall a. IORef a -> IO a
readIORef IORef (Maybe (String, ShakeException))
except
            let raiseError :: ShakeException -> IO ()
raiseError ShakeException
err
                    | Bool -> Bool
not Bool
shakeStaunch = ShakeException -> IO ()
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 (String -> String)
-> (ShakeException -> String) -> ShakeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeException -> String
shakeExceptionTarget
                        IORef (Maybe (String, ShakeException))
-> (Maybe (String, ShakeException)
    -> (Maybe (String, ShakeException), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (String, ShakeException))
except ((Maybe (String, ShakeException)
  -> (Maybe (String, ShakeException), ()))
 -> IO ())
-> (Maybe (String, ShakeException)
    -> (Maybe (String, ShakeException), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (String, ShakeException)
v -> ((String, ShakeException) -> Maybe (String, ShakeException)
forall a. a -> Maybe a
Just ((String, ShakeException) -> Maybe (String, ShakeException))
-> (String, ShakeException) -> Maybe (String, ShakeException)
forall a b. (a -> b) -> a -> b
$ (String, ShakeException)
-> Maybe (String, ShakeException) -> (String, ShakeException)
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 <- [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
            IORef [(Key, Key)]
absent <- [(Key, Key)] -> IO (IORef [(Key, Key)])
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
                    | Maybe Lint -> Bool
forall a. Maybe a -> Bool
isJust Maybe Lint
shakeLint = \Key
k -> do
                        IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
lintCurrentDirectory String
curdir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k
                        Action ()
lintTrackFinished
                        IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
watch (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k
                    | Bool
otherwise = IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> (Key -> IO ()) -> Key -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
watch (String -> IO ()) -> (Key -> String) -> Key -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String
forall a. Show a => a -> String
show

            String -> IO ()
addTiming String
"Running rules"
            IORef [Local]
locals <- [Local] -> IO (IORef [Local])
forall a. a -> IO (IORef a)
newIORef []
            Bool -> Int -> (Pool -> IO ()) -> IO ()
runPool (Int
shakeThreads Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) Int
shakeThreads ((Pool -> IO ()) -> IO ()) -> (Pool -> IO ()) -> IO ()
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!
                [(Stack, Action ())] -> ((Stack, Action ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Stack, Action ())]
actions [(Stack, Action ())]
-> [(Stack, Action ())] -> [(Stack, Action ())]
forall a. [a] -> [a] -> [a]
++ (Action () -> (Stack, Action ()))
-> [Action ()] -> [(Stack, Action ())]
forall a b. (a -> b) -> [a] -> [b]
map (Stack
emptyStack,) [Action ()]
actions2) (((Stack, Action ()) -> IO ()) -> IO ())
-> ((Stack, Action ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Stack
stack, Action ()
act) -> do
                    let local :: Local
local = Stack -> Verbosity -> Local
newLocal Stack
stack Verbosity
shakeVerbosity
                    PoolPriority -> Pool -> IO () -> IO ()
forall a. PoolPriority -> Pool -> IO a -> IO ()
addPool PoolPriority
PoolStart Pool
pool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global
-> Local -> Action Local -> Capture (Either SomeException Local)
forall a.
Global -> Local -> Action a -> Capture (Either SomeException a)
runAction Global
global Local
local (Action ()
act Action () -> Action Local -> Action Local
forall a b. Action a -> Action b -> Action b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Action Local
getLocal) Capture (Either SomeException Local)
-> Capture (Either SomeException Local)
forall a b. (a -> b) -> a -> b
$ \case
                        Left SomeException
e -> ShakeException -> IO ()
raiseError (ShakeException -> IO ()) -> IO ShakeException -> IO ()
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 -> IORef [Local] -> ([Local] -> [Local]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef [Local]
locals (Local
localLocal -> [Local] -> [Local]
forall a. a -> [a] -> [a]
:)

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

            [Local]
locals <- IORef [Local] -> IO [Local]
forall a. IORef a -> IO a
readIORef IORef [Local]
locals
            Seconds
end <- IO Seconds
start
            if [(Stack, Action ())] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Stack, Action ())]
actions Bool -> Bool -> Bool
&& [Action ()] -> Bool
forall a. [a] -> 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

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

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

        IO (Maybe [String]) -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (IORef (Maybe [String]) -> IO (Maybe [String])
forall a. IORef a -> IO a
readIORef IORef (Maybe [String])
timingsToShow) (([String] -> IO ()) -> IO ()) -> ([String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
putStr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
        [IO ()] -> IO [IO ()]
forall a. a -> IO a
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
_ [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
shakeRunAfter ShakeOptions
opts [IO ()]
after = ShakeOptions
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO ())
-> IO ()
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 ())
 -> IO ())
-> (ShakeOptions
    -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO ())
-> IO ()
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} IO String -> IO ()
diagnostic Verbosity -> String -> IO ()
_ -> do
    let n :: String
n = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [IO ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IO ()]
after
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Running " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" after actions"
    (Seconds
time, ()
_) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> [IO ()]
forall a. [a] -> [a]
reverse [IO ()]
after
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shakeTimings Bool -> Bool -> Bool
&& Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"(+ running " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" after actions in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
time String -> String -> String
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 =
    (Cleanup -> IO a) -> IO a
forall a. (Cleanup -> IO a) -> IO a
withCleanup ((Cleanup -> IO a) -> IO a) -> (Cleanup -> IO a) -> IO a
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} <- 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 (Lock -> (IO String -> IO (), Verbosity -> String -> IO ()))
-> IO Lock -> IO (IO String -> IO (), Verbosity -> String -> IO ())
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} <- if ShakeOptions -> Int
shakeThreads ShakeOptions
opts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then ShakeOptions -> IO ShakeOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeOptions
opts else do Int
p <- IO Int
getProcessorCount; ShakeOptions -> IO ShakeOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeOptions
opts{shakeThreads=p}
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shakeLineBuffering (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Cleanup -> IO ()
usingLineBuffering Cleanup
cleanup
    Cleanup -> Int -> IO ()
usingNumCapabilities Cleanup
cleanup Int
shakeThreads
    ShakeOptions -> IO ShakeOptions
forall a. a -> IO a
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} Lock
outputLock = (IO String -> IO ()
diagnostic, Verbosity -> String -> IO ()
output)
    where
        outputLocked :: Verbosity -> String -> IO ()
outputLocked Verbosity
v String
msg = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
outputLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
v String
msg

        diagnostic :: IO String -> IO ()
diagnostic | Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
< Verbosity
Diagnostic = IO () -> IO String -> IO ()
forall a b. a -> b -> a
const (IO () -> IO String -> IO ()) -> IO () -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"% " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
        output :: Verbosity -> String -> IO ()
output Verbosity
v = Verbosity -> String -> IO ()
outputLocked Verbosity
v (String -> IO ()) -> (String -> String) -> String -> IO ()
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 ()
shakeFiles :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeVersion :: ShakeOptions -> String
shakeVerbosity :: ShakeOptions -> Verbosity
shakeStaunch :: ShakeOptions -> Bool
shakeReport :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeLintInside :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintWatch :: ShakeOptions -> [String]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeStorageLog :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeCreationCheck :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeVersionIgnore :: ShakeOptions -> Bool
shakeColor :: ShakeOptions -> Bool
shakeShare :: ShakeOptions -> Maybe String
shakeCloud :: ShakeOptions -> [String]
shakeSymlink :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} 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
            Progress -> IO Progress
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
stats{isFailure=failure}
    Cleanup -> IO () -> IO ()
allocateThread Cleanup
cleanup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Progress -> IO ()
shakeProgress IO Progress
getProgress
    IO Progress -> IO (IO Progress)
forall a. a -> IO a
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) <- HashMap TypeRep Dynamic -> [(TypeRep, Dynamic)]
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 TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeRep
k]
    case [(TypeRep, TypeRep)]
bad of
        (TypeRep
k,TypeRep
t):[(TypeRep, TypeRep)]
xs -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured String
"Invalid Map in shakeExtra"
            [(String
"Key",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
k),(String
"Value type",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t)]
            (if [(TypeRep, TypeRep)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TypeRep, TypeRep)]
xs then String
"" else String
"Plus " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(TypeRep, TypeRep)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TypeRep, TypeRep)]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" other keys")
        [(TypeRep, TypeRep)]
_ -> () -> IO ()
forall a. a -> IO a
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 TypeRep -> HashMap TypeRep BuiltinRule -> Maybe BuiltinRule
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 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    Just BuiltinRule{String
BinaryOp Key
Ver
BuiltinRun Key Value
BuiltinIdentity Key Value
Key -> Value -> IO (Maybe String)
builtinLint :: Key -> Value -> IO (Maybe String)
builtinIdentity :: BuiltinIdentity Key Value
builtinRun :: BuiltinRun Key Value
builtinKey :: BinaryOp Key
builtinVersion :: Ver
builtinLocation :: String
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinKey :: BuiltinRule -> BinaryOp Key
builtinVersion :: BuiltinRule -> Ver
builtinLocation :: BuiltinRule -> 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 <- Database -> IO [(Key, 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]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Key]
bad [Key] -> [Key] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        SomeException -> IO ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> SomeException
errorComplexRecursion ((Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
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
opts :: RunState -> ShakeOptions
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
userRules :: RunState -> Map UserRuleVersioned
database :: RunState -> Database
curdir :: RunState -> String
shared :: RunState -> Maybe Shared
cloud :: RunState -> Maybe Cloud
actions :: RunState -> [(Stack, Action ())]
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
..} = 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
opts :: RunState -> ShakeOptions
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
userRules :: RunState -> Map UserRuleVersioned
database :: RunState -> Database
curdir :: RunState -> String
shared :: RunState -> Maybe Shared
cloud :: RunState -> Maybe Cloud
actions :: RunState -> [(Stack, Action ())]
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
..} 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 <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    let specialIsFileKey :: TypeRep -> Bool
specialIsFileKey TypeRep
t = TyCon -> String
forall a. Show a => a -> String
show ((TyCon, [TypeRep]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [TypeRep]) -> TyCon) -> (TyCon, [TypeRep]) -> TyCon
forall a b. (a -> b) -> a -> b
$ TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FileQ"
    [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Key -> String
forall a. Show a => a -> String
show Key
k | (Key
k, Ready{}) <- [(Key, Status)]
status, TypeRep -> Bool
specialIsFileKey (TypeRep -> Bool) -> TypeRep -> Bool
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
opts :: RunState -> ShakeOptions
builtinRules :: RunState -> HashMap TypeRep BuiltinRule
userRules :: RunState -> Map UserRuleVersioned
database :: RunState -> Database
curdir :: RunState -> String
shared :: RunState -> Maybe Shared
cloud :: RunState -> Maybe Cloud
actions :: RunState -> [(Stack, Action ())]
opts :: ShakeOptions
builtinRules :: HashMap TypeRep BuiltinRule
userRules :: Map UserRuleVersioned
database :: Database
curdir :: String
shared :: Maybe Shared
cloud :: Maybe Cloud
actions :: [(Stack, Action ())]
..} = do
    [(Key, Status)]
status <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    [(String, SomeException)] -> IO [(String, SomeException)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Key -> String
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 <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
db
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
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 -> ([(Key, (Value, BS_Store), String)]
 -> (Key, Status) -> IO [(Key, (Value, BS_Store), String)])
-> [(Key, (Value, BS_Store), String)]
-> [(Key, Status)]
-> IO [(Key, (Value, BS_Store), String)]
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) (([(Key, (Value, BS_Store), String)]
  -> (Key, Status) -> IO [(Key, (Value, BS_Store), String)])
 -> IO [(Key, (Value, BS_Store), String)])
-> ([(Key, (Value, BS_Store), String)]
    -> (Key, Status) -> IO [(Key, (Value, BS_Store), String)])
-> IO [(Key, (Value, BS_Store), String)]
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
result :: (Value, BS_Store)
built :: Step
changed :: Step
depends :: [Depends]
execution :: Float
traces :: [Trace]
result :: forall a. Result a -> a
built :: forall a. Result a -> Step
changed :: forall a. Result a -> Step
depends :: forall a. Result a -> [Depends]
execution :: forall a. Result a -> Float
traces :: forall a. Result a -> [Trace]
..}) -> do
            Maybe String
good <- Key -> Value -> IO (Maybe String)
check Key
key (Value -> IO (Maybe String)) -> Value -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ (Value, BS_Store) -> Value
forall a b. (a, b) -> a
fst (Value, BS_Store)
result
            IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Checking if " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Value, BS_Store) -> String
forall a. Show a => a -> String
show (Value, BS_Store)
result String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
good then String
"passed" else String
"FAILED"
            [(Key, (Value, BS_Store), String)]
-> IO [(Key, (Value, BS_Store), String)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Key, (Value, BS_Store), String)]
 -> IO [(Key, (Value, BS_Store), String)])
-> [(Key, (Value, BS_Store), String)]
-> IO [(Key, (Value, BS_Store), String)]
forall a b. (a -> b) -> a -> b
$ [(Key
key, (Value, BS_Store)
result, String
now) | Just String
now <- [Maybe String
good]] [(Key, (Value, BS_Store), String)]
-> [(Key, (Value, BS_Store), String)]
-> [(Key, (Value, BS_Store), String)]
forall a. [a] -> [a] -> [a]
++ [(Key, (Value, BS_Store), String)]
seen
        (Key, Status)
_ -> [(Key, (Value, BS_Store), String)]
-> IO [(Key, (Value, BS_Store), String)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Key, (Value, BS_Store), String)]
seen
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Key, (Value, BS_Store), String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, (Value, BS_Store), String)]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let n :: Int
n = [(Key, (Value, BS_Store), String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, (Value, BS_Store), String)]
bad
        SomeException -> IO ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured
            (String
"Lint checking error - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"value has" else Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values have")  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed since being depended upon")
            ([(String, Maybe String)]
-> [[(String, Maybe String)]] -> [(String, Maybe String)]
forall a. [a] -> [[a]] -> [a]
intercalate [(String
"",String -> Maybe String
forall a. a -> Maybe a
Just String
"")] [ [(String
"Key", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
key),(String
"Old", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Value, BS_Store) -> String
forall a. Show a => a -> String
show (Value, BS_Store)
result),(String
"New", String -> Maybe String
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 <- Database -> IO (Key -> Maybe Id)
forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> IO (k -> Maybe Id)
getIdFromKey Database
db
    [(Key, Key)]
bad <- [(Key, Key)] -> IO [(Key, Key)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Key
parent,Key
key) | (Key
parent, Key
key) <- HashSet (Key, Key) -> [(Key, Key)]
forall a. HashSet a -> [a]
Set.toList (HashSet (Key, Key) -> [(Key, Key)])
-> HashSet (Key, Key) -> [(Key, Key)]
forall a b. (a -> b) -> a -> b
$ [(Key, Key)] -> HashSet (Key, Key)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [(Key, Key)]
absent, Maybe Id -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Id -> Bool) -> Maybe Id -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> Maybe Id
exists Key
key]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Key, Key)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, Key)]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let n :: Int
n = [(Key, Key)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Key)]
bad
        SomeException -> IO ()
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured
            (String
"Lint checking error - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"value" else Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" did not have " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"its" else String
"their") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" creation tracked")
            ([(String, Maybe String)]
-> [[(String, Maybe String)]] -> [(String, Maybe String)]
forall a. [a] -> [[a]] -> [a]
intercalate [(String
"",String -> Maybe String
forall a. a -> Maybe a
Just String
"")] [ [(String
"Rule", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
parent), (String
"Created", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
key)] | (Key
parent,Key
key) <- [(Key, Key)]
bad])
            String
""

    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
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 = (Proxy StepKey -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy StepKey
forall {k} (t :: k). Proxy t
Proxy :: Proxy StepKey), (Int -> Ver
Ver Int
0, (Key -> Builder) -> (BS_Store -> Key) -> BinaryOp Key
forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (Builder -> Key -> Builder
forall a b. a -> b -> a
const Builder
forall a. Monoid a => a
mempty) (Key -> BS_Store -> Key
forall a b. a -> b -> a
const Key
stepKey)))
    let root :: (TypeRep, (Ver, BinaryOp Key))
root = (Proxy Root -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Root
forall {k} (t :: k). Proxy t
Proxy :: Proxy Root), (Int -> Ver
Ver Int
0, (Key -> Builder) -> (BS_Store -> Key) -> BinaryOp Key
forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (Builder -> Key -> Builder
forall a b. a -> b -> a
const Builder
forall a. Monoid a => a
mempty) (Key -> BS_Store -> Key
forall a b. a -> b -> a
const Key
rootKey)))
    HashMap QTypeRep (Ver, BinaryOp (Key, Status))
witness<- HashMap QTypeRep (Ver, BinaryOp (Key, Status))
-> IO (HashMap QTypeRep (Ver, BinaryOp (Key, Status)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap QTypeRep (Ver, BinaryOp (Key, Status))
 -> IO (HashMap QTypeRep (Ver, BinaryOp (Key, Status))))
-> HashMap QTypeRep (Ver, BinaryOp (Key, Status))
-> IO (HashMap QTypeRep (Ver, BinaryOp (Key, Status)))
forall a b. (a -> b) -> a -> b
$ [(QTypeRep, (Ver, BinaryOp (Key, Status)))]
-> HashMap QTypeRep (Ver, BinaryOp (Key, Status))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
        [ (TypeRep -> QTypeRep
QTypeRep TypeRep
t, (Ver
version, ((Key, Status) -> Builder)
-> (BS_Store -> (Key, Status)) -> BinaryOp (Key, Status)
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
putOp :: Key -> Builder
getOp :: BS_Store -> Key
putOp :: forall v. BinaryOp v -> v -> Builder
getOp :: forall v. BinaryOp v -> BS_Store -> v
..})) <- (TypeRep, (Ver, BinaryOp Key))
step (TypeRep, (Ver, BinaryOp Key))
-> [(TypeRep, (Ver, BinaryOp Key))]
-> [(TypeRep, (Ver, BinaryOp Key))]
forall a. a -> [a] -> [a]
: (TypeRep, (Ver, BinaryOp Key))
root (TypeRep, (Ver, BinaryOp Key))
-> [(TypeRep, (Ver, BinaryOp Key))]
-> [(TypeRep, (Ver, BinaryOp Key))]
forall a. a -> [a] -> [a]
: HashMap TypeRep (Ver, BinaryOp Key)
-> [(TypeRep, (Ver, BinaryOp Key))]
forall k v. HashMap k v -> [(k, v)]
Map.toList ((BuiltinRule -> (Ver, BinaryOp Key))
-> HashMap TypeRep BuiltinRule
-> HashMap TypeRep (Ver, BinaryOp Key)
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)
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinKey :: BuiltinRule -> BinaryOp Key
builtinVersion :: BuiltinRule -> Ver
builtinLocation :: BuiltinRule -> String
builtinLint :: Key -> Value -> IO (Maybe String)
builtinIdentity :: BuiltinIdentity Key Value
builtinRun :: BuiltinRun Key Value
builtinKey :: BinaryOp Key
builtinVersion :: Ver
builtinLocation :: String
..} -> (Ver
builtinVersion, BinaryOp Key
builtinKey)) HashMap TypeRep BuiltinRule
owitness)]
    (Ids (Key, Status)
status, QTypeRep -> Id -> (Key, Status) -> IO ()
journal) <- Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap QTypeRep (Ver, BinaryOp (Key, Status))
-> IO (Ids (Key, Status), QTypeRep -> Id -> (Key, Status) -> IO ())
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<- (Id -> Key -> Status -> IO ()) -> IO (Id -> Key -> Status -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Id -> Key -> Status -> IO ())
 -> IO (Id -> Key -> Status -> IO ()))
-> (Id -> Key -> Status -> IO ())
-> IO (Id -> Key -> Status -> IO ())
forall a b. (a -> b) -> a -> b
$ \Id
i Key
k Status
v -> QTypeRep -> Id -> (Key, Status) -> IO ()
journal (TypeRep -> QTypeRep
QTypeRep (TypeRep -> QTypeRep) -> TypeRep -> QTypeRep
forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k) Id
i (Key
k, Status
v)
    Ids (Key, Status)
-> (Id -> Key -> Status -> IO ()) -> Status -> IO Database
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 = Database -> Locked Step -> IO Step
forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
db (Locked Step -> IO Step) -> Locked Step -> IO Step
forall a b. (a -> b) -> a -> b
$ do
    Id
stepId <- Database -> Key -> Locked Id
forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> Locked Id
mkId Database
db Key
stepKey
    Maybe (Key, Status)
v <- IO (Maybe (Key, Status)) -> Locked (Maybe (Key, Status))
forall a. IO a -> Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Key, Status)) -> Locked (Maybe (Key, Status)))
-> IO (Maybe (Key, Status)) -> Locked (Maybe (Key, Status))
forall a b. (a -> b) -> a -> b
$ Database -> Id -> IO (Maybe (Key, Status))
forall k v. DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId Database
db Id
stepId
    Step
step <- IO Step -> Locked Step
forall a. IO a -> Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Step -> Locked Step) -> IO Step -> Locked Step
forall a b. (a -> b) -> a -> b
$ Step -> IO Step
forall a. a -> IO a
evaluate (Step -> IO Step) -> Step -> IO Step
forall a b. (a -> b) -> a -> b
$ case Maybe (Key, Status)
v of
        Just (Key
_, Loaded Result BS_Store
r) -> Step -> Step
incStep (Step -> Step) -> Step -> Step
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
    Database -> Id -> Key -> Status -> Locked ()
forall k v. DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database
db Id
stepId Key
stepKey (Status -> Locked ()) -> Status -> Locked ()
forall a b. (a -> b) -> a -> b
$ Result (Value, BS_Store) -> Status
Ready Result (Value, BS_Store)
stepRes
    IO () -> Locked ()
forall a. IO a -> Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Locked ()) -> IO () -> Locked ()
forall a b. (a -> b) -> a -> b
$ Database -> Id -> Key -> Status -> IO ()
forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk Database
db Id
stepId Key
stepKey (Status -> IO ()) -> Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Result BS_Store -> Status
Loaded (Result BS_Store -> Status) -> Result BS_Store -> Status
forall a b. (a -> b) -> a -> b
$ ((Value, BS_Store) -> BS_Store)
-> Result (Value, BS_Store) -> Result BS_Store
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value, BS_Store) -> BS_Store
forall a b. (a, b) -> b
snd Result (Value, BS_Store)
stepRes
    Step -> Locked Step
forall a. a -> Locked a
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 = (Value, BS_Store)
-> Step
-> Step
-> [Depends]
-> Float
-> [Trace]
-> Result (Value, BS_Store)
forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result (Step -> Value
forall a. (Typeable a, Show a, NFData a) => a -> Value
newValue Step
i, Builder -> BS_Store
runBuilder (Builder -> BS_Store) -> Builder -> BS_Store
forall a b. (a -> b) -> a -> b
$ Step -> Builder
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 = BS_Store -> Step
forall a. BinaryEx a => BS_Store -> a
getEx (BS_Store -> Step)
-> (Result BS_Store -> BS_Store) -> Result BS_Store -> Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result BS_Store -> BS_Store
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 = Database -> Locked () -> IO ()
forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked Database
db (Locked () -> IO ()) -> Locked () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Id
rootId <- Database -> Key -> Locked Id
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 = (() -> Value
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 (DependsList -> [Depends]) -> DependsList -> [Depends]
forall a b. (a -> b) -> a -> b
$ Local -> DependsList
localDepends Local
local
            ,execution :: Float
execution = Float
0
            ,traces :: [Trace]
traces = Traces -> [Trace]
flattenTraces (Traces -> [Trace]) -> Traces -> [Trace]
forall a b. (a -> b) -> a -> b
$ Traces -> Trace -> Traces
addTrace (Local -> Traces
localTraces Local
local) (Trace -> Traces) -> Trace -> Traces
forall a b. (a -> b) -> a -> b
$ BS_Store -> Float -> Float -> Trace
Trace BS_Store
BS.empty Float
end Float
end}
    Database -> Id -> Key -> Status -> Locked ()
forall k v. DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database
db Id
rootId Key
rootKey (Status -> Locked ()) -> Status -> Locked ()
forall a b. (a -> b) -> a -> b
$ Result (Value, BS_Store) -> Status
Ready Result (Value, BS_Store)
rootRes
    IO () -> Locked ()
forall a. IO a -> Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Locked ()) -> IO () -> Locked ()
forall a b. (a -> b) -> a -> b
$ Database -> Id -> Key -> Status -> IO ()
forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk Database
db Id
rootId Key
rootKey (Status -> IO ()) -> Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Result BS_Store -> Status
Loaded (Result BS_Store -> Status) -> Result BS_Store -> Status
forall a b. (a -> b) -> a -> b
$ ((Value, BS_Store) -> BS_Store)
-> Result (Value, BS_Store) -> Result BS_Store
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value, BS_Store) -> BS_Store
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 = [(String, BuiltinRule)] -> HashMap String BuiltinRule
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(String, BuiltinRule)] -> HashMap String BuiltinRule)
-> [(String, BuiltinRule)] -> HashMap String BuiltinRule
forall a b. (a -> b) -> a -> b
$ ((TypeRep, BuiltinRule) -> (String, BuiltinRule))
-> [(TypeRep, BuiltinRule)] -> [(String, BuiltinRule)]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeRep -> String)
-> (TypeRep, BuiltinRule) -> (String, BuiltinRule)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((TypeRep -> String)
 -> (TypeRep, BuiltinRule) -> (String, BuiltinRule))
-> (TypeRep -> String)
-> (TypeRep, BuiltinRule)
-> (String, BuiltinRule)
forall a b. (a -> b) -> a -> b
$ QTypeRep -> String
forall a. Show a => a -> String
show (QTypeRep -> String) -> (TypeRep -> QTypeRep) -> TypeRep -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> QTypeRep
QTypeRep) ([(TypeRep, BuiltinRule)] -> [(String, BuiltinRule)])
-> [(TypeRep, BuiltinRule)] -> [(String, BuiltinRule)]
forall a b. (a -> b) -> a -> b
$ HashMap TypeRep BuiltinRule -> [(TypeRep, BuiltinRule)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep BuiltinRule
owitness
    let wit :: BinaryOp (String, Key)
wit = (String -> BinaryOp Key) -> BinaryOp (String, Key)
forall a b. BinaryEx a => (a -> BinaryOp b) -> BinaryOp (a, b)
binaryOpMap ((String -> BinaryOp Key) -> BinaryOp (String, Key))
-> (String -> BinaryOp Key) -> BinaryOp (String, Key)
forall a b. (a -> b) -> a -> b
$ \String
a -> BinaryOp Key
-> (BuiltinRule -> BinaryOp Key)
-> Maybe BuiltinRule
-> BinaryOp Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> BinaryOp Key
forall a. Partial => String -> a
error (String -> BinaryOp Key) -> String -> BinaryOp Key
forall a b. (a -> b) -> a -> b
$ String
"loadSharedCloud, couldn't find map for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
a) BuiltinRule -> BinaryOp Key
builtinKey (Maybe BuiltinRule -> BinaryOp Key)
-> Maybe BuiltinRule -> BinaryOp Key
forall a b. (a -> b) -> a -> b
$ String -> HashMap String BuiltinRule -> Maybe BuiltinRule
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 = (Key -> Builder) -> (BS_Store -> Key) -> BinaryOp Key
forall v. (v -> Builder) -> (BS_Store -> v) -> BinaryOp v
BinaryOp (\Key
k -> BinaryOp (String, Key) -> (String, Key) -> Builder
forall v. BinaryOp v -> v -> Builder
putOp BinaryOp (String, Key)
wit (QTypeRep -> String
forall a. Show a => a -> String
show (QTypeRep -> String) -> QTypeRep -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> QTypeRep
QTypeRep (TypeRep -> QTypeRep) -> TypeRep -> QTypeRep
forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k, Key
k)) ((String, Key) -> Key
forall a b. (a, b) -> b
snd ((String, Key) -> Key)
-> (BS_Store -> (String, Key)) -> BS_Store -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryOp (String, Key) -> BS_Store -> (String, Key)
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) <- HashMap TypeRep BuiltinRule -> [(TypeRep, BuiltinRule)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap TypeRep BuiltinRule
owitness]
    let ver :: Ver
ver = String -> Ver
makeVer (String -> Ver) -> String -> Ver
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 -> Maybe Shared -> IO (Maybe Shared)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Shared
forall a. Maybe a
Nothing
        Just String
x -> Shared -> Maybe Shared
forall a. a -> Maybe a
Just (Shared -> Maybe Shared) -> IO Shared -> IO (Maybe Shared)
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 (DatabasePoly k v -> Locked () -> IO ()
forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked DatabasePoly k v
var) ((BuiltinRule -> BinaryOp Key)
-> HashMap TypeRep BuiltinRule -> HashMap TypeRep (BinaryOp Key)
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 ([String] -> Maybe (IO Cloud)) -> [String] -> Maybe (IO Cloud)
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeCloud ShakeOptions
opts of
        Maybe (IO Cloud)
_ | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeCloud ShakeOptions
opts -> Maybe Cloud -> IO (Maybe Cloud)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Cloud
forall a. Maybe a
Nothing
        Maybe (IO Cloud)
Nothing -> String -> IO (Maybe Cloud)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"shakeCloud set but Shake not compiled for cloud operation"
        Just IO Cloud
res -> Cloud -> Maybe Cloud
forall a. a -> Maybe a
Just (Cloud -> Maybe Cloud) -> IO Cloud -> IO (Maybe Cloud)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Cloud
res
    (Maybe Shared, Maybe Cloud) -> IO (Maybe Shared, Maybe Cloud)
forall a. a -> IO a
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) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN (BS_Store -> Builder
forall a. BinaryEx a => a -> Builder
putEx BS_Store
x1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Step -> Builder
forall a. BinaryEx a => a -> Builder
putEx Step
x2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Step -> Builder
forall a. BinaryEx a => a -> Builder
putEx Step
x3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Float -> Builder
forall a. BinaryEx a => a -> Builder
putEx Float
x5 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN ([Depends] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Depends]
x4) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Trace] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Trace]
x6
putDatabase Key -> Builder
_ (Key
_, Status
x) = SomeException -> Builder
forall a. SomeException -> a
throwImpure (SomeException -> Builder) -> SomeException -> Builder
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"putWith, Cannot write Status with constructor " String -> String -> String
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) <- BS_Store -> (Step, Step, Float, BS_Store)
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 (BS_Store
-> Step -> Step -> [Depends] -> Float -> [Trace] -> Result BS_Store
forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result BS_Store
x1 Step
x2 Step
x3 (BS_Store -> [Depends]
forall a. BinaryEx a => BS_Store -> a
getEx BS_Store
x4) Float
x5 (BS_Store -> [Trace]
forall a. BinaryEx a => BS_Store -> a
getEx BS_Store
x6)))