{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE ExistentialQuantification #-}
module Development.IDE.Graph.Database(
    ShakeDatabase,
    ShakeValue,
    shakeNewDatabase,
    shakeRunDatabase,
    shakeRunDatabaseForKeys,
    shakeProfileDatabase,
    shakeGetBuildStep,
    shakeGetDirtySet,
    shakeGetCleanKeys
    ,shakeGetBuildEdges) where
import           Control.Concurrent.STM.Stats            (readTVarIO)
import           Data.Dynamic
import           Data.Maybe
import           Development.IDE.Graph.Classes           ()
import           Development.IDE.Graph.Internal.Action
import           Development.IDE.Graph.Internal.Database
import           Development.IDE.Graph.Internal.Options
import           Development.IDE.Graph.Internal.Profile  (writeProfile)
import           Development.IDE.Graph.Internal.Rules
import           Development.IDE.Graph.Internal.Types


-- Placeholder to be the 'extra' if the user doesn't set it
data NonExportedType = NonExportedType

shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase
shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase
shakeNewDatabase ShakeOptions
opts Rules ()
rules = do
    let extra :: Dynamic
extra = Dynamic -> Maybe Dynamic -> Dynamic
forall a. a -> Maybe a -> a
fromMaybe (NonExportedType -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn NonExportedType
NonExportedType) (Maybe Dynamic -> Dynamic) -> Maybe Dynamic -> Dynamic
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> Maybe Dynamic
shakeExtra ShakeOptions
opts
    (TheRules
theRules, [Action ()]
actions) <- Dynamic -> Rules () -> IO (TheRules, [Action ()])
runRules Dynamic
extra Rules ()
rules
    Database
db <- Dynamic -> TheRules -> IO Database
newDatabase Dynamic
extra TheRules
theRules
    ShakeDatabase -> IO ShakeDatabase
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeDatabase -> IO ShakeDatabase)
-> ShakeDatabase -> IO ShakeDatabase
forall a b. (a -> b) -> a -> b
$ Int -> [Action ()] -> Database -> ShakeDatabase
ShakeDatabase ([Action ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action ()]
actions) [Action ()]
actions Database
db

shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabase = Maybe [Key] -> ShakeDatabase -> [Action a] -> IO [a]
forall a. Maybe [Key] -> ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabaseForKeys Maybe [Key]
forall a. Maybe a
Nothing

-- | Returns the set of dirty keys annotated with their age (in # of builds)
shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
shakeGetDirtySet (ShakeDatabase Int
_ [Action ()]
_ Database
db) =
    Database -> IO [(Key, Int)]
Development.IDE.Graph.Internal.Database.getDirtySet Database
db

-- | Returns the build number
shakeGetBuildStep :: ShakeDatabase -> IO Int
shakeGetBuildStep :: ShakeDatabase -> IO Int
shakeGetBuildStep (ShakeDatabase Int
_ [Action ()]
_ Database
db) = do
    Step Int
s <- TVar Step -> IO Step
forall a. TVar a -> IO a
readTVarIO (TVar Step -> IO Step) -> TVar Step -> IO Step
forall a b. (a -> b) -> a -> b
$ Database -> TVar Step
databaseStep Database
db
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
s

-- Only valid if we never pull on the results, which we don't
unvoid :: Functor m => m () -> m a
unvoid :: m () -> m a
unvoid = (() -> a) -> m () -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> a
forall a. HasCallStack => a
undefined

-- | Assumes that the database is not running a build
shakeRunDatabaseForKeys
    :: Maybe [Key]
      -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
    -> ShakeDatabase
    -> [Action a]
    -> IO [a]
shakeRunDatabaseForKeys :: Maybe [Key] -> ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabaseForKeys Maybe [Key]
keysChanged (ShakeDatabase Int
lenAs1 [Action ()]
as1 Database
db) [Action a]
as2 = do
    Database -> Maybe [Key] -> IO ()
incDatabase Database
db Maybe [Key]
keysChanged
    ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
lenAs1) (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ Database -> [Action a] -> IO [a]
forall a. Database -> [Action a] -> IO [a]
runActions Database
db ([Action a] -> IO [a]) -> [Action a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ (Action () -> Action a) -> [Action ()] -> [Action a]
forall a b. (a -> b) -> [a] -> [b]
map Action () -> Action a
forall (m :: * -> *) a. Functor m => m () -> m a
unvoid [Action ()]
as1 [Action a] -> [Action a] -> [Action a]
forall a. [a] -> [a] -> [a]
++ [Action a]
as2

-- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
shakeProfileDatabase (ShakeDatabase Int
_ [Action ()]
_ Database
s) FilePath
file = FilePath -> Database -> IO ()
writeProfile FilePath
file Database
s

-- | Returns the clean keys in the database
shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]
shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result)]
shakeGetCleanKeys (ShakeDatabase Int
_ [Action ()]
_ Database
db) = do
    [(Key, Status)]
keys <- Database -> IO [(Key, Status)]
getDatabaseValues Database
db
    [(Key, Result)] -> IO [(Key, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Key
k,Result
res) | (Key
k, Clean Result
res) <- [(Key, Status)]
keys]

-- | Returns the total count of edges in the build graph
shakeGetBuildEdges :: ShakeDatabase -> IO Int
shakeGetBuildEdges :: ShakeDatabase -> IO Int
shakeGetBuildEdges (ShakeDatabase Int
_ [Action ()]
_ Database
db) = do
    [(Key, Status)]
keys <- Database -> IO [(Key, Status)]
getDatabaseValues Database
db
    let ress :: [Result]
ress = ((Key, Status) -> Maybe Result) -> [(Key, Status)] -> [Result]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Status -> Maybe Result
getResult (Status -> Maybe Result)
-> ((Key, Status) -> Status) -> (Key, Status) -> Maybe Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Status) -> Status
forall a b. (a, b) -> b
snd) [(Key, Status)]
keys
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Result -> Int) -> [Result] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Key] -> Int) -> (Result -> [Key]) -> Result -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ResultDeps -> [Key]
getResultDepsDefault [] (ResultDeps -> [Key]) -> (Result -> ResultDeps) -> Result -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> ResultDeps
resultDeps) [Result]
ress