diff options
Diffstat (limited to 'haddock-library')
4 files changed, 59 insertions, 10 deletions
diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs index 1c20555d..fe8cf99b 100644 --- a/haddock-library/src/Documentation/Haddock/Doc.hs +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -1,12 +1,30 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Documentation.Haddock.Doc (docParagraph, docAppend, docConcat) where +module Documentation.Haddock.Doc (docParagraph, docAppend, + docConcat, metaDocConcat, + metaDocAppend, emptyMetaDoc) where +import Data.Monoid (mempty, (<>)) import Documentation.Haddock.Types import Data.Char (isSpace) docConcat :: [DocH mod id] -> DocH mod id docConcat = foldr docAppend DocEmpty +-- | Like 'docConcat' but also joins the 'Meta' info. +metaDocConcat :: [MetaDoc mod id] -> MetaDoc mod id +metaDocConcat = foldr metaDocAppend emptyMetaDoc + +-- | We do something perhaps unexpected here and join the meta info +-- in ‘reverse’: this results in the metadata from the ‘latest’ +-- paragraphs taking precedence. +metaDocAppend :: MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id +metaDocAppend (MetaDoc { _meta = m, _doc = d }) + (MetaDoc { _meta = m', _doc = d' }) = + MetaDoc { _meta = m' <> m, _doc = d `docAppend` d' } + +emptyMetaDoc :: MetaDoc mod id +emptyMetaDoc = MetaDoc { _meta = mempty, _doc = DocEmpty } + docAppend :: DocH mod id -> DocH mod id -> DocH mod id docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 1cc277b8..b88a8c7f 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -86,9 +86,11 @@ parse p = either err id . parseOnly (p <* endOfInput) -- | Main entry point to the parser. Appends the newline character -- to the input string. parseParas :: String -- ^ String to parse - -> (Maybe Version, DocH mod Identifier) + -> MetaDoc mod Identifier parseParas input = case parseParasState input of - (state, a) -> (parserStateSince state, a) + (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state } + , _doc = a + } parseParasState :: String -> (ParserState, DocH mod Identifier) parseParasState = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 92ddeb7e..6f22efb5 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -15,8 +15,28 @@ module Documentation.Haddock.Types where import Data.Foldable +import Data.Monoid import Data.Traversable +-- | With the advent of 'Version', we may want to start attaching more +-- meta-data to comments. We make a structure for this ahead of time +-- so we don't have to gut half the core each time we want to add such +-- info. +newtype Meta = Meta { _version :: Maybe Version } deriving (Eq, Show) + +instance Monoid Meta where + mempty = Meta { _version = Nothing } + Meta { _version = v } `mappend` Meta { _version = v' } = + Meta { _version = v `mappend` v' } + +data MetaDoc mod id = + MetaDoc { _meta :: Meta + , _doc :: DocH mod id + } deriving (Eq, Show, Functor, Foldable, Traversable) + +overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d +overDoc f d = d { _doc = f $ _doc d } + type Version = [Int] data Hyperlink = Hyperlink diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 7b0ef78d..44ec2988 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -22,8 +22,8 @@ instance IsString (Doc String) where instance IsString a => IsString (Maybe a) where fromString = Just . fromString -parseParas :: String -> (Maybe Version, Doc String) -parseParas = fmap Parse.toRegular . Parse.parseParas +parseParas :: String -> MetaDoc () String +parseParas = overDoc Parse.toRegular . Parse.parseParas parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString @@ -358,7 +358,7 @@ spec = do describe "parseParas" $ do let infix 1 `shouldParseTo` shouldParseTo :: String -> Doc String -> Expectation - shouldParseTo input ast = snd (parseParas input) `shouldBe` ast + shouldParseTo input ast = _doc (parseParas input) `shouldBe` ast it "is total" $ do property $ \xs -> @@ -366,13 +366,20 @@ spec = do context "when parsing @since" $ do it "adds specified version to the result" $ do - parseParas "@since 0.5.0" `shouldBe` (Just [0,5,0], DocEmpty) + parseParas "@since 0.5.0" `shouldBe` + MetaDoc { _meta = Meta { _version = Just [0,5,0] } + , _doc = DocEmpty } it "ignores trailing whitespace" $ do - parseParas "@since 0.5.0 \t " `shouldBe` (Just [0,5,0], DocEmpty) + parseParas "@since 0.5.0 \t " `shouldBe` + MetaDoc { _meta = Meta { _version = Just [0,5,0] } + , _doc = DocEmpty } it "does not allow trailing input" $ do - parseParas "@since 0.5.0 foo" `shouldBe` (Nothing, DocParagraph "@since 0.5.0 foo") + parseParas "@since 0.5.0 foo" `shouldBe` + MetaDoc { _meta = Meta { _version = Nothing } + , _doc = DocParagraph "@since 0.5.0 foo" } + context "when given multiple times" $ do it "gives last occurrence precedence" $ do @@ -380,7 +387,9 @@ spec = do "@since 0.5.0" , "@since 0.6.0" , "@since 0.7.0" - ] `shouldBe` (Just [0,7,0], DocEmpty) + ] `shouldBe` MetaDoc { _meta = Meta { _version = Just [0,7,0] } + , _doc = DocEmpty } + context "when parsing text paragraphs" $ do let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) |