Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - 24 changed files: - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Default.hs - libraries/xhtml - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html Changes: ===================================== hadrian/src/Rules/ToolArgs.hs ===================================== @@ -172,6 +172,7 @@ toolTargets = [ cabalSyntax , time , semaphoreCompat , unlit -- # executable + , xhtml ] ++ if windowsHost then [ win32 ] else [ unix ] -- | Create a mapping from files to which component it belongs to. ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -109,6 +109,7 @@ stage0Packages = do , thLift -- new library not yet present for boot compilers , thQuasiquoter -- new library not yet present for boot compilers , unlit + , xhtml -- new version is not backwards compat with latest , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version -- bundled with GHC 9.6 is too old for `semaphore-compat`. ===================================== libraries/xhtml ===================================== @@ -1 +1 @@ -Subproject commit 68353ccd1a2e776d6c2b11619265d8140bb7dc07 +Subproject commit cc203b9cc0a60c53a3bcbf2f38eb72cb7cf6098d ===================================== utils/haddock/cabal.project ===================================== @@ -12,4 +12,4 @@ package haddock-api tests: False -- Pinning the index-state helps to make reasonably CI deterministic -index-state: 2024-06-18T11:54:44Z +index-state: 2025-11-17T03:30:46Z ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -51,6 +51,7 @@ common extensions StrictData TypeApplications TypeOperators + OverloadedStrings default-language: Haskell2010 @@ -81,7 +82,7 @@ library build-depends: base >= 4.16 && < 4.23 , ghc ^>= 9.15 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , parsec ^>= 3.1.13.0 -- Versions for the dependencies below are transitively pinned by @@ -97,6 +98,7 @@ library , ghc-boot , mtl , transformers + , text hs-source-dirs: src @@ -212,7 +214,7 @@ test-suite spec build-depends: ghc ^>= 9.7 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , hspec ^>= 2.9 , parsec ^>= 3.1.13.0 , QuickCheck >= 2.11 && ^>= 2.14 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -134,7 +134,7 @@ out :: Outputable a => SDocContext -> a -> String out sDocContext = outWith $ Outputable.renderWithContext sDocContext operator :: String -> String -operator (x : xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x : xs ++ ")" +operator (x : xs) | not (isAlphaNum x) && x `notElem` ("_' ([{" :: String) = '(' : x : xs ++ ")" operator x = x commaSeparate :: Outputable a => SDocContext -> [a] -> String ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -28,10 +28,11 @@ import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Utils (renderToString) +import Haddock.Backends.Xhtml.Utils (renderToBuilder) import Haddock.InterfaceFile import Haddock.Types -import Haddock.Utils (Verbosity, out, verbose, writeUtf8File) +import Haddock.Utils (Verbosity, out, verbose) +import qualified Data.ByteString.Builder as Builder -- | Generate hyperlinked source for given interfaces. -- @@ -117,7 +118,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens + Builder.writeFile path . renderToBuilder pretty . render' thisModule fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -24,7 +24,9 @@ import qualified Text.XHtml as Html import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -type StyleClass = String +import qualified Data.Text.Lazy as LText + +type StyleClass = LText.Text -- | Produce the HTML corresponding to a hyperlinked Haskell source render @@ -50,7 +52,7 @@ body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml -header mcss mjs = Html.header $ css mcss <> js mjs +header mcss mjs = Html.header $ css (LText.pack <$> mcss) <> js (LText.pack <$> mjs) where css Nothing = Html.noHtml css (Just cssFile) = @@ -225,7 +227,7 @@ tokenStyle TkPragma = ["hs-pragma"] tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . unwords +multiclass = Html.theclass . LText.unwords externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html externalAnchor (Right name) contexts content @@ -250,11 +252,11 @@ internalAnchor (Right name) contexts content Html.thespan content ! [Html.identifier $ internalAnchorIdent name] internalAnchor _ _ content = content -externalAnchorIdent :: Name -> String -externalAnchorIdent = hypSrcNameUrl +externalAnchorIdent :: Name -> LText.Text +externalAnchorIdent name = LText.pack (hypSrcNameUrl name) -internalAnchorIdent :: Name -> String -internalAnchorIdent = ("l-" ++) . showUnique . nameUnique +internalAnchorIdent :: Name -> LText.Text +internalAnchorIdent = LText.pack . ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html @@ -269,16 +271,16 @@ hyperlink thisModule (srcs, srcs') ident = case ident of makeHyperlinkUrl url = ".." url internalHyperlink name content = - Html.anchor content ! [Html.href $ "#" ++ internalAnchorIdent name] + Html.anchor content ! [Html.href $ "#" <> internalAnchorIdent name] externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] + ! [Html.href $ LText.pack (hypSrcModuleNameUrl' thisModule mdl name)] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] Nothing -> content where mdl = nameModule name @@ -287,11 +289,11 @@ hyperlink thisModule (srcs, srcs') ident = case ident of case Map.lookup moduleName srcs' of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleUrl' moduleName] + ! [Html.href $ LText.pack $ hypSrcModuleUrl' moduleName] Just (SrcExternal path) -> let hyperlinkUrl = makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] Nothing -> content renderSpace :: Int -> String -> Html @@ -307,4 +309,4 @@ renderSpace line space = in Html.toHtml hspace <> renderSpace line rest lineAnchor :: Int -> Html -lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ hypSrcLineUrl line] +lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ LText.pack $ hypSrcLineUrl line] ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -51,6 +51,10 @@ import qualified System.IO as IO import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml import Prelude hiding (div) +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy as LBS import Haddock.Backends.Xhtml.Decl import Haddock.Backends.Xhtml.DocMarkup @@ -221,7 +225,7 @@ copyHtmlBits odir libdir themes withQuickjump = do headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html headHtml docTitle themes mathjax_url base_url = header - ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) base_url) + ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) (LText.pack <$> base_url)) << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle @@ -229,18 +233,18 @@ headHtml docTitle themes mathjax_url base_url = , thelink ! [ rel "stylesheet" , thetype "text/css" - , href (withBaseURL base_url quickJumpCssFile) + , href (LText.pack $ withBaseURL base_url quickJumpCssFile) ] << noHtml , thelink ! [rel "stylesheet", thetype "text/css", href fontUrl] << noHtml , script - ! [ src (withBaseURL base_url haddockJsFile) + ! [ src (LText.pack $ withBaseURL base_url haddockJsFile) , emptyAttr "async" , thetype "text/javascript" ] << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf - , script ! [src mjUrl, thetype "text/javascript"] << noHtml + , script ! [src (LText.pack mjUrl), thetype "text/javascript"] << noHtml ] where fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" @@ -257,31 +261,31 @@ 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 (LText.pack src_base_url)] << ("Source" :: LText)) srcButton (_, Just src_module_url, _, _) (Just iface) = let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url - in Just (anchor ! [href url] << "Source") + in Just (anchor ! [href (LText.pack url)] << ("Source" :: LText)) 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 (LText.pack wiki_base_url)] << ("User Comments" :: LText)) wikiButton (_, Just wiki_module_url, _) (Just mdl) = let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url - in Just (anchor ! [href url] << "User Comments") + in Just (anchor ! [href (LText.pack url)] << ("User Comments" :: LText)) wikiButton _ _ = Nothing contentsButton :: Maybe String -> Maybe Html contentsButton maybe_contents_url = - Just (anchor ! [href url] << "Contents") + Just (anchor ! [href (LText.pack url)] << ("Contents" :: LText)) where url = fromMaybe contentsHtmlFile maybe_contents_url indexButton :: Maybe String -> Maybe Html indexButton maybe_index_url = - Just (anchor ! [href url] << "Index") + Just (anchor ! [href (LText.pack url)] << ("Index" :: LText)) where url = fromMaybe indexHtmlFile maybe_index_url @@ -318,8 +322,8 @@ bodyHtml , divContent << pageContent , divFooter << paragraph - << ( "Produced by " - +++ (anchor ! [href projectUrl] << toHtml projectName) + << ( ("Produced by " :: LText) + +++ (anchor ! [href (LText.pack projectUrl)] << toHtml projectName) +++ (" version " ++ projectVersion) ) ] @@ -368,7 +372,7 @@ moduleInfo iface = xs -> extField $ unordList xs ! [theclass "extension-list"] | otherwise = [] where - extField x = return $ th << "Extensions" <-> td << x + extField x = return $ th << ("Extensions" :: LText) <-> td << x dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x in case entries of @@ -454,7 +458,7 @@ ppHtmlContents , ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, contentsHtmlFile]) (renderToBuilder debug html) where -- Extract a module's short description. toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) @@ -472,11 +476,11 @@ 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 << ("Signatures" :: LText) +++ ppSignatureTree pkg qual "n" info ts) ppSignatureTrees pkg qual tss = divModuleList << ( sectionName - << "Signatures" + << ("Signatures" :: LText) +++ concatHtml [ ppSignatureTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -491,11 +495,11 @@ 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 << ("Modules" :: LText) +++ ppModuleTree pkg qual "n" info ts) ppModuleTrees pkg qual tss = divPackageList << ( sectionName - << "Packages" + << ("Packages" :: LText) +++ concatHtml [ ppModuleTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -519,11 +523,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_ : _, Nothing) -> collapseControl p "module" + (_ : _, Nothing) -> collapseControl (LText.pack p) "module" (_, _) -> [theclass "module"] cBtn = case (ts, leaf) of - (_ : _, Just _) -> thespan ! collapseControl p "" << spaceHtml + (_ : _, Just _) -> thespan ! collapseControl (LText.pack p) "" << spaceHtml ([], Just _) -> thespan ! [theclass "noexpander"] << spaceHtml (_, _) -> noHtml -- We only need an explicit collapser button when the module name @@ -547,11 +551,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = then noHtml else collapseDetails - p + (LText.pack p) DetailsOpen ( thesummary ! [theclass "hide-when-js-enabled"] - << "Submodules" + << ("Submodules" :: LText) +++ mkNodeList pkg qual (s : ss) p ts ) @@ -650,10 +654,10 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins | Just item_html <- processExport True links_info unicode pkg qual item = Just JsonIndexEntry - { jieHtmlFragment = showHtmlFragment item_html + { jieHtmlFragment = Text.unpack (Text.decodeUtf8Lenient (LBS.toStrict (Builder.toLazyByteString (showHtmlFragment item_html)))) , jieName = unwords (map getOccString names) , jieModule = moduleString mdl - , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + , jieLink = LText.unpack $ fromMaybe "" (listToMaybe (map (nameLink mdl) names)) } | otherwise = Nothing where @@ -668,7 +672,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins exportName ExportNoDecl{expItemName} = [expItemName] exportName _ = [] - nameLink :: NamedThing name => Module -> name -> String + nameLink :: NamedThing name => Module -> name -> LText nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName links_info = (maybe_source_url, maybe_wiki_url) @@ -720,9 +724,9 @@ ppHtmlIndex mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + Builder.writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToBuilder debug mergedhtml) - writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, indexHtmlFile]) (renderToBuilder debug html) where indexPage showLetters ch items = headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing @@ -754,7 +758,7 @@ ppHtmlIndex indexInitialLetterLinks = divAlphabet << unordList - ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + ( map (\str -> anchor ! [href (LText.pack $ subIndexHtmlFile str)] << str) $ [ [c] | c <- initialChars, any (indexStartsWith c) index ] ++ [merged_name] @@ -773,7 +777,7 @@ ppHtmlIndex do_sub_index this_ix c = unless (null index_part) $ - writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + Builder.writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToBuilder debug html) where html = indexPage True (Just c) index_part index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] @@ -844,9 +848,9 @@ ppHtmlIndex <-> indexLinks nm entries ppAnnot n - | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" + | not (isValOcc n) = toHtml ("Type/Class" :: LText) + | isDataOcc n = toHtml ("Data Constructor" :: LText) + | otherwise = toHtml ("Function" :: LText) indexLinks nm entries = td @@ -909,10 +913,10 @@ ppHtmlModule mdl_str_linked | ifaceIsSig iface = mdl_str - +++ " (signature" + +++ (" (signature" :: LText) +++ sup - << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]") - +++ ")" + << (("[" :: LText) +++ anchor ! [href (LText.pack signatureDocURL)] << ("?" :: LText) +++ ("]" :: LText)) + +++ (")" :: LText) | otherwise = toHtml mdl_str real_qual = makeModuleQual qual mdl @@ -930,7 +934,7 @@ ppHtmlModule ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + Builder.writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToBuilder debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" @@ -965,7 +969,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = description | isNoHtml doc = doc - | otherwise = divDescription $ sectionName << "Description" +++ doc + | otherwise = divDescription $ sectionName << ("Description" :: LText) +++ doc where doc = docSection Nothing pkg qual (ifaceRnDoc iface) @@ -978,7 +982,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = "syn" DetailsClosed ( thesummary - << "Synopsis" + << ("Synopsis" :: LText) +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode pkg qual) exports ) @@ -991,7 +995,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = case exports of [] -> noHtml ExportGroup{} : _ -> noHtml - _ -> h1 << "Documentation" + _ -> h1 << ("Documentation" :: LText) bdy = foldr (+++) noHtml $ @@ -1017,7 +1021,7 @@ ppModuleContents pkg qual exports orphan contentsDiv = divTableOfContents << ( divContentsList - << ( (sectionName << "Contents") + << ( (sectionName << ("Contents" :: LText)) ! [strAttr "onclick" "window.scrollTo(0,0)"] +++ unordList (sections ++ orphanSection) ) @@ -1025,7 +1029,7 @@ ppModuleContents pkg qual exports orphan (sections, _leftovers {-should be []-}) = process 0 exports orphanSection - | orphan = [linkedAnchor "section.orphans" << "Orphan instances"] + | orphan = [linkedAnchor "section.orphans" << ("Orphan instances" :: LText)] | otherwise = [] process :: Int -> [ExportItem DocNameI] -> ([Html], [ExportItem DocNameI]) @@ -1035,7 +1039,7 @@ ppModuleContents pkg qual exports orphan | otherwise = (html : secs, rest2) where html = - linkedAnchor (groupId id0) + linkedAnchor (groupId (LText.pack id0)) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest @@ -1103,7 +1107,7 @@ processExport ) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = - nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) + nothingIf summary $ groupHeading lev (LText.pack id0) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ _ qual (ExportNoDecl y subs) = @@ -1113,7 +1117,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 ("module" :: LText) <+> ppModule mdl nothingIf :: Bool -> a -> Maybe a nothingIf True _ = Nothing @@ -1132,7 +1136,7 @@ processDeclOneLiner :: Bool -> Html -> Maybe Html processDeclOneLiner True = Just processDeclOneLiner False = Just . divTopDecl . declElem -groupHeading :: Int -> String -> Html -> Html +groupHeading :: Int -> LText -> Html -> Html groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] where grpId = groupId id0 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -45,6 +45,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.Doc (combineDocumentation) import Haddock.GhcUtils import Haddock.Types +import qualified Data.Text.Lazy as LText -- | Pretty print a declaration ppDecl @@ -352,9 +353,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 ("," :: LText) + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("}" :: LText) + gadtOpen = toHtml ("{" :: LText) ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml @@ -365,7 +366,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge ! [theclass "fixity"] << (toHtml d <+> toHtml (show p) <+> ppNames ns) - ppDir InfixR = "infixr" + ppDir InfixR = ("infixr" :: LText) ppDir InfixL = "infixl" ppDir InfixN = "infix" @@ -730,7 +731,7 @@ ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmp ppContextNoLocsMaybe [] _ _ emptyCtxts = case emptyCtxts of HideEmptyContexts -> Nothing - ShowEmptyToplevelContexts -> Just (toHtml "()") + ShowEmptyToplevelContexts -> Just (toHtml ("()" :: LText)) ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html @@ -1006,13 +1007,13 @@ ppClassDecl == [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml "Nothing" + And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) 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 +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) @@ -1115,7 +1116,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead{..}) md pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual DataInst {} -> error "ppInstHead" where - mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl + mname = maybe noHtml (\m -> toHtml ("Defined in" :: LText) <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual @@ -1163,9 +1164,9 @@ ppInstanceSigs links splice unicode qual sigs = do lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> LText instanceId origin no orphan ihd = - concat $ + LText.pack $ concat $ ["o:" | orphan] ++ [ qual origin , ":" ++ getOccString origin @@ -1529,7 +1530,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode - +++ toHtml " " + +++ toHtml (" " :: LText) -- | Pretty-print a record field ppSideBySideField @@ -1564,7 +1565,7 @@ ppSideBySideField subdocs unicode qual (HsConDeclRecField _ names ltype) = ppRecFieldMultAnn :: Unicode -> Qualification -> HsConDeclField DocNameI -> Html ppRecFieldMultAnn unicode qual (CDF { cdf_multiplicity = ann }) = case ann of HsUnannotated _ -> noHtml - HsLinearAnn _ -> toHtml "%1" + HsLinearAnn _ -> toHtml ("%1" :: LText) HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts ppShortField :: Bool -> Unicode -> Qualification -> HsConDeclRecField DocNameI -> Html @@ -1668,8 +1669,8 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- ppBang :: HsSrcBang -> Html -ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" -ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml ("!" :: LText) +ppBang (HsSrcBang _ _ SrcLazy) = toHtml ("~" :: LText) ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -1707,7 +1708,7 @@ ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) un ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg _ ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign <> ppLParendType unicode qual emptyCtxts ki -ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ("" :: LText) class RenderableBndrFlag flag where ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html @@ -1814,12 +1815,12 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ - | getOccString (getName name) == "(->)" = toHtml "(→)" + | getOccString (getName name) == "(->)" = toHtml ("(→)" :: LText) 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 (if u || isUni then "★" else "*" :: LText) ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts @@ -1842,7 +1843,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v ppr_mono_ty (XHsType (HsBangTy b ty)) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}" +ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml ("{..}" :: LText) -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs ===================================== @@ -39,6 +39,7 @@ import Haddock.Doc ) import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText parHtmlMarkup :: Qualification @@ -60,7 +61,7 @@ parHtmlMarkup qual insertAnchors ppId = mdl' = case reverse mdl of '\\' : _ -> init mdl _ -> mdl - in ppModuleRef lbl (mkModuleName mdl') ref + in ppModuleRef lbl (mkModuleName mdl') (LText.pack ref) , markupWarning = thediv ! [theclass "warning"] , markupEmphasis = emphasize , markupBold = strong @@ -73,14 +74,14 @@ parHtmlMarkup qual insertAnchors ppId = if insertAnchors then anchor - ! [href url] + ! [href (LText.pack url)] << fromMaybe (toHtml url) mLabel else fromMaybe (toHtml url) mLabel , markupAName = \aname -> if insertAnchors - then namedAnchor aname << "" + then namedAnchor (LText.pack aname) << ("" :: LText.Text) else noHtml - , markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)) + , markupPic = \(Picture uri t) -> image ! ([src (LText.pack uri)] ++ fromMaybe [] (return . title <$> (LText.pack <$> t))) , markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)") , markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]") , markupProperty = pre . toHtml @@ -121,7 +122,7 @@ parHtmlMarkup qual insertAnchors ppId = exampleToHtml (Example expression result) = htmlExample where htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) - htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlPrompt = (thecode . toHtml $ (">>> " :: LText.Text)) ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] makeOrdList :: HTML a => [(Int, a)] -> Html @@ -204,9 +205,9 @@ hackMarkup fmt' currPkg h' = hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> - let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n + let id_ = makeAnchorId $ "ch:" <> fromMaybe "noid:" (LText.pack <$> nm) <> LText.pack (show n) col' = collapseControl id_ "subheading" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Expand" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Expand" :: LText.Text) instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 ..] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs ===================================== @@ -63,6 +63,7 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -73,7 +74,7 @@ import Haddock.Utils (makeAnchorId, nameAnchorId) miniBody :: Html -> Html miniBody = body ! [identifier "mini"] -sectionDiv :: String -> Html -> Html +sectionDiv :: LText -> Html -> Html sectionDiv i = thediv ! [identifier i] sectionName :: Html -> Html @@ -138,11 +139,11 @@ divTopDecl = thediv ! [theclass "top"] type SubDecl = (Html, Maybe (MDoc DocName), [Html]) -divSubDecls :: HTML a => String -> a -> Maybe Html -> Html +divSubDecls :: LText -> LText -> Maybe Html -> Html divSubDecls cssClass captionName = maybe noHtml wrap where wrap = (subSection <<) . (subCaption +++) - subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subSection = thediv ! [theclass $ LText.unwords ["subs", cssClass]] subCaption = paragraph ! [theclass "caption"] << captionName subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html @@ -232,9 +233,9 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - hdr = h4 ! collapseControl id_ "instances" << "Instances" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instances details" - id_ = makeAnchorId $ "i:" ++ nm + hdr = h4 ! collapseControl id_ "instances" << ("Instances" :: LText) + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instances details" :: LText) + id_ = makeAnchorId $ "i:" <> (LText.pack nm) subOrphanInstances :: Maybe Package @@ -245,12 +246,12 @@ subOrphanInstances -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where - wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! [identifier ("section." ++ id_)] <<) . subTableSrc pkg qual lnks splice + wrap = ((h1 << ("Orphan instances" :: LText)) +++) + instTable = fmap (thediv ! [identifier ("section." <> id_)] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId "orphans" subInstHead - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) @@ -261,7 +262,7 @@ subInstHead iid hdr = expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents @@ -274,7 +275,7 @@ subInstDetails iid ats mets mdl = subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance @@ -285,16 +286,16 @@ subFamInstDetails iid fi mdl = subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -> Html subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) where - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instance details" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instance details" :: LText) -instAnchorId :: String -> String -instAnchorId iid = makeAnchorId $ "i:" ++ iid +instAnchorId :: LText -> LText +instAnchorId iid = makeAnchorId $ "i:" <> iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -321,7 +322,7 @@ topDeclElem lnks loc splice name html = -- Name must be documented, otherwise we wouldn't get here. links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = - srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") + srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << ("#" :: LText)) where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -335,15 +336,15 @@ links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docNa in case mUrl of Nothing -> noHtml Just url -> - let url' = spliceURL (Just origMod) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Source" + let url' = LText.pack $ spliceURL (Just origMod) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Source" :: LText) wikiLink = case maybe_wiki_url of Nothing -> noHtml Just url -> - let url' = spliceURL (Just mdl) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Comments" + let url' = LText.pack $ spliceURL (Just mdl) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Comments" :: LText) -- For source links, we want to point to the original module, -- because only that will have the source. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs ===================================== @@ -41,6 +41,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText -- | Indicator of how to render a 'DocName' into 'Html' data Notation @@ -171,7 +172,7 @@ linkIdOcc mdl mbName insertAnchors = then anchor ! [href url, title ttl] else id where - ttl = moduleNameString (moduleName mdl) + ttl = LText.pack (moduleNameString (moduleName mdl)) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name @@ -179,9 +180,9 @@ linkIdOcc mdl mbName insertAnchors = linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where - ttl = moduleNameString mdl + ttl = LText.pack (moduleNameString mdl) url = case mbName of - Nothing -> moduleHtmlFile' mdl + Nothing -> LText.pack (moduleHtmlFile' mdl) Just name -> moduleNameUrl' mdl name ppModule :: Module -> Html @@ -190,14 +191,14 @@ ppModule mdl = ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef :: Maybe Html -> ModuleName -> LText -> Html ppModuleRef Nothing mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << toHtml (moduleNameString mdl) ppModuleRef (Just lbl) mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << lbl -- NB: The ref parameter already includes the '#'. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs ===================================== @@ -27,6 +27,7 @@ import System.Directory import System.FilePath import Text.XHtml hiding (name, p, quote, title, ()) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Backends.Xhtml.Types (BaseURL, withBaseURL) import Haddock.Options @@ -185,10 +186,10 @@ styleSheet base_url ts = toHtml $ zipWith mkLink rels ts rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (withBaseURL base_url (themeHref t)) + ! [ href (LText.pack (withBaseURL base_url (themeHref t))) , rel aRel , thetype "text/css" - , XHtml.title (themeName t) + , XHtml.title (LText.pack (themeName t)) ] << noHtml ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -13,7 +13,7 @@ -- Stability : experimental -- Portability : portable module Haddock.Backends.Xhtml.Utils - ( renderToString + ( renderToBuilder , namedAnchor , linkedAnchor , spliceURL @@ -58,6 +58,7 @@ import GHC.Types.Name (getOccString, isValOcc, nameOccName) import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString) import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Utils @@ -118,8 +119,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run run ('%' : '{' : 'L' : 'I' : 'N' : 'E' : '}' : rest) = line ++ run rest run (c : rest) = c : run rest -renderToString :: Bool -> Html -> String -renderToString debug html +renderToBuilder :: Bool -> Html -> Builder +renderToBuilder debug html | debug = renderHtml html | otherwise = showHtml html @@ -136,7 +137,7 @@ infixr 8 <+> (<+>) :: Html -> Html -> Html a <+> b = a +++ sep +++ b where - sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml (" " :: LText) -- | Join two 'Html' values together with a linebreak in between. -- Has 'noHtml' as left identity. @@ -167,7 +168,7 @@ promoQuote h = char '\'' +++ h parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +pabrackets h = toHtml ("[:" :: LText) +++ h +++ toHtml (":]" :: LText) braces h = char '{' +++ h +++ char '}' punctuate :: Html -> [Html] -> [Html] @@ -188,37 +189,37 @@ ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma ubxSumList :: [Html] -> Html -ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") +ubxSumList = ubxparens . hsep . punctuate (toHtml (" | " :: LText)) ubxparens :: Html -> Html -ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" +ubxparens h = toHtml ("(#" :: LText) <+> h <+> toHtml ("#)" :: LText) dcolon, arrow, lollipop, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" +dcolon unicode = toHtml (if unicode then "∷" :: LText else "::") +arrow unicode = toHtml (if unicode then "→" :: LText else "->") +lollipop unicode = toHtml (if unicode then "⊸" :: LText else "%1 ->") +darrow unicode = toHtml (if unicode then "⇒" :: LText else "=>") +forallSymbol unicode = if unicode then toHtml ("∀" :: LText) else keyword "forall" atSign :: Html -atSign = toHtml "@" +atSign = toHtml ("@" :: LText) multAnnotation :: Html -multAnnotation = toHtml "%" +multAnnotation = toHtml ("%" :: LText) dot :: Html -dot = toHtml "." +dot = toHtml ("." :: LText) -- | Generate a named anchor -namedAnchor :: String -> Html -> Html +namedAnchor :: LText -> Html -> Html namedAnchor n = anchor ! [XHtml.identifier n] -linkedAnchor :: String -> Html -> Html -linkedAnchor n = anchor ! [href ('#' : n)] +linkedAnchor :: LText -> Html -> Html +linkedAnchor n = anchor ! [href ("#" <> n)] -- | generate an anchor identifier for a group -groupId :: String -> String -groupId g = makeAnchorId ("g:" ++ g) +groupId :: LText -> LText +groupId g = makeAnchorId ("g:" <> g) -- -- A section of HTML which is collapsible. @@ -226,7 +227,7 @@ groupId g = makeAnchorId ("g:" ++ g) data DetailsState = DetailsOpen | DetailsClosed -collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails :: LText -> DetailsState -> Html -> Html collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) where openAttrs = case state of DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] @@ -235,14 +236,14 @@ thesummary :: Html -> Html thesummary = tag "summary" -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle :: LText -> LText -> [HtmlAttr] collapseToggle id_ classes = [theclass cs, strAttr "data-details-id" id_] where - cs = unwords (words classes ++ ["details-toggle"]) + cs = LText.unwords (LText.words classes <> ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> String -> [HtmlAttr] +collapseControl :: LText -> LText -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs where - cs = unwords (words classes ++ ["details-toggle-control"]) + cs = LText.unwords (LText.words classes <> ["details-toggle-control"]) ===================================== utils/haddock/haddock-api/src/Haddock/Doc.hs ===================================== @@ -32,7 +32,7 @@ combineDocumentation (Documentation mDoc mWarning) = -- docCodeBlock :: DocH mod id -> DocH mod id docCodeBlock (DocString s) = - DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) + DocString (reverse $ dropWhile (`elem` (" \t" :: String)) $ reverse s) docCodeBlock (DocAppend l r) = DocAppend l (docCodeBlock r) docCodeBlock d = d ===================================== utils/haddock/haddock-api/src/Haddock/Utils.hs ===================================== @@ -83,6 +83,8 @@ import System.IO.Unsafe (unsafePerformIO) import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -184,35 +186,43 @@ subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" -- before being matched with IDs in the target document. ------------------------------------------------------------------------------- -moduleUrl :: Module -> String -moduleUrl = moduleHtmlFile +moduleUrl :: Module -> Text +moduleUrl module_ = LText.pack (moduleHtmlFile module_) -moduleNameUrl :: Module -> OccName -> String -moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n +moduleNameUrl :: Module -> OccName -> Text +moduleNameUrl mdl n = moduleUrl mdl <> "#" <> nameAnchorId n -moduleNameUrl' :: ModuleName -> OccName -> String -moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n +moduleNameUrl' :: ModuleName -> OccName -> Text +moduleNameUrl' mdl n = LText.pack (moduleHtmlFile' mdl) <> "#" <> nameAnchorId n -nameAnchorId :: OccName -> String -nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) +nameAnchorId :: OccName -> Text +nameAnchorId name = makeAnchorId (prefix <> ":" <> LText.pack (occNameString name)) where prefix - | isValOcc name = 'v' - | otherwise = 't' + | isValOcc name = "v" + | otherwise = "t" -- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is -- identity preserving. -makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r +makeAnchorId :: Text -> Text +makeAnchorId input = + case LText.uncons input of + Nothing -> LText.empty + Just (f, rest) -> + escape isAlpha f <> LText.concatMap (escape isLegal) rest where + escape :: (Char -> Bool) -> Char -> Text escape p c - | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" + | p c = LText.singleton c + | otherwise = + -- "-" <> show (ord c) <> "-" + LText.cons '-' (LText.pack (show (ord c) <> "-")) + + isLegal :: Char -> Bool isLegal ':' = True isLegal '_' = True isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c + isLegal c = isAscii c && isAlphaNum c -- NB: '-' is legal in IDs, but we use it as the escape char @@ -272,7 +282,7 @@ escapeURIString :: (Char -> Bool) -> String -> String escapeURIString = concatMap . escapeURIChar isUnreserved :: Char -> Bool -isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") +isUnreserved c = isAlphaNumChar c || (c `elem` ("-_.~" :: String)) isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') ===================================== utils/haddock/html-test/ref/Bug26.html ===================================== @@ -53,7 +53,7 @@ >Description</p ><div class="doc" >

This module tests the ‘@since …’ annotation.