{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE ExistentialQuantification #-}
module Development.IDE.Graph.Database(
    ShakeDatabase,
    ShakeValue,
    shakeOpenDatabase,
    shakeRunDatabase,
    shakeRunDatabaseForKeys,
    shakeProfileDatabase,
    shakeGetBuildStep,
    shakeGetDirtySet,
    shakeGetCleanKeys
    ,shakeGetBuildEdges) where
import           Data.Dynamic
import           Data.IORef                              (readIORef)
import           Data.Maybe
import           Development.IDE.Graph.Classes           ()
import           Development.IDE.Graph.Internal.Action
import           Development.IDE.Graph.Internal.Database
import qualified Development.IDE.Graph.Internal.Ids      as Ids
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

data ShakeDatabase = ShakeDatabase !Int [Action ()] Database

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

shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase ShakeOptions
opts Rules ()
rules = (IO ShakeDatabase, IO ()) -> IO (IO ShakeDatabase, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeOptions -> Rules () -> IO ShakeDatabase
shakeNewDatabase ShakeOptions
opts Rules ()
rules, () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

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], [IO ()])
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase = Maybe [Key] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
forall a.
Maybe [Key] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
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) =
    ((Int, (Key, Int)) -> (Key, Int))
-> [(Int, (Key, Int))] -> [(Key, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, (Key, Int)) -> (Key, Int)
forall a b. (a, b) -> b
snd ([(Int, (Key, Int))] -> [(Key, Int)])
-> IO [(Int, (Key, Int))] -> IO [(Key, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> IO [(Int, (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 <- IORef Step -> IO Step
forall a. IORef a -> IO a
readIORef (IORef Step -> IO Step) -> IORef Step -> IO Step
forall a b. (a -> b) -> a -> b
$ Database -> IORef 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

shakeRunDatabaseForKeys
    :: Maybe [Key]
      -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
    -> ShakeDatabase
    -> [Action a]
    -> IO ([a], [IO ()])
shakeRunDatabaseForKeys :: Maybe [Key] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
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]
as <- ([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
    ([a], [IO ()]) -> IO ([a], [IO ()])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as, [])

-- | 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 <- Ids (Key, Status) -> IO [(Key, Status)]
forall a. Ids a -> IO [a]
Ids.elems (Ids (Key, Status) -> IO [(Key, Status)])
-> Ids (Key, Status) -> IO [(Key, Status)]
forall a b. (a -> b) -> a -> b
$ Database -> Ids (Key, Status)
databaseValues 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 <- Ids (Key, Status) -> IO [(Key, Status)]
forall a. Ids a -> IO [a]
Ids.elems (Ids (Key, Status) -> IO [(Key, Status)])
-> Ids (Key, Status) -> IO [(Key, Status)]
forall a b. (a -> b) -> a -> b
$ Database -> Ids (Key, Status)
databaseValues 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 ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> (Result -> [Int]) -> Result -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> ResultDeps -> [Int]
getResultDepsDefault [] (ResultDeps -> [Int]) -> (Result -> ResultDeps) -> Result -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> ResultDeps
resultDeps) [Result]
ress