From 3fb325a2ca6b6397905116024922d079447a2e08 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Tue, 28 Oct 2014 21:57:49 +0000
Subject: Experimental support for collapsable headers
(cherry picked from commit e2ed3b9d8dfab09f1b1861dbc8e74f08e137ebcc)
---
src/Haddock/Backends/Xhtml.hs | 17 +++--
src/Haddock/Backends/Xhtml/Decl.hs | 14 +++--
src/Haddock/Backends/Xhtml/DocMarkup.hs | 106 +++++++++++++++++++++++++++++---
src/Haddock/Backends/Xhtml/Layout.hs | 9 +--
4 files changed, 117 insertions(+), 29 deletions(-)
(limited to 'src/Haddock/Backends')
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index b6a1190d..38382871 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -544,7 +544,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
description | isNoHtml doc = doc
| otherwise = divDescription $ sectionName << "Description" +++ doc
- where doc = docSection qual (ifaceRnDoc iface)
+ where doc = docSection Nothing qual (ifaceRnDoc iface)
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -592,7 +592,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0
map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
_ -> []
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
- [groupTag lvl << docToHtml qual txt]
+ [groupTag lvl << docToHtml Nothing qual txt]
processForMiniSynopsis _ _ _ _ = []
@@ -609,7 +609,6 @@ ppTyClBinderWithVarsMini mdl decl =
ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
-
ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
ppModuleContents qual exports
| null sections = noHtml
@@ -627,10 +626,10 @@ ppModuleContents qual exports
| lev <= n = ( [], items )
| otherwise = ( html:secs, rest2 )
where
- html = linkedAnchor (groupId id0)
- << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs
- (ssecs, rest1) = process lev rest
- (secs, rest2) = process n rest1
+ html = linkedAnchor (groupId id0)
+ << docToHtmlNoAnchors (Just id0) qual doc +++ mk_subsections ssecs
+ (ssecs, rest1) = process lev rest
+ (secs, rest2) = process n rest1
process n (_ : rest) = process n rest
mk_subsections [] = noHtml
@@ -652,7 +651,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
- = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
+ = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual doc
processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
= processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
@@ -662,7 +661,7 @@ processExport summary _ _ qual (ExportNoDecl y subs)
ppDocName qual Prefix True y
+++ parenList (map (ppDocName qual Prefix True) subs)
processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection_ qual doc
+ = nothingIf summary $ docSection_ Nothing qual doc
processExport summary _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 829c6668..d4869abd 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -28,6 +28,7 @@ import Haddock.GhcUtils
import Haddock.Types
import Haddock.Doc (combineDocumentation)
+import Control.Applicative
import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
@@ -89,7 +90,7 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
splice unicode qual
| summary = pref1
| otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
- +++ docSection qual doc
+ +++ docSection Nothing qual doc
where
pref1 = hsep [ toHtml "pattern"
, pp_cxt prov
@@ -130,10 +131,11 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
-> Splice -> Unicode -> Qualification -> Html
ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
| summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
| otherwise = topDeclElem links loc splice docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ docSection qual doc
+ subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc
where
+ curName = getName <$> listToMaybe docnames
argDoc n = Map.lookup n argDocs
do_largs n leader (L _ t) = do_args n leader t
@@ -263,7 +265,7 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ docSection qual doc +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit
where
docname = unLoc $ fdLName decl
@@ -439,7 +441,7 @@ ppClassDecl summary links instances fixities loc d subdocs
, tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
splice unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
- | otherwise = classheader +++ docSection qual d
+ | otherwise = classheader +++ docSection Nothing qual d
+++ minimalBit +++ atBit +++ methodBit +++ instancesBit
where
classheader
@@ -558,7 +560,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
splice unicode qual
| summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
where
docname = tcdName dataDecl
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 5e27d9b0..741e97e0 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -31,6 +31,7 @@ import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)
import GHC
+import Name
parHtmlMarkup :: Qualification -> Bool
-> (Bool -> a -> Html) -> DocMarkup a Html
@@ -86,26 +87,108 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+-- | We use this intermediate type to transform the input 'Doc' tree
+-- in an arbitrary way before rendering, such as grouping some
+-- elements. This is effectivelly a hack to prevent the 'Doc' type
+-- from changing if it is possible to recover the layout information
+-- we won't need after the fact.
+data Hack a id =
+ UntouchedDoc (DocH a id)
+ | CollapsingHeader (Header (DocH a id)) (DocH a id) Int (Maybe String)
+ | HackAppend (Hack a id) (Hack a id)
+ deriving Eq
+
+-- | Group things under bold 'DocHeader's together.
+toHack :: Int -- ^ Counter for header IDs which serves to assign
+ -- unique identifiers within the comment scope
+ -> Maybe String
+ -- ^ It is not enough to have unique identifier within the
+ -- scope of the comment: if two different comments have the
+ -- same ID for headers, the collapse/expand behaviour will act
+ -- on them both. This serves to make each header a little bit
+ -- more unique. As we can't export things with the same names,
+ -- this should work more or less fine: it is in fact the
+ -- implicit assumption the collapse/expand mechanism makes for
+ -- things like ‘Instances’ boxes.
+ -> [DocH a id] -> Hack a id
+toHack _ _ [] = UntouchedDoc DocEmpty
+toHack _ _ [x] = UntouchedDoc x
+toHack n nm (DocHeader (Header l (DocBold x)):xs) =
+ let -- Header with dropped bold
+ h = Header l x
+ -- Predicate for takeWhile, grab everything including ‘smaller’
+ -- headers
+ p (DocHeader (Header l' _)) = l' > l
+ p _ = True
+ -- Stuff ‘under’ this header
+ r = takeWhile p xs
+ -- Everything else that didn't make it under
+ r' = drop (length r) xs
+ app y [] = y
+ app y ys = HackAppend y (toHack (n + 1) nm ys)
+ in case r of
+ -- No content under this header
+ [] -> CollapsingHeader h DocEmpty n nm `app` r'
+ -- We got something out, stitch it back together into one chunk
+ y:ys -> CollapsingHeader h (foldl DocAppend y ys) n nm `app` r'
+toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs)
+
+-- | Remove ‘top-level’ 'DocAppend's turning them into a flat list.
+-- This lends itself much better to processing things in order user
+-- might look at them, such as in 'toHack'.
+flatten :: DocH a id -> [DocH a id]
+flatten (DocAppend x y) = flatten x ++ flatten y
+flatten x = [x]
+
+-- | Generate the markup needed for collapse to happen. For
+-- 'UntouchedDoc' and 'HackAppend' we do nothing more but
+-- extract/append the underlying 'Doc' and convert it to 'Html'. For
+-- 'CollapsingHeader', we attach extra info to the generated 'Html'
+-- that allows us to expand/collapse the content.
+hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html
+hackMarkup fmt h = case h of
+ UntouchedDoc d -> markup fmt d
+ CollapsingHeader (Header lvl titl) par n nm ->
+ let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
+ col' = collapseControl id_ True "caption"
+ instTable = (thediv ! collapseSection id_ True [] <<)
+ lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
+ getHeader = fromMaybe caption (lookup lvl lvs)
+ subCation = getHeader ! col' << markup fmt titl
+ in (subCation +++) . instTable $ markup fmt par
+ HackAppend d d' -> markupAppend fmt (hackMarkup fmt d) (hackMarkup fmt d')
+
+-- | Goes through 'hackMarkup' to generate the 'Html' rather than
+-- skipping straight to 'markup': this allows us to employ XHtml
+-- specific hacks to the tree before first.
+markupHacked :: DocMarkup id Html
+ -> Maybe String
+ -> Doc id
+ -> Html
+markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten
-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
-docToHtml :: Qualification -> Doc DocName -> Html
-docToHtml qual = markup fmt . cleanup
+docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
+ -- comments on 'toHack' for details.
+ -> Qualification -> Doc DocName -> Html
+docToHtml n qual = markupHacked fmt n . cleanup
where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
-docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html
-docToHtmlNoAnchors qual = markup fmt . cleanup
+docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
+ -> Qualification -> Doc DocName -> Html
+docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup
where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
origDocToHtml :: Qualification -> Doc Name -> Html
-origDocToHtml qual = markup fmt . cleanup
+origDocToHtml qual = markupHacked fmt Nothing . cleanup
where fmt = parHtmlMarkup qual True (const $ ppName Raw)
rdrDocToHtml :: Qualification -> Doc RdrName -> Html
-rdrDocToHtml qual = markup fmt . cleanup
+rdrDocToHtml qual = markupHacked fmt Nothing . cleanup
where fmt = parHtmlMarkup qual True (const ppRdrName)
@@ -116,12 +199,15 @@ docElement el content_ =
else el ! [theclass "doc"] << content_
-docSection :: Qualification -> Documentation DocName -> Html
-docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
+docSection :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Qualification -> Documentation DocName -> Html
+docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation
-docSection_ :: Qualification -> Doc DocName -> Html
-docSection_ qual = (docElement thediv <<) . docToHtml qual
+docSection_ :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Qualification -> Doc DocName -> Html
+docSection_ n qual =
+ (docElement thediv <<) . docToHtml (getOccString <$> n) qual
cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 253854c8..64930ef9 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -51,7 +51,6 @@ import Text.XHtml hiding ( name, title, p, quote )
import FastString ( unpackFS )
import GHC
-
--------------------------------------------------------------------------------
-- * Sections of the document
--------------------------------------------------------------------------------
@@ -134,7 +133,7 @@ subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
subEntry (decl, mdoc, subs) =
dterm ! [theclass "src"] << decl
+++
- docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+ docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs)
clearDiv = thediv ! [ theclass "clear" ] << noHtml
@@ -146,7 +145,7 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
subRow (decl, mdoc, subs) =
(td ! [theclass "src"] << decl
<->
- docElement td << fmap (docToHtml qual) mdoc)
+ docElement td << fmap (docToHtml Nothing qual) mdoc)
: map (cell . (td <<)) subs
@@ -175,7 +174,9 @@ subEquations :: Qualification -> [SubDecl] -> Html
subEquations qual = divSubDecls "equations" "Equations" . subTable qual
-subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances :: Qualification
+ -> String -- ^ Class name, used for anchor generation
+ -> [SubDecl] -> Html
subInstances qual nm = maybe noHtml wrap . instTable
where
wrap = (subSection <<) . (subCaption +++)
--
cgit v1.2.3