diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +0.2, released 2019-07-05 + +* Added the commandline option '-o OUTFILE' which writes the output to + the given filename. +* Show the time the eventlog was created in the generated HTML output. + 0.1, released 2019-06-23 * Initial release, a complete rewrite on hp2pretty. Implemented by diff --git a/eventlog2html.cabal b/eventlog2html.cabal --- a/eventlog2html.cabal +++ b/eventlog2html.cabal @@ -1,5 +1,5 @@ Name: eventlog2html -Version: 0.1.0 +Version: 0.2.0 Synopsis: Visualise an eventlog Description: eventlog2html is a library for visualising eventlogs. At the moment, the intended use is to visualise eventlogs @@ -39,10 +39,9 @@ attoparsec >= 0.13.2 && < 0.14, array >= 0.5.3 && < 0.6, base >= 4 && < 5, + blaze-html >= 0.9.1 && < 0.10, bytestring >= 0.10.8 && < 0.11, containers >= 0.6.0 && < 0.7, - text >= 1.2.3 && < 1.3, - blaze-html >= 0.9.1 && < 0.10, file-embed >= 0.0.11 && < 0.1, filepath >= 1.4.2 && < 1.5, ghc-events >= 0.8.0 && < 0.10, @@ -50,7 +49,9 @@ hvega >= 0.2.0 && < 0.3, mtl >= 2.2.2 && < 2.3, optparse-applicative >= 0.14.3 && < 0.15, - semigroups >= 0.18 && < 0.20 + semigroups >= 0.18 && < 0.20, + text >= 1.2.3 && < 1.3, + time >= 1.8.0 && < 2.0 GHC-options: -Wall default-language: Haskell2010 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} module Main (main) where @@ -26,21 +25,23 @@ argsToOutput a argsToOutput :: Args -> IO () -argsToOutput a = - if | json a -> doJson a - | otherwise -> doHtml a +argsToOutput a@Args{files = files, outputFile = Nothing} = + if | json a -> forM_ files $ \file -> doOneJson a file (file <.> "json") + | otherwise -> forM_ files $ \file -> doOneHtml a file (file <.> "html") +argsToOutput a@Args{files = [fin], outputFile = Just fout} = + if | json a -> doOneJson a fin fout + | otherwise -> doOneHtml a fin fout +argsToOutput _ = + die "When the -o option is specified, exactly one eventlog file has to be passed." + +doOneJson :: Args -> FilePath -> FilePath -> IO () +doOneJson a fin fout = do + (_, val) <- generateJson fin a + encodeFile fout val -doJson :: Args -> IO () -doJson a = do - forM_ (files a) $ \file -> do - (_, val) <- generateJson file a - encodeFile (file <.> "json") val +doOneHtml :: Args -> FilePath -> FilePath -> IO () +doOneHtml a fin fout = do + (header, data_json) <- generateJson fin a + let html = templateString header data_json a + writeFile fout html -doHtml :: Args -> IO () -doHtml a = do - forM_ (files a) $ \file -> do - (header, data_json) <- generateJson file a - let html = templateString header data_json a - let filename2 = file <.> "html" - writeFile filename2 html - exitSuccess diff --git a/src/Eventlog/Args.hs b/src/Eventlog/Args.hs --- a/src/Eventlog/Args.hs +++ b/src/Eventlog/Args.hs @@ -10,6 +10,7 @@ import Options.Applicative import Data.Text (Text) import Data.Semigroup ((<>)) +import Control.Applicative (optional) data Sort = Size | StdDev | Name @@ -24,6 +25,7 @@ , json :: Bool , noTraces :: Bool , userColourScheme :: Text + , outputFile :: Maybe String , files :: [String] } @@ -67,6 +69,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\". ") + <*> (optional $ option str + (short 'o' + <> help "Write the output to the given filename." + <> metavar "OUTFILE")) <*> some (argument str ( help "Eventlogs (FILE.eventlog will be converted to FILE.html)." <> metavar "FILES..." )) diff --git a/src/Eventlog/Data.hs b/src/Eventlog/Data.hs --- a/src/Eventlog/Data.hs +++ b/src/Eventlog/Data.hs @@ -24,6 +24,7 @@ StdDev -> cmpStdDev reversing' = if reversing a then swap else id (ph, fs, traces) <- chunk file + putStrLn (show fs) let (h, totals) = total ph fs let keeps = prune cmp 0 (bound $ nBands a) totals let combinedJson = object [ diff --git a/src/Eventlog/Events.hs b/src/Eventlog/Events.hs --- a/src/Eventlog/Events.hs +++ b/src/Eventlog/Events.hs @@ -13,8 +13,8 @@ import Data.List import Data.Function import Data.Word ---import Data.Time ---import Data.Time.Clock.POSIX(posixSecondsToUTCTime) +import Data.Time +import Data.Time.Clock.POSIX fromNano :: Word64 -> Double fromNano e = fromIntegral e * 1e-9 @@ -39,6 +39,7 @@ data EL = EL { pargs :: Maybe [String] + , clocktimeSec :: Word64 , samples :: Maybe (Word64, [Sample]) , frames :: [(Word64, [Sample])] , traces :: [Trace] @@ -46,7 +47,15 @@ , end :: Word64 } deriving Show initEL :: Word64 -> EL -initEL t = EL Nothing Nothing [] [] t 0 +initEL t = EL + { pargs = Nothing + , clocktimeSec = 0 + , samples = Nothing + , frames = [] + , traces = [] + , start = t + , end = 0 + } foldEvents :: [Event] -> EL foldEvents (e:es) = @@ -67,9 +76,11 @@ --HeapProfSampleCostCentre {} -> True HeapProfSampleString _hid res k -> addSample (Sample k (fromIntegral res)) ProgramArgs _ as -> addArgs as + WallClockTime _ s _ -> addClocktime s _ -> id - +addClocktime :: Word64 -> EL -> EL +addClocktime s el = el { clocktimeSec = s } addArgs :: [String] -> EL -> EL addArgs as el = el { pargs = Just as } @@ -95,13 +106,17 @@ updateLast :: Word64 -> EL -> EL updateLast t el = el { end = t } +formatDate :: Word64 -> T.Text +formatDate sec = + let posixTime :: POSIXTime + posixTime = realToFrac sec + in + T.pack $ formatTime defaultTimeLocale "%Y-%m-%d, %H:%M %Z" (posixSecondsToUTCTime posixTime) elHeader :: EL -> PartialHeader elHeader EL{..} = let title = maybe "" (T.unwords . map T.pack) pargs - -- dl = formatTime defaultTimeLocale "%c" - -- . posixSecondsToUTCTime $ realToFrac start - - in Header title "aaa" "" "" + date = formatDate clocktimeSec + in Header title date "" "" diff --git a/src/Eventlog/HtmlTemplate.hs b/src/Eventlog/HtmlTemplate.hs --- a/src/Eventlog/HtmlTemplate.hs +++ b/src/Eventlog/HtmlTemplate.hs @@ -68,23 +68,37 @@ template header' dat as = docTypeHtml $ do htmlHeader dat as body $ H.div ! class_ "container" $ do - H.div ! class_ "tabcontent" $ do - h1 $ a ! href "https://mpickering.github.io/eventlog2html" $ "eventlog2html" - code $ toHtml $ hJob header' + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + h1 $ a ! href "https://mpickering.github.io/eventlog2html" $ "eventlog2html" - button ! class_ "tablink button-black" ! onclick "changeTab('areachart', this)" ! A.id "defaultOpen" $ "Area Chart" - 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" + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + "Options: " + code $ toHtml $ hJob header' - mapM_ (\(vid, chartname, conf) -> - H.div ! A.id chartname ! class_ "tabviz" $ do - renderChart vid - (TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf))))) - [(1, "areachart", AreaChart Stacked) - ,(2, "normalizedchart", AreaChart Normalized) - ,(3, "streamgraph", AreaChart StreamGraph) - ,(4, "linechart", LineChart)] + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + "Created at: " + code $ toHtml $ hDate header' + + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + button ! class_ "tablink button-black" ! onclick "changeTab('areachart', this)" ! A.id "defaultOpen" $ "Area Chart" + 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" + + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + mapM_ (\(vid, chartname, conf) -> + H.div ! A.id chartname ! class_ "tabviz" $ do + renderChart vid + (TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf))))) + [(1, "areachart", AreaChart Stacked) + ,(2, "normalizedchart", AreaChart Normalized) + ,(3, "streamgraph", AreaChart StreamGraph) + ,(4, "linechart", LineChart)] script $ preEscapedToHtml tablogic