{-# 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 qualified Data.HashMap.Strict                     as Map
import           Data.List                               (dropWhileEnd, foldl',
                                                          intercalate,
                                                          partition, sort,
                                                          sortBy)
import           Data.List.Extra                         (nubOrd)
import           Data.Maybe
import           Data.Time                               (getCurrentTime)
import           Data.Time.Format.ISO8601                (iso8601Show)
import           Development.IDE.Graph.Internal.Database (getDirtySet)
import           Development.IDE.Graph.Internal.Key
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 :: String -> Database -> IO ()
writeProfile String
out Database
db = do
    ([ProfileEntry]
report, KeyMap Int
mapping) <- Database -> IO ([ProfileEntry], KeyMap Int)
toReport Database
db
    Maybe [Int]
dirtyKeysMapped <- do
        KeySet
dirtyIds <- [Key] -> KeySet
fromListKeySet ([Key] -> KeySet)
-> ([(Key, Int)] -> [Key]) -> [(Key, Int)] -> KeySet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Int) -> Key) -> [(Key, Int)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
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)] -> KeySet) -> IO [(Key, Int)] -> IO KeySet
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 -> KeyMap Int -> Maybe Int
forall a. Key -> KeyMap a -> Maybe a
`lookupKeyMap` KeyMap Int
mapping) ([Key] -> [Int]) -> (KeySet -> [Key]) -> KeySet -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> [Key]
toListKeySet (KeySet -> [Int]) -> KeySet -> [Int]
forall a b. (a -> b) -> a -> b
$ KeySet
dirtyIds
        Maybe [Int] -> IO (Maybe [Int])
forall a. a -> IO a
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
    String -> ByteString -> IO ()
LBS.writeFile String
out ByteString
rpt

data ProfileEntry = ProfileEntry
    {ProfileEntry -> String
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)] -> KeyMap Result
resultsOnly :: [(Key, Status)] -> KeyMap Result
resultsOnly [(Key, Status)]
mp = (Result -> Result) -> KeyMap Result -> KeyMap Result
forall a b. (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap (\Result
r ->
      Result
r{resultDeps = mapResultDeps (filterKeySet (isJust . flip lookupKeyMap keep)) $ resultDeps r}
    ) KeyMap Result
keep
    where
        keep :: KeyMap Result
keep = [(Key, Result)] -> KeyMap Result
forall a. [(Key, a)] -> KeyMap a
fromListKeyMap ([(Key, Result)] -> KeyMap Result)
-> [(Key, Result)] -> KeyMap 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Key, a) -> f (Key, 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.
--
-- 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 :: (Key -> String) -> [(Key, [Key])] -> [Key]
dependencyOrder :: (Key -> String) -> [(Key, [Key])] -> [Key]
dependencyOrder Key -> String
shw [(Key, [Key])]
status =
  [Key] -> KeyMap (Maybe [(Key, [Key])]) -> [Key]
f (((Key, [Key]) -> Key) -> [(Key, [Key])] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, [Key]) -> Key
forall a b. (a, b) -> a
fst [(Key, [Key])]
noDeps) (KeyMap (Maybe [(Key, [Key])]) -> [Key])
-> KeyMap (Maybe [(Key, [Key])]) -> [Key]
forall a b. (a -> b) -> a -> b
$
    ([(Key, [Key])] -> Maybe [(Key, [Key])])
-> KeyMap [(Key, [Key])] -> KeyMap (Maybe [(Key, [Key])])
forall a b. (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap [(Key, [Key])] -> Maybe [(Key, [Key])]
forall a. a -> Maybe a
Just (KeyMap [(Key, [Key])] -> KeyMap (Maybe [(Key, [Key])]))
-> KeyMap [(Key, [Key])] -> KeyMap (Maybe [(Key, [Key])])
forall a b. (a -> b) -> a -> b
$
      ([(Key, [Key])] -> [(Key, [Key])] -> [(Key, [Key])])
-> [(Key, [(Key, [Key])])] -> KeyMap [(Key, [Key])]
forall a. (a -> a -> a) -> [(Key, a)] -> KeyMap a
fromListWithKeyMap [(Key, [Key])] -> [(Key, [Key])] -> [(Key, [Key])]
forall a. [a] -> [a] -> [a]
(++)
        [(Key
d, [(Key
k,[Key]
ds)]) | (Key
k,Key
d:[Key]
ds) <- [(Key, [Key])]
hasDeps]
    where
        ([(Key, [Key])]
noDeps, [(Key, [Key])]
hasDeps) = ((Key, [Key]) -> Bool)
-> [(Key, [Key])] -> ([(Key, [Key])], [(Key, [Key])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Key] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Key] -> Bool) -> ((Key, [Key]) -> [Key]) -> (Key, [Key]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, [Key]) -> [Key]
forall a b. (a, b) -> b
snd) [(Key, [Key])]
status

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

        f (Key
x:[Key]
xs) KeyMap (Maybe [(Key, [Key])])
mp = Key
x Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key] -> KeyMap (Maybe [(Key, [Key])]) -> [Key]
f ([Key]
now[Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++[Key]
xs) KeyMap (Maybe [(Key, [Key])])
later
            where free :: [(Key, [Key])]
free = [(Key, [Key])] -> Maybe [(Key, [Key])] -> [(Key, [Key])]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Key, [Key])] -> [(Key, [Key])])
-> Maybe [(Key, [Key])] -> [(Key, [Key])]
forall a b. (a -> b) -> a -> b
$ Maybe [(Key, [Key])]
-> Key -> KeyMap (Maybe [(Key, [Key])]) -> Maybe [(Key, [Key])]
forall a. a -> Key -> KeyMap a -> a
lookupDefaultKeyMap ([(Key, [Key])] -> Maybe [(Key, [Key])]
forall a. a -> Maybe a
Just []) Key
x KeyMap (Maybe [(Key, [Key])])
mp
                  ([Key]
now,KeyMap (Maybe [(Key, [Key])])
later) = (([Key], KeyMap (Maybe [(Key, [Key])]))
 -> (Key, [Key]) -> ([Key], KeyMap (Maybe [(Key, [Key])])))
-> ([Key], KeyMap (Maybe [(Key, [Key])]))
-> [(Key, [Key])]
-> ([Key], KeyMap (Maybe [(Key, [Key])]))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Key], KeyMap (Maybe [(Key, [Key])]))
-> (Key, [Key]) -> ([Key], KeyMap (Maybe [(Key, [Key])]))
forall {a}.
([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([], Key
-> Maybe [(Key, [Key])]
-> KeyMap (Maybe [(Key, [Key])])
-> KeyMap (Maybe [(Key, [Key])])
forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap Key
x Maybe [(Key, [Key])]
forall a. Maybe a
Nothing KeyMap (Maybe [(Key, [Key])])
mp) [(Key, [Key])]
free

        g :: ([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, []) = (a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
free, KeyMap (Maybe [(a, [Key])])
mp)
        g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, Key
d:[Key]
ds) = case Maybe [(a, [Key])]
-> Key -> KeyMap (Maybe [(a, [Key])]) -> Maybe [(a, [Key])]
forall a. a -> Key -> KeyMap a -> a
lookupDefaultKeyMap ([(a, [Key])] -> Maybe [(a, [Key])]
forall a. a -> Maybe a
Just []) Key
d KeyMap (Maybe [(a, [Key])])
mp of
            Maybe [(a, [Key])]
Nothing   -> ([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, [Key]
ds)
            Just [(a, [Key])]
todo -> ([a]
free, Key
-> Maybe [(a, [Key])]
-> KeyMap (Maybe [(a, [Key])])
-> KeyMap (Maybe [(a, [Key])])
forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap Key
d ([(a, [Key])] -> Maybe [(a, [Key])]
forall a. a -> Maybe a
Just ([(a, [Key])] -> Maybe [(a, [Key])])
-> [(a, [Key])] -> Maybe [(a, [Key])]
forall a b. (a -> b) -> a -> b
$ (a
k,[Key]
ds) (a, [Key]) -> [(a, [Key])] -> [(a, [Key])]
forall a. a -> [a] -> [a]
: [(a, [Key])]
todo) KeyMap (Maybe [(a, [Key])])
mp)

prepareForDependencyOrder :: Database -> IO (KeyMap Result)
prepareForDependencyOrder :: Database -> IO (KeyMap 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 -> KeyMap Result -> KeyMap Result
forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap (String -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey String
"alwaysRerun") (Step -> Result
alwaysRerunResult Step
current) (KeyMap Result -> KeyMap Result)
-> ([(Key, Status)] -> KeyMap Result)
-> [(Key, Status)]
-> KeyMap Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [(Key, Status)] -> KeyMap Result
resultsOnly
        ([(Key, Status)] -> KeyMap Result)
-> IO [(Key, Status)] -> IO (KeyMap 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], KeyMap Int)
toReport :: Database -> IO ([ProfileEntry], KeyMap Int)
toReport Database
db = do
    KeyMap Result
status <- Database -> IO (KeyMap Result)
prepareForDependencyOrder Database
db
    let order :: [Key]
order = (Key -> String) -> [(Key, [Key])] -> [Key]
dependencyOrder Key -> String
forall a. Show a => a -> String
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 b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (KeySet -> [Key]
toListKeySet (KeySet -> [Key]) -> (Result -> KeySet) -> Result -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> ResultDeps -> KeySet
getResultDepsDefault (Key -> KeySet
singletonKeySet (Key -> KeySet) -> Key -> KeySet
forall a b. (a -> b) -> a -> b
$ String -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey String
"alwaysRerun") (ResultDeps -> KeySet)
-> (Result -> ResultDeps) -> Result -> KeySet
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
$ KeyMap Result -> [(Key, Result)]
forall a. KeyMap a -> [(Key, a)]
toListKeyMap KeyMap Result
status
        ids :: KeyMap Int
ids = [(Key, Int)] -> KeyMap Int
forall a. [(Key, a)] -> KeyMap a
fromListKeyMap ([(Key, Int)] -> KeyMap Int) -> [(Key, Int)] -> KeyMap 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
resultDeps :: Result -> ResultDeps
resultChanged :: Step
resultBuilt :: Step
resultVisited :: Step
resultValue :: Value
resultDeps :: ResultDeps
resultExecution :: Seconds
resultData :: ByteString
resultValue :: Result -> Value
resultBuilt :: Result -> Step
resultChanged :: Result -> Step
resultVisited :: Result -> Step
resultExecution :: Result -> Seconds
resultData :: Result -> ByteString
..} <- KeyMap Result -> [Result]
forall a. KeyMap a -> [a]
elemsKeyMap KeyMap 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
resultDeps :: Result -> ResultDeps
resultValue :: Result -> Value
resultBuilt :: Result -> Step
resultChanged :: Result -> Step
resultVisited :: Result -> Step
resultExecution :: Result -> Seconds
resultData :: Result -> ByteString
resultValue :: Value
resultBuilt :: Step
resultChanged :: Step
resultVisited :: Step
resultDeps :: ResultDeps
resultExecution :: Seconds
resultData :: ByteString
..} = ProfileEntry
            {prfName :: String
prfName = a -> String
forall a. Show a => a -> String
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 a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ KeyMap Int -> [Int]
forall a. KeyMap a -> [a]
elemsKeyMap (KeyMap Int -> [Int]) -> KeyMap Int -> [Int]
forall a b. (a -> b) -> a -> b
$ KeyMap Int -> KeySet -> KeyMap Int
forall a. KeyMap a -> KeySet -> KeyMap a
restrictKeysKeyMap KeyMap Int
ids (KeySet -> KeyMap Int) -> KeySet -> KeyMap Int
forall a b. (a -> b) -> a -> b
$ KeySet -> ResultDeps -> KeySet
getResultDepsDefault (Key -> KeySet
singletonKeySet (Key -> KeySet) -> Key -> KeySet
forall a b. (a -> b) -> a -> b
$ String -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey String
"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], KeyMap Int) -> IO ([ProfileEntry], KeyMap Int)
forall a. a -> IO a
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 (String -> ProfileEntry
forall a. HasCallStack => String -> a
error String
"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 -> KeyMap Result -> Maybe Result
forall a. Key -> KeyMap a -> Maybe a
lookupKeyMap Key
i KeyMap Result
status | Key
i <- [Key]
order], KeyMap 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
$ String -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn String
"<alwaysRerun>") (Int -> Step
Step Int
0) (Int -> Step
Step Int
0) Step
current (KeySet -> ResultDeps
ResultDeps KeySet
forall a. Monoid a => a
mempty) 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 <- String -> IO ByteString
readDataFileHTML String
"profile.html"
    let f :: String -> f ByteString
f String
"data/profile-data.js" = ByteString -> f ByteString
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"var profile =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
generateJSONProfile [ProfileEntry]
xs
        f String
"data/build-data.js" = ByteString -> f ByteString
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"var build =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe [Int] -> String
generateJSONBuild Maybe [Int]
dirtyKeys
        f String
other = String -> f ByteString
forall a. HasCallStack => String -> a
error String
other
    (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate String -> IO ByteString
forall {f :: * -> *}. Applicative f => String -> f ByteString
f ByteString
report

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

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

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

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

-- 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 :: [(String, IO ByteString)]
libraries =
    [(String
"jquery.js",            FILE(JQuery.file))
    ,(String
"jquery.dgtable.js",    FILE(DGTable.file))
    ,(String
"jquery.flot.js",       FILE(Flot.file Flot.Flot))
    ,(String
"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 :: (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate String -> IO ByteString
ask = (ByteString -> IO ByteString) -> ByteString -> IO ByteString
lbsMapLinesIO ByteString -> IO ByteString
f
    where
        link :: ByteString
link = String -> ByteString
LBS.pack String
"<link href=\""
        script :: ByteString
script = String -> ByteString
LBS.pack String
"<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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack String
"<script>\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` String -> ByteString
LBS.pack String
"\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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack String
"<style type=\"text/css\">\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` String -> ByteString
LBS.pack String
"\n</style>"
            | Bool
otherwise = ByteString -> IO ByteString
forall a. a -> IO a
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 = String -> IO ByteString
asker (String -> IO ByteString)
-> (ByteString -> String) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"') (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
LBS.unpack

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

        asker String
"shake.js" = String -> IO ByteString
readDataFileHTML String
"shake.js"
        asker String
"data/metadata.js" = do
            UTCTime
time <- IO UTCTime
getCurrentTime
            ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
                String
"var version = \"0\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"\nvar generated = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. ISO8601 t => t -> String
iso8601Show UTCTime
time
        asker String
x = String -> IO ByteString
ask String
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 a. a -> IO a
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