Use the Builder patch for xhtml

cabal.project

@@ -5,6 +5,11 @@ packages: ./
           ./haddock-library
           ./haddock-test
 
+source-repository-package
+    type: git
+    location: https://github.com/parsonsmatt/xhtml
+    tag: 0c9a8ae2c88d0804c2fc22306a8656d1e6828614
+
 with-compiler: ghc-9.4
 
 allow-newer:

haddock-api/haddock-api.cabal

@@ -47,7 +47,7 @@ library
                , ghc             ^>= 9.4
                , ghc-paths       ^>= 0.1.0.9
                , haddock-library ^>= 1.11
-               , xhtml           ^>= 3000.2.2
+               , xhtml           ^>= 3000.3
                , parsec          ^>= 3.1.13.0
                , text            ^>= 2.0
 

haddock-api/src/Haddock.hs

@@ -334,7 +334,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
       | otherwise        = dflags
     logger               = setLogFlags log' (initLogFlags dflags')
 
-    visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
+    visibleIfaces    = [i | i <- ifaces, OptHide `notElem` ifaceOptions i]
 
     -- /All/ interfaces including external package modules, grouped by
     -- interface file (package).

haddock-api/src/Haddock/Backends/Hoogle.hs

@@ -60,7 +60,7 @@ ppHoogle logger dflags unit_state package version synopsis prologue ifaces odir
                    | not (null (versionBranch version)) ] ++
                    concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
     createDirectoryIfMissing True odir
-    writeUtf8File (odir </> filename) (unlines contents)
+    writeUtf8File (odir </> filename) (stringUtf8 $ unlines contents)
 
 ppModule :: DynFlags -> UnitState -> Interface -> [String]
 ppModule dflags unit_state iface =

haddock-api/src/Haddock/Backends/LaTeX.hs

@@ -152,7 +152,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
 
       filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
 
-  writeUtf8File filename (show tex)
+  writeUtf8File filename (fromString (show tex))
 
 
 ppLaTeXModule :: Logger -> String -> FilePath -> Interface -> IO ()
@@ -185,7 +185,7 @@ ppLaTeXModule logger _title odir iface = timed $ do
 
       body = processExports exports
   --
-  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)
+  writeUtf8File (odir </> moduleLaTeXFile mdl) (fromString $ fullRender (PageMode True) 80 1 txtPrinter "" tex)
   where
     timed =
       withTiming logger (fromString ("ppLatexModule " ++ moduleString (ifaceMod iface))) (const ())

haddock-api/src/Haddock/Backends/Xhtml.hs

@@ -1,3 +1,5 @@
+{-# language OverloadedStrings #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html
@@ -95,7 +97,6 @@ ppHtml logger state doctitle maybe_package ifaces reexported_ifaces odir prologu
   let
     visible_ifaces = filter visible ifaces
     visible i = OptHide `notElem` ifaceOptions i
-
   when (isNothing maybe_contents_url) $
     ppHtmlContents logger state odir doctitle maybe_package
         themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
@@ -168,36 +169,36 @@ headHtml docTitle themes mathjax_url base_url =
 
 srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
 srcButton (Just src_base_url, _, _, _) Nothing =
-  Just (anchor ! [href src_base_url] << "Source")
+  Just (anchor ! [href src_base_url] << asText "Source")
 srcButton (_, Just src_module_url, _, _) (Just iface) =
   let url = spliceURL (Just $ ifaceOrigFilename iface)
                       (Just $ ifaceMod iface) Nothing Nothing src_module_url
-   in Just (anchor ! [href url] << "Source")
+   in Just (anchor ! [href url] << asText "Source")
 srcButton _ _ =
   Nothing
 
 
 wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
 wikiButton (Just wiki_base_url, _, _) Nothing =
-  Just (anchor ! [href wiki_base_url] << "User Comments")
+  Just (anchor ! [href wiki_base_url] << asText "User Comments")
 
 wikiButton (_, Just wiki_module_url, _) (Just mdl) =
   let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
-   in Just (anchor ! [href url] << "User Comments")
+   in Just (anchor ! [href url] << asText "User Comments")
 
 wikiButton _ _ =
   Nothing
 
 
 contentsButton :: Maybe String -> Maybe Html
 contentsButton maybe_contents_url
-  = Just (anchor ! [href url] << "Contents")
+  = Just (anchor ! [href url] << asText "Contents")
   where url = fromMaybe contentsHtmlFile maybe_contents_url
 
 
 indexButton :: Maybe String -> Maybe Html
 indexButton maybe_index_url
-  = Just (anchor ! [href url] << "Index")
+  = Just (anchor ! [href url] << asText "Index")
   where url = fromMaybe indexHtmlFile maybe_index_url
 
 
@@ -221,7 +222,7 @@ bodyHtml doctitle iface
       ],
     divContent << pageContent,
     divFooter << paragraph << (
-      "Produced by " +++
+      asText "Produced by " +++
       (anchor ! [href projectUrl] << toHtml projectName) +++
       (" version " ++ projectVersion)
       )
@@ -265,7 +266,7 @@ moduleInfo iface =
                 xs -> extField $ unordList xs ! [theclass "extension-list"]
             | otherwise = []
             where
-              extField x = return $ th << "Extensions" <-> td << x
+              extField x = return $ th << asText "Extensions" <-> td << x
               dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
    in
       case entries of
@@ -342,10 +343,10 @@ ppPrologue pkg qual title (Just doc) =
 ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
 ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
 ppSignatureTrees pkg qual [(info, ts)] =
-  divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
+  divPackageList << (sectionName << asText "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
 ppSignatureTrees pkg qual tss =
   divModuleList <<
-    (sectionName << "Signatures"
+    (sectionName << asText "Signatures"
      +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts
                     | (i, (info, ts)) <- zip [(1::Int)..] tss
                     ])
@@ -358,10 +359,10 @@ ppSignatureTree pkg qual p info ts =
 ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
 ppModuleTrees _ _ tss | all (null . snd) tss = mempty
 ppModuleTrees pkg qual [(info, ts)] =
-  divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)
+  divModuleList << (sectionName << asText "Modules" +++ ppModuleTree pkg qual "n" info ts)
 ppModuleTrees pkg qual tss =
   divPackageList <<
-    (sectionName << "Packages"
+    (sectionName << asText "Packages"
      +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts
                     | (i, (info, ts)) <- zip [(1::Int)..] tss
                     ])
@@ -408,7 +409,7 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
     subtree =
       if null ts then noHtml else
       collapseDetails p DetailsOpen (
-        thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++
+        thesummary ! [ theclass "hide-when-js-enabled" ] << asText "Submodules" +++
         mkNodeList pkg qual (s:ss) p ts
       )
 
@@ -502,7 +503,7 @@ ppJsonIndex logger odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifa
     mkIndex mdl qual item
       | Just item_html <- processExport True links_info unicode pkg qual item
       = Just JsonIndexEntry
-          { jieHtmlFragment = showHtmlFragment item_html
+          { jieHtmlFragment = builderToString $ showHtmlFragment item_html
           , jieName         = unwords (map getOccString names)
           , jieModule       = moduleString mdl
           , jieLink         = fromMaybe "" (listToMaybe (map (nameLink mdl) names))
@@ -639,9 +640,9 @@ ppHtmlIndex odir doctitle _maybe_package themes
                   toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
                    indexLinks nm entries
 
-    ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
-              | isDataOcc n      = toHtml "Data Constructor"
-              | otherwise        = toHtml "Function"
+    ppAnnot n | not (isValOcc n) = toHtml @String "Type/Class"
+              | isDataOcc n      = toHtml @String "Data Constructor"
+              | otherwise        = toHtml @String "Function"
 
     indexLinks nm entries =
        td ! [ theclass "module" ] <<
@@ -675,9 +676,9 @@ ppHtmlModule logger odir doctitle themes
                                     else ""
       mdl_str_linked
         | ifaceIsSig iface
-        = mdl_str +++ " (signature" +++
-                       sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
-                       ")"
+        = mdl_str +++ asText " (signature" +++
+                       sup << (asText "[" +++ anchor ! [href signatureDocURL] << asText "?" +++ asText "]" ) +++
+                       asText ")"
         | otherwise
         = toHtml mdl_str
       real_qual = makeModuleQual qual aliases mdl
@@ -718,7 +719,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
     no_doc_at_all = not (any has_doc exports)
 
     description | isNoHtml doc = doc
-                | otherwise    = divDescription $ sectionName << "Description" +++ doc
+                | otherwise    = divDescription $ sectionName << asText "Description" +++ doc
                 where doc = docSection Nothing pkg qual (ifaceRnDoc iface)
 
         -- omit the synopsis if there are no documentation annotations at all
@@ -727,7 +728,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
       | otherwise
       = divSynopsis $
             collapseDetails "syn" DetailsClosed (
-              thesummary << "Synopsis" +++
+              thesummary << asText "Synopsis" +++
               shortDeclList (
                   mapMaybe (processExport True linksInfo unicode pkg qual) exports
               ) ! collapseToggle "syn" ""
@@ -739,7 +740,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
       = case exports of
           [] -> noHtml
           ExportGroup {} : _ -> noHtml
-          _ -> h1 << "Documentation"
+          _ -> h1 << asText "Documentation"
 
     bdy =
       foldr (+++) noHtml $
@@ -761,12 +762,12 @@ ppModuleContents pkg qual exports orphan
   | otherwise                    = contentsDiv
  where
   contentsDiv = divTableOfContents << (divContentsList << (
-    (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++
+    (sectionName << asText "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++
     unordList (sections ++ orphanSection)))
 
   (sections, _leftovers{-should be []-}) = process 0 exports
   orphanSection
-    | orphan =  [ linkedAnchor "section.orphans" << "Orphan instances" ]
+    | orphan =  [ linkedAnchor "section.orphans" << asText "Orphan instances" ]
     | otherwise = []
 
   process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI])
@@ -818,7 +819,7 @@ processExport summary _ _ _ qual (ExportNoDecl y subs)
 processExport summary _ _ pkg qual (ExportDoc doc)
   = nothingIf summary $ docSection_ Nothing pkg qual doc
 processExport summary _ _ _ _ (ExportModule mdl)
-  = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
+  = processDeclOneLiner summary $ toHtml @String "module" <+> ppModule mdl
 
 
 nothingIf :: Bool -> a -> Maybe a

haddock-api/src/Haddock/Backends/Xhtml/Decl.hs

@@ -1,3 +1,5 @@
+{-# language OverloadedStrings #-}
+{-# language TypeApplications #-}
 {-# LANGUAGE TransformListComp #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE Rank2Types #-}
@@ -28,6 +30,7 @@ import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
 import Haddock.Types
 import Haddock.Doc (combineDocumentation)
+import Haddock.Utils
 
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
@@ -193,9 +196,9 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
     -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
     -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
     -- mode since `->` and `::` are rendered as single characters.
-    gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","
-    gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"
-    gadtOpen = toHtml "{"
+    gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml @String ","
+    gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml @String "}"
+    gadtOpen = toHtml @String "{"
 
 
 ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
@@ -205,6 +208,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
     ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<
                          (toHtml d <+> toHtml (show p) <+> ppNames ns)
 
+    ppDir :: FixityDirection -> Text
     ppDir InfixR = "infixr"
     ppDir InfixL = "infixl"
     ppDir InfixN = "infix"
@@ -369,7 +373,7 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info
 
 -- | Print the keywords that begin the family declaration
 ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html
-ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family")
+ppFamilyLeader assoc info = keyword (typ <> if assoc then "" else " family")
   where
     typ = case info of
        OpenTypeFamily     -> "type"
@@ -459,7 +463,7 @@ ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmp
 ppContextNoLocsMaybe [] _ _ emptyCtxts =
   case emptyCtxts of
     HideEmptyContexts -> Nothing
-    ShowEmptyToplevelContexts -> Just (toHtml "()")
+    ShowEmptyToplevelContexts -> Just (toHtml @String "()")
 ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
 
 ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
@@ -622,14 +626,15 @@ ppClassDecl summary links instances fixities loc d subdocs
         -> noHtml
 
       -- Minimal complete definition = nothing
-      And [] : _ -> subMinimal $ toHtml "Nothing"
+      And [] : _ -> subMinimal $ toHtml @String "Nothing"
 
       m : _  -> subMinimal $ ppMinimal False m
       _ -> noHtml
 
     ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
-    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs
-    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs
+    ppMinimal _ (And fs) =
+      foldr1 (\a b -> a +++ asText ", " +++b) $ map (ppMinimal True . unLoc) fs
+    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ asText " | " +++ b) $ map (ppMinimal False . unLoc) fs
       where wrap | p = parens | otherwise = id
     ppMinimal p (Parens x) = ppMinimal p (unLoc x)
 
@@ -706,7 +711,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m
             pdata = pref <+> typ
             pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
   where
-    mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
+    mname = maybe noHtml (\m -> toHtml @String "Defined in" <+> ppModule m) mdl
     iid = instanceId origin no orphan ihd
     typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
 
@@ -1018,7 +1023,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
     ppCtxt
       | null ctxt = noHtml
       | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts
-                      <+> darrow unicode +++ toHtml " "
+                      <+> darrow unicode +++ toHtml @String " "
 
 
 -- | Pretty-print a record field
@@ -1108,8 +1113,8 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
 
 
 ppBang :: HsSrcBang -> Html
-ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
-ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"
+ppBang (HsSrcBang _ _ SrcStrict) = toHtml @String "!"
+ppBang (HsSrcBang _ _ SrcLazy)   = toHtml @String "~"
 ppBang _                         = noHtml
 
 
@@ -1148,7 +1153,7 @@ ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocN
 ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
 ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
                                                        ppLParendType unicode qual emptyCtxts ki
-ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
+ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml @String ""
 
 class RenderableBndrFlag flag where
   ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html
@@ -1236,15 +1241,15 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
 
 -- UnicodeSyntax alternatives
 ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
-  | getOccString (getName name) == "(->)" = toHtml "(→)"
+  | getOccString (getName name) == "(->)" = toHtml @String "(→)"
 
 ppr_mono_ty (HsBangTy _ b ty) u q _ =
   ppBang b +++ ppLParendType u q HideEmptyContexts ty
 ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
   | isPromoted prom = promoQuote (ppDocName q Prefix True name)
   | otherwise = ppDocName q Prefix True name
 ppr_mono_ty (HsStarTy _ isUni) u _ _ =
-  toHtml (if u || isUni then "★" else "*")
+  toHtml @String (if u || isUni then "★" else "*")
 ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
   hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
        , arr <+> ppr_mono_lty ty2 u q e
@@ -1264,7 +1269,7 @@ ppr_mono_ty (HsListTy _ ty)       u q _ = brackets (ppr_mono_lty ty u q HideEmpt
 ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
   ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
 ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v
-ppr_mono_ty (HsRecTy {})        _ _ _ = toHtml "{..}"
+ppr_mono_ty (HsRecTy {})        _ _ _ = toHtml @String "{..}"
        -- Can now legally occur in ConDeclGADT, the output here is to provide a
        -- placeholder in the signature, which is followed by the field
        -- declarations.