diff options
| -rw-r--r-- | CHANGES | 4 | ||||
| -rw-r--r-- | doc/haddock.xml | 23 | ||||
| -rw-r--r-- | haddock-api/haddock-api.cabal | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 17 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 14 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 106 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 9 | ||||
| -rw-r--r-- | haddock.cabal | 4 | ||||
| -rw-r--r-- | html-test/ref/Bug335.html | 125 | ||||
| -rw-r--r-- | html-test/src/Bug335.hs | 26 |
10 files changed, 296 insertions, 34 deletions
@@ -1,3 +1,7 @@ +Changes in version 2.15.1 + + * Experimental collapsible header support (#335) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/doc/haddock.xml b/doc/haddock.xml index 03970517..662aafd3 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -29,7 +29,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract> - <para>This document describes Haddock version 2.15.0, a Haskell + <para>This document describes Haddock version 2.15.1, a Haskell documentation tool.</para> </abstract> </bookinfo> @@ -2143,7 +2143,7 @@ This belongs to the list above! <programlisting> -- | --- = Heading level 1 with some __bold__ +-- = Heading level 1 with some /emphasis/ -- Something underneath the heading. -- -- == /Subheading/ @@ -2169,6 +2169,25 @@ This belongs to the list above! -- >>> examples are only allowed at the start of paragraphs </programlisting> + <para>As of 2.15.1, there's experimental (read: subject to + change or get removed) support for collapsible headers: simply + wrap your existing header title in underscores, as per bold + syntax. The collapsible section will stretch until the end of + the comment or until a header of equal or smaller number of + <literal>=</literal>s.</para> + +<programlisting> +-- | +-- === __Examples:__ +-- >>> Some very long list of examples +-- +-- ==== This still falls under the collapse +-- Some specialised examples +-- +-- === This is does not go into the collapsable section. +-- More content. +</programlisting> + </section> </section> diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 028ef5bf..5e49b4c8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,5 +1,5 @@ name: haddock-api -version: 2.15.0 +version: 2.15.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 9628a33d..3b085c8e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -542,7 +542,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 @@ -590,7 +590,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 _ _ _ _ = [] @@ -607,7 +607,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 @@ -625,10 +624,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 @@ -650,7 +649,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 []) @@ -660,7 +659,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/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7b30b52f..5e326019 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/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 @@ -262,7 +264,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 @@ -438,7 +440,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 @@ -557,7 +559,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/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 5e27d9b0..741e97e0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/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/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e84a57b3..c5d8b7a3 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/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 +++) diff --git a/haddock.cabal b/haddock.cabal index bb14ee6a..7bd2dfb5 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.15.0 +version: 2.15.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -108,7 +108,7 @@ executable haddock Haddock.GhcUtils Haddock.Convert else - build-depends: haddock-api == 2.15.0 + build-depends: haddock-api == 2.15.1 test-suite html-test type: exitcode-stdio-1.0 diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html new file mode 100644 index 00000000..76c39951 --- /dev/null +++ b/html-test/ref/Bug335.html @@ -0,0 +1,125 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug335</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe-Inferred</td + ></tr + ></table + ><p class="caption" + >Bug335</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >f</a + > :: ()</li + ><li class="src short" + ><a href="" + >g</a + > :: ()</li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:f" class="def" + >f</a + > :: ()</p + ><div class="doc" + ><h3 id="control.ch:f0" class="caption collapser" onclick="toggleSection('ch:f0')" + >ExF:</h3 + ><div id="section.ch:f0" class="show" + ><p + >abc</p + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:g" class="def" + >g</a + > :: ()</p + ><div class="doc" + ><h3 id="control.ch:g0" class="caption collapser" onclick="toggleSection('ch:g0')" + >ExG:</h3 + ><div id="section.ch:g0" class="show" + ><pre class="screen" + ><code class="prompt" + >>>> </code + ><strong class="userinput" + ><code + >a +</code + ></strong + >b +</pre + ><pre class="screen" + ><code class="prompt" + >>>> </code + ><strong class="userinput" + ><code + >c +</code + ></strong + >d +</pre + ><h4 + >Under ex</h4 + ><p + >foo</p + ></div + ><h2 + >Out of Ex</h2 + ><p + >foo</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.15.1</p + ></div + ></body + ></html +> diff --git a/html-test/src/Bug335.hs b/html-test/src/Bug335.hs new file mode 100644 index 00000000..c1821dd0 --- /dev/null +++ b/html-test/src/Bug335.hs @@ -0,0 +1,26 @@ +-- Tests for collapsable headers +module Bug335 where + +{-| +=== __ExF:__ +abc +-} +f :: () +f = () + +{-| +=== __ExG:__ +>>> a +b + +>>> c +d + +==== Under ex +foo + +== Out of Ex +foo +-} +g :: () +g = () |