Experimental support for collapsable headers

Closes #335

10 files changed, 296 insertions, 34 deletions

diff --git a/CHANGES b/CHANGES
index a8155673..009d63fe 100644
--- a/CHANGES
+++ b/CHANGES
@@ -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"
+      >&nbsp;</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"
+		>&gt;&gt;&gt; </code
+		><strong class="userinput"
+		><code
+		  >a
+</code
+		  ></strong
+		>b
+</pre
+	      ><pre class="screen"
+	      ><code class="prompt"
+		>&gt;&gt;&gt; </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 = ()