Factor out html generation of summary files

The "hpc markup" command generates, among others, the summary files "index_hpc.html", "index_hpc_fun.html", "index_hpc_alt.html" and "index_hpc_exp.html". This commit factors out the logic for generating these files into a self-contained module, in view of using the Lucid2 templating engine to generate these html files.

Factor out html generation of summary files
981c700b · BinderDavid · BinderDavid · 0c38cf17 · 981c700b · 981c700b
Commit 981c700b authored 1 year ago by BinderDavid Committed by BinderDavid 1 year ago
--- a/hpc-bin.cabal
+++ b/hpc-bin.cabal
@@ -39,6 +39,7 @@ executable hpc
                   Trace.Hpc.Flags
                   Trace.Hpc.Lexer
                   Trace.Hpc.Plugin
+                   Trace.Hpc.Markup.Summary
                   Trace.Hpc.Markup
                   Trace.Hpc.Map
                   Trace.Hpc.Sum

--- a/src/Trace/Hpc/Markup.hs
+++ b/src/Trace/Hpc/Markup.hs
@@ -9,10 +9,10 @@ import Control.Monad
 import Data.Array
 import Data.List (find, sortBy)
 import Data.Maybe
-import Data.Semigroup as Semi
 import qualified Data.Set as Set
 import System.FilePath
 import Trace.Hpc.Flags
+import Trace.Hpc.Markup.Summary
 import Trace.Hpc.Mix
 import Trace.Hpc.Plugin
 import Trace.Hpc.Tix
@@ -62,84 +62,25 @@ markupMain flags (prog : modNames) = do
          allowModule hpcflags1 (tixModuleName tix)
      ]
-  let index_name = "hpc_index"
+  -- Write "hpc_index.html"
-      index_fun = "hpc_index_fun"
+  let (fp_name_index, html_name_index) = name_summary mods
-      index_alt = "hpc_index_alt"
+  unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_name_index))
-      index_exp = "hpc_index_exp"
+  writeFileUtf8 (dest_dir </> fp_name_index) html_name_index
-  let writeSummary filename cmp = do
+  -- Write "hpc_index_fun.html"
-        let mods' = sortBy cmp mods
+  let (fp_fun_index, html_fun_index) = fun_summary mods
+  unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_fun_index))
-        unless (verbosity flags < Normal) $
+  writeFileUtf8 (dest_dir </> fp_fun_index) html_fun_index
-          putStrLn $
-            "Writing: " ++ (filename <.> "html")
+  -- Write "hpc_index_alt.html"
+  let (fp_alt_index, html_alt_index) = alt_summary mods
-        writeFileUtf8 (dest_dir </> filename <.> "html") $
+  unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_alt_index))
-          "<html>"
+  writeFileUtf8 (dest_dir </> fp_alt_index) html_alt_index
-            ++ "<head>"
-            ++ "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
+  -- Write "hpc_index_exp.html"
-            ++ "<style type=\"text/css\">"
+  let (fp_exp_index, html_exp_index) = exp_summary mods
-            ++ "table.bar { background-color: #f25913; }\n"
+  unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_exp_index))
-            ++ "td.bar { background-color: #60de51;  }\n"
+  writeFileUtf8 (dest_dir </> fp_exp_index) html_exp_index
-            ++ "td.invbar { background-color: #f25913;  }\n"
-            ++ "table.dashboard { border-collapse: collapse  ; border: solid 1px black }\n"
-            ++ ".dashboard td { border: solid 1px black }\n"
-            ++ ".dashboard th { border: solid 1px black }\n"
-            ++ "</style>\n"
-            ++ "</head>"
-            ++ "<body>"
-            ++ "<table class=\"dashboard\" width=\"100%\" border=1>\n"
-            ++ "<tr>"
-            ++ "<th rowspan=2><a href=\""
-            ++ index_name
-            ++ ".html\">module</a></th>"
-            ++ "<th colspan=3><a href=\""
-            ++ index_fun
-            ++ ".html\">Top Level Definitions</a></th>"
-            ++ "<th colspan=3><a href=\""
-            ++ index_alt
-            ++ ".html\">Alternatives</a></th>"
-            ++ "<th colspan=3><a href=\""
-            ++ index_exp
-            ++ ".html\">Expressions</a></th>"
-            ++ "</tr>"
-            ++ "<tr>"
-            ++ "<th>%</th>"
-            ++ "<th colspan=2>covered / total</th>"
-            ++ "<th>%</th>"
-            ++ "<th colspan=2>covered / total</th>"
-            ++ "<th>%</th>"
-            ++ "<th colspan=2>covered / total</th>"
-            ++ "</tr>"
-            ++ concat
-              [ showModuleSummary (modName, fileName, modSummary)
-                | (modName, fileName, modSummary) <- mods'
-              ]
-            ++ "<tr></tr>"
-            ++ showTotalSummary
-              ( mconcat
-                  [ modSummary
-                    | (_, _, modSummary) <- mods'
-                  ]
-              )
-            ++ "</table></body></html>\n"
-  writeSummary index_name $ \(n1, _, _) (n2, _, _) -> compare n1 n2
-  writeSummary index_fun $ \(_, _, s1) (_, _, s2) ->
-    compare
-      (percent (topFunTicked s2) (topFunTotal s2))
-      (percent (topFunTicked s1) (topFunTotal s1))
-  writeSummary index_alt $ \(_, _, s1) (_, _, s2) ->
-    compare
-      (percent (altTicked s2) (altTotal s2))
-      (percent (altTicked s1) (altTotal s1))
-  writeSummary index_exp $ \(_, _, s1) (_, _, s2) ->
-    compare
-      (percent (expTicked s2) (expTotal s2))
-      (percent (expTicked s1) (expTotal s1))
 markupMain _ [] =
  hpcError markupPlugin "no .tix file or executable name specified"
@@ -426,89 +367,6 @@ allowNesting IsTicked TickedOnlyFalse = False
 allowNesting IsTicked TickedOnlyTrue = False
 allowNesting _ _ = True
------------------------------------------------------------------------------
-data ModuleSummary = ModuleSummary
-  { expTicked :: !Int,
-    expTotal :: !Int,
-    topFunTicked :: !Int,
-    topFunTotal :: !Int,
-    altTicked :: !Int,
-    altTotal :: !Int
-  }
-  deriving (Show)
-showModuleSummary :: (String, String, ModuleSummary) -> String
-showModuleSummary (modName, fileName, modSummary) =
-  "<tr>\n"
-    ++ "<td>&nbsp;&nbsp;<tt>module <a href=\""
-    ++ fileName
-    ++ "\">"
-    ++ modName
-    ++ "</a></tt></td>\n"
-    ++ showSummary (topFunTicked modSummary) (topFunTotal modSummary)
-    ++ showSummary (altTicked modSummary) (altTotal modSummary)
-    ++ showSummary (expTicked modSummary) (expTotal modSummary)
-    ++ "</tr>\n"
-showTotalSummary :: ModuleSummary -> String
-showTotalSummary modSummary =
-  "<tr style=\"background: #e0e0e0\">\n"
-    ++ "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n"
-    ++ showSummary (topFunTicked modSummary) (topFunTotal modSummary)
-    ++ showSummary (altTicked modSummary) (altTotal modSummary)
-    ++ showSummary (expTicked modSummary) (expTotal modSummary)
-    ++ "</tr>\n"
-showSummary :: (Integral t, Show t) => t -> t -> String
-showSummary ticked total =
-  "<td align=\"right\">"
-    ++ showP (percent ticked total)
-    ++ "</td>"
-    ++ "<td>"
-    ++ show ticked
-    ++ "/"
-    ++ show total
-    ++ "</td>"
-    ++ "<td width=100>"
-    ++ ( case percent ticked total of
-           Nothing -> "&nbsp;"
-           Just w -> bar w "bar"
-       )
-    ++ "</td>"
-  where
-    showP Nothing = "-&nbsp;"
-    showP (Just x) = show x ++ "%"
-    bar 0 _ = bar 100 "invbar"
-    bar w inner =
-      "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">"
-        ++ "<tr><td><table cellpadding=0 cellspacing=0 width=\""
-        ++ show w
-        ++ "%\">"
-        ++ "<tr><td height=12 class="
-        ++ show inner
-        ++ "></td></tr>"
-        ++ "</table></td></tr></table>"
-percent :: (Integral a) => a -> a -> Maybe a
-percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
-instance Semi.Semigroup ModuleSummary where
-  (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) <> (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) =
-    ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
-instance Monoid ModuleSummary where
-  mempty =
-    ModuleSummary
-      { expTicked = 0,
-        expTotal = 0,
-        topFunTicked = 0,
-        topFunTotal = 0,
-        altTicked = 0,
-        altTotal = 0
-      }
-  mappend = (<>)
 ------------------------------------------------------------------------------
 -- global color palette

--- a/src/Trace/Hpc/Markup/Summary.hs
+++ b/src/Trace/Hpc/Markup/Summary.hs
+-- |
+-- Module             : Trace.Hpc.Markup.Summary
+-- Description        : Generating the summary html files.
+module Trace.Hpc.Markup.Summary
+  ( ModuleSummary (..),
+    name_summary,
+    fun_summary,
+    exp_summary,
+    alt_summary
+  )
+where
+import Data.List (sortBy)
+import Data.Semigroup as Semi
+import System.FilePath ((<.>))
+index_name :: String
+index_name = "hpc_index"
+index_fun :: String
+index_fun = "hpc_index_fun"
+index_alt :: String
+index_alt = "hpc_index_alt"
+index_exp :: String
+index_exp = "hpc_index_exp"
+data ModuleSummary = ModuleSummary
+  { expTicked :: !Int,
+    expTotal :: !Int,
+    topFunTicked :: !Int,
+    topFunTotal :: !Int,
+    altTicked :: !Int,
+    altTotal :: !Int
+  }
+  deriving (Show)
+showModuleSummary :: (String, String, ModuleSummary) -> String
+showModuleSummary (modName, fileName, modSummary) =
+  "<tr>\n"
+    <> "<td>&nbsp;&nbsp;<tt>module <a href=\""
+    <> fileName
+    <> "\">"
+    <> modName
+    <> "</a></tt></td>\n"
+    <> showSummary (topFunTicked modSummary) (topFunTotal modSummary)
+    <> showSummary (altTicked modSummary) (altTotal modSummary)
+    <> showSummary (expTicked modSummary) (expTotal modSummary)
+    <> "</tr>\n"
+showTotalSummary :: ModuleSummary -> String
+showTotalSummary modSummary =
+  "<tr style=\"background: #e0e0e0\">\n"
+    <> "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n"
+    <> showSummary (topFunTicked modSummary) (topFunTotal modSummary)
+    <> showSummary (altTicked modSummary) (altTotal modSummary)
+    <> showSummary (expTicked modSummary) (expTotal modSummary)
+    <> "</tr>\n"
+showSummary :: (Integral t, Show t) => t -> t -> String
+showSummary ticked total =
+  "<td align=\"right\">"
+    <> showP (percent ticked total)
+    <> "</td>"
+    <> "<td>"
+    <> show ticked
+    <> "/"
+    <> show total
+    <> "</td>"
+    <> "<td width=100>"
+    <> ( case percent ticked total of
+           Nothing -> "&nbsp;"
+           Just w -> bar w "bar"
+       )
+    <> "</td>"
+  where
+    showP Nothing = "-&nbsp;"
+    showP (Just x) = show x <> "%"
+    bar 0 _ = bar 100 "invbar"
+    bar w inner =
+      "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">"
+        <> "<tr><td><table cellpadding=0 cellspacing=0 width=\""
+        <> show w
+        <> "%\">"
+        <> "<tr><td height=12 class="
+        <> show inner
+        <> "></td></tr>"
+        <> "</table></td></tr></table>"
+percent :: (Integral a) => a -> a -> Maybe a
+percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
+instance Semi.Semigroup ModuleSummary where
+  (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) <> (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) =
+    ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
+instance Monoid ModuleSummary where
+  mempty =
+    ModuleSummary
+      { expTicked = 0,
+        expTotal = 0,
+        topFunTicked = 0,
+        topFunTotal = 0,
+        altTicked = 0,
+        altTotal = 0
+      }
+  mappend = (<>)
+summaryHtml :: [(String, String, ModuleSummary)] -> String
+summaryHtml mods = "<html>" <> header <> body <> "</html>\n"
+  where
+    header :: String
+    header =
+      "<head>"
+        <> "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
+        <> "<style type=\"text/css\">"
+        <> "table.bar { background-color: #f25913; }\n"
+        <> "td.bar { background-color: #60de51;  }\n"
+        <> "td.invbar { background-color: #f25913;  }\n"
+        <> "table.dashboard { border-collapse: collapse  ; border: solid 1px black }\n"
+        <> ".dashboard td { border: solid 1px black }\n"
+        <> ".dashboard th { border: solid 1px black }\n"
+        <> "</style>\n"
+        <> "</head>"
+    body :: String
+    body =
+      "<body>"
+        <> "<table class=\"dashboard\" width=\"100%\" border=1>\n"
+        <> "<tr>"
+        <> "<th rowspan=2><a href=\""
+        <> index_name
+        <> ".html\">module</a></th>"
+        <> "<th colspan=3><a href=\""
+        <> index_fun
+        <> ".html\">Top Level Definitions</a></th>"
+        <> "<th colspan=3><a href=\""
+        <> index_alt
+        <> ".html\">Alternatives</a></th>"
+        <> "<th colspan=3><a href=\""
+        <> index_exp
+        <> ".html\">Expressions</a></th>"
+        <> "</tr>"
+        <> "<tr>"
+        <> "<th>%</th>"
+        <> "<th colspan=2>covered / total</th>"
+        <> "<th>%</th>"
+        <> "<th colspan=2>covered / total</th>"
+        <> "<th>%</th>"
+        <> "<th colspan=2>covered / total</th>"
+        <> "</tr>"
+        <> concat
+          [ showModuleSummary (modName, fileName, modSummary)
+            | (modName, fileName, modSummary) <- mods
+          ]
+        <> "<tr></tr>"
+        <> showTotalSummary
+          ( mconcat
+              [ modSummary
+                | (_, _, modSummary) <- mods
+              ]
+          )
+        <> "</table></body>"
+-- | Compute "hpc_index.html"
+name_summary :: [(String, String, ModuleSummary)] -> (FilePath, String)
+name_summary mods = (index_name <.> "html", summaryHtml (sortBy cmp mods))
+  where
+    cmp (n1, _, _) (n2, _, _) = compare n1 n2
+-- | Compute "hpc_index_fun.html"
+fun_summary :: [(String, String, ModuleSummary)] -> (FilePath, String)
+fun_summary mods = (index_fun <.> "html", summaryHtml (sortBy cmp mods))
+  where
+    cmp (_, _, s1) (_, _, s2) = compare
+      (percent (topFunTicked s2) (topFunTotal s2))
+      (percent (topFunTicked s1) (topFunTotal s1))
+-- | Compute "hpc_index_alt.html"
+alt_summary :: [(String, String, ModuleSummary)] -> (FilePath, String)
+alt_summary mods = (index_alt <.> "html", summaryHtml (sortBy cmp mods))
+  where
+    cmp (_, _, s1) (_, _, s2) = compare
+      (percent (altTicked s2) (altTotal s2))
+      (percent (altTicked s1) (altTotal s1))
+-- | Compute "hpc_index_exp.html"
+exp_summary :: [(String, String, ModuleSummary)] -> (FilePath, String)
+exp_summary mods = (index_exp <.> "html", summaryHtml (sortBy cmp mods))
+  where
+    cmp (_, _, s1) (_, _, s2) = compare
+      (percent (expTicked s2) (expTotal s2))
+      (percent (expTicked s1) (expTotal s1))