From 5ea393ad5e8b260686038bdbe8ce3826f413ca4f Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Fri, 20 Oct 2023 09:31:14 +0100
Subject: [PATCH] Fix build of hakyll site

---
 hakyll-eventlog/site.hs         | 18 +++++++-----------
 main/Main.hs                    |  3 +--
 src/Eventlog/HtmlTemplate.hs    | 21 ++++++++++++++-------
 src/Eventlog/Rendering/Types.hs |  9 ++++++---
 4 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/hakyll-eventlog/site.hs b/hakyll-eventlog/site.hs
index ef1fc79..f32a595 100644
--- a/hakyll-eventlog/site.hs
+++ b/hakyll-eventlog/site.hs
@@ -19,6 +19,7 @@ import           Eventlog.Data
 import           Eventlog.Args
 import           Eventlog.VegaTemplate
 import           Eventlog.HtmlTemplate
+import           Eventlog.Rendering.Types
 import           Eventlog.Ticky
 import           Text.Blaze.Html.Renderer.Text
 import           Options.Applicative
@@ -109,18 +110,18 @@ eventlogSnippet :: IORef Int -> [T.Text] -> ChartConfig -> IO T.Text
 eventlogSnippet c as conf = do
    n <- readIORef c
    modifyIORef c (+1)
-   drawEventlog as n conf
+   drawEventlog as (mkTabID (show n)) conf
 
-drawEventlog :: [T.Text] -> Int -> ChartConfig -> IO T.Text
+drawEventlog :: [T.Text] -> TabID -> ChartConfig -> IO T.Text
 drawEventlog args vid conf  = do
   let final_args = ["--no-include-js"] ++ args
   Run as <- handleParseResult (execParserPure defaultPrefs argsInfo (map T.unpack final_args))
   ty <- generateJson (head $ files as) as
-  return $ case ty of
-    HeapProfile (_, dat, _, _) ->
+  return $ case eventlogHeapProfile ty of
+    Just (HeapProfileData dat _ _) ->
       let itd = if traces conf then TraceData else NoTraceData
       in TL.toStrict $ renderHtml $ renderChartWithJson itd (chartType conf) vid dat (vegaJsonText conf)
-    TickyProfile {} -> mempty
+    Nothing -> mempty
 
 def :: ChartConfig
 def = ChartConfig 600 500 True "category20" "set1" (AreaChart Stacked) Nothing
@@ -167,9 +168,4 @@ fullEventLogPage file = do
   Run as <- handleParseResult (execParserPure defaultPrefs argsInfo
           [file, "--no-include-js", "--include-trace-events", "--limit-detailed=100"])
   ty <- generateJson file as
-  case ty of
-    HeapProfile (header, data_json, descs, closure_descs) ->
-      return $ templateString header data_json descs closure_descs as
-    TickyProfile (header, tallocs, ticked_per, dat) ->
-      return $ tickyTemplateString header tallocs ticked_per dat as
-
+  return $ templateString ty as
diff --git a/main/Main.hs b/main/Main.hs
index 8f24e2d..ea2af7f 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -63,8 +63,7 @@ doOneJson a fin fout = do
 doOneHtml :: Args -> FilePath -> FilePath -> IO ()
 doOneHtml a fin fout = do
   prof_type <- generateJsonValidate checkTraces fin a
-  let h = eventlogHeader prof_type
-  let html = templateString h (eventlogHeapProfile prof_type) (eventlogTickyProfile prof_type) a
+  let html = templateString prof_type a
   writeFile fout html
   where
     checkTraces :: ProfData -> IO ()
diff --git a/src/Eventlog/HtmlTemplate.hs b/src/Eventlog/HtmlTemplate.hs
index 1ee7265..0e3ee5f 100644
--- a/src/Eventlog/HtmlTemplate.hs
+++ b/src/Eventlog/HtmlTemplate.hs
@@ -130,8 +130,11 @@ htmlHeader mb_hpd mb_ticky as =
   where
     has_ticky = isJust mb_ticky
 
-template :: Header -> Maybe HeapProfileData -> Maybe TickyProfileData -> Args -> [TabGroup] -> Html
-template header' x y as tab_groups = docTypeHtml $ do
+template :: EventlogType
+         -> Args
+         -> [TabGroup]
+         -> Html
+template (EventlogType header' x y) as tab_groups = docTypeHtml $ do
   H.stringComment $ "Generated with eventlog2html-" <> showVersion version
   htmlHeader x y as
   body $ H.div ! class_ "container-fluid" $ do
@@ -204,9 +207,11 @@ renderChartWithJson itd ct k dat vegaSpec = do
     renderChart itd ct True k vegaSpec
 
 
-templateString :: Header -> Maybe HeapProfileData -> Maybe TickyProfileData -> Args -> String
-templateString h x y as =
-  renderHtml $ template h x y as $ allTabs h x y as
+templateString :: EventlogType
+               -> Args
+               -> String
+templateString x as =
+  renderHtml $ template x as $ allTabs x as
 
 
 ppHeapProfileType :: HeapProfBreakdown -> Text
@@ -220,8 +225,10 @@ ppHeapProfileType (HeapProfBreakdownClosureType) = "Basic heap profile (implied
 ppHeapProfileType (HeapProfBreakdownInfoTable) = "Info table profile (implied by -hi)"
 
 
-allTabs :: Header -> Maybe HeapProfileData -> Maybe TickyProfileData -> Args -> [TabGroup]
-allTabs h x y as =
+allTabs :: EventlogType
+        -> Args
+        -> [TabGroup]
+allTabs (EventlogType h x y) as =
     [SingleTab (metaTab h as)] ++
     maybe [] (allHeapTabs h as) x ++
     [tickyProfileTabs y]
diff --git a/src/Eventlog/Rendering/Types.hs b/src/Eventlog/Rendering/Types.hs
index 8f5e2d7..0ef9015 100644
--- a/src/Eventlog/Rendering/Types.hs
+++ b/src/Eventlog/Rendering/Types.hs
@@ -12,12 +12,15 @@ data IncludeTraceData
   | NoTraceData
 
 -- | Tab IDs must be usable as HTML and Javascript identifiers, so we allow a
--- limited selection of characters. This is enforced only at runtime by the
--- 'IsString' instance, but that seems good enough for now.
+-- limited selection of characters. This is enforced only at runtime by
+-- 'mkTabID' and the 'IsString' instance, but that seems good enough for now.
 newtype TabID = TabID T.Text
 
 instance IsString TabID where
-  fromString s
+  fromString = mkTabID
+
+mkTabID :: String -> TabID
+mkTabID s
     | all valid s = TabID (T.pack s)
     | otherwise   = error $ "mkTabID: invalid tab ID: " ++ s
     where