aboutsummaryrefslogtreecommitdiff
path: root/haddock-library/src/Documentation
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-library/src/Documentation')
-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
3 files changed, 43 insertions, 3 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