Allow for headings inside function documentation.

LaTeX will treat the h3-h6 headings the same as we'd have to hack the
style file heavily otherwise and it would make the headings tiny
anyway.

Hoogle upstream said they will put in the functionality on their end.

Conflicts:
	src/Haddock/Interface/Rename.hs
	src/Haddock/Types.hs
	test/Haddock/ParserSpec.hs

9 files changed, 89 insertions, 8 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 521b0c90..1f098d6d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -257,7 +257,8 @@ markupTag dflags = Markup {
   markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
   markupAName                = const $ str "",
   markupProperty             = box TagPre . str,
-  markupExample              = box TagPre . str . unlines . map exampleToString
+  markupExample              = box TagPre . str . unlines . map exampleToString,
+  markupHeader               = \(Header l h) -> box (TagInline $ "h" ++ show l) h
   }
 
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index f4edb5fc..5f00d784 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1013,9 +1013,16 @@ parLatexMarkup ppId = Markup {
   markupHyperlink            = \l _ -> markupLink l,
   markupAName                = \_ _ -> empty,
   markupProperty             = \p _ -> quote $ verb $ text p,
-  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
+  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
+  markupHeader               = \(Header l h) p -> header l (h p)
   }
   where
+    header 1 d = text "\\section*" <> braces d
+    header 2 d = text "\\subsection*" <> braces d
+    header l d
+      | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
+    header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
+
     fixString Plain s = latexFilter s
     fixString Verb  s = s
     fixString Mono  s = latexMonoFilter s
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index ee77012f..ca963f48 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -53,9 +53,20 @@ parHtmlMarkup qual ppId = Markup {
   markupAName                = \aname -> namedAnchor aname << "",
   markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
   markupProperty             = pre . toHtml,
-  markupExample              = examplesToHtml
+  markupExample              = examplesToHtml,
+  markupHeader               = \(Header l t) -> makeHeader l t
   }
   where
+    makeHeader :: Int -> Html -> Html
+    makeHeader 1 mkup = h1 mkup
+    makeHeader 2 mkup = h2 mkup
+    makeHeader 3 mkup = h3 mkup
+    makeHeader 4 mkup = h4 mkup
+    makeHeader 5 mkup = h5 mkup
+    makeHeader 6 mkup = h6 mkup
+    makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+
+
     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
 
     exampleToHtml (Example expression result) = htmlExample
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 041b5be1..73f2c165 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -125,6 +125,7 @@ rename dflags gre = rn
       DocExamples e -> DocExamples e
       DocEmpty -> DocEmpty
       DocString str -> DocString str
+      DocHeader (Header l t) -> DocHeader $ Header l (rn t)
 
 dataTcOccs' :: RdrName -> [RdrName]
 -- If the input is a data constructor, return both it and a type
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 3024f212..6bf22c9b 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -437,7 +437,14 @@ instance Binary Picture where
         title <- get bh
         return (Picture uri title)
 
-
+instance Binary a => Binary (Header a) where
+    put_ bh (Header l t) = do
+        put_ bh l
+        put_ bh t
+    get bh = do
+        l <- get bh
+        t <- get bh
+        return (Header l t)
 
 {-* Generated by DrIFT : Look, but Don't Touch. *-}
 instance (Binary id) => Binary (Doc id) where
@@ -501,6 +508,10 @@ instance (Binary id) => Binary (Doc id) where
     put_ bh (DocBold x) = do
             putByte bh 19
             put_ bh x
+    put_ bh (DocHeader aa) = do
+            putByte bh 20
+            put_ bh aa
+
     get bh = do
             h <- getByte bh
             case h of
@@ -564,7 +575,10 @@ instance (Binary id) => Binary (Doc id) where
               19 -> do
                     x <- get bh
                     return (DocBold x)
-              _ -> fail "invalid binary data found"
+              20 -> do
+                    aa <- get bh
+                    return (DocHeader aa)
+              _ -> error "invalid binary data found in the interface file"
 
 
 instance Binary name => Binary (HaddockModInfo name) where
diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs
index 58d047f7..0d24cf17 100644
--- a/src/Haddock/Parser.hs
+++ b/src/Haddock/Parser.hs
@@ -14,7 +14,7 @@ module Haddock.Parser (parseString, parseParas, parseStringMaybe, parseParasMayb
 import           Prelude hiding (takeWhile)
 import           Control.Monad (void, mfilter)
 import           Control.Applicative
-import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, string, endOfLine)
+import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine)
 import qualified Data.ByteString.Char8 as BS
 import           Data.Char (chr, isAsciiUpper)
 import           Data.List (stripPrefix, intercalate)
@@ -168,7 +168,17 @@ picture = DocPic . makeLabeled Picture . decodeUtf8
 -- | Paragraph parser, called by 'parseParas'.
 paragraph :: DynFlags -> Parser (Doc RdrName)
 paragraph d = examples <|> skipSpace *> (list d <|> birdtracks <|> codeblock d
-                                         <|> property <|> textParagraph d)
+                                         <|> property <|> header d
+                                         <|> textParagraph d)
+
+header :: DynFlags -> Parser (Doc RdrName)
+header d = do
+  let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1]
+      pser = foldl1 (<|>) psers
+  delim <- decodeUtf8 <$> pser
+  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString d
+  rest <- paragraph d <|> return mempty
+  return $ docAppend (DocParagraph (DocHeader (Header (length delim) line))) rest
 
 textParagraph :: DynFlags -> Parser (Doc RdrName)
 textParagraph d = docParagraph . parseString d . intercalate "\n" <$> many1 nonEmptyLine
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index b847bfdb..27a6201f 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -309,8 +309,15 @@ data Doc id
   | DocAName String
   | DocProperty String
   | DocExamples [Example]
+  | DocHeader (Header (Doc id))
   deriving (Functor, Foldable, Traversable)
 
+instance Foldable Header where
+  foldMap f (Header _ a) = f a
+
+instance Traversable Header where
+  traverse f (Header l a) = Header l `fmap` f a
+
 instance NFData a => NFData (Doc a) where
   rnf doc = case doc of
     DocEmpty                  -> ()
@@ -333,6 +340,7 @@ instance NFData a => NFData (Doc a) where
     DocAName a                -> a `deepseq` ()
     DocProperty a             -> a `deepseq` ()
     DocExamples a             -> a `deepseq` ()
+    DocHeader a               -> a `deepseq` ()
 
 
 instance NFData Name
@@ -351,6 +359,13 @@ data Picture = Picture
   , pictureTitle :: Maybe String
   } deriving (Eq, Show)
 
+data Header id = Header
+  { headerLevel :: Int
+  , headerTitle :: id
+  } deriving Functor
+
+instance NFData id => NFData (Header id) where
+  rnf (Header a b) = a `deepseq` b `deepseq` ()
 
 instance NFData Hyperlink where
   rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
@@ -395,6 +410,7 @@ data DocMarkup id a = Markup
   , markupPic                  :: Picture -> a
   , markupProperty             :: String -> a
   , markupExample              :: [Example] -> a
+  , markupHeader               :: Header a -> a
   }
 
 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index eccf81ed..ee7bfd0a 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -433,6 +433,7 @@ markup m (DocAName ref)              = markupAName m ref
 markup m (DocPic img)                = markupPic m img
 markup m (DocProperty p)             = markupProperty m p
 markup m (DocExamples e)             = markupExample m e
+markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
 
 
 markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
@@ -461,7 +462,8 @@ idMarkup = Markup {
   markupAName                = DocAName,
   markupPic                  = DocPic,
   markupProperty             = DocProperty,
-  markupExample              = DocExamples
+  markupExample              = DocExamples,
+  markupHeader               = DocHeader
   }
 
 
diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs
index 8c8e25ca..b5a9561f 100644
--- a/test/Haddock/ParserSpec.hs
+++ b/test/Haddock/ParserSpec.hs
@@ -21,7 +21,9 @@ import           Helper
 instance Outputable a => Show a where
   show = showSDoc dynFlags . ppr
 
+deriving instance Show a => Show (Header a)
 deriving instance Show a => Show (Doc a)
+deriving instance Eq a => Eq (Header a)
 deriving instance Eq a => Eq (Doc a)
 
 instance IsString RdrName where
@@ -651,3 +653,20 @@ spec = before initStaticOpts $ do
             ("cat", "kitten\n")
           , ("pineapple", "fruit\n")
           ]
+
+    context "when parsing function documentation headers" $ do
+      it "can parse a simple header" $ do
+        "= Header 1\nHello." `shouldParseTo`
+          DocParagraph (DocHeader (Header 1 "Header 1"))
+          <> DocParagraph "Hello."
+
+      it "allow consecutive headers" $ do
+        "= Header 1\n== Header 2" `shouldParseTo`
+          DocParagraph (DocHeader (Header 1 "Header 1"))
+          <> DocParagraph (DocHeader (Header 2 "Header 2"))
+
+      it "accepts markup in the header" $ do
+        "= /Header/ __1__\nFoo" `shouldParseTo`
+          DocParagraph (DocHeader
+                        (Header 1 (DocEmphasis "Header" <> " " <> DocBold "1")))
+          <> DocParagraph "Foo"