From ac28e84211798d05e8cc3058fbf694e992b43aa4 Mon Sep 17 00:00:00 2001
From: Georgy Lukyanov <mail@geo2a.info>
Date: Sun, 9 Jun 2024 17:25:56 +0200
Subject: [PATCH] Use lucid for per-module header
---
src/Trace/Hpc/Markup.hs | 82 ++++++++++++++++-------------
test/Markup/gold/Recip/Main.hs.html | 20 ++-----
2 files changed, 48 insertions(+), 54 deletions(-)
diff --git a/src/Trace/Hpc/Markup.hs b/src/Trace/Hpc/Markup.hs
index 29d4a3f..0380af9 100644
--- a/src/Trace/Hpc/Markup.hs
+++ b/src/Trace/Hpc/Markup.hs
@@ -1,3 +1,4 @@
+{-# Language OverloadedStrings #-}
-- |
-- Module : Trace.Hpc.Markup
-- Description : The subcommand @hpc markup@
@@ -7,6 +8,7 @@ module Trace.Hpc.Markup (markupPlugin) where
import qualified Lucid as L
import qualified Data.Text.Lazy as TL
+import qualified Data.Text as T
import Control.Monad
import Data.Array
import Data.List (find, sortBy)
@@ -174,46 +176,48 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
let addLines = unlines . zipWith addLine [1 :: Int ..] . lines
let fileName = modName0 <.> "hs" <.> "html"
+ let headerAndBody :: L.Html ()
+ headerAndBody =
+ L.html_ [] $ do
+ L.head_ [] $ do
+ L.meta_ [L.httpEquiv_ "Content-Type", L.content_ "text/html; charset=UTF-8"]
+ stylesheet
+ L.body_ [] $ do
+ L.pre_ [] $ do
+ L.span_ [L.class_ "decl"] $ do
+ L.span_ [L.class_ "nottickedoff"] "never executed" <> rawStr_ " "
+ L.span_ [L.class_ "tickonlytrue"] "always true" <> rawStr_ " "
+ L.span_ [L.class_ "tickonlyfalse"] "always false"
+ L.pre_ [] (L.toHtmlRaw (addLines content'))
+
+ stylesheet :: L.Html ()
+ stylesheet = L.style_ [L.type_ "text/css"] stylecontent
+
+ stylecontent :: T.Text
+ stylecontent = T.unlines
+ [ "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }"
+ , if invertOutput
+ then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
+ else "span.nottickedoff { background: " <> yellow <> "}"
+ , if invertOutput
+ then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
+ else "span.istickedoff { background: white }"
+ , "span.tickonlyfalse { margin: -1px; border: 1px solid " <> red <> "; background: " <> red <> " }"
+ , "span.tickonlytrue { margin: -1px; border: 1px solid " <> green <> "; background: " <> green <> " }"
+ , "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }"
+ , if invertOutput
+ then "span.decl { font-weight: bold; background: #d0c0ff }"
+ else "span.decl { font-weight: bold }"
+ , "span.spaces { background: white }"
+ ]
+
unless (verbosity flags < Normal) $ do
putStrLn $ "Writing: " ++ fileName
- writeFileUtf8 (dest_dir </> fileName) $
- unlines
- [ "<html>",
- "<head>",
- "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">",
- "<style type=\"text/css\">",
- "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
- if invertOutput
- then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
- else "span.nottickedoff { background: " ++ yellow ++ "}",
- if invertOutput
- then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
- else "span.istickedoff { background: white }",
- "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
- "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
- "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
- if invertOutput
- then "span.decl { font-weight: bold; background: #d0c0ff }"
- else "span.decl { font-weight: bold }",
- "span.spaces { background: white }",
- "</style>",
- "</head>",
- "<body>",
- "<pre>",
- concat
- [ "<span class=\"decl\">",
- "<span class=\"nottickedoff\">never executed</span> ",
- "<span class=\"tickonlytrue\">always true</span> ",
- "<span class=\"tickonlyfalse\">always false</span></span>"
- ],
- "</pre>",
- "<pre>"
- ]
- ++ addLines content'
- ++ "\n</pre>\n</body>\n</html>\n"
+ writeFileUtf8 (dest_dir </> fileName) . TL.unpack . L.renderText $ headerAndBody
modSummary `seq` return (modName0, fileName, modSummary)
+
data Loc = Loc !Int !Int
deriving (Eq, Ord, Show)
@@ -297,7 +301,7 @@ addMarkup tabStop0 (c0 : cs) loc@(Loc _ p) os ticks
| otherwise =
escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
where
- (w, cs') = span (`elem` " \t") cs
+ (w, cs') = span (`elem` (" \t" :: String)) cs
loc' = foldl (flip incBy) loc (c0 : w)
escape '>' = ">"
escape '<' = "<"
@@ -372,7 +376,11 @@ allowNesting _ _ = True
------------------------------------------------------------------------------
-- global color palette
-red, green, yellow :: String
+red, green, yellow :: T.Text
red = "#f20913"
green = "#60de51"
yellow = "yellow"
+
+-- | A string literal embedded as-is, without escaping
+rawStr_ :: T.Text -> L.Html ()
+rawStr_ = L.toHtmlRaw
diff --git a/test/Markup/gold/Recip/Main.hs.html b/test/Markup/gold/Recip/Main.hs.html
index 11f216e..80e93ea 100644
--- a/test/Markup/gold/Recip/Main.hs.html
+++ b/test/Markup/gold/Recip/Main.hs.html
@@ -1,8 +1,4 @@
-<html>
-<head>
-<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-<style type="text/css">
-span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
+<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
@@ -10,14 +6,7 @@ span.tickonlytrue { margin: -1px; border: 1px solid #60de51; background: #60de5
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces { background: white }
-</style>
-</head>
-<body>
-<pre>
-<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
-</pre>
-<pre>
-<span class="lineno"> 1 </span>module Main where
+</style></head><body><pre><span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span></pre><pre><span class="lineno"> 1 </span>module Main where
<span class="lineno"> 2 </span>
<span class="lineno"> 3 </span>reciprocal :: Int -> (String, Int)
<span class="lineno"> 4 </span><span class="decl"><span class="istickedoff">reciprocal n | <span class="tickonlytrue">n > 1</span> = ('0' : '.' : digits, recur)</span>
@@ -50,7 +39,4 @@ span.spaces { background: white }
<span class="lineno"> 31 </span><span class="spaces"> </span><span class="istickedoff">putStrLn (showRecip number)</span>
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="istickedoff">main</span></span>
<span class="lineno"> 33 </span>
-
-</pre>
-</body>
-</html>
+</pre></body></html>
\ No newline at end of file
--
GitLab