{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

-- | Lower-level primitives to drive Shake, which are wrapped into the
--   'Development.Shake.shake' function. Useful if you want to perform multiple Shake
--   runs in a row without reloading from the database.
--   Sometimes used in conjunction with @'shakeFiles'=\"\/dev\/null\"@.
--   Using these functions you can approximate the 'Development.Shake.shake' experience with:
--
-- @
-- shake opts rules = do
--     (_, after) \<- 'shakeWithDatabase' opts rules $ \\db -> do
--         'shakeOneShotDatabase' db
--         'shakeRunDatabase' db []
--     'shakeRunAfter' opts after
-- @
module Development.Shake.Database(
    ShakeDatabase,
    shakeOpenDatabase,
    shakeWithDatabase,
    shakeOneShotDatabase,
    shakeRunDatabase,
    shakeLiveFilesDatabase,
    shakeProfileDatabase,
    shakeErrorsDatabase,
    shakeRunAfter
    ) where

import Control.Concurrent.Extra
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import General.Cleanup
import Development.Shake.Internal.Errors
import Development.Shake.Internal.Options
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Core.Run
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Rules.Default


data UseState
    = Closed
    | Using String
    | Open {UseState -> Bool
openOneShot :: Bool, UseState -> Bool
openRequiresReset :: Bool}

-- | The type of an open Shake database. Created with
--   'shakeOpenDatabase' or 'shakeWithDatabase'. Used with
--   'shakeRunDatabase'. You may not execute simultaneous calls using 'ShakeDatabase'
--   on separate threads (it will raise an error).
data ShakeDatabase = ShakeDatabase (Var UseState) RunState

-- | Given some options and rules, return a pair. The first component opens the database,
--   the second cleans it up. The creation /does not/ need to be run masked, because the
--   cleanup is able to run at any point. Most users should prefer 'shakeWithDatabase'
--   which handles exceptions duration creation properly.
shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase ShakeOptions
opts Rules ()
rules = do
    (Cleanup
cleanup, IO ()
clean) <- IO (Cleanup, IO ())
newCleanup
    Var UseState
use <- UseState -> IO (Var UseState)
forall a. a -> IO (Var a)
newVar (UseState -> IO (Var UseState)) -> UseState -> IO (Var UseState)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> UseState
Open Bool
False Bool
False
    let alloc :: IO ShakeDatabase
alloc =
            Var UseState
-> String
-> (UseState -> UseState)
-> (UseState -> IO ShakeDatabase)
-> IO ShakeDatabase
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeOpenDatabase" UseState -> UseState
forall a. a -> a
id ((UseState -> IO ShakeDatabase) -> IO ShakeDatabase)
-> (UseState -> IO ShakeDatabase) -> IO ShakeDatabase
forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
                Var UseState -> RunState -> ShakeDatabase
ShakeDatabase Var UseState
use (RunState -> ShakeDatabase) -> IO RunState -> IO ShakeDatabase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cleanup -> ShakeOptions -> Rules () -> IO RunState
open Cleanup
cleanup ShakeOptions
opts (Rules ()
rules Rules () -> Rules () -> Rules ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules ()
defaultRules)
    let free :: IO ()
free = do
            Var UseState -> (UseState -> IO UseState) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var UseState
use ((UseState -> IO UseState) -> IO ())
-> (UseState -> IO UseState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
                    Using String
s -> SomeException -> IO UseState
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO UseState) -> SomeException -> IO UseState
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured String
"Error when calling shakeOpenDatabase close function, currently running" [(String
"Existing call", String -> Maybe String
forall a. a -> Maybe a
Just String
s)] String
""
                    UseState
_ -> UseState -> IO UseState
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseState
Closed
            IO ()
clean
    (IO ShakeDatabase, IO ()) -> IO (IO ShakeDatabase, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ShakeDatabase
alloc, IO ()
free)

withOpen :: Var UseState -> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen :: Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
var String
name UseState -> UseState
final UseState -> IO a
act = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    UseState
o <- Var UseState
-> (UseState -> IO (UseState, UseState)) -> IO UseState
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var UseState
var ((UseState -> IO (UseState, UseState)) -> IO UseState)
-> (UseState -> IO (UseState, UseState)) -> IO UseState
forall a b. (a -> b) -> a -> b
$ \case
        Using String
s -> SomeException -> IO (UseState, UseState)
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO (UseState, UseState))
-> SomeException -> IO (UseState, UseState)
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured (String
"Error when calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", currently running") [(String
"Existing call", String -> Maybe String
forall a. a -> Maybe a
Just String
s)] String
""
        UseState
Closed -> SomeException -> IO (UseState, UseState)
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO (UseState, UseState))
-> SomeException -> IO (UseState, UseState)
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured (String
"Error when calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", already closed") [] String
""
        o :: UseState
o@Open{} -> (UseState, UseState) -> IO (UseState, UseState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> UseState
Using String
name, UseState
o)
    let clean :: IO ()
clean = Var UseState -> UseState -> IO ()
forall a. Var a -> a -> IO ()
writeVar Var UseState
var (UseState -> IO ()) -> UseState -> IO ()
forall a b. (a -> b) -> a -> b
$ UseState -> UseState
final UseState
o
    a
res <- IO a -> IO a
forall a. IO a -> IO a
restore (UseState -> IO a
act UseState
o) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` IO ()
clean
    IO ()
clean
    a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Declare that a just-openned database will be used to call 'shakeRunDatabase' at most once.
--   If so, an optimisation can be applied to retain less memory.
shakeOneShotDatabase :: ShakeDatabase -> IO ()
shakeOneShotDatabase :: ShakeDatabase -> IO ()
shakeOneShotDatabase (ShakeDatabase Var UseState
use RunState
_) =
    Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO ()) -> IO ()
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeOneShotDatabase" (\UseState
o -> UseState
o{openOneShot :: Bool
openOneShot=Bool
True}) ((UseState -> IO ()) -> IO ()) -> (UseState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UseState
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Given some options and rules, create a 'ShakeDatabase' that can be used to run
--   executions.
shakeWithDatabase :: ShakeOptions -> Rules () -> (ShakeDatabase -> IO a) -> IO a
shakeWithDatabase :: ShakeOptions -> Rules () -> (ShakeDatabase -> IO a) -> IO a
shakeWithDatabase ShakeOptions
opts Rules ()
rules ShakeDatabase -> IO a
act = do
    (IO ShakeDatabase
db, IO ()
clean) <- ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase ShakeOptions
opts Rules ()
rules
    (ShakeDatabase -> IO a
act (ShakeDatabase -> IO a) -> IO ShakeDatabase -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ShakeDatabase
db) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` IO ()
clean

-- | Given a 'ShakeDatabase', what files did the execution ensure were up-to-date
--   in the previous call to 'shakeRunDatabase'. Corresponds to the list of files
--   written out to 'shakeLiveFiles'.
shakeLiveFilesDatabase :: ShakeDatabase -> IO [FilePath]
shakeLiveFilesDatabase :: ShakeDatabase -> IO [String]
shakeLiveFilesDatabase (ShakeDatabase Var UseState
use RunState
s) =
    Var UseState
-> String
-> (UseState -> UseState)
-> (UseState -> IO [String])
-> IO [String]
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeLiveFilesDatabase" UseState -> UseState
forall a. a -> a
id ((UseState -> IO [String]) -> IO [String])
-> (UseState -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
        RunState -> IO [String]
liveFilesState RunState
s

-- | Given a 'ShakeDatabase', generate profile information to the given file about the latest run.
--   See 'shakeReport' for the types of file that can be generated.
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
shakeProfileDatabase :: ShakeDatabase -> String -> IO ()
shakeProfileDatabase (ShakeDatabase Var UseState
use RunState
s) String
file =
    Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO ()) -> IO ()
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeProfileDatabase" UseState -> UseState
forall a. a -> a
id ((UseState -> IO ()) -> IO ()) -> (UseState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
        RunState -> String -> IO ()
profileState RunState
s String
file

-- | Given a 'ShakeDatabase', what files did the execution reach an error on last time.
--   Some special considerations when using this function:
--
-- * The presence of an error does not mean the build will fail, specifically if a
--   previously required dependency was run and raised an error, then the thing that previously
--   required it will be run. If the build system has changed in an untracked manner,
--   the build may succeed this time round.
--
-- * If the previous run actually failed then 'shakeRunDatabase' will have thrown an exception.
--   You probably want to catch that exception so you can make the call to 'shakeErrorsDatabase'.
--
-- * You may see a single failure reported multiple times, with increasingly large call stacks, showing
--   the ways in which the error lead to further errors throughout.
--
-- * The 'SomeException' values are highly likely to be of type 'ShakeException'.
--
-- * If you want as many errors as possile in one run set @'shakeStaunch'=True@.
shakeErrorsDatabase :: ShakeDatabase -> IO [(String, SomeException)]
shakeErrorsDatabase :: ShakeDatabase -> IO [(String, SomeException)]
shakeErrorsDatabase (ShakeDatabase Var UseState
use RunState
s) =
    Var UseState
-> String
-> (UseState -> UseState)
-> (UseState -> IO [(String, SomeException)])
-> IO [(String, SomeException)]
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeErrorsDatabase" UseState -> UseState
forall a. a -> a
id ((UseState -> IO [(String, SomeException)])
 -> IO [(String, SomeException)])
-> (UseState -> IO [(String, SomeException)])
-> IO [(String, SomeException)]
forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
        RunState -> IO [(String, SomeException)]
errorsState RunState
s

-- | Given an open 'ShakeDatabase', run both whatever actions were added to the 'Rules',
--   plus the list of 'Action' given here. Returns the results from the explicitly passed
--   actions along with a list of actions to run after the database was closed, as added with
--   'Development.Shake.runAfter' and 'Development.Shake.removeFilesAfter'.
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase (ShakeDatabase Var UseState
use RunState
s) [Action a]
as =
    Var UseState
-> String
-> (UseState -> UseState)
-> (UseState -> IO ([a], [IO ()]))
-> IO ([a], [IO ()])
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeRunDatabase" (\UseState
o -> UseState
o{openRequiresReset :: Bool
openRequiresReset=Bool
True}) ((UseState -> IO ([a], [IO ()])) -> IO ([a], [IO ()]))
-> (UseState -> IO ([a], [IO ()])) -> IO ([a], [IO ()])
forall a b. (a -> b) -> a -> b
$ \Open{Bool
openRequiresReset :: Bool
openOneShot :: Bool
openRequiresReset :: UseState -> Bool
openOneShot :: UseState -> Bool
..} -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
openRequiresReset (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
openOneShot (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 -> [(String, Maybe String)] -> String -> SomeException
errorStructured String
"Error when calling shakeRunDatabase twice, after calling shakeOneShotDatabase" [] String
""
            RunState -> IO ()
reset RunState
s
        ([IORef (Maybe a)]
refs, [Action ()]
as) <- ([(IORef (Maybe a), Action ())]
 -> ([IORef (Maybe a)], [Action ()]))
-> IO [(IORef (Maybe a), Action ())]
-> IO ([IORef (Maybe a)], [Action ()])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(IORef (Maybe a), Action ())] -> ([IORef (Maybe a)], [Action ()])
forall a b. [(a, b)] -> ([a], [b])
unzip (IO [(IORef (Maybe a), Action ())]
 -> IO ([IORef (Maybe a)], [Action ()]))
-> IO [(IORef (Maybe a), Action ())]
-> IO ([IORef (Maybe a)], [Action ()])
forall a b. (a -> b) -> a -> b
$ [Action a]
-> (Action a -> IO (IORef (Maybe a), Action ()))
-> IO [(IORef (Maybe a), Action ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Action a]
as ((Action a -> IO (IORef (Maybe a), Action ()))
 -> IO [(IORef (Maybe a), Action ())])
-> (Action a -> IO (IORef (Maybe a), Action ()))
-> IO [(IORef (Maybe a), Action ())]
forall a b. (a -> b) -> a -> b
$ \Action a
a -> do
            IORef (Maybe a)
ref <- Maybe a -> IO (IORef (Maybe a))
forall a. a -> IO (IORef a)
newIORef Maybe a
forall a. Maybe a
Nothing
            (IORef (Maybe a), Action ()) -> IO (IORef (Maybe a), Action ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef (Maybe a)
ref, IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> (a -> IO ()) -> a -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe a) -> Maybe a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (Maybe a -> IO ()) -> (a -> Maybe a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just (a -> Action ()) -> Action a -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action a
a)
        [IO ()]
after <- RunState -> Bool -> [Action ()] -> IO [IO ()]
run RunState
s Bool
openOneShot ([Action ()] -> IO [IO ()]) -> [Action ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ (Action () -> Action ()) -> [Action ()] -> [Action ()]
forall a b. (a -> b) -> [a] -> [b]
map Action () -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void [Action ()]
as
        [Maybe a]
results <- (IORef (Maybe a) -> IO (Maybe a))
-> [IORef (Maybe a)] -> IO [Maybe a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IORef (Maybe a) -> IO (Maybe a)
forall a. IORef a -> IO a
readIORef [IORef (Maybe a)]
refs
        case [Maybe a] -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe a]
results of
            Just [a]
result -> ([a], [IO ()]) -> IO ([a], [IO ()])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
result, [IO ()]
after)
            Maybe [a]
Nothing -> SomeException -> IO ([a], [IO ()])
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO ([a], [IO ()]))
-> SomeException -> IO ([a], [IO ()])
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal String
"Expected all results were written, but some where not"