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.

7 files changed, 59 insertions, 53 deletions

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 33a2f7de..477bf09d 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -153,7 +153,8 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
   ghcExportedNames  = modInfoExports modInfo,
   ghcDefinedNames   = map getName $ modInfoTyThings modInfo,
   ghcNamesInScope   = fromJust $ modInfoTopLevelScope modInfo,
-  ghcInstances      = modInfoInstances modInfo
+  ghcInstances      = modInfoInstances modInfo,
+  ghcDynFlags       = dynflags
 }
   where
     mbOpts = haddockOptions dynflags
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,
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index fca2bf7f..e59b10ea 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -138,10 +138,10 @@ tokenPos t = let AlexPn _ line col = snd t in (line, col)
 -- Alex support stuff
 
 type StartCode = Int
-type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> [LToken]
+type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken]
 
-tokenise :: String -> (Int, Int) -> [LToken]
-tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
+tokenise :: DynFlags -> String -> (Int, Int) -> [LToken]
+tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
   where
     posn = AlexPn 0 line col
 
@@ -150,41 +150,41 @@ tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-tra
 		AlexEOF -> []
 		AlexError _ -> error "lexical error"
 		AlexSkip  inp' _       -> go inp' sc
-		AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc)
+		AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags
 
 -- NB. we add a final \n to the string, (see comment in the beginning of line
 -- production above).
 eofHack str = str++"\n"
 
 andBegin  :: Action -> StartCode -> Action
-andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont
+andBegin act new_sc = \pos str _ cont dflags -> act pos str new_sc cont dflags
 
 token :: Token -> Action
-token t = \pos _ sc cont -> (t, pos) : cont sc
+token t = \pos _ sc cont _ -> (t, pos) : cont sc
 
 strtoken, strtokenNL :: (String -> Token) -> Action
-strtoken t = \pos str sc cont -> (t str, pos) : cont sc
-strtokenNL t = \pos str sc cont -> (t (filter (/= '\r') str), pos) : cont sc
+strtoken t = \pos str sc cont _ -> (t str, pos) : cont sc
+strtokenNL t = \pos str sc cont _ -> (t (filter (/= '\r') str), pos) : cont sc
 -- ^ We only want LF line endings in our internal doc string format, so we
 -- filter out all CRs.
 
 begin :: StartCode -> Action
-begin sc = \_ _ _ cont -> cont sc
+begin sc = \_ _ _ cont _ -> cont sc
 
 -- -----------------------------------------------------------------------------
 -- Lex a string as a Haskell identifier
 
 ident :: Action
-ident pos str sc cont = 
-  case strToHsQNames id of
+ident pos str sc cont dflags = 
+  case strToHsQNames dflags id of
 	Just names -> (TokIdent names, pos) : cont sc
 	Nothing -> (TokString str, pos) : cont sc
  where id = init (tail str)
 
-strToHsQNames :: String -> Maybe [RdrName]
-strToHsQNames str0 = 
+strToHsQNames :: DynFlags -> String -> Maybe [RdrName]
+strToHsQNames dflags str0 = 
   let buffer = unsafePerformIO (stringToStringBuffer str0)
-      pstate = mkPState buffer noSrcLoc defaultDynFlags
+      pstate = mkPState buffer noSrcLoc dflags
       result = unP parseIdentifier pstate 
   in case result of 
        POk _ name -> Just [unLoc name] 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 610f958c..39209b17 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -156,7 +156,8 @@ data GhcModule = GhcModule {
    ghcExportedNames  :: [Name],
    ghcDefinedNames   :: [Name],
    ghcNamesInScope   :: [Name],
-   ghcInstances      :: [Instance]
+   ghcInstances      :: [Instance],
+   ghcDynFlags       :: DynFlags
 }
 
 
diff --git a/src/Main.hs b/src/Main.hs
index 571cb25e..67e4b877 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -408,7 +408,7 @@ getPrologue flags =
     [] -> return Nothing
     [filename] -> do
       str <- readFile filename
-      case parseParas (tokenise str (0,0) {- TODO: real position -}) of
+      case parseParas (tokenise defaultDynFlags str (0,0) {- TODO: real position -}) of
         Nothing -> throwE "parsing haddock prologue failed"
         Just doc -> return (Just doc)
     _otherwise -> throwE "multiple -p/--prologue options"