{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
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}
data ShakeDatabase = ShakeDatabase (Var UseState) RunState
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 <- forall a. a -> IO (Var a)
newVar forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> UseState
Open Bool
False Bool
False
let alloc :: IO ShakeDatabase
alloc =
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeOpenDatabase" forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
Var UseState -> RunState -> ShakeDatabase
ShakeDatabase Var UseState
use forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cleanup -> ShakeOptions -> Rules () -> IO RunState
open Cleanup
cleanup ShakeOptions
opts (Rules ()
rules forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules ()
defaultRules)
let free :: IO ()
free = do
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var UseState
use forall a b. (a -> b) -> a -> b
$ \case
Using String
s -> forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM 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", forall a. a -> Maybe a
Just String
s)] String
""
UseState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UseState
Closed
IO ()
clean
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 :: forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
var String
name UseState -> UseState
final UseState -> IO a
act = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
UseState
o <- forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var UseState
var forall a b. (a -> b) -> a -> b
$ \case
Using String
s -> forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured (String
"Error when calling " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
", currently running") [(String
"Existing call", forall a. a -> Maybe a
Just String
s)] String
""
UseState
Closed -> forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> SomeException
errorStructured (String
"Error when calling " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
", already closed") [] String
""
o :: UseState
o@Open{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> UseState
Using String
name, UseState
o)
let clean :: IO ()
clean = forall a. Var a -> a -> IO ()
writeVar Var UseState
var forall a b. (a -> b) -> a -> b
$ UseState -> UseState
final UseState
o
a
res <- forall a. IO a -> IO a
restore (UseState -> IO a
act UseState
o) forall a b. IO a -> IO b -> IO a
`onException` IO ()
clean
IO ()
clean
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
shakeOneShotDatabase :: ShakeDatabase -> IO ()
shakeOneShotDatabase :: ShakeDatabase -> IO ()
shakeOneShotDatabase (ShakeDatabase Var UseState
use RunState
_) =
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}) forall a b. (a -> b) -> a -> b
$ \UseState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
shakeWithDatabase :: ShakeOptions -> Rules () -> (ShakeDatabase -> IO a) -> IO a
shakeWithDatabase :: forall a.
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ShakeDatabase
db) forall a b. IO a -> IO b -> IO a
`finally` IO ()
clean
shakeLiveFilesDatabase :: ShakeDatabase -> IO [FilePath]
shakeLiveFilesDatabase :: ShakeDatabase -> IO [String]
shakeLiveFilesDatabase (ShakeDatabase Var UseState
use RunState
s) =
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeLiveFilesDatabase" forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
RunState -> IO [String]
liveFilesState RunState
s
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
shakeProfileDatabase :: ShakeDatabase -> String -> IO ()
shakeProfileDatabase (ShakeDatabase Var UseState
use RunState
s) String
file =
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeProfileDatabase" forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
RunState -> String -> IO ()
profileState RunState
s String
file
shakeErrorsDatabase :: ShakeDatabase -> IO [(String, SomeException)]
shakeErrorsDatabase :: ShakeDatabase -> IO [(String, SomeException)]
shakeErrorsDatabase (ShakeDatabase Var UseState
use RunState
s) =
forall a.
Var UseState
-> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a
withOpen Var UseState
use String
"shakeErrorsDatabase" forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \UseState
_ ->
RunState -> IO [(String, SomeException)]
errorsState RunState
s
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase :: forall a. ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase (ShakeDatabase Var UseState
use RunState
s) [Action a]
as =
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}) forall a b. (a -> b) -> a -> b
$ \Open{Bool
openRequiresReset :: Bool
openOneShot :: Bool
openRequiresReset :: UseState -> Bool
openOneShot :: UseState -> Bool
..} -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
openRequiresReset forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
openOneShot forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM 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) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Action a]
as forall a b. (a -> b) -> a -> b
$ \Action a
a -> do
IORef (Maybe a)
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef (Maybe a)
ref, forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action a
a)
[IO ()]
after <- RunState -> Bool -> [Action ()] -> IO [IO ()]
run RunState
s Bool
openOneShot forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Functor f => f a -> f ()
void [Action ()]
as
[Maybe a]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. IORef a -> IO a
readIORef [IORef (Maybe a)]
refs
case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe a]
results of
Just [a]
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
result, [IO ()]
after)
Maybe [a]
Nothing -> forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal String
"Expected all results were written, but some where not"