{-# 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)
dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> Map.HashMap a [a] -> [a]
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)
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
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
| 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))
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
"}"