eventlog2html 0.5.0 → 0.6.0

raw patch · 18 files changed

+397/−108 lines, 18 filesdep +hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: hashable

API changes (from Hackage documentation)

Files

• CHANGELOG +8/−0
• eventlog2html.cabal +6/−2
• javascript/ccmap.vg +102/−0
• javascript/stylesheet.css +10/−0
• main/Main.hs +5/−4
• src/Eventlog/Args.hs +5/−0
• src/Eventlog/Bands.hs +5/−6
• src/Eventlog/Data.hs +17/−7
• src/Eventlog/Events.hs +48/−35
• src/Eventlog/HeapProf.hs +6/−3
• src/Eventlog/HtmlTemplate.hs +76/−25
• src/Eventlog/Javascript.hs +4/−0
• src/Eventlog/Prune.hs +12/−10
• src/Eventlog/Total.hs +2/−3
• src/Eventlog/Trie.hs +42/−0
• src/Eventlog/Types.hs +32/−4
• src/Eventlog/Vega.hs +11/−5
• src/Eventlog/VegaTemplate.hs +6/−4

@@ -1,3 +1,11 @@+0.6, released 2019-10-22++* Revamp how cost centre profiles are displayed.+* Fix incorrectly calculated start time for certain profiles.+* Line chart now displays points for each sample so it's easier to see where to hover.+* Add `--y-axis` option to allow the user to specify the extent of the y-axis.+  This is useful when comparing two different profiles together.+ 0.5, released 2019-10-11  * Add some more metainformation to the header (sample mode and sample interval)

@@ -1,5 +1,5 @@ Name:                eventlog2html-Version:             0.5.0+Version:             0.6.0 Synopsis:            Visualise an eventlog Description:         eventlog2html is a library for visualising eventlogs.                      At the moment, the intended use is to visualise eventlogs@@ -26,6 +26,7 @@   javascript/vega@5.4.0   javascript/stylesheet.css   javascript/tablogic.js+  javascript/ccmap.vg   javascript/milligram.min.css   javascript/normalize.min.css cabal-version: 1.18@@ -53,13 +54,15 @@     text                 >= 1.2.3 && < 1.3,     time                 >= 1.8.0 && < 2.0,     vector               >= 0.11,-    trie-simple          >= 0.4+    trie-simple          >= 0.4,+    hashable             >= 1.0    GHC-options:         -Wall   default-language:    Haskell2010   HS-source-dirs:      src   exposed-modules:     Eventlog.Args                        Eventlog.Data+                       Eventlog.Trie                        Eventlog.Javascript                        Eventlog.Types                        Eventlog.Total@@ -70,6 +73,7 @@                        Eventlog.Vega                        Eventlog.HtmlTemplate                        Eventlog.VegaTemplate+  other-modules:       Paths_eventlog2html  Executable eventlog2html   GHC-options:         -Wall

@@ -0,0 +1,102 @@+{+  "$schema": "https://vega.github.io/schema/vega/v5.json",+  "width": 1000,+  "height": 600,+  "padding": 5,++  "signals": [+  ],++  "data": [+    {+      "name": "tree",+      "values": desc_json,+      "transform": [+        {+          "type": "stratify",+          "key": "id",+          "parentKey": "parent"+        },+        {+          "type": "tree",+          "method": "tidy",+          "size": [{"signal": "width - 100"}, {"signal": "height"}],+          "separation": false,+          "as": ["x", "y", "depth", "children"]+        }+      ]+    },+    {+      "name": "links",+      "source": "tree",+      "transform": [+        { "type": "treelinks" },+        {+          "type": "linkpath",+          "orient": "vertical",+          "shape": "diagonal"+        }+      ]+    }+  ],++  "scales": [+    {+      "name": "color",+      "type": "ordinal",+      "domain": { "fields": [{"data": "tree", "field": "c"}+                            ,{"data": "tree", "field": "c"}], "sort": true},+      "range": {"scheme": colour_scheme}+    }+  ],++  "marks": [+    {+      "type": "path",+      "from": {"data": "links"},+      "encode": {+        "update": {+          "path": {"field": "path"},+          "stroke": {"value": "#ccc"}+        }+      }+    },+    {+      "type": "symbol",+      "from": {"data": "tree"},+      "encode": {+        "enter": {+          "size": {"value": 500},+          "stroke": {"value": "black"},+          "tooltip": {"signal": "datum.name"}+        },+        "update": {+          "x": {"field": "x"},+          "y": {"field": "y"},+          "fill": {"scale": "color", "field": "c"}+        }+      }+    },+    {+      "type": "text",+      "from": {"data": "tree"},+      "encode": {+        "enter": {+          "text": {"field": "ccs"},+          "fontSize": {"value": 9},+          "baseline": {"value": "middle"}+        },+        "update": {+          "x": {"field": "x"},+          "y": {"field": "y"},+          "angle": {"signal": "datum.children ? 0 : 0"},+          "dy": {"signal": "datum.children ? 0 : 0"},+          "dx": {"signal": "datum.children ? 0 : 0"},+          "align": {"signal": "datum.children ? 'center' : 'center'"},+          "opacity": 0+        }+      }+    }+  ]+}+

@@ -21,3 +21,13 @@     vertical-align: baseline;     background: transparent; }++.hoverflow {+  overflow: auto;+  width: 900px;+  white-space: nowrap;+}++#description{+  visibility: hidden;+}

@@ -19,6 +19,7 @@   when (null (files a)) exitSuccess   argsToOutput a + argsToOutput :: Args -> IO () argsToOutput a@Args{files = files', outputFile = Nothing} =   if | json a    -> forM_ files' $ \file -> doOneJson a file (file <.> "json")@@ -31,17 +32,17 @@  doOneJson :: Args -> FilePath -> FilePath -> IO () doOneJson a fin fout = do-  (_, val) <- generateJson fin a+  (_, val, _) <- generateJson fin a   encodeFile fout val  doOneHtml :: Args -> FilePath -> FilePath -> IO () doOneHtml a fin fout = do-  (header, data_json) <- generateJsonValidate checkTraces fin a-  let html = templateString header data_json a+  (header, data_json, descs) <- generateJsonValidate checkTraces fin a+  let html = templateString header data_json descs a   writeFile fout html   where     checkTraces :: ProfData -> IO ()-    checkTraces (ProfData _ _ _ ts) =+    checkTraces (ProfData _ _ _ _ ts) =       if length ts > 1000         then hPutStrLn stderr               "More than 1000 traces, consider reducing using -i or -x"

@@ -26,6 +26,7 @@   , traceEvents  :: Bool -- ^ By default, only traceMarkers are included.                          -- This option enables the inclusion of traceEvents.   , userColourScheme :: Text+  , fixedYAxis :: Maybe Int   , includeStr :: [Text]   , excludeStr :: [Text]   , outputFile :: Maybe String@@ -72,6 +73,10 @@           ( long "colour-scheme"           <> value "category20b"           <> help "The name of the colour scheme. See the vega documentation (https://vega.github.io/vega/docs/schemes/#reference) for a complete list. Examples include \"category10\" \"dark2\" \"tableau10\". ")+      <*> option (Just <$> auto)+          ( long "y-axis"+          <> value Nothing+          <> help "Fixed value for the maximum extent of the y-axis in bytes. This option is useful for comparing profiles together.")       <*> many (option str           (short 'i'           <> long "include"

@@ -11,14 +11,13 @@ import Data.Array.Unboxed (UArray) import Data.Map (Map, lookup, size, foldrWithKey) import Prelude hiding (lookup, lines, words, length)-import Data.Text (Text) import Eventlog.Types import Data.HashTable.ST.Basic hiding (lookup) import Data.Aeson hiding (Series) import GHC.Generics import Data.Set (Set, notMember) -bands :: Header -> Map Text Int -> [Frame] -> (UArray Int Double, UArray (Int, Int) Double)+bands :: Header -> Map Bucket Int -> [Frame] -> (UArray Int Double, UArray (Int, Int) Double) bands h bs frames = runST $ do   times <- newArray (1, hCount h) 0   vals  <- newArray ((-1,1), (size bs, hCount h)) 0@@ -32,7 +31,7 @@   vals'  <- unsafeFreezeSTUArray vals   return (times', vals') -bandsToSeries :: Map Text Int -> (UArray Int Double, UArray (Int, Int) Double)+bandsToSeries :: Map Bucket Int -> (UArray Int Double, UArray (Int, Int) Double)               -> [Series] bandsToSeries ks (ts, vs) =   let (t1, tn) = bounds ts@@ -40,12 +39,12 @@         where           go_1 :: [(Double, Double)]           go_1 = flip map [t1 .. tn] $ \t -> (ts ! t, vs ! (v, t))-  in foldrWithKey go (go "OTHER" 0 []) ks+  in foldrWithKey go (go (Bucket "OTHER") 0 []) ks -data Series = Series { key :: Text, values :: [(Double, Double)] }+data Series = Series { key :: Bucket, values :: [(Double, Double)] }   deriving (Show, ToJSON, Generic) -series :: Set Text -> [Frame] ->  [Series]+series :: Set Bucket -> [Frame] ->  [Series] series ks fs = runST $ do   m <- new   forM_ (reverse fs) $ \(Frame t s) ->

@@ -3,6 +3,7 @@  import Prelude hiding (readFile) import Data.Aeson (Value(..), (.=), object)+import qualified Data.Map as Map  import Eventlog.Args (Args(..)) import Eventlog.Bands (bands)@@ -10,20 +11,29 @@ import qualified Eventlog.HeapProf as H import Eventlog.Prune (prune) import Eventlog.Vega-import Eventlog.Types (Header, ProfData(..))+import Eventlog.Types (Header(..), ProfData(..), HeapProfBreakdown(..))+import Data.List+import Data.Ord+import Eventlog.Trie -generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO (Header, Value)+generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO (Header, Value, Maybe Value) generateJsonValidate validate file a = do   let chunk = if heapProfile a then H.chunk else E.chunk a-  dat@(ProfData h totals fs traces) <- chunk file+  dat@(ProfData h binfo ccMap fs traces) <- chunk file   validate dat-  let keeps = prune a totals+  let keeps = prune a binfo       combinedJson = object [-          "samples" .= bandsToVega keeps (bands h keeps fs)+          "samples" .= bandsToVega keeps (bands h (Map.map fst keeps) fs)         , "traces"  .= tracesToVega traces         ]-  return (h, combinedJson)+      mdescs =+        sortBy (flip (comparing (fst . snd))) $ Map.toList keeps+      -- Only supply the cost centre view in cost centre profiling mode.+      descs = case hHeapProfileType h of+                Just HeapProfBreakdownCostCentre -> Just (outputTree ccMap mdescs)+                _ -> Nothing+  return (h, combinedJson, descs) -generateJson :: FilePath -> Args -> IO (Header, Value)+generateJson :: FilePath -> Args -> IO (Header, Value, Maybe Value) generateJson = generateJsonValidate (const (return ())) 

@@ -29,6 +29,8 @@ import Data.Char import System.IO import qualified Data.Trie.Map as Trie+import Data.Map.Merge.Lazy+import Data.Functor.Identity  type PartialHeader = Int -> Header @@ -38,10 +40,21 @@ chunk :: Args -> FilePath -> IO ProfData chunk a f = do   (EventLog _ e) <- either error id <$> readEventLogFromFile f-  (ph, frames, traces) <- eventsToHP a e+  (ph, bucket_map, ccMap, frames, traces) <- eventsToHP a e   let (counts, totals) = total frames-  return $ (ProfData (ph counts) totals frames traces)+      -- If both keys are present, combine+      combine = zipWithAMatched (\_ (t, mt) (tot, sd) -> Identity $ BucketInfo t mt tot sd)+      -- If total is missing, something bad has happened+      combineMissingTotal :: Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo+      combineMissingTotal k = error ("Missing total for: " ++ show k) +      -- This case happens when we are not in CC mode+      combineMissingDesc :: Bucket -> (Double, Double) -> Identity BucketInfo+      combineMissingDesc (Bucket t) (tot, sd) = Identity (BucketInfo t Nothing tot sd)++      binfo = merge (traverseMissing combineMissingTotal) (traverseMissing combineMissingDesc) combine bucket_map totals+  return $ (ProfData (ph counts) binfo ccMap frames traces)+ checkGHCVersion :: EL -> Maybe String checkGHCVersion EL { ident = Just (version,_)}   | version <= makeVersion [8,4,4]  =@@ -57,19 +70,19 @@             ++ ", which does not support biographical or retainer profiling." checkGHCVersion _ = Nothing --eventsToHP :: Args -> Data -> IO (PartialHeader, [Frame], [Trace])+eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace]) eventsToHP a (Data es) = do   let       el@EL{..} = foldEvents a es       fir = Frame (fromNano start) []       las = Frame (fromNano end) []   mapM_ (hPutStrLn stderr) (checkGHCVersion el)-  return $ (elHeader el, fir : reverse (las: normalise frames) , traces)+  return $ (elHeader el, elBucketMap el, ccMap, fir : reverse (las: normalise frames) , traces)  normalise :: [FrameEL] -> [Frame] normalise fs = map (\(FrameEL t ss) -> Frame (fromNano t) ss) fs +type BucketMap = Map.Map Bucket (Text, Maybe [Word32])  data EL = EL   { pargs :: !(Maybe [String])@@ -77,6 +90,9 @@   , samplingRate :: !(Maybe Word64)   , heapProfileType :: !(Maybe HeapProfBreakdown)   , ccMap :: !(Map.Map Word32 CostCentre)+  -- At the moment bucketMap and CCS map are quite similar, cost centre profiling+  -- is the only mode to populate the bucket map+  , bucketMap :: BucketMap   , ccsMap :: CCSMap   , clocktimeSec :: !Word64   , samples :: !(Maybe FrameEL)@@ -89,29 +105,32 @@  data CCSMap = CCSMap (Trie.TMap Word32 CCStack) Int deriving Show + data CCStack = CCStack { ccsId :: Int, ccsName :: Text } deriving Show  getCCSId :: EL -> Vector Word32 -> (CCStack, EL) getCCSId el@EL { ccsMap = (CCSMap trie uniq), ccMap = ccMap } k  =-  let kl = toList k+  let kl = reverse $ toList k   in case Trie.lookup kl trie of         Just n -> (n, el)         Nothing ->           let new_stack = CCStack uniq name-          in (new_stack, el { ccsMap = CCSMap (Trie.insert kl new_stack trie) (uniq + 1) })++              sid = T.pack $ "(" ++ show uniq ++ ") "+              short_bucket_info = sid <> name+              bucket_info = (short_bucket_info, Just kl)+              bucket_key = Bucket (T.pack (show uniq))+          in (new_stack, el { ccsMap = CCSMap (Trie.insert kl new_stack trie) (uniq + 1)+                            , bucketMap = Map.insert bucket_key bucket_info (bucketMap el) })   where     name = fromMaybe "MAIN" $ do              cid <- (k !? 0)-             CC{label, modul} <- Map.lookup cid ccMap-             return $ modul <> "." <> label+             CC{label} <- Map.lookup cid ccMap+             return $ label -data CostCentre = CC { cid :: Word32-                     , label :: Text-                     , modul :: Text-                     , loc :: Text } deriving Show -initEL :: Word64 -> EL-initEL t = EL+initEL :: EL+initEL = EL   { pargs = Nothing   , ident = Nothing   , samplingRate = Nothing@@ -120,17 +139,17 @@   , samples = Nothing   , frames = []   , traces = []-  , start = t+  , start = 0   , end = 0   , ccMap = Map.empty   , ccsMap =  CCSMap Trie.empty 0+  , bucketMap = Map.empty   }  foldEvents :: Args -> [Event] -> EL-foldEvents a (e:es) =-  let res = foldl' (folder a)  (initEL (evTime e)) (e:es)+foldEvents a es =+  let res = foldl' (folder a) initEL es   in addFrame 0 res-foldEvents _ [] = error "Empty event log"  folder :: Args -> EL -> Event -> EL folder a el (Event t e _) = el &@@ -153,7 +172,7 @@       HeapProfSampleBegin {} -> addFrame t       HeapBioProfSampleBegin { heapProfSampleTime = t' } -> addFrame t'       HeapProfSampleCostCentre _hid r d s -> addCCSample r d s-      HeapProfSampleString _hid res k -> addSample (Sample k (fromIntegral res))+      HeapProfSampleString _hid res k -> addSample (Sample (Bucket k) (fromIntegral res))       _ -> id  @@ -174,16 +193,15 @@       x <- munch1 isDigit       return $ read x - addCostCentre :: Word32 -> CostCentre -> EL -> EL addCostCentre s cc el = el { ccMap = Map.insert s cc (ccMap el) }  addCCSample :: Word64 -> Word8 -> Vector Word32 -> EL -> EL addCCSample res _sd st el =-  let (CCStack stack_id tid, el') = getCCSId el st+  let (CCStack stack_id _tid, el') = getCCSId el st       -- TODO: Can do better than this by differentiating normal samples form stack samples-      sample_string = (T.pack $ "(" ++ show stack_id ++ ") ") <> tid-  in addSample (Sample sample_string (fromIntegral res)) el'+      sample_string = T.pack (show stack_id)+  in addSample (Sample (Bucket sample_string) (fromIntegral res)) el'   addClocktime :: Word64 -> EL -> EL@@ -250,16 +268,11 @@ elHeader EL{..} =   let title = maybe "" (T.unwords . map T.pack) pargs       date = formatDate clocktimeSec-      profileType = ppHeapProfileType heapProfileType       ppSamplingRate = T.pack . maybe "<Not available>" (show . fromNano) $ samplingRate-  in Header title date profileType ppSamplingRate "" ""+  in Header title date heapProfileType ppSamplingRate "" "" -ppHeapProfileType :: Maybe HeapProfBreakdown -> Text-ppHeapProfileType (Just HeapProfBreakdownCostCentre) = "Cost centre profiling (implied by -hc)"-ppHeapProfileType (Just HeapProfBreakdownModule) = "Profiling by module (implied by -hm)"-ppHeapProfileType (Just HeapProfBreakdownClosureDescr) = "Profiling by closure description (implied by -hd)"-ppHeapProfileType (Just HeapProfBreakdownTypeDescr) = "Profiling by type (implied by -hy)"-ppHeapProfileType (Just HeapProfBreakdownRetainer) = "Retainer profiling (implied by -hr)"-ppHeapProfileType (Just HeapProfBreakdownBiography) = "Biographical profiling (implied by -hb)"-ppHeapProfileType (Just HeapProfBreakdownClosureType) = "Basic heap profile (implied by -hT)"-ppHeapProfileType Nothing = "<Not available>"++elBucketMap :: EL -> BucketMap+elBucketMap = bucketMap++

@@ -5,6 +5,7 @@ import Data.Text (Text, lines, init, drop, length, isPrefixOf, unpack, words, pack) import Data.Text.IO (readFile) import Data.Attoparsec.Text (parseOnly, double)+import qualified Data.Map as Map  import Eventlog.Total import Eventlog.Types@@ -13,8 +14,10 @@ chunk f = do   (ph, fs) <- chunkT <$> readFile f   let (counts, totals) = total fs+      -- Heap profiles don't contain any other information than the simple bucket name+      binfo = Map.mapWithKey (\(Bucket k) (t,s) -> BucketInfo k Nothing t s ) totals   -- Heap profiles do not support traces-  return (ProfData (ph counts) totals fs [])+  return (ProfData (ph counts) binfo mempty fs [])  chunkT :: Text -> (Int -> Header, [Frame]) chunkT s =@@ -24,7 +27,7 @@         zipWith header [sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT] hs       fs = chunkSamples ss   in  (-        Header job date (pack "") (pack "") smpU valU+        Header job date Nothing (pack "") smpU valU       ,  fs       ) @@ -54,7 +57,7 @@ parseSample s =   let [k,vs] = words s       !v = readDouble vs-  in (Sample k v)+  in (Sample (Bucket k) v)   sampleTime :: Text -> Text -> Double

@@ -15,8 +15,12 @@  import Eventlog.Javascript import Eventlog.Args-import Eventlog.Types (Header(..))+import Eventlog.Types (Header(..), HeapProfBreakdown(..)) import Eventlog.VegaTemplate+import Paths_eventlog2html+import Data.Version+import Control.Monad+import Data.Maybe  type VizID = Int @@ -27,26 +31,53 @@   where     dat' = TL.toStrict (T.decodeUtf8 (encode dat)) +insertJsonDesc :: Value -> Html+insertJsonDesc dat = preEscapedToHtml $ T.unlines [+    "desc_json= " `append` dat' `append` ";"+  , "console.log(desc_json);" ]+  where+    dat' = TL.toStrict (T.decodeUtf8 (encode dat)) +-- Dynamically bound in ccs tree+insertColourScheme :: Text -> Html+insertColourScheme scheme = preEscapedToHtml $ T.unlines [+    "colour_scheme= \"" `append` scheme `append` "\";"+  , "console.log(colour_scheme);" ] ++data_sets :: [Text]+data_sets = [+    ".insert(\"data_json_samples\", data_json.samples)"+  , ".insert(\"data_json_traces\", data_json.traces)" ]+ encloseScript :: VizID -> Text -> Html-encloseScript vid vegaspec = preEscapedToHtml $ T.unlines [+encloseScript = encloseScriptX True++encloseRawVegaScript :: VizID -> Text -> Html+encloseRawVegaScript = encloseScriptX False++encloseScriptX :: Bool -> VizID -> Text -> Html+encloseScriptX insert_data_sets vid vegaspec = preEscapedToHtml $ T.unlines ([   "var yourVlSpec" `append` vidt `append`"= " `append` vegaspec  `append` ";"   , "vegaEmbed('#vis" `append` vidt `append` "', yourVlSpec" `append` vidt `append` ")"   , ".then((res) => "-  , "res.view"-  , ".insert(\"data_json_samples\", data_json.samples)"-  , ".insert(\"data_json_traces\", data_json.traces)"-  , ".runAsync());" ]+  , "res.view" ]+-- For the 4 vega lite charts we dynamically insert the data after the+-- chart is created to avoid duplicating it. For the vega chart, this+-- causes a harmless error so we just don't do it.+  ++ (if insert_data_sets then data_sets else []) +++  [ ".runAsync());" ])   where     vidt = T.pack $ show vid -htmlHeader :: Value -> Args -> Html-htmlHeader dat as =+htmlHeader :: Value -> Maybe Value -> Args -> Html+htmlHeader dat desc as =     H.head $ do-    H.title "Heap Profile"+    H.title "eventlog2html - Heap Profile"     meta ! charset "UTF-8"     script $ insertJsonData dat+    maybe (return ()) (script . insertJsonDesc) desc+    script $ insertColourScheme (userColourScheme as)     if not (noIncludejs as)       then do         script $ preEscapedToHtml vegaLite@@ -64,9 +95,11 @@     -- Include this last to overwrite some milligram styling     H.style $ preEscapedToHtml stylesheet -template :: Header -> Value -> Args -> Html-template header' dat as = docTypeHtml $ do-  htmlHeader dat as++template :: Header -> Value -> Maybe Value -> Args -> Html+template header' dat descs as = docTypeHtml $ do+  H.stringComment $ "Generated with eventlog2html-" <> showVersion version+  htmlHeader dat descs as   body $ H.div ! class_ "container" $ do     H.div ! class_ "row" $ do       H.div ! class_ "column" $ do@@ -82,10 +115,11 @@         "Created at: "         code $ toHtml $ hDate header' -    H.div ! class_ "row" $ do-      H.div ! class_ "column" $ do-        "Type of profile: "-        code $ toHtml $ hHeapProfileType header'+    forM_ (hHeapProfileType header') $ \prof_type -> do+      H.div ! class_ "row" $ do+        H.div ! class_ "column" $ do+          "Type of profile: "+          code $ toHtml $ ppHeapProfileType prof_type      H.div ! class_ "row" $ do       H.div ! class_ "column" $ do@@ -98,35 +132,52 @@         button ! class_ "tablink button-black" ! onclick "changeTab('normalizedchart', this)" $ "Normalized"         button ! class_ "tablink button-black" ! onclick "changeTab('streamgraph', this)" $ "Streamgraph"         button ! class_ "tablink button-black" ! onclick "changeTab('linechart', this)" $ "Linechart"+        when (isJust descs) $ do+          button ! class_ "tablink button-black" ! onclick "changeTab('cost-centres', this)" $ "Cost Centres"      H.div ! class_ "row" $ do       H.div ! class_ "column" $ do         mapM_ (\(vid, chartname, conf) ->                   H.div ! A.id chartname ! class_ "tabviz" $ do-                    renderChart vid+                    renderChart True vid                       (TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf)))))           [(1, "areachart",  AreaChart Stacked)           ,(2, "normalizedchart", AreaChart Normalized)           ,(3, "streamgraph", AreaChart StreamGraph)           ,(4, "linechart", LineChart)] +        when (isJust descs) $ do+          H.div ! A.id "cost-centres" ! class_ "tabviz" $ do+            renderChart False 5 treevega     script $ preEscapedToHtml tablogic + htmlConf :: Args -> ChartType -> ChartConfig-htmlConf as = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as)+htmlConf as ct = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as) ct (fromIntegral <$> (fixedYAxis as)) -renderChart :: VizID -> Text -> Html-renderChart vid vegaSpec = do+renderChart :: Bool -> VizID -> Text -> Html+renderChart vega_lite vid vegaSpec = do     H.div ! A.id (fromString $ "vis" ++ show vid) ! class_ "chart" $ ""     script ! type_ "text/javascript" $ do-      (encloseScript vid vegaSpec)+      if vega_lite+        then encloseScript vid vegaSpec+        else encloseRawVegaScript vid vegaSpec  renderChartWithJson :: Int -> Value -> Text -> Html renderChartWithJson k dat vegaSpec = do     script $ insertJsonData dat-    renderChart k vegaSpec+    renderChart True k vegaSpec  -templateString :: Header -> Value -> Args -> String-templateString header' dat as =-  renderHtml $ template header' dat as+templateString :: Header -> Value -> Maybe Value -> Args -> String+templateString header' dat descs as =+  renderHtml $ template header' dat descs as++ppHeapProfileType :: HeapProfBreakdown -> Text+ppHeapProfileType (HeapProfBreakdownCostCentre) = "Cost centre profiling (implied by -hc)"+ppHeapProfileType (HeapProfBreakdownModule) = "Profiling by module (implied by -hm)"+ppHeapProfileType (HeapProfBreakdownClosureDescr) = "Profiling by closure description (implied by -hd)"+ppHeapProfileType (HeapProfBreakdownTypeDescr) = "Profiling by type (implied by -hy)"+ppHeapProfileType (HeapProfBreakdownRetainer) = "Retainer profiling (implied by -hr)"+ppHeapProfileType (HeapProfBreakdownBiography) = "Biographical profiling (implied by -hb)"+ppHeapProfileType (HeapProfBreakdownClosureType) = "Basic heap profile (implied by -hT)"

@@ -8,6 +8,7 @@   , tablogic   , milligram   , normalizecss+  , treevega   ) where  import Data.Text@@ -34,4 +35,7 @@  normalizecss :: Text normalizecss = decodeUtf8 $(embedFile "javascript/normalize.min.css")++treevega :: Text+treevega = decodeUtf8 $(embedFile "javascript/ccmap.vg") 

@@ -2,16 +2,16 @@   ( prune   ) where -import Data.Text (Text) import Data.List (sortBy) import Data.Ord (comparing)-import Data.Map.Strict (Map, toList, fromList)+import Data.Map.Strict (Map, toList, fromList, (!))+import Eventlog.Types  import Eventlog.Args (Args(..), Sort(..))  type Compare a = a -> a -> Ordering -getComparison :: Args -> Compare (Text, (Double, Double))+getComparison :: Args -> Compare (Bucket, BucketInfo) getComparison Args { sorting = Size,   reversing = False }  = cmpSizeDescending getComparison Args { sorting = Size,   reversing = True } = cmpSizeAscending getComparison Args { sorting = StdDev, reversing = False }  = cmpStdDevDescending@@ -21,26 +21,28 @@  cmpNameAscending, cmpNameDescending,   cmpStdDevAscending, cmpStdDevDescending,-  cmpSizeAscending, cmpSizeDescending :: Compare (Text, (Double, Double))+  cmpSizeAscending, cmpSizeDescending :: Compare (Bucket, BucketInfo) cmpNameAscending = comparing fst cmpNameDescending = flip cmpNameAscending-cmpStdDevAscending = comparing (snd . snd)+cmpStdDevAscending = comparing (bucketStddev . snd) cmpStdDevDescending = flip cmpStdDevAscending-cmpSizeAscending = comparing (fst . snd)+cmpSizeAscending = comparing (bucketTotal . snd) cmpSizeDescending = flip cmpSizeAscending -prune :: Args -> Map Text (Double, Double) -> Map Text Int+prune :: Args -> Map Bucket BucketInfo+              -> Map Bucket (Int, BucketInfo) prune args ts =   let ccTotals = sortBy cmpSizeDescending (toList ts)-      sizes = map (fst . snd) ccTotals+      sizes = map (bucketTotal . snd) ccTotals       limit = sum sizes       bigs = takeWhile (< limit) . scanl (+) 0 $ sizes       bands = zipWith const ccTotals $ take (bound $ nBands args) bigs       ccs = map fst (sortBy (getComparison args) bands)-  in  fromList (reverse ccs `zip` [1 ..])+      res :: [(Bucket, (Int, BucketInfo))]+      res = zipWith (\b k -> (b, (k, ts ! b))) (reverse ccs) [1..]+  in  fromList res  bound :: Int -> Int bound n   | n <= 0 = maxBound   | otherwise = n-

@@ -4,21 +4,20 @@ import Control.Monad.State.Strict (State(), execState, get, put, modify) import Data.Map (Map, empty, alter) import Prelude hiding (init, lookup, lines, words, drop, length, readFile)-import Data.Text (Text)  import Eventlog.Types   data Parse =   Parse-  { totals    :: !(Map Text (Double, Double)) -- compute running totass and total of squares+  { totals    :: !(Map Bucket (Double, Double)) -- compute running totals and total of squares   , count     :: !Int                         -- number of frames   }  parse0 :: Parse parse0 = Parse{ totals = empty, count = 0 } -total :: [Frame] -> (Int, Map Text (Double, Double))+total :: [Frame] -> (Int, Map Bucket (Double, Double)) total fs =   let parse1 = flip execState parse0 . mapM_ parseFrame $ fs   in  (

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+module Eventlog.Trie where++import Prelude hiding (init, lookup)+import Data.Text (Text)++import Eventlog.Types+import Data.Word+import qualified Data.Map as Map+import Data.Map ((!))+import qualified Data.Trie.Map as Trie+import qualified Data.Trie.Map.Internal as TrieI+import Data.Aeson++outputTree :: Map.Map Word32 CostCentre -> [(Bucket, (Int, BucketInfo))]+           -> Value+outputTree ccMap mdescs =+  let t = Trie.fromList [(k, (i, b, v)) | (Bucket b, (i, BucketInfo v (Just k) _ _)) <- mdescs ]+  in toJSON $ outputTrie ccMap t++outputTrie :: Map.Map Word32 CostCentre -> Trie.TMap Word32 (Int, Text, Text) -> [Value]+outputTrie ccMap (TrieI.TMap (TrieI.Node ni m))  =+    (mkNode 0 Nothing "MAIN" ni) : outputTrieLoop ccMap 0 m+++outputTrieLoop :: Map.Map Word32 CostCentre+               -> Word32+               -> Map.Map Word32 (Trie.TMap Word32 (Int, Text, Text))+               -> [Value]+outputTrieLoop ccMap p cs =+  let go p' (TrieI.TMap (TrieI.Node mv cs')) os+        = mkNode p' (Just p) (label $ ccMap ! p') mv :  outputTrieLoop ccMap p' cs' ++ os+  in Map.foldrWithKey go [] cs++mkNode :: Word32 -> Maybe Word32 -> Text -> Maybe (Int, Text, Text) -> Value+mkNode i mparent n mccs = object $ [ "id" .= i, "name" .= n+                             , "ccs" .= maybe "" (\(_, v, _) -> v) mccs+                             , "c" .= maybe "OTHER" (\(_, _, c) -> c) mccs]+                             ++ ["parent" .= p | Just p <- [mparent] ]+++

@@ -1,24 +1,52 @@-module Eventlog.Types where+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Eventlog.Types(module Eventlog.Types, HeapProfBreakdown(..)) where  import Data.Text (Text) import Data.Map (Map)+import Data.Aeson+import Data.Hashable+import Data.Word+import GHC.RTS.Events (HeapProfBreakdown(..))  data Header =   Header   { hJob         :: Text   , hDate        :: Text-  , hHeapProfileType :: Text+  , hHeapProfileType :: Maybe HeapProfBreakdown   , hSamplingRate :: Text   , hSampleUnit  :: Text   , hValueUnit   :: Text   , hCount       :: Int   } deriving Show -data Sample = Sample Text Double deriving Show +-- The bucket is a key to uniquely identify a band+newtype Bucket = Bucket Text+                  deriving (Show, Ord, Eq)+                  deriving newtype (ToJSON, Hashable)+++data BucketInfo = BucketInfo { shortDescription :: Text -- For the legend and hover+                             , longDescription :: Maybe [Word32]+                             , bucketTotal :: Double+                             , bucketStddev :: Double+                             } deriving Show++data CostCentre = CC { cid :: Word32+                     , label :: Text+                     , modul :: Text+                     , loc :: Text } deriving Show++data Sample = Sample Bucket Double deriving Show+ data Frame = Frame Double [Sample] deriving Show  -- | A trace we also want to show on the graph data Trace = Trace Double Text deriving Show -data ProfData = ProfData Header (Map Text (Double, Double)) [Frame] [Trace] deriving Show+data ProfData = ProfData { profHeader :: Header+                         , profTotals :: (Map Bucket BucketInfo)+                         , profCCMap  :: Map Word32 CostCentre+                         , profFrames :: [Frame]+                         , profTraces :: [Trace] } deriving Show

@@ -6,7 +6,7 @@  import Data.Array.Base ((!), bounds) import Data.Array.Unboxed (UArray)-import Data.Map (Map,  foldrWithKey)+import Data.Map (Map,  foldr) import Prelude hiding (lookup, lines, words, length) import Data.Text (Text) import Eventlog.Types@@ -16,16 +16,22 @@ data VegaEntry = VegaEntry { x :: Double, y :: Double, k :: Int, c :: Text }   deriving (Show, ToJSON, Generic) -bandsToVega :: Map Text Int+bandsToVega :: Map Bucket (Int, BucketInfo)             -> (UArray Int Double, UArray (Int, Int) Double)             -> [VegaEntry] bandsToVega ks (ts, vs) =   let (t1, tn) = bounds ts-      go key v rs = go_1 ++ rs+      go (i, binfo) rs = go_1 ++ rs         where+          txt = shortDescription binfo+           go_1 :: [VegaEntry]-          go_1 = flip map [t1 .. tn] $ \t -> VegaEntry (ts ! t) (vs ! (v, t)) v key-  in foldrWithKey go (go "OTHER" 0 []) ks+          go_1 = flip map [t1 .. tn] $ \t -> VegaEntry (ts ! t) (vs ! (i, t)) i txt++      other_binfo = BucketInfo "OTHER" Nothing+                               -- Last two fields currently unused+                               0 0+  in Data.Map.foldr go (go (0, other_binfo) []) ks  data VegaTrace = VegaTrace { tx :: Double, desc :: Text }   deriving (Show, ToJSON, Generic)

@@ -30,7 +30,6 @@   = AreaChart AreaChartType   | LineChart - -- Arguments for directly outputting javascript data ChartConfig =   ChartConfig { cwidth :: Double@@ -38,6 +37,7 @@               , traces :: Bool               , colourScheme :: Text               , chartType :: ChartType+              , fixedYAxisExtent :: Maybe Double               }  colourProperty :: ChartConfig -> ScaleProperty@@ -104,7 +104,7 @@     VL.width (0.9 * cwidth c),     VL.height (0.7 * cheight c),     dataFromSource "data_json_samples" [],-    VL.mark Line [],+    VL.mark Line [MPoint (PMMarker [])],     encodingLineLayer c [],     transformLineLayer []   ]@@ -190,7 +190,7 @@         ]     . position X [PName "x", PmType Quantitative, PAxis [AxTitle ""]                  , PScale [SDomain (DSelection "brush")]]-    . position Y [PName "y"+    . position Y ([PName "y"                  , PmType Quantitative                  , PAxis $ case ct of                              Stacked -> [AxTitle "Allocation"@@ -204,6 +204,8 @@                              Stacked -> StZero                              Normalized -> StNormalize                              StreamGraph -> StCenter)]+                 +++                  [PScale [SDomain (DNumbers [0,  extent])] | Just extent <- [fixedYAxisExtent c]] )  transformBandsLayer :: [LabelledSpec] -> (VLProperty, VLSpec) transformBandsLayer =@@ -251,7 +253,7 @@   . injectJSON "tooltip" Null   . color      [-       MSelectionCondition (SelectionName "legend") [MName "c", MmType Nominal, MAggregate Min, MLegend []] [MString "lightgray"]+       MSelectionCondition (SelectionName "legend") [MName "c", MmType Nominal, MLegend []] [MString "lightgray"]      ]   . position Y [PName "c"                , PmType Nominal