aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Interface.hs3
-rw-r--r--src/Haddock/Interface/Create.hs43
-rw-r--r--src/Haddock/Interface/LexParseRn.hs24
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs9
-rw-r--r--src/Haddock/Lex.x28
-rw-r--r--src/Haddock/Types.hs3
-rw-r--r--src/Main.hs2
-rw-r--r--tests/tests/Ticket112.hs9
-rw-r--r--tests/tests/Ticket112.html.ref116
9 files changed, 184 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"
diff --git a/tests/tests/Ticket112.hs b/tests/tests/Ticket112.hs
new file mode 100644
index 00000000..c9cd5117
--- /dev/null
+++ b/tests/tests/Ticket112.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash #-}
+
+module Ticket112 where
+
+import GHC.Prim
+
+-- | ...given a raw 'Addr#' to the string, and the length of the string.
+f :: a
+f = undefined
diff --git a/tests/tests/Ticket112.html.ref b/tests/tests/Ticket112.html.ref
new file mode 100644
index 00000000..9ff3a192
--- /dev/null
+++ b/tests/tests/Ticket112.html.ref
@@ -0,0 +1,116 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<!--Rendered using the Haskell Html Library v0.2-->
+<HTML
+><HEAD
+><META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=UTF-8"
+><TITLE
+>Ticket112</TITLE
+><LINK HREF="haddock.css" REL="stylesheet" TYPE="text/css"
+><SCRIPT SRC="haddock-util.js" TYPE="text/javascript"
+></SCRIPT
+><SCRIPT TYPE="text/javascript"
+>window.onload = function () {setSynopsis("mini_Ticket112.html")};</SCRIPT
+></HEAD
+><BODY
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD CLASS="topbar"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD
+><IMG SRC="haskell_icon.gif" WIDTH="16" HEIGHT="16" ALT=" "
+></TD
+><TD CLASS="title"
+></TD
+><TD CLASS="topbut"
+><A HREF="">Contents</A
+></TD
+><TD CLASS="topbut"
+><A HREF="">Index</A
+></TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="modulebar"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD
+><FONT SIZE="6"
+>Ticket112</FONT
+></TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="section1"
+>Synopsis</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="body"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD CLASS="decl"
+><A HREF="">f</A
+> :: a</TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="section1"
+>Documentation</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A NAME="v:f"
+><A NAME="v%3Af"
+></A
+></A
+><B
+>f</B
+> :: a</TD
+></TR
+><TR
+><TD CLASS="doc"
+>...given a raw <TT
+><A HREF="">Addr#</A
+></TT
+> to the string, and the length of the string.
+</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="botbar"
+>Produced by <A HREF="">Haddock</A
+> version 2.7.2</TD
+></TR
+></TABLE
+></BODY
+></HTML
+>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:54:44 +0000