aboutsummaryrefslogtreecommitdiff
path: root/haddock-library
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-12-09 07:00:07 +0000
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-12-10 00:58:24 +0000
commit12a066d96332b40f346621c9376c5c7328c92a0b (patch)
treecdfff73571b8c437a19d85035d28c639c77557cf /haddock-library
parentc67e63a1a426dc311ce4b1ad7c628b842d87024c (diff)
Allow the parser to spit out meta-info
Currently we only use it only for ‘since’ annotations but with these patches it should be fairly simple to add new attributes if we wish to. Closes #26. It seems to work fine but due to 7.10 rush I don't have the chance to do more exhaustive testing right now. The way the meta is output (emphasis at the end of the whole comment) is fairly arbitrary and subject to bikeshedding. Note that this makes test for Bug310 fail due to interface version bump: it can't find the docs for base with this interface version so it fails. There is not much we can do to help this because it tests for ’built-in’ identifier, not something we can provide ourselves.
Diffstat (limited to 'haddock-library')
-rw-r--r--haddock-library/src/Documentation/Haddock/Doc.hs20
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs6
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs20
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs23
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))