Eliminate dependency on lucid2, which is not a GHC boot package at the moment

hpc-bin.cabal

@@ -49,6 +49,7 @@ executable hpc
                    Trace.Hpc.Utils
                    Trace.Hpc.Main
                    Paths_hpc_bin
+                   Lucid
     autogen-modules: Paths_hpc_bin
 
     if flag(ci-build)
@@ -61,7 +62,6 @@ executable hpc
                    containers >= 0.1 && < 0.9,
                    array      >= 0.1 && < 0.6,
                    hpc        >= 0.6.2 && < 0.8,
-                   lucid2     ^>= 0.0.20240424,
                    text       >= 2.0 && < 2.2
 
     if flag(build-tool-depends)
@@ -92,7 +92,7 @@ test-suite hpc-test
     , directory    >= 1   && < 1.4
     , filepath     >= 1   && < 1.6
     , process      ^>= 1.6
-    , tasty        ^>= 1.4
+    , tasty        >= 1.4 && < 1.6
     , tasty-golden ^>= 2.3
     , tasty-hunit  ^>= 0.10
     , text         >= 2.0 && < 2.2

src/Lucid.hs

+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | At the moment `lucid2` is not a GHC boot package,
+-- so this module provides a poor man substitute
+-- tailored just enough to suffice for HPC purposes.
+
+module Lucid
+  ( Html
+  , toHtmlRaw
+  , toHtml
+  , renderText
+  , Attributes
+  , makeAttributes
+  , a_
+  , body_
+  , class_
+  , code_
+  , colspan_
+  , content_
+  , head_
+  , height_
+  , href_
+  , html_
+  , httpEquiv_
+  , meta_
+  , rowspan_
+  , style_
+  , table_
+  , td_
+  , th_
+  , tr_
+  , type_
+  , width_
+  ) where
+
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as B
+import Data.List (intersperse)
+import Data.Char (isSpace, isControl)
+
+type Html a = B.Builder
+
+toHtmlRaw :: T.Text -> B.Builder
+toHtmlRaw = B.fromText
+
+toHtml :: String -> B.Builder
+toHtml = foldMap $ \case
+  '>' -> ">"
+  '<' -> "&lt;"
+  '&' -> "&amp;"
+  '"' -> "&quot;"
+  '\'' -> "&#39;"
+  '\DEL' -> ""
+  c
+    | isControl c && not (isSpace c) -> ""
+    | otherwise -> B.singleton c
+
+renderText :: B.Builder -> TL.Text
+renderText = B.toLazyText
+
+newtype Attributes = Attributes { unAttributes :: B.Builder }
+
+class Term arg result | result -> arg where
+  term :: T.Text -> arg -> result
+
+instance Term B.Builder B.Builder where
+  term = makeTag
+
+instance Term [Attributes] (B.Builder -> B.Builder) where
+  term = makeTagWithAttr
+
+instance Term T.Text Attributes where
+  term = makeAttributes
+
+makeAttributes :: T.Text -> T.Text -> Attributes
+makeAttributes attr cnt = Attributes $ B.fromText attr <> "=\"" <> toHtml (T.unpack cnt) <> "\""
+
+makeTag :: T.Text -> B.Builder -> B.Builder
+makeTag tag cnt = "<" <> B.fromText tag <> ">" <> cnt <> "</" <> B.fromText tag <> ">"
+
+makeTagWithAttr :: T.Text -> [Attributes] -> B.Builder -> B.Builder
+makeTagWithAttr tag attrs cnt =
+  "<" <> mconcat (intersperse " " (B.fromText tag : map unAttributes attrs)) <> ">" <> cnt <> "</" <> B.fromText tag <> ">"
+
+makeTagWithoutContent :: T.Text -> [Attributes] -> B.Builder
+makeTagWithoutContent tag attrs =
+  "<" <> mconcat (intersperse " " (B.fromText tag : map unAttributes attrs)) <> ">"
+
+colspan_, rowspan_, width_, height_, class_, type_, href_, content_, httpEquiv_ :: T.Text -> Attributes
+colspan_ = makeAttributes "colspan"
+rowspan_ = makeAttributes "rowspan"
+width_ = makeAttributes "width"
+height_ = makeAttributes "height"
+class_ = makeAttributes "class"
+type_ = makeAttributes "type"
+href_ = makeAttributes "href"
+content_ = makeAttributes "content"
+httpEquiv_ = makeAttributes "http-equiv"
+
+html_, head_, body_, code_ :: B.Builder -> B.Builder
+html_ = makeTag "html"
+head_ = makeTag "head"
+body_ = makeTag "body"
+code_ = makeTag "code"
+
+a_, table_ :: [Attributes] -> B.Builder -> B.Builder
+a_ = makeTagWithAttr "a"
+table_ = makeTagWithAttr "table"
+
+meta_ :: [Attributes] -> B.Builder
+meta_ = makeTagWithoutContent "meta"
+
+th_, tr_, td_, style_ :: Term arg result => arg -> result
+th_ = term "th"
+tr_ = term "tr"
+td_ = term "td"
+style_ = term "style"

src/Trace/Hpc/Markup/Summary.hs

 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Avoid restricted function" #-}
 
 -- |
 -- Module             : Trace.Hpc.Markup.Summary
@@ -16,7 +18,6 @@ import Data.List (sortBy)
 import Data.Semigroup as Semi
 import qualified Data.Text as T
 import qualified Lucid as L
-import qualified Lucid.Base as L
 import Prelude hiding (exp, last)
 
 index_name :: String
@@ -93,7 +94,7 @@ showSummary ticked total = percentHtml <> tickedTotal <> last
         innerTable = L.table_ [cellpadding_ "0", cellspacing_ "0", L.width_ (T.pack (show w <> "%"))] tableContent
 
         tableContent :: L.Html ()
-        tableContent = L.tr_ (L.td_ [L.height_ "12", L.class_ (T.pack inner)] "")
+        tableContent = L.tr_ (L.td_ [L.height_ "12", L.class_ (T.pack inner)] ("" :: L.Html ()))
 
 percent :: (Integral a) => a -> a -> Maybe a
 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
@@ -120,12 +121,13 @@ summaryHtml mods =
   where
     header :: L.Html ()
     header =
-      L.head_ $ do
-        L.meta_ [L.httpEquiv_ "Content-Type", L.content_ "text/html; charset=UTF-8"]
-        stylesheet
+      L.head_ $ mconcat
+        [ L.meta_ [L.httpEquiv_ "Content-Type", L.content_ "text/html; charset=UTF-8"]
+        , stylesheet
+        ]
 
     stylesheet :: L.Html ()
-    stylesheet = L.style_ [L.type_ "text/css"] stylecontent
+    stylesheet = L.style_ [L.type_ "text/css"] (L.toHtml (T.unpack stylecontent))
 
     stylecontent :: T.Text
     stylecontent =
@@ -139,27 +141,30 @@ summaryHtml mods =
     body :: L.Html ()
     body =
       L.body_ $
-        L.table_ [L.class_ "dashboard", L.width_ "100%", border_ "1"] $ do
-          L.tr_ $ do
-            L.th_ [L.rowspan_ "2"] $ L.a_ [L.href_ (T.pack index_name)] "module"
-            L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_fun)] "Top Level Definitions"
-            L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_alt)] "Alternatives"
-            L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_exp)] "Expressions"
-          L.tr_ $ do
-            L.th_ "%" <> L.th_ [L.colspan_ "2"] "covered / total"
-            L.th_ "%" <> L.th_ [L.colspan_ "2"] "covered / total"
-            L.th_ "%" <> L.th_ [L.colspan_ "2"] "covered / total"
-          sequence_
+        L.table_ [L.class_ "dashboard", L.width_ "100%", border_ "1"] $ mconcat
+          [ L.tr_ $ mconcat
+            [ L.th_ [L.rowspan_ "2"] $ L.a_ [L.href_ (T.pack index_name)] "module"
+            , L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_fun)] "Top Level Definitions"
+            , L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_alt)] "Alternatives"
+            , L.th_ [L.colspan_ "3"] $ L.a_ [L.href_ (T.pack index_exp)] "Expressions"
+            ]
+          , L.tr_ $ mconcat
+            [ L.th_ "%" <> L.th_ [L.colspan_ "2"] ("covered / total" :: L.Html ())
+            , L.th_ "%" <> L.th_ [L.colspan_ "2"] ("covered / total" :: L.Html ())
+            , L.th_ "%" <> L.th_ [L.colspan_ "2"] ("covered / total" :: L.Html ())
+            ]
+          , mconcat
             [ showModuleSummary (modName, fileName, modSummary)
               | (modName, fileName, modSummary) <- mods
             ]
-          L.tr_ ""
-          showTotalSummary
+          , L.tr_ ""
+          , showTotalSummary
             ( mconcat
                 [ modSummary
                   | (_, _, modSummary) <- mods
                 ]
             )
+          ]
 
 -- | Compute "hpc_index.html"
 name_summary :: [(String, String, ModuleSummary)] -> (FilePath, L.Html ())