aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Backends/LaTeX.hs26
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs25
-rw-r--r--src/Haddock/Interface/Rename.hs10
-rw-r--r--src/Haddock/Interface/Rn.hs19
-rw-r--r--src/Haddock/InterfaceFile.hs4
-rw-r--r--src/Haddock/Lex.x10
-rw-r--r--src/Haddock/Types.hs5
-rw-r--r--src/Haddock/Utils.hs2
9 files changed, 38 insertions, 65 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 45399963..ed8d4665 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -232,7 +232,7 @@ markupTag = Markup {
markupEmpty = str "",
markupString = str,
markupAppend = (++),
- markupIdentifier = box (TagInline "a") . str . out . head,
+ markupIdentifier = box (TagInline "a") . str . out,
markupModule = box (TagInline "a") . str,
markupEmphasis = box (TagInline "i"),
markupMonospaced = box (TagInline "tt"),
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 5c21f0cf..fc313888 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -22,8 +22,8 @@ import qualified Pretty
import GHC
import OccName
-import Name ( isTyConName, nameOccName )
-import RdrName ( rdrNameOcc, isRdrTc )
+import Name ( nameOccName )
+import RdrName ( rdrNameOcc )
import BasicTypes ( ipNameName )
import FastString ( unpackFS, unpackLitString )
@@ -997,9 +997,8 @@ latexMonoMunge c s = latexMunge c s
-------------------------------------------------------------------------------
-parLatexMarkup :: (a -> LaTeX) -> (a -> Bool)
- -> DocMarkup a (StringContext -> LaTeX)
-parLatexMarkup ppId isTyCon = Markup {
+parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
+parLatexMarkup ppId = Markup {
markupParagraph = \p v -> p v <> text "\\par" $$ text "",
markupEmpty = \_ -> empty,
markupString = \s v -> text (fixString v s),
@@ -1027,26 +1026,15 @@ parLatexMarkup ppId isTyCon = Markup {
Verb -> theid
Mono -> theid
Plain -> text "\\haddockid" <> braces theid
- where theid = ppId (choose id)
-
- -- If an id can refer to multiple things, we give precedence to type
- -- constructors. This should ideally be done during renaming from RdrName
- -- to Name, but since we will move this process from GHC into Haddock in
- -- the future, we fix it here in the meantime.
- -- TODO: mention this rule in the documentation.
- choose [] = error "empty identifier list in HsDoc"
- choose [x] = x
- choose (x:y:_)
- | isTyCon x = x
- | otherwise = y
+ where theid = ppId id
latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
-latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName)
+latexMarkup = parLatexMarkup ppVerbDocName
rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
-rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc
+rdrLatexMarkup = parLatexMarkup ppVerbRdrName
docToLaTeX :: Doc DocName -> LaTeX
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 93536834..05ce7dbb 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -28,17 +28,15 @@ import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
import GHC
-import Name
-import RdrName
-parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
-parHtmlMarkup ppId isTyCon = Markup {
+parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
+parHtmlMarkup ppId = Markup {
markupEmpty = noHtml,
markupString = toHtml,
markupParagraph = paragraph,
markupAppend = (+++),
- markupIdentifier = thecode . ppId . choose,
+ markupIdentifier = thecode . ppId,
markupModule = \m -> let (mdl,ref) = break (=='#') m
in ppModuleRef (mkModuleNoPackage mdl) ref,
markupEmphasis = emphasize,
@@ -53,17 +51,6 @@ parHtmlMarkup ppId isTyCon = Markup {
markupExample = examplesToHtml
}
where
- -- If an id can refer to multiple things, we give precedence to type
- -- constructors. This should ideally be done during renaming from RdrName
- -- to Name, but since we will move this process from GHC into Haddock in
- -- the future, we fix it here in the meantime.
- -- TODO: mention this rule in the documentation.
- choose [] = error "empty identifier list in HsDoc"
- choose [x] = x
- choose (x:y:_)
- | isTyCon x = x
- | otherwise = y
-
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
exampleToHtml (Example expression result) = htmlExample
@@ -77,17 +64,17 @@ parHtmlMarkup ppId isTyCon = Markup {
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
docToHtml :: Qualification -> Doc DocName -> Html
docToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName)
+ where fmt = parHtmlMarkup (ppDocName qual)
origDocToHtml :: Doc Name -> Html
origDocToHtml = markup fmt . cleanup
- where fmt = parHtmlMarkup ppName isTyConName
+ where fmt = parHtmlMarkup ppName
rdrDocToHtml :: Doc RdrName -> Html
rdrDocToHtml = markup fmt . cleanup
- where fmt = parHtmlMarkup ppRdrName isRdrTc
+ where fmt = parHtmlMarkup ppRdrName
docElement :: (Html -> Html) -> Html -> Html
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 88e64cfa..2c10146d 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -58,7 +58,7 @@ renameInterface renamingEnv warnings iface =
-- combine the missing names and filter out the built-ins, which would
-- otherwise allways be missing.
- missingNames = nub $ filter isExternalName
+ missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
(missingNames1 ++ missingNames2 ++ missingNames3)
-- filter out certain built in type constructors using their string
@@ -171,11 +171,9 @@ renameDoc d = case d of
DocParagraph doc -> do
doc' <- renameDoc doc
return (DocParagraph doc')
- DocIdentifier ids -> do
- lkp <- getLookupRn
- case [ n | (True, n) <- map lkp ids ] of
- ids'@(_:_) -> return (DocIdentifier ids')
- [] -> return (DocIdentifier (map Undocumented ids))
+ DocIdentifier x -> do
+ x' <- rename x
+ return (DocIdentifier x')
DocModule str -> return (DocModule str)
DocEmphasis doc -> do
doc' <- renameDoc doc
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
index d63524b6..57704db7 100644
--- a/src/Haddock/Interface/Rn.hs
+++ b/src/Haddock/Interface/Rn.hs
@@ -5,7 +5,7 @@ import Haddock.Types
import RnEnv ( dataTcOccs )
import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
-import Name ( Name )
+import Name ( Name, isTyConName )
import Outputable ( ppr, showSDoc )
rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
@@ -13,10 +13,6 @@ rnHaddockModInfo gre hmod =
let desc = hmi_description hmod
in hmod { hmi_description = fmap (rnDoc gre) desc }
-ids2string :: [RdrName] -> String
-ids2string [] = []
-ids2string (x:_) = showSDoc $ ppr x
-
data Id x = Id {unId::x}
instance Monad Id where (Id v)>>=f = f v; return = Id
@@ -38,13 +34,16 @@ rnDoc gre = unId . do_rn
doc' <- do_rn doc
return (DocParagraph doc')
- DocIdentifier ids -> do
- let choices = concatMap dataTcOccs ids
+ DocIdentifier x -> do
+ let choices = dataTcOccs x
let gres = concatMap (\rdrName ->
map gre_name (lookupGRE_RdrName rdrName gre)) choices
- case gres of
- [] -> return (DocMonospaced (DocString (ids2string ids)))
- ids' -> return (DocIdentifier ids')
+ return $ case gres of
+ [] -> DocMonospaced (DocString (showSDoc $ ppr x)) -- TODO: DocIdentifierRdrName
+ [a] -> DocIdentifier a
+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
+ -- If an id can refer to multiple things, we give precedence to type
+ -- constructors.
DocModule str -> return (DocModule str)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 64f8baab..c1b54b1b 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -65,9 +65,9 @@ binaryInterfaceMagic = 0xD0Cface
-- we version our interface files accordingly.
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 17
+binaryInterfaceVersion = 18
#elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 17
+binaryInterfaceVersion = 18
#else
#error Unknown GHC version
#endif
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 153f6677..f65aee8c 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -121,7 +121,7 @@ data Token
| TokDefStart
| TokDefEnd
| TokSpecial Char
- | TokIdent [RdrName]
+ | TokIdent RdrName
| TokString String
| TokURL String
| TokPic String
@@ -209,7 +209,7 @@ begin sc = \_ _ _ cont _ -> cont sc
ident :: Action
ident pos str sc cont dflags =
- case strToHsQNames dflags loc id of
+ case parseIdent dflags loc id of
Just names -> (TokIdent names, pos) : cont sc
Nothing -> (TokString str, pos) : cont sc
where id = init (tail str)
@@ -220,12 +220,12 @@ ident pos str sc cont dflags =
AlexPn _ line col ->
mkRealSrcLoc filename line col
-strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]
-strToHsQNames dflags loc str0 =
+parseIdent :: DynFlags -> RealSrcLoc -> String -> Maybe RdrName
+parseIdent dflags loc str0 =
let buffer = stringToStringBuffer str0
pstate = mkPState dflags buffer loc
result = unP parseIdentifier pstate
in case result of
- POk _ name -> Just [unLoc name]
+ POk _ name -> Just (unLoc name)
_ -> Nothing
}
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index c9b29bd0..4989a067 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -275,7 +275,8 @@ data Doc id
| DocAppend (Doc id) (Doc id)
| DocString String
| DocParagraph (Doc id)
- | DocIdentifier [id]
+ | DocIdentifier id
+-- | DocIdentifierOutOfScope [RdrName]
| DocModule String
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
@@ -310,7 +311,7 @@ data DocMarkup id a = Markup
, markupString :: String -> a
, markupParagraph :: a -> a
, markupAppend :: a -> a -> a
- , markupIdentifier :: [id] -> a
+ , markupIdentifier :: id -> a
, markupModule :: String -> a
, markupEmphasis :: a -> a
, markupMonospaced :: a -> a
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 20598263..478025d8 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -384,7 +384,7 @@ markup m DocEmpty = markupEmpty m
markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s) = markupString m s
markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier ids) = markupIdentifier m ids
+markup m (DocIdentifier x) = markupIdentifier m x
markup m (DocModule mod0) = markupModule m mod0
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 12:24:16 +0000