Fix #112

No link was generated for 'Addr#' in a doc comment. The reason was simply that
the identifier didn't parse. We were using parseIdentifier from the GHC API,
with a parser state built from 'defaultDynFlags'. If we pass the dynflags of
the module instead, the right options are turned on on while parsing the
identifer (in this case -XMagicHash), and the parse succeeds.

3 files changed, 40 insertions, 36 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 7a0a2e16..4af90017 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -42,7 +42,8 @@ createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
                 -> ErrMsgGhc Interface
 createInterface ghcMod flags modMap instIfaceMap = do
 
-  let mdl = ghcModule ghcMod
+  let mdl    = ghcModule ghcMod
+      dflags = ghcDynFlags ghcMod
 
   -- The pattern-match should not fail, because createInterface is only
   -- done on loaded modules.
@@ -53,9 +54,10 @@ createInterface ghcMod flags modMap instIfaceMap = do
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  (info, mbDoc)    <- liftErrMsg $ lexParseRnHaddockModHeader
+
+  (info, mbDoc)    <- liftErrMsg $ lexParseRnHaddockModHeader dflags
                                        gre (ghcMbDocHdr ghcMod)
-  decls0           <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
+  decls0           <- liftErrMsg $ declInfos dflags gre (topDecls (ghcGroup ghcMod))
 
   let instances      = ghcInstances ghcMod
       localInsts     = filter (nameIsLocalOrFrom mdl . getName) instances
@@ -71,7 +73,7 @@ createInterface ghcMod flags modMap instIfaceMap = do
   liftErrMsg $ warnAboutFilteredDecls mdl decls0
 
   exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap
-                               opts exports ignoreExps instances instIfaceMap
+                               opts exports ignoreExps instances instIfaceMap dflags
 
   let visibleNames = mkVisibleNames exportItems opts
 
@@ -168,22 +170,22 @@ mkDeclMap decls = Map.fromList . concat $
   , not (isDocD d), not (isInstD d) ]
 
 
-declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
-declInfos gre decls =
+declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
+declInfos dflags gre decls =
   forM decls $ \(parent@(L _ d), mbDocString) -> do
-            mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+            mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment
                        gre mbDocString
             fnArgsDoc <- fmap (Map.mapMaybe id) $
                 Traversable.forM (getDeclFnArgDocs d) $
-                \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+                \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
 
             let subs_ = subordinates d
             subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do
-                mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+                mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment
                               gre mbSubDocStr
                 subFnArgsDoc <- fmap (Map.mapMaybe id) $
                   Traversable.forM subFnArgsDocStr $
-                  \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+                  \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
                 return (subName, (mbSubDoc, subFnArgsDoc))
 
             return (parent, (mbDoc, fnArgsDoc), subs)
@@ -431,10 +433,11 @@ mkExportItems
   -> Bool               -- --ignore-all-exports flag
   -> [Instance]
   -> InstIfaceMap
+  -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 
 mkExportItems modMap this_mod gre exported_names decls declMap
-              opts maybe_exps ignore_all_exports _ instIfaceMap
+              opts maybe_exps ignore_all_exports _ instIfaceMap dflags
   | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
     = everything_local_exported
   | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps)
@@ -442,7 +445,7 @@ mkExportItems modMap this_mod gre exported_names decls declMap
 
 
     everything_local_exported =  -- everything exported
-      liftErrMsg $ fullContentsOfThisModule gre decls
+      liftErrMsg $ fullContentsOfThisModule dflags gre decls
 
 
     lookupExport (IEVar x) = declWith x
@@ -451,15 +454,15 @@ mkExportItems modMap this_mod gre exported_names decls declMap
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  = fullContentsOf m
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr)
+      ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
     lookupExport (IEDoc docStr)        = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+      ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
             (\doc -> return [ ExportDoc doc ])
     lookupExport (IEDocNamed str) = liftErrMsg $
       ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ])
             (\docStr ->
-            ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+            ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
                   (\doc -> return [ ExportDoc doc ]))
 
 
@@ -618,7 +621,7 @@ mkExportItems modMap this_mod gre exported_names decls declMap
 
 
     fullContentsOf modname
-      | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
+      | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls
       | otherwise =
           case Map.lookup m modMap of
             Just iface
@@ -666,14 +669,14 @@ mkExportItems modMap this_mod gre exported_names decls declMap
 -- (For more information, see Trac #69)
 
 
-fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]
-fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls
+fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]
+fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem decls
   where
     mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do
-        mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr
+        mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr
         return $ fmap (ExportGroup lev "") mbDoc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do
-        mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr
+        mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
         return $ fmap ExportDoc mbDoc
     mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs []
 
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 02fd4bc7..5b1dd8b5 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -31,20 +31,20 @@ import RdrName
 
 data HaddockCommentType = NormalHaddockComment | DocSectionComment
 
-lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockCommentList hty gre docStrs = do
-  docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs
+lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+lexParseRnHaddockCommentList dflags hty gre docStrs = do
+  docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
   let docs = catMaybes docMbs
   let doc = foldl docAppend DocEmpty docs
   case doc of
     DocEmpty -> return Nothing
     _ -> return (Just doc)
 
-lexParseRnHaddockComment :: HaddockCommentType ->
+lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
     GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment hty gre (HsDocString fs) = do
+lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
    let str = unpackFS fs
-   let toks = tokenise str (0,0) -- TODO: real position
+   let toks = tokenise dflags str (0,0) -- TODO: real position
    let parse = case hty of
          NormalHaddockComment -> parseParas
          DocSectionComment -> parseString
@@ -54,19 +54,19 @@ lexParseRnHaddockComment hty gre (HsDocString fs) = do
        return Nothing
      Just doc -> return (Just (rnDoc gre doc))
 
-lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnMbHaddockComment _ _ Nothing = return Nothing
-lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d
+lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
+lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
+lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
 
 -- yes, you always get a HaddockModInfo though it might be empty
-lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-lexParseRnHaddockModHeader gre mbStr = do
+lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+lexParseRnHaddockModHeader dflags gre mbStr = do
   let failure = (emptyHaddockModInfo, Nothing)
   case mbStr of
     Nothing -> return failure
     Just (L _ (HsDocString fs)) -> do
       let str = unpackFS fs
-      case parseModuleHeader str of
+      case parseModuleHeader dflags str of
         Left mess -> do
           tell ["haddock module header parse failed: " ++ mess]
           return failure
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 2bdd30a7..c28effad 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -17,6 +17,7 @@ import Haddock.Lex
 import Haddock.Parse
 
 import RdrName
+import DynFlags
 
 import Data.Char
 
@@ -26,8 +27,8 @@ import Data.Char
 -- 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 :: String -> Either String (HaddockModInfo RdrName, Doc RdrName)
-parseModuleHeader str0 =
+parseModuleHeader :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader dflags str0 =
    let
       getKey :: String -> String -> (Maybe String,String)
       getKey key str = case parseKey key str of
@@ -47,14 +48,14 @@ parseModuleHeader str0 =
       description1 = case descriptionOpt of
          Nothing -> Right Nothing
          -- TODO: pass real file position
-         Just description -> case parseString $ tokenise description (0,0) of
+         Just description -> case parseString $ tokenise dflags description (0,0) of
             Nothing -> Left ("Cannot parse Description: " ++ description)
             Just doc -> Right (Just doc)
    in
       case description1 of
          Left mess -> Left mess
          -- TODO: pass real file position
-         Right docOpt -> case parseParas $ tokenise str8 (0,0) of
+         Right docOpt -> case parseParas $ tokenise dflags str8 (0,0) of
            Nothing -> Left "Cannot parse header documentation paragraphs"
            Just doc -> Right (HaddockModInfo {
             hmi_description = docOpt,