From b11f371fdc9197cb45a6dafbcc0b095273d6614f Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 3 Sep 2013 01:29:27 +0100 Subject: 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 --- src/Haddock/Backends/Hoogle.hs | 3 ++- src/Haddock/Backends/LaTeX.hs | 9 ++++++++- src/Haddock/Backends/Xhtml/DocMarkup.hs | 13 ++++++++++++- src/Haddock/Interface/LexParseRn.hs | 1 + src/Haddock/InterfaceFile.hs | 18 ++++++++++++++++-- src/Haddock/Parser.hs | 14 ++++++++++++-- src/Haddock/Types.hs | 16 ++++++++++++++++ src/Haddock/Utils.hs | 4 +++- test/Haddock/ParserSpec.hs | 19 +++++++++++++++++++ 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" -- cgit v1.2.3