{-# LANGUAGE PatternGuards, RecordWildCards #-}

module Development.Shake.Internal.Profile(writeProfile) where

import General.Template
import Data.Tuple.Extra
import Data.Function
import Data.List.Extra
import Data.Maybe
import System.FilePath
import System.IO.Extra
import Numeric.Extra
import General.Extra
import Development.Shake.Internal.Errors
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.Value
import qualified Data.HashSet as Set
import Development.Shake.Internal.Paths
import Development.Shake.Classes
import System.Time.Extra
import qualified Data.HashMap.Strict as Map
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Char8 as BS
import General.Intern(Id)


-- | 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) -> Map.HashMap 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 :: forall a.
(Eq a, Hashable a) =>
(a -> String) -> HashMap a [a] -> [a]
dependencyOrder a -> String
shw HashMap a [a]
status = [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, [a])]
noDeps) forall a b. (a -> b) -> a -> b
$ forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap a [a]
status

        f :: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f [] HashMap a (Maybe [(a, [a])])
mp | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad = []
                | Bool
otherwise = forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                    String
"Internal invariant broken, database seems to be cyclic" forall a. a -> [a] -> [a]
:
                    forall a b. (a -> b) -> [a] -> [b]
map (String
"    " forall a. [a] -> [a] -> [a]
++) [String]
bad forall a. [a] -> [a] -> [a]
++
                    [String
"... plus " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
badOverflow) forall a. [a] -> [a] -> [a]
++ String
" more ..." | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
badOverflow]
            where ([String]
bad,[String]
badOverflow) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
10 [a -> String
shw a
i | (a
i, Just [(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 forall a. a -> [a] -> [a]
: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f ([a]
nowforall a. [a] -> [a] -> [a]
++[a]
xs) HashMap a (Maybe [(a, [a])])
later
            where Just [(a, [a])]
free = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault (forall a. a -> Maybe a
Just []) a
x HashMap a (Maybe [(a, [a])])
mp
                  ([a]
now,HashMap a (Maybe [(a, [a])])
later) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {k} {a}.
Hashable k =>
([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([], forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
x 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
kforall 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 forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault (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, forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
d (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (a
k,[k]
ds) forall a. a -> [a] -> [a]
: [(a, [k])]
todo) HashMap k (Maybe [(a, [k])])
mp)


-- | 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 :: HashMap Id (Key, Status)
-> HashMap Id (Key, Result (Either ByteString Value))
resultsOnly HashMap Id (Key, Status)
mp = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (\(Key
k, Status
v) -> (Key
k, let Just Result (Either ByteString Value)
r = Status -> Maybe (Result (Either ByteString Value))
getResult Status
v in Result (Either ByteString Value)
r{depends :: [Depends]
depends = forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> Depends
Depends forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup HashMap Id (Key, Status)
keep) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Depends -> [Id]
fromDepends) forall a b. (a -> b) -> a -> b
$ forall a. Result a -> [Depends]
depends Result (Either ByteString Value)
r})) HashMap Id (Key, Status)
keep
    where keep :: HashMap Id (Key, Status)
keep = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Maybe (Result (Either ByteString Value))
getResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) HashMap Id (Key, Status)
mp

removeStep :: Map.HashMap Id (Key, Result a) -> Map.HashMap Id (Key, Result a)
removeStep :: forall a. HashMap Id (Key, Result a) -> HashMap Id (Key, Result a)
removeStep = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter (\(Key
k,Result a
_) -> Key
k forall a. Eq a => a -> a -> Bool
/= Key
stepKey)

toReport :: Database -> IO [ProfileEntry]
toReport :: Database -> IO [ProfileEntry]
toReport Database
db = do
    HashMap Id (Key, Result (Either ByteString Value))
status <- forall a. HashMap Id (Key, Result a) -> HashMap Id (Key, Result a)
removeStep forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Id (Key, Status)
-> HashMap Id (Key, Result (Either ByteString Value))
resultsOnly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. DatabasePoly k v -> IO (HashMap Id (k, v))
getKeyValuesFromId Database
db
    let order :: [Id]
order = let shw :: Id -> String
shw Id
i = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<unknown>" (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Id
i HashMap Id (Key, Result (Either ByteString Value))
status
                in forall a.
(Eq a, Hashable a) =>
(a -> String) -> HashMap a [a] -> [a]
dependencyOrder Id -> String
shw forall a b. (a -> b) -> a -> b
$ forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Depends -> [Id]
fromDepends forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Result a -> [Depends]
depends forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) HashMap Id (Key, Result (Either ByteString Value))
status
        ids :: HashMap Id Int
ids = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
order [Int
0..]

        steps :: HashMap Step Int
steps = let xs :: [Step]
xs = forall a. HashSet a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Step
changed, Step
built] | (Key
_,Result{Float
[Depends]
[Trace]
Either ByteString Value
Step
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
traces :: [Trace]
execution :: Float
depends :: [Depends]
result :: Either ByteString Value
built :: Step
changed :: Step
depends :: forall a. Result a -> [Depends]
..}) <- forall k v. HashMap k v -> [v]
Map.elems HashMap Id (Key, Result (Either ByteString Value))
status]
                in forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) [Step]
xs) [Int
0..]

        f :: (a, Result a) -> ProfileEntry
f (a
k, Result{a
Float
[Depends]
[Trace]
Step
traces :: [Trace]
execution :: Float
depends :: [Depends]
changed :: Step
built :: Step
result :: a
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
depends :: forall a. Result a -> [Depends]
..}) = ProfileEntry
            {prfName :: String
prfName = forall a. Show a => a -> String
show a
k
            ,prfBuilt :: Int
prfBuilt = Step -> Int
fromStep Step
built
            ,prfChanged :: Int
prfChanged = Step -> Int
fromStep Step
changed
            ,prfDepends :: [[Int]]
prfDepends = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Id Int
ids) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Depends -> [Id]
fromDepends) [Depends]
depends
            ,prfExecution :: Double
prfExecution = Float -> Double
floatToDouble Float
execution
            ,prfTraces :: [ProfileTrace]
prfTraces = forall a b. (a -> b) -> [a] -> [b]
map Trace -> ProfileTrace
fromTrace forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Trace -> Float
traceStart [Trace]
traces
            }
            where fromStep :: Step -> Int
fromStep Step
i = forall a. Partial => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Step
i HashMap Step Int
steps
                  fromTrace :: Trace -> ProfileTrace
fromTrace (Trace ByteString
a Float
b Float
c) = String -> Double -> Double -> ProfileTrace
ProfileTrace (ByteString -> String
BS.unpack ByteString
a) (Float -> Double
floatToDouble Float
b) (Float -> Double
floatToDouble Float
c)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal String
"toReport") forall {a} {a}. Show a => (a, Result a) -> ProfileEntry
f forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Id
i HashMap Id (Key, Result (Either ByteString Value))
status | Id
i <- [Id]
order]


data ProfileEntry = ProfileEntry
    {ProfileEntry -> String
prfName :: String, ProfileEntry -> Int
prfBuilt :: Int, ProfileEntry -> Int
prfChanged :: Int, ProfileEntry -> [[Int]]
prfDepends :: [[Int]], ProfileEntry -> Double
prfExecution :: Double, ProfileEntry -> [ProfileTrace]
prfTraces :: [ProfileTrace]}
data ProfileTrace = ProfileTrace
    {ProfileTrace -> String
prfCommand :: String, ProfileTrace -> Double
prfStart :: Double, ProfileTrace -> Double
prfStop :: Double}
prfTime :: ProfileTrace -> Double
prfTime ProfileTrace{Double
String
prfStop :: Double
prfStart :: Double
prfCommand :: String
prfStop :: ProfileTrace -> Double
prfStart :: ProfileTrace -> Double
prfCommand :: ProfileTrace -> String
..} = Double
prfStop forall a. Num a => a -> a -> a
- Double
prfStart

-- | Generates an report given some build system profiling data.
writeProfile :: FilePath -> Database -> IO ()
writeProfile :: String -> Database -> IO ()
writeProfile String
out Database
db = String -> [ProfileEntry] -> IO ()
writeProfileInternal String
out forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Database -> IO [ProfileEntry]
toReport Database
db

writeProfileInternal :: FilePath -> [ProfileEntry] -> IO ()
writeProfileInternal :: String -> [ProfileEntry] -> IO ()
writeProfileInternal String
out [ProfileEntry]
xs
    | String -> String
takeExtension String
out forall a. Eq a => a -> a -> Bool
== String
".js" = String -> String -> IO ()
writeFileBinary String
out forall a b. (a -> b) -> a -> b
$ String
"var profile = \n" forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
generateJSON [ProfileEntry]
xs
    | String -> String
takeExtension String
out forall a. Eq a => a -> a -> Bool
== String
".json" = String -> String -> IO ()
writeFileBinary String
out forall a b. (a -> b) -> a -> b
$ [ProfileEntry] -> String
generateJSON [ProfileEntry]
xs
    | String -> String
takeExtension String
out forall a. Eq a => a -> a -> Bool
== String
".trace" = String -> String -> IO ()
writeFileBinary String
out forall a b. (a -> b) -> a -> b
$ [ProfileEntry] -> String
generateTrace [ProfileEntry]
xs
    | String
out forall a. Eq a => a -> a -> Bool
== String
"-" = String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [ProfileEntry] -> [String]
generateSummary [ProfileEntry]
xs
    -- NOTE: On my laptop writing 1.5Mb of profile report takes 0.6s.
    --       This is fundamentals of my laptop, not a Haskell profiling issue.
    --       Verified with similar "type foo > bar" commands taking similar time.
    | Bool
otherwise = String -> ByteString -> IO ()
LBS.writeFile String
out forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProfileEntry] -> IO ByteString
generateHTML [ProfileEntry]
xs


generateSummary :: [ProfileEntry] -> [String]
generateSummary :: [ProfileEntry] -> [String]
generateSummary [ProfileEntry]
xs =
    [String
"* This database has tracked " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ProfileEntry -> Int
prfChanged [ProfileEntry]
xs) forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
" runs."
    ,let f :: [a] -> String
f = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length in String
"* There are " forall a. [a] -> [a] -> [a]
++ forall {a}. [a] -> String
f [ProfileEntry]
xs forall a. [a] -> [a] -> [a]
++ String
" rules (" forall a. [a] -> [a] -> [a]
++ forall {a}. [a] -> String
f [ProfileEntry]
ls forall a. [a] -> [a] -> [a]
++ String
" rebuilt in the last run)."
    ,let f :: [ProfileEntry] -> String
f = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProfileEntry -> [ProfileTrace]
prfTraces) in String
"* Building required " forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
f [ProfileEntry]
xs forall a. [a] -> [a] -> [a]
++ String
" traced commands (" forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
f [ProfileEntry]
ls forall a. [a] -> [a] -> [a]
++ String
" in the last run)."
    ,String
"* The total (unparallelised) time is " forall a. [a] -> [a] -> [a]
++ Double -> String
showDuration (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ProfileEntry -> Double
prfExecution [ProfileEntry]
xs) forall a. [a] -> [a] -> [a]
++
        String
" of which " forall a. [a] -> [a] -> [a]
++ Double -> String
showDuration (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ProfileTrace -> Double
prfTime forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProfileEntry -> [ProfileTrace]
prfTraces [ProfileEntry]
xs) forall a. [a] -> [a] -> [a]
++ String
" is traced commands."
    ,let f :: [(Double, String)] -> String
f [(Double, String)]
xs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Double, String)]
xs then String
"0s" else (\(Double
a,String
b) -> Double -> String
showDuration Double
a forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
b forall a. [a] -> [a] -> [a]
++ String
")") forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> a
maximumBy' (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(Double, String)]
xs in
        String
"* The longest rule takes " forall a. [a] -> [a] -> [a]
++ [(Double, String)] -> String
f (forall a b. (a -> b) -> [a] -> [b]
map (ProfileEntry -> Double
prfExecution forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& ProfileEntry -> String
prfName) [ProfileEntry]
xs) forall a. [a] -> [a] -> [a]
++
        String
", and the longest traced command takes " forall a. [a] -> [a] -> [a]
++ [(Double, String)] -> String
f (forall a b. (a -> b) -> [a] -> [b]
map (ProfileTrace -> Double
prfTime forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& ProfileTrace -> String
prfCommand) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProfileEntry -> [ProfileTrace]
prfTraces [ProfileEntry]
xs) forall a. [a] -> [a] -> [a]
++ String
"."
    ,let sumLast :: Double
sumLast = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ProfileTrace -> Double
prfTime forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProfileEntry -> [ProfileTrace]
prfTraces [ProfileEntry]
ls
         maxStop :: Double
maxStop = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Double
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ProfileTrace -> Double
prfStop (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProfileEntry -> [ProfileTrace]
prfTraces [ProfileEntry]
ls) in
        String
"* Last run gave an average parallelism of " forall a. [a] -> [a] -> [a]
++ forall a. RealFloat a => Int -> a -> String
showDP Int
2 (if Double
maxStop forall a. Eq a => a -> a -> Bool
== Double
0 then Double
0 else Double
sumLast forall a. Fractional a => a -> a -> a
/ Double
maxStop) forall a. [a] -> [a] -> [a]
++
        String
" times over " forall a. [a] -> [a] -> [a]
++ Double -> String
showDuration Double
maxStop forall a. [a] -> [a] -> [a]
++ String
"."
    ]
    where ls :: [ProfileEntry]
ls = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(==) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProfileEntry -> Int
prfBuilt) [ProfileEntry]
xs


generateHTML :: [ProfileEntry] -> IO LBS.ByteString
generateHTML :: [ProfileEntry] -> IO ByteString
generateHTML [ProfileEntry]
xs = do
    ByteString
report <- String -> IO ByteString
readDataFileHTML String
"profile.html"
    let f :: String -> f ByteString
f String
"data/profile-data.js" = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$ String
"var profile =\n" forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
generateJSON [ProfileEntry]
xs
    (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate forall {f :: * -> *}. Applicative f => String -> f ByteString
f ByteString
report


generateTrace :: [ProfileEntry] -> String
generateTrace :: [ProfileEntry] -> String
generateTrace [ProfileEntry]
xs = [String] -> String
jsonListLines forall a b. (a -> b) -> a -> b
$
    forall {a}. Show a => a -> [ProfileTrace] -> [String]
showEntries Integer
0 [ProfileTrace
y{prfCommand :: String
prfCommand=ProfileEntry -> String
prfName ProfileEntry
x} | ProfileEntry
x <- [ProfileEntry]
onlyLast, ProfileTrace
y <- ProfileEntry -> [ProfileTrace]
prfTraces ProfileEntry
x] forall a. [a] -> [a] -> [a]
++
    forall {a}. Show a => a -> [ProfileTrace] -> [String]
showEntries Integer
1 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProfileEntry -> [ProfileTrace]
prfTraces [ProfileEntry]
onlyLast)
    where
        onlyLast :: [ProfileEntry]
onlyLast = forall a. (a -> Bool) -> [a] -> [a]
filter (\ProfileEntry
x -> ProfileEntry -> Int
prfBuilt ProfileEntry
x forall a. Eq a => a -> a -> Bool
== Int
0) [ProfileEntry]
xs
        showEntries :: a -> [ProfileTrace] -> [String]
showEntries a
pid [ProfileTrace]
xs = forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {a}.
(Show a, Show a) =>
a -> (a, ProfileTrace) -> String
showEntry a
pid) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [ProfileTrace]
-> ProfileTrace -> ([ProfileTrace], (Int, ProfileTrace))
alloc [] forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ProfileTrace -> Double
prfStart [ProfileTrace]
xs

        alloc :: [ProfileTrace] -> ProfileTrace -> ([ProfileTrace], (Int, ProfileTrace))
        -- FIXME: I don't really understand what this code is doing, or the invariants it ensures
        alloc :: [ProfileTrace]
-> ProfileTrace -> ([ProfileTrace], (Int, ProfileTrace))
alloc [ProfileTrace]
as ProfileTrace
r | ([ProfileTrace]
a1,ProfileTrace
_:[ProfileTrace]
a2) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\ProfileTrace
a -> ProfileTrace -> Double
prfStop ProfileTrace
a forall a. Ord a => a -> a -> Bool
<= ProfileTrace -> Double
prfStart ProfileTrace
r) [ProfileTrace]
as = ([ProfileTrace]
a1forall a. [a] -> [a] -> [a]
++ProfileTrace
rforall a. a -> [a] -> [a]
:[ProfileTrace]
a2, (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProfileTrace]
a1,ProfileTrace
r))
                   | Bool
otherwise = ([ProfileTrace]
asforall a. [a] -> [a] -> [a]
++[ProfileTrace
r], (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProfileTrace]
as,ProfileTrace
r))

        showEntry :: a -> (a, ProfileTrace) -> String
showEntry a
pid (a
tid, ProfileTrace{Double
String
prfStop :: Double
prfStart :: Double
prfCommand :: String
prfStop :: ProfileTrace -> Double
prfStart :: ProfileTrace -> Double
prfCommand :: ProfileTrace -> String
..}) = forall {a}. Show a => [(a, String)] -> String
jsonObject
            [(String
"args",String
"{}"), (String
"ph",forall a. Show a => a -> String
show String
"X"), (String
"cat",forall a. Show a => a -> String
show String
"target")
            ,(String
"name",forall a. Show a => a -> String
show String
prfCommand), (String
"tid",forall a. Show a => a -> String
show a
tid), (String
"pid",forall a. Show a => a -> String
show a
pid)
            ,(String
"ts",forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
1000000forall a. Num a => a -> a -> a
*Double
prfStart), (String
"dur",forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
1000000forall a. Num a => a -> a -> a
*(Double
prfStopforall a. Num a => a -> a -> a
-Double
prfStart))]


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

jsonListLines :: [String] -> String
jsonListLines [String]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n," [String]
xs forall a. [a] -> [a] -> [a]
++ String
"\n]"
jsonList :: [String] -> String
jsonList [String]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs forall a. [a] -> [a] -> [a]
++ String
"]"
jsonObject :: [(a, String)] -> String
jsonObject [(a, String)]
xs = String
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
b | (a
a,String
b) <- [(a, String)]
xs] forall a. [a] -> [a] -> [a]
++ String
"}"