aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2013-09-03 01:29:27 +0100
committerAustin Seipp <austin@well-typed.com>2014-01-12 14:48:35 -0600
commitb11f371fdc9197cb45a6dafbcc0b095273d6614f (patch)
tree47dcee8f16e17903dfa059ed9236f276d6cdf1b0
parentef9aa98d6ccbe79888c501f94c9aa6688520c28e (diff)
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
-rw-r--r--src/Haddock/Backends/Hoogle.hs3
-rw-r--r--src/Haddock/Backends/LaTeX.hs9
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs13
-rw-r--r--src/Haddock/Interface/LexParseRn.hs1
-rw-r--r--src/Haddock/InterfaceFile.hs18
-rw-r--r--src/Haddock/Parser.hs14
-rw-r--r--src/Haddock/Types.hs16
-rw-r--r--src/Haddock/Utils.hs4
-rw-r--r--test/Haddock/ParserSpec.hs19
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"