From 981c700b4a3d76e28248126d8e81366e11c294ff Mon Sep 17 00:00:00 2001
From: David Binder <david.binder@uni-tuebingen.de>
Date: Fri, 24 May 2024 17:12:51 +0200
Subject: [PATCH] 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.
---
hpc-bin.cabal | 1 +
src/Trace/Hpc/Markup.hs | 182 ++++--------------------------
src/Trace/Hpc/Markup/Summary.hs | 194 ++++++++++++++++++++++++++++++++
3 files changed, 215 insertions(+), 162 deletions(-)
create mode 100644 src/Trace/Hpc/Markup/Summary.hs
diff --git a/hpc-bin.cabal b/hpc-bin.cabal
index 203e284..0a7e416 100644
--- 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
diff --git a/src/Trace/Hpc/Markup.hs b/src/Trace/Hpc/Markup.hs
index 884d020..f76eb52 100644
--- 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"
- index_fun = "hpc_index_fun"
- index_alt = "hpc_index_alt"
- index_exp = "hpc_index_exp"
-
- let writeSummary filename cmp = do
- let mods' = sortBy cmp mods
-
- unless (verbosity flags < Normal) $
- putStrLn $
- "Writing: " ++ (filename <.> "html")
-
- writeFileUtf8 (dest_dir </> filename <.> "html") $
- "<html>"
- ++ "<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>"
- ++ "<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))
+ -- Write "hpc_index.html"
+ let (fp_name_index, html_name_index) = name_summary mods
+ unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_name_index))
+ writeFileUtf8 (dest_dir </> fp_name_index) html_name_index
+
+ -- Write "hpc_index_fun.html"
+ let (fp_fun_index, html_fun_index) = fun_summary mods
+ unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_fun_index))
+ writeFileUtf8 (dest_dir </> fp_fun_index) html_fun_index
+
+ -- Write "hpc_index_alt.html"
+ let (fp_alt_index, html_alt_index) = alt_summary mods
+ unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_alt_index))
+ writeFileUtf8 (dest_dir </> fp_alt_index) html_alt_index
+
+ -- Write "hpc_index_exp.html"
+ let (fp_exp_index, html_exp_index) = exp_summary mods
+ unless (verbosity flags < Normal) (putStrLn ("Writing: " <> fp_exp_index))
+ writeFileUtf8 (dest_dir </> fp_exp_index) html_exp_index
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> <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> 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 -> " "
- Just w -> bar w "bar"
- )
- ++ "</td>"
- where
- showP Nothing = "- "
- 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
diff --git a/src/Trace/Hpc/Markup/Summary.hs b/src/Trace/Hpc/Markup/Summary.hs
new file mode 100644
index 0000000..1d11eb9
--- /dev/null
+++ b/src/Trace/Hpc/Markup/Summary.hs
@@ -0,0 +1,194 @@
+-- |
+-- 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> <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> 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 -> " "
+ Just w -> bar w "bar"
+ )
+ <> "</td>"
+ where
+ showP Nothing = "- "
+ 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))
--
GitLab