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.

4 files changed, 28 insertions, 33 deletions

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 00c119fa..2ed25542 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -14,7 +14,7 @@
 -----------------------------------------------------------------------------
 module Haddock.Interface.Create (createInterface) where
 
-import Documentation.Haddock.Doc (docAppend)
+import Documentation.Haddock.Doc (metaDocAppend)
 import Haddock.Types
 import Haddock.Options
 import Haddock.GhcUtils
@@ -256,19 +256,19 @@ mkMaps dflags gre instances decls =
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
 
-    f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
-    f' = M.fromListWith docAppend . concat
+    f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
+    f' = M.fromListWith metaDocAppend . concat
 
     mappings :: (LHsDecl Name, [HsDocString])
-             -> ( [(Name, Doc Name)]
-                , [(Name, Map Int (Doc Name))]
+             -> ( [(Name, MDoc Name)]
+                , [(Name, Map Int (MDoc Name))]
                 , [(Name, [Name])]
                 , [(Name,  [LHsDecl Name])]
                 )
     mappings (ldecl, docStrs) =
       let L l decl = ldecl
           declDoc :: [HsDocString] -> Map Int HsDocString
-                  -> (Maybe (Doc Name), Map Int (Doc Name))
+                  -> (Maybe (MDoc Name), Map Int (MDoc Name))
           declDoc strs m =
             let doc' = processDocStrings dflags gre strs
                 m' = M.map (processDocStringParas dflags gre) m
@@ -641,7 +641,8 @@ hiValExportItem dflags name doc splice fixity = do
 
 
 -- | Lookup docs for a declaration from maps.
-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap
+           -> (DocForDecl Name, [(Name, DocForDecl Name)])
 lookupDocs n warnings docMap argMap subMap =
   let lookupArgDoc x = M.findWithDefault M.empty x argMap in
   let doc = (lookupDoc n, lookupArgDoc n) in
@@ -731,8 +732,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     expandSig = foldr f []
       where
         f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
-        f (L l (SigD (TypeSig    names t)))          xs = foldr (\n acc -> L l (SigD (TypeSig    [n] t))          : acc) xs names
-        f (L l (SigD (GenericSig names t)))          xs = foldr (\n acc -> L l (SigD (GenericSig [n] t))          : acc) xs names
+        f (L l (SigD (TypeSig    names t))) xs = foldr (\n acc -> L l (SigD (TypeSig    [n] t)) : acc) xs names
+        f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
         f x xs = x : xs
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index f1021436..35abf8a6 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -21,7 +21,7 @@ module Haddock.Interface.LexParseRn
 import Control.Applicative
 import Data.IntSet (toList)
 import Data.List
-import Documentation.Haddock.Doc (docConcat)
+import Documentation.Haddock.Doc (metaDocConcat)
 import DynFlags (ExtensionFlag(..), languageExtensions)
 import FastString
 import GHC
@@ -32,31 +32,26 @@ import Name
 import Outputable (showPpr)
 import RdrName
 
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
+                  -> Maybe (MDoc Name)
 processDocStrings dflags gre strs =
-  case docConcat $ map (processDocStringParas dflags gre) strs of
-    DocEmpty -> Nothing
+  case metaDocConcat $ map (processDocStringParas dflags gre) strs of
+    -- We check that we don't have any version info to render instead
+    -- of just checking if there is no comment: there may not be a
+    -- comment but we still want to pass through any meta data.
+    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing
     x -> Just x
 
-
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
-processDocStringParas = process parseParas
-
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
+processDocStringParas dflags gre (HsDocString fs) =
+  overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
 
 processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
-processDocString = process parseString
-
-process :: (DynFlags -> String -> Doc RdrName)
-        -> DynFlags
-        -> GlobalRdrEnv
-        -> HsDocString
-        -> Doc Name
-process parse dflags gre (HsDocString fs) =
-  rename dflags gre $ parse dflags (unpackFS fs)
-
+processDocString dflags gre (HsDocString fs) =
+  rename dflags gre $ parseString dflags (unpackFS fs)
 
 processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-                    -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+                    -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
 processModuleHeader dflags gre safety mayStr = do
   (hmi, doc) <-
     case mayStr of
@@ -66,7 +61,7 @@ processModuleHeader dflags gre safety mayStr = do
             (hmi, doc) = parseModuleHeader dflags str
             !descr = rename dflags gre <$> hmi_description hmi
             hmi' = hmi { hmi_description = descr }
-            doc' = rename dflags gre doc
+            doc' = overDoc (rename dflags gre) doc
         return (hmi', Just doc')
 
   let flags :: [ExtensionFlag]
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 6848dc63..d92e8b2a 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -25,7 +25,7 @@ import RdrName
 -- NB.  The headers must be given in the order Module, Description,
 -- Copyright, License, Maintainer, Stability, Portability, except that
 -- any or all may be omitted.
-parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName)
 parseModuleHeader dflags str0 =
    let
       getKey :: String -> String -> (Maybe String,String)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 748e0210..277d6ca9 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -12,7 +12,7 @@
 module Haddock.Interface.Rename (renameInterface) where
 
 
-import Data.Traversable (traverse)
+import Data.Traversable (traverse, Traversable)
 
 import Haddock.GhcUtils
 import Haddock.Types
@@ -160,10 +160,9 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
 renameLDocHsSyn = return
 
 
-renameDoc :: Doc Name -> RnM (Doc DocName)
+renameDoc :: Traversable t => t Name -> RnM (t DocName)
 renameDoc = traverse rename
 
-
 renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
 renameFnArgsDoc = mapM renameDoc