{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}

{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion

module Development.IDE.Graph.Internal.Profile (writeProfile) where

import           Control.Concurrent.STM.Stats            (readTVarIO)
import           Data.Bifunctor
import qualified Data.ByteString.Lazy.Char8              as LBS
import           Data.Char
import           Data.Dynamic                            (toDyn)
import           Data.HashMap.Strict                     (HashMap)
import qualified Data.HashMap.Strict                     as Map
import qualified Data.HashSet                            as Set
import           Data.List                               (dropWhileEnd, foldl',
                                                          intercalate,
                                                          partition, sort,
                                                          sortBy)
import           Data.List.Extra                         (nubOrd)
import           Data.Maybe
import           Data.Time                               (defaultTimeLocale,
                                                          formatTime,
                                                          getCurrentTime,
                                                          iso8601DateFormat)
import           Development.IDE.Graph.Classes
import           Development.IDE.Graph.Internal.Database (getDirtySet)
import           Development.IDE.Graph.Internal.Paths
import           Development.IDE.Graph.Internal.Types
import qualified Language.Javascript.DGTable             as DGTable
import qualified Language.Javascript.Flot                as Flot
import qualified Language.Javascript.JQuery              as JQuery
import           Numeric.Extra                           (showDP)
import           System.FilePath
import           System.IO.Unsafe                        (unsafePerformIO)
import           System.Time.Extra                       (Seconds)

#ifdef FILE_EMBED
import           Data.FileEmbed
import           Language.Haskell.TH.Syntax              (runIO)
#endif

-- | Generates an report given some build system profiling data.
writeProfile :: FilePath -> Database -> IO ()
writeProfile :: FilePath -> Database -> IO ()
writeProfile FilePath
out Database
db = do
    ([ProfileEntry]
report, HashMap Key Int
mapping) <- Database -> IO ([ProfileEntry], HashMap Key Int)
toReport Database
db
    Maybe [Int]
dirtyKeysMapped <- do
        HashSet Key
dirtyIds <- [Key] -> HashSet Key
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Key] -> HashSet Key)
-> ([(Key, Int)] -> [Key]) -> [(Key, Int)] -> HashSet Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Int) -> Key) -> [(Key, Int)] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, Int) -> Key
forall a b. (a, b) -> a
fst ([(Key, Int)] -> HashSet Key)
-> IO [(Key, Int)] -> IO (HashSet Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> IO [(Key, Int)]
getDirtySet Database
db
        let dirtyKeysMapped :: [Int]
dirtyKeysMapped = (Key -> Maybe Int) -> [Key] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key -> HashMap Key Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Key Int
mapping) ([Key] -> [Int]) -> (HashSet Key -> [Key]) -> HashSet Key -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet Key -> [Key]
forall a. HashSet a -> [a]
Set.toList (HashSet Key -> [Int]) -> HashSet Key -> [Int]
forall a b. (a -> b) -> a -> b
$ HashSet Key
dirtyIds
        Maybe [Int] -> IO (Maybe [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Int] -> IO (Maybe [Int]))
-> Maybe [Int] -> IO (Maybe [Int])
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [Int]
dirtyKeysMapped
    ByteString
rpt <- Maybe [Int] -> [ProfileEntry] -> IO ByteString
generateHTML Maybe [Int]
dirtyKeysMapped [ProfileEntry]
report
    FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
out ByteString
rpt

data ProfileEntry = ProfileEntry
    {ProfileEntry -> FilePath
prfName :: !String, ProfileEntry -> Int
prfBuilt :: !Int, ProfileEntry -> Int
prfChanged :: !Int, ProfileEntry -> Int
prfVisited :: !Int, ProfileEntry -> [[Int]]
prfDepends :: [[Int]], ProfileEntry -> Seconds
prfExecution :: !Seconds}

-- | Eliminate all errors from the database, pretending they don't exist
-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result
resultsOnly :: [(Key, Status)] -> HashMap Key Result
resultsOnly [(Key, Status)]
mp = (Result -> Result) -> HashMap Key Result -> HashMap Key Result
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (\Result
r ->
      Result
r{resultDeps :: ResultDeps
resultDeps = ([Key] -> [Key]) -> ResultDeps -> ResultDeps
mapResultDeps ((Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Result -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Result -> Bool) -> (Key -> Maybe Result) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> HashMap Key Result -> Maybe Result)
-> HashMap Key Result -> Key -> Maybe Result
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashMap Key Result -> Maybe Result
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup HashMap Key Result
keep)) (ResultDeps -> ResultDeps) -> ResultDeps -> ResultDeps
forall a b. (a -> b) -> a -> b
$ Result -> ResultDeps
resultDeps Result
r}
    ) HashMap Key Result
keep
    where
        keep :: HashMap Key Result
keep = [(Key, Result)] -> HashMap Key Result
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Key, Result)] -> HashMap Key Result)
-> [(Key, Result)] -> HashMap Key Result
forall a b. (a -> b) -> a -> b
$ ((Key, Status) -> Maybe (Key, Result))
-> [(Key, Status)] -> [(Key, Result)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Status -> Maybe Result) -> (Key, Status) -> Maybe (Key, Result)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Status -> Maybe Result
getResult) [(Key, Status)]
mp

-- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such
--   that no item points to an item before itself.
--   Raise an error if you end up with a cycle.
dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a]
-- Algorithm:
--    Divide everyone up into those who have no dependencies [Id]
--    And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]
--    Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds
--    For each with no dependencies, add to list, then take its dep hole and
--    promote them either to Nothing (if ds == []) or into a new slot.
--    k :-> Nothing means the key has already been freed
dependencyOrder :: (a -> FilePath) -> [(a, [a])] -> [a]
dependencyOrder a -> FilePath
shw [(a, [a])]
status =
  [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f (((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
forall a b. (a, b) -> a
fst [(a, [a])]
noDeps) (HashMap a (Maybe [(a, [a])]) -> [a])
-> HashMap a (Maybe [(a, [a])]) -> [a]
forall a b. (a -> b) -> a -> b
$
    ([(a, [a])] -> Maybe [(a, [a])])
-> HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])])
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map [(a, [a])] -> Maybe [(a, [a])]
forall a. a -> Maybe a
Just (HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])]))
-> HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])])
forall a b. (a -> b) -> a -> b
$
      ([(a, [a])] -> [(a, [a])] -> [(a, [a])])
-> [(a, [(a, [a])])] -> HashMap a [(a, [a])]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith [(a, [a])] -> [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a] -> [a]
(++)
        [(a
d, [(a
k,[a]
ds)]) | (a
k,a
d:[a]
ds) <- [(a, [a])]
hasDeps]
    where
        ([(a, [a])]
noDeps, [(a, [a])]
hasDeps) = ((a, [a]) -> Bool) -> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd) [(a, [a])]
status

        f :: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f [] HashMap a (Maybe [(a, [a])])
mp | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
bad = []
                | Bool
otherwise = FilePath -> [a]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [a]) -> FilePath -> [a]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                    FilePath
"Internal invariant broken, database seems to be cyclic" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
                    (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"    " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
bad [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                    [FilePath
"... plus " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show ([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
badOverflow) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" more ..." | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
badOverflow]
            where ([FilePath]
bad,[FilePath]
badOverflow) = Int -> [FilePath] -> ([FilePath], [FilePath])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
10 [a -> FilePath
shw a
i | (a
i, Just [(a, [a])]
_) <- HashMap a (Maybe [(a, [a])]) -> [(a, Maybe [(a, [a])])]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap a (Maybe [(a, [a])])
mp]

        f (a
x:[a]
xs) HashMap a (Maybe [(a, [a])])
mp = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f ([a]
now[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
xs) HashMap a (Maybe [(a, [a])])
later
            where Just [(a, [a])]
free = Maybe [(a, [a])]
-> a -> HashMap a (Maybe [(a, [a])]) -> Maybe [(a, [a])]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault ([(a, [a])] -> Maybe [(a, [a])]
forall a. a -> Maybe a
Just []) a
x HashMap a (Maybe [(a, [a])])
mp
                  ([a]
now,HashMap a (Maybe [(a, [a])])
later) = (([a], HashMap a (Maybe [(a, [a])]))
 -> (a, [a]) -> ([a], HashMap a (Maybe [(a, [a])])))
-> ([a], HashMap a (Maybe [(a, [a])]))
-> [(a, [a])]
-> ([a], HashMap a (Maybe [(a, [a])]))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], HashMap a (Maybe [(a, [a])]))
-> (a, [a]) -> ([a], HashMap a (Maybe [(a, [a])]))
forall k a.
Hashable k =>
([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([], a
-> Maybe [(a, [a])]
-> HashMap a (Maybe [(a, [a])])
-> HashMap a (Maybe [(a, [a])])
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
x Maybe [(a, [a])]
forall a. Maybe a
Nothing HashMap a (Maybe [(a, [a])])
mp) [(a, [a])]
free

        g :: ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, []) = (a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
free, HashMap k (Maybe [(a, [k])])
mp)
        g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, k
d:[k]
ds) = case Maybe [(a, [k])]
-> k -> HashMap k (Maybe [(a, [k])]) -> Maybe [(a, [k])]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault ([(a, [k])] -> Maybe [(a, [k])]
forall a. a -> Maybe a
Just []) k
d HashMap k (Maybe [(a, [k])])
mp of
            Maybe [(a, [k])]
Nothing   -> ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, [k]
ds)
            Just [(a, [k])]
todo -> ([a]
free, k
-> Maybe [(a, [k])]
-> HashMap k (Maybe [(a, [k])])
-> HashMap k (Maybe [(a, [k])])
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
d ([(a, [k])] -> Maybe [(a, [k])]
forall a. a -> Maybe a
Just ([(a, [k])] -> Maybe [(a, [k])]) -> [(a, [k])] -> Maybe [(a, [k])]
forall a b. (a -> b) -> a -> b
$ (a
k,[k]
ds) (a, [k]) -> [(a, [k])] -> [(a, [k])]
forall a. a -> [a] -> [a]
: [(a, [k])]
todo) HashMap k (Maybe [(a, [k])])
mp)

prepareForDependencyOrder :: Database -> IO (HashMap Key Result)
prepareForDependencyOrder :: Database -> IO (HashMap Key Result)
prepareForDependencyOrder Database
db = do
    Step
current <- 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
    Key -> Result -> HashMap Key Result -> HashMap Key Result
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (FilePath -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key FilePath
"alwaysRerun") (Step -> Result
alwaysRerunResult Step
current) (HashMap Key Result -> HashMap Key Result)
-> ([(Key, Status)] -> HashMap Key Result)
-> [(Key, Status)]
-> HashMap Key Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [(Key, Status)] -> HashMap Key Result
resultsOnly
        ([(Key, Status)] -> HashMap Key Result)
-> IO [(Key, Status)] -> IO (HashMap Key Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> IO [(Key, Status)]
getDatabaseValues Database
db

-- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry
toReport :: Database -> IO ([ProfileEntry], HashMap Key Int)
toReport :: Database -> IO ([ProfileEntry], HashMap Key Int)
toReport Database
db = do
    HashMap Key Result
status <- Database -> IO (HashMap Key Result)
prepareForDependencyOrder Database
db
    let order :: [Key]
order = (Key -> FilePath) -> [(Key, [Key])] -> [Key]
forall a.
(Eq a, Hashable a) =>
(a -> FilePath) -> [(a, [a])] -> [a]
dependencyOrder Key -> FilePath
forall a. Show a => a -> FilePath
show
                ([(Key, [Key])] -> [Key]) -> [(Key, [Key])] -> [Key]
forall a b. (a -> b) -> a -> b
$ ((Key, Result) -> (Key, [Key]))
-> [(Key, Result)] -> [(Key, [Key])]
forall a b. (a -> b) -> [a] -> [b]
map ((Result -> [Key]) -> (Key, Result) -> (Key, [Key])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Key] -> ResultDeps -> [Key]
getResultDepsDefault [FilePath -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key FilePath
"alwaysRerun"] (ResultDeps -> [Key]) -> (Result -> ResultDeps) -> Result -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> ResultDeps
resultDeps))
                ([(Key, Result)] -> [(Key, [Key])])
-> [(Key, Result)] -> [(Key, [Key])]
forall a b. (a -> b) -> a -> b
$ HashMap Key Result -> [(Key, Result)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap Key Result
status
        ids :: HashMap Key Int
ids = [(Key, Int)] -> HashMap Key Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Key, Int)] -> HashMap Key Int)
-> [(Key, Int)] -> HashMap Key Int
forall a b. (a -> b) -> a -> b
$ [Key] -> [Int] -> [(Key, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
order [Int
0..]

        steps :: HashMap Step Int
steps = let xs :: [Step]
xs = [Step] -> [Step]
forall a. Ord a => [a] -> [a]
nubOrd ([Step] -> [Step]) -> [Step] -> [Step]
forall a b. (a -> b) -> a -> b
$ [[Step]] -> [Step]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Step
resultChanged, Step
resultBuilt, Step
resultVisited] | Result{Seconds
ByteString
ResultDeps
Value
Step
resultData :: Result -> ByteString
resultExecution :: Result -> Seconds
resultVisited :: Result -> Step
resultChanged :: Result -> Step
resultBuilt :: Result -> Step
resultValue :: Result -> Value
resultData :: ByteString
resultExecution :: Seconds
resultDeps :: ResultDeps
resultValue :: Value
resultVisited :: Step
resultBuilt :: Step
resultChanged :: Step
resultDeps :: Result -> ResultDeps
..} <- HashMap Key Result -> [Result]
forall k v. HashMap k v -> [v]
Map.elems HashMap Key Result
status]

                in [(Step, Int)] -> HashMap Step Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Step, Int)] -> HashMap Step Int)
-> [(Step, Int)] -> HashMap Step Int
forall a b. (a -> b) -> a -> b
$ [Step] -> [Int] -> [(Step, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Step -> Step -> Ordering) -> [Step] -> [Step]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Step -> Step -> Ordering) -> Step -> Step -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Step -> Step -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [Step]
xs) [Int
0..]

        f :: a -> Result -> ProfileEntry
f a
k Result{Seconds
ByteString
ResultDeps
Value
Step
resultData :: ByteString
resultExecution :: Seconds
resultDeps :: ResultDeps
resultVisited :: Step
resultChanged :: Step
resultBuilt :: Step
resultValue :: Value
resultData :: Result -> ByteString
resultExecution :: Result -> Seconds
resultVisited :: Result -> Step
resultChanged :: Result -> Step
resultBuilt :: Result -> Step
resultValue :: Result -> Value
resultDeps :: Result -> ResultDeps
..} = ProfileEntry :: FilePath -> Int -> Int -> Int -> [[Int]] -> Seconds -> ProfileEntry
ProfileEntry
            {prfName :: FilePath
prfName = a -> FilePath
forall a. Show a => a -> FilePath
show a
k
            ,prfBuilt :: Int
prfBuilt = Step -> Int
fromStep Step
resultBuilt
            ,prfVisited :: Int
prfVisited = Step -> Int
fromStep Step
resultVisited
            ,prfChanged :: Int
prfChanged = Step -> Int
fromStep Step
resultChanged
            ,prfDepends :: [[Int]]
prfDepends = (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe Int) -> [Key] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key -> HashMap Key Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Key Int
ids) ([Key] -> [Int]) -> [Key] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Key] -> ResultDeps -> [Key]
getResultDepsDefault [FilePath -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key FilePath
"alwaysRerun"] ResultDeps
resultDeps
            ,prfExecution :: Seconds
prfExecution = Seconds
resultExecution
            }
            where fromStep :: Step -> Int
fromStep Step
i = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Step -> HashMap Step Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Step
i HashMap Step Int
steps
    ([ProfileEntry], HashMap Key Int)
-> IO ([ProfileEntry], HashMap Key Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ProfileEntry
-> (Result -> ProfileEntry) -> Maybe Result -> ProfileEntry
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> ProfileEntry
forall a. HasCallStack => FilePath -> a
error FilePath
"toReport") (Key -> Result -> ProfileEntry
forall a. Show a => a -> Result -> ProfileEntry
f Key
i) (Maybe Result -> ProfileEntry) -> Maybe Result -> ProfileEntry
forall a b. (a -> b) -> a -> b
$ Key -> HashMap Key Result -> Maybe Result
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Key
i HashMap Key Result
status | Key
i <- [Key]
order], HashMap Key Int
ids)

alwaysRerunResult :: Step -> Result
alwaysRerunResult :: Step -> Result
alwaysRerunResult Step
current = Value
-> Step
-> Step
-> Step
-> ResultDeps
-> Seconds
-> ByteString
-> Result
Result (Dynamic -> Value
Value (Dynamic -> Value) -> Dynamic -> Value
forall a b. (a -> b) -> a -> b
$ FilePath -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn FilePath
"<alwaysRerun>") (Int -> Step
Step Int
0) (Int -> Step
Step Int
0) Step
current ([Key] -> ResultDeps
ResultDeps []) Seconds
0 ByteString
forall a. Monoid a => a
mempty

generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString
generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO ByteString
generateHTML Maybe [Int]
dirtyKeys [ProfileEntry]
xs = do
    ByteString
report <- FilePath -> IO ByteString
readDataFileHTML FilePath
"profile.html"
    let f :: FilePath -> f ByteString
f FilePath
"data/profile-data.js" = ByteString -> f ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
LBS.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"var profile =\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> FilePath
generateJSONProfile [ProfileEntry]
xs
        f FilePath
"data/build-data.js" = ByteString -> f ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
LBS.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"var build =\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe [Int] -> FilePath
generateJSONBuild Maybe [Int]
dirtyKeys
        f FilePath
other = FilePath -> f ByteString
forall a. HasCallStack => FilePath -> a
error FilePath
other
    (FilePath -> IO ByteString) -> ByteString -> IO ByteString
runTemplate FilePath -> IO ByteString
forall (f :: * -> *). Applicative f => FilePath -> f ByteString
f ByteString
report

generateJSONBuild :: Maybe [Int] -> String
generateJSONBuild :: Maybe [Int] -> FilePath
generateJSONBuild (Just [Int]
dirtyKeys) = [FilePath] -> FilePath
jsonList [[FilePath] -> FilePath
jsonList ((Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
forall a. Show a => a -> FilePath
show [Int]
dirtyKeys)]
generateJSONBuild Maybe [Int]
Nothing          = [FilePath] -> FilePath
jsonList []

generateJSONProfile :: [ProfileEntry] -> String
generateJSONProfile :: [ProfileEntry] -> FilePath
generateJSONProfile = [FilePath] -> FilePath
jsonListLines ([FilePath] -> FilePath)
-> ([ProfileEntry] -> [FilePath]) -> [ProfileEntry] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProfileEntry -> FilePath) -> [ProfileEntry] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ProfileEntry -> FilePath
showEntry
    where
        showEntry :: ProfileEntry -> FilePath
showEntry ProfileEntry{Seconds
Int
FilePath
[[Int]]
prfExecution :: Seconds
prfDepends :: [[Int]]
prfVisited :: Int
prfChanged :: Int
prfBuilt :: Int
prfName :: FilePath
prfExecution :: ProfileEntry -> Seconds
prfDepends :: ProfileEntry -> [[Int]]
prfVisited :: ProfileEntry -> Int
prfChanged :: ProfileEntry -> Int
prfBuilt :: ProfileEntry -> Int
prfName :: ProfileEntry -> FilePath
..} = [FilePath] -> FilePath
jsonList ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
            [FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
prfName
            ,Seconds -> FilePath
forall a. RealFloat a => a -> FilePath
showTime Seconds
prfExecution
            ,Int -> FilePath
forall a. Show a => a -> FilePath
show Int
prfBuilt
            ,Int -> FilePath
forall a. Show a => a -> FilePath
show Int
prfChanged
            ,Int -> FilePath
forall a. Show a => a -> FilePath
show Int
prfVisited
            ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
            [[[Int]] -> FilePath
forall a. Show a => a -> FilePath
show [[Int]]
prfDepends | Bool -> Bool
not ([[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Int]]
prfDepends)]
        showTime :: a -> FilePath
showTime a
x = if Char
'.' Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
y then (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') FilePath
y else FilePath
y
            where y :: FilePath
y = Int -> a -> FilePath
forall a. RealFloat a => Int -> a -> FilePath
showDP Int
4 a
x

jsonListLines :: [String] -> String
jsonListLines :: [FilePath] -> FilePath
jsonListLines [FilePath]
xs = FilePath
"[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n," [FilePath]
xs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n]"

jsonList :: [String] -> String
jsonList :: [FilePath] -> FilePath
jsonList [FilePath]
xs = FilePath
"[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," [FilePath]
xs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"]"

-- Very hard to abstract over TH, so we do it with CPP
#ifdef FILE_EMBED
#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x))))
#else
#define FILE(x) (LBS.readFile =<< (x))
#endif

libraries :: [(String, IO LBS.ByteString)]
libraries :: [(FilePath, IO ByteString)]
libraries =
    [(FilePath
"jquery.js",            FILE(JQuery.file))
    ,(FilePath
"jquery.dgtable.js",    FILE(DGTable.file))
    ,(FilePath
"jquery.flot.js",       FILE(Flot.file Flot.Flot))
    ,(FilePath
"jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack))
    ]


-- | Template Engine. Perform the following replacements on a line basis:
--
-- * <script src="foo"></script> ==> <script>[[foo]]</script>
--
-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>
runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
runTemplate :: (FilePath -> IO ByteString) -> ByteString -> IO ByteString
runTemplate FilePath -> IO ByteString
ask = (ByteString -> IO ByteString) -> ByteString -> IO ByteString
lbsMapLinesIO ByteString -> IO ByteString
f
    where
        link :: ByteString
link = FilePath -> ByteString
LBS.pack FilePath
"<link href=\""
        script :: ByteString
script = FilePath -> ByteString
LBS.pack FilePath
"<script src=\""

        f :: ByteString -> IO ByteString
f ByteString
x | Just ByteString
file <- ByteString -> ByteString -> Maybe ByteString
LBS.stripPrefix ByteString
script ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
LBS.pack FilePath
"<script>\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` FilePath -> ByteString
LBS.pack FilePath
"\n</script>"
            | Just ByteString
file <- ByteString -> ByteString -> Maybe ByteString
LBS.stripPrefix ByteString
link ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
LBS.pack FilePath
"<style type=\"text/css\">\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` FilePath -> ByteString
LBS.pack FilePath
"\n</style>"
            | Bool
otherwise = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
x
            where
                y :: ByteString
y = (Char -> Bool) -> ByteString -> ByteString
LBS.dropWhile Char -> Bool
isSpace ByteString
x
                grab :: ByteString -> IO ByteString
grab = FilePath -> IO ByteString
asker (FilePath -> IO ByteString)
-> (ByteString -> FilePath) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"') (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
LBS.unpack

        asker :: FilePath -> IO ByteString
asker o :: FilePath
o@(FilePath -> (FilePath, FilePath)
splitFileName -> (FilePath
"lib/",FilePath
x)) =
            case FilePath -> [(FilePath, IO ByteString)] -> Maybe (IO ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
x [(FilePath, IO ByteString)]
libraries of
                Maybe (IO ByteString)
Nothing  -> FilePath -> IO ByteString
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Template library, unknown library: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
o
                Just IO ByteString
act -> IO ByteString
act

        asker FilePath
"shake.js" = FilePath -> IO ByteString
readDataFileHTML FilePath
"shake.js"
        asker FilePath
"data/metadata.js" = do
            UTCTime
time <- IO UTCTime
getCurrentTime
            ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
LBS.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$
                FilePath
"var version = \"0\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                FilePath
"\nvar generated = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale (Maybe FilePath -> FilePath
iso8601DateFormat (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"%H:%M:%S")) UTCTime
time)
        asker FilePath
x = FilePath -> IO ByteString
ask FilePath
x

-- Perform a mapM on each line and put the result back together again
lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines
-- before it starts producing the lazy result, killing streaming and having more stack usage.
-- The real solution (albeit with too many dependencies for something small) is a streaming library,
-- but a little bit of unsafePerformIO does the trick too.
lbsMapLinesIO :: (ByteString -> IO ByteString) -> ByteString -> IO ByteString
lbsMapLinesIO ByteString -> IO ByteString
f = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.unlines ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString)
-> (ByteString -> IO ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ByteString
f) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.lines