From 6dee5e814d1934cbed458894e01b4913452422e6 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 00:05:58 +0000
Subject: [PATCH] Clearly default to variables in out of scope case
---
CHANGES | 3 +
.../src/Haddock/Interface/LexParseRn.hs | 63 ++++++++++++-------
2 files changed, 43 insertions(+), 23 deletions(-)
diff --git a/CHANGES b/CHANGES
index c988423d..419a7be7 100644
--- a/CHANGES
+++ b/CHANGES
@@ -32,6 +32,9 @@ Changes in version 2.16.0
* Deal better with long synopsis lines (#151)
+ * Don't default to type constructors for out-of-scope names (#253 and
+ #375)
+
Changes in version 2.15.0
* Always read in prologue files as UTF8 (#286 and Cabal #1721)
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 614e606b..14826eaa 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -30,6 +30,7 @@ import Haddock.Types
import Name
import Outputable (showPpr)
import RdrName
+import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-> Maybe (MDoc Name)
@@ -73,7 +74,13 @@ processModuleHeader dflags gre safety mayStr = do
where
failure = (emptyHaddockModInfo, Nothing)
-
+-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the
+-- definitions and a parsed comment and we attempt to make sense of
+-- where the identifiers in the comment point to. We're in effect
+-- trying to convert 'RdrName's to 'Name's, with some guesswork and
+-- fallbacks in case we can't locate the identifiers.
+--
+-- See the comments in the source for implementation commentary.
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
where
@@ -81,19 +88,36 @@ rename dflags gre = rn
DocAppend a b -> DocAppend (rn a) (rn b)
DocParagraph doc -> DocParagraph (rn doc)
DocIdentifier x -> do
- let choices = dataTcOccs' x
+ -- Generate the choices for the possible kind of thing this
+ -- is.
+ let choices = dataTcOccs x
+ -- Try to look up all the names in the GlobalRdrEnv that match
+ -- the names.
let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+
case names of
+ -- We found no names in the env so we start guessing.
[] ->
case choices of
[] -> DocMonospaced (DocString (showPpr dflags x))
- [a] -> outOfScope dflags a
- a:b:_ | isRdrTc a -> outOfScope dflags a
- | otherwise -> outOfScope dflags b
+ -- There was nothing in the environment so we need to
+ -- pick some default from what's available to us. We
+ -- diverge here from the old way where we would default
+ -- to type constructors as we're much more likely to
+ -- actually want anchors to regular definitions than
+ -- type constructor names (such as in #253). So now we
+ -- only get type constructor links if they are actually
+ -- in scope.
+ a:_ -> outOfScope dflags a
+
+ -- There is only one name in the environment that matches so
+ -- use it.
[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.
+ -- But when there are multiple names available, default to
+ -- type constructors: somewhat awfully GHC returns the
+ -- values in the list positionally.
+ a:b:_ | isTyConName a -> DocIdentifier a
+ | otherwise -> DocIdentifier b
DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
@@ -114,21 +138,14 @@ rename dflags gre = rn
DocString str -> DocString str
DocHeader (Header l t) -> DocHeader $ Header l (rn t)
-dataTcOccs' :: RdrName -> [RdrName]
--- If the input is a data constructor, return both it and a type
--- constructor. This is useful when we aren't sure which we are
--- looking at.
---
--- We use this definition instead of the GHC's to provide proper linking to
--- functions accross modules. See ticket #253 on Haddock Trac.
-dataTcOccs' rdr_name
- | isDataOcc occ = [rdr_name, rdr_name_tc]
- | otherwise = [rdr_name]
- where
- occ = rdrNameOcc rdr_name
- rdr_name_tc = setRdrNameSpace rdr_name tcName
-
-
+-- | Wrap an identifier that's out of scope (i.e. wasn't found in
+-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
+-- we simply monospace the identifier in most cases except when the
+-- identifier is qualified: if the identifier is qualified then we can
+-- still try to guess and generate anchors accross modules but the
+-- users shouldn't rely on this doing the right thing. See tickets
+-- #253 and #375 on the confusion this causes depending on which
+-- default we pick in 'rename'.
outOfScope :: DynFlags -> RdrName -> Doc a
outOfScope dflags x =
case x of
--
GitLab