aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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"
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 10:57:43 +0000