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

    diagnostic $ pure $ "Number of actions = " ++ show (length actions)
    diagnostic $ pure $ "Number of builtin rules = " ++ show (Map.size builtinRules) ++ " " ++ show (Map.keys builtinRules)
    diagnostic $ pure $ "Number of user rule types = " ++ show (TMap.size userRules)
    diagnostic $ pure $ "Number of user rules = " ++ show (sum (TMap.toList (userRuleSize . userRuleContents) userRules))

    checkShakeExtra shakeExtra
    curdir <- getCurrentDirectory

    database <- usingDatabase cleanup opts diagnostic builtinRules
    (shared, cloud) <- loadSharedCloud database opts builtinRules
    pure RunState{..}


-- 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 ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
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
        timingsToShow <- Maybe [String] -> IO (IORef (Maybe [String]))
forall a. a -> IO (IORef a)
newIORef Maybe [String]
forall a. Maybe a
Nothing

        res <- withCleanup $ \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

            start <- IO (IO Seconds)
offsetTime
            except <- newIORef (Nothing :: Maybe (String, ShakeException))
            let 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
err
                    | Bool -> Bool
not Bool
shakeStaunch = ShakeException -> IO ()
forall e a. (Partial, 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

            after <- newIORef []
            absent <- newIORef []
            step <- incrementStep database
            getProgress <- usingProgress cleanup opts database step getFailure
            lintCurrentDirectory curdir "When running"

            watch <- lintWatch shakeLintWatch
            let 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

            addTiming "Running rules"
            locals <- newIORef []
            runPool (shakeThreads == 1) shakeThreads $ \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]
:)

            whenJustM (readIORef except) (throwIO . snd)
            assertFinishedDatabase database
            let 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

            locals <- readIORef locals
            end <- start
            if null actions && null actions2 then
                putWhen Info "Warning: No want/action statements, nothing to do"
             else
                recordRoot step locals end database

            when (isJust shakeLint) $ do
                addTiming "Lint checking"
                lintCurrentDirectory curdir "After completion"
                checkValid diagnostic database (runLint builtinRules) =<< readIORef absent
                putWhen Verbose "Lint checking succeeded"
            when (shakeReport /= []) $ do
                addTiming "Profile report"
                forM_ shakeReport $ \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
            when (shakeLiveFiles /= []) $ do
                addTiming "Listing live"
                diagnostic $ pure "Listing live keys"
                xs <- liveFiles database
                forM_ shakeLiveFiles $ \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

            res <- readIORef after
            addTiming "Cleanup"
            pure res

        whenJustM (readIORef timingsToShow) $
            putStr . unlines
        pure 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 ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
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"
    (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
    when (shakeTimings && shakeVerbosity >= Info) $
        putStrLn $ "(+ running " ++ show n ++ " after actions in " ++ showDuration time ++ ")"


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{..} <- Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions Cleanup
cleanup ShakeOptions
opts
        (diagnostic, output) <- outputFunctions opts <$> newLock
        act opts diagnostic output


usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions
usingShakeOptions Cleanup
cleanup ShakeOptions
opts = do
    opts@ShakeOptions{..} <- 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 p <- IO Int
getProcessorCount; pure opts{shakeThreads=p}
    when shakeLineBuffering $ usingLineBuffering cleanup
    usingNumCapabilities cleanup shakeThreads
    pure opts

outputFunctions :: ShakeOptions -> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())
outputFunctions :: ShakeOptions
-> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())
outputFunctions opts :: ShakeOptions
opts@ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
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 v <- IO String
act; outputLocked Diagnostic $ "% " ++ 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 ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
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
            failure <- IO (Maybe String)
getFailure
            stats <- progress database step
            pure 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. (Partial, 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
builtinLocation :: BuiltinRule -> String
builtinVersion :: BuiltinRule -> Ver
builtinKey :: BuiltinRule -> BinaryOp Key
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
..} -> 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)
    status <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    let bad = [Key
key | (Key
key, Running{}) <- [(Key, Status)]
status]
    when (bad /= []) $
        throwM $ errorComplexRecursion (map show 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
    status <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    let 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"
    pure [show k | (k, Ready{}) <- status, specialIsFileKey $ typeKey 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
    status <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
database
    pure [(show k, e) | (k, Failed e _) <- 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
    status <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
db
    diagnostic $ pure "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
    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)]
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]
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
depends :: forall a. Result a -> [Depends]
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
..}) -> do
            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
            diagnostic $ pure $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if isNothing good then "passed" else "FAILED"
            pure $ [(key, result, now) | Just now <- [good]] ++ 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
    unless (null bad) $ do
        let 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
        throwM $ errorStructured
            ("Lint checking error - " ++ (if n == 1 then "value has" else show n ++ " values have")  ++ " changed since being depended upon")
            (intercalate [("",Just "")] [ [("Key", Just $ show key),("Old", Just $ show result),("New", Just now)]
                                        | (key, result, now) <- bad])
            ""

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

    diagnostic $ pure "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)))
    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
getOp :: forall v. BinaryOp v -> BS_Store -> v
putOp :: forall v. BinaryOp v -> v -> Builder
..})) <- (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)
builtinLocation :: BuiltinRule -> String
builtinVersion :: BuiltinRule -> Ver
builtinKey :: BuiltinRule -> BinaryOp Key
builtinRun :: BuiltinRule -> BuiltinRun Key Value
builtinIdentity :: BuiltinRule -> BuiltinIdentity Key Value
builtinLint :: BuiltinRule -> Key -> Value -> IO (Maybe String)
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)]
    (status, journal) <- usingStorage cleanup opts diagnostic witness
    journal<- pure $ \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)
    createDatabase status journal 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
    stepId <- Database -> Key -> Locked Id
forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> Locked Id
mkId Database
db Key
stepKey
    v <- liftIO $ getKeyValueFromId db stepId
    step <- liftIO $ evaluate $ case 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 = Step -> Result (Value, BS_Store)
toStepResult Step
step
    setMem db stepId stepKey $ Ready stepRes
    liftIO $ setDisk db stepId stepKey $ Loaded $ fmap snd stepRes
    pure 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
    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
localMergeMutable (Stack -> Verbosity -> Local
newLocal Stack
emptyStack Verbosity
Info) [Local]
locals
    let 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}
    setMem db rootId rootKey $ Ready rootRes
    liftIO $ setDisk db rootId rootKey $ Loaded $ fmap snd 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

    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
    cloud <- case newCloud (runLocked var) (Map.map builtinKey owitness) ver keyVers $ shakeCloud 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
    pure (shared, 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)))