aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/LexParseRn.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface/LexParseRn.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs73
1 files changed, 45 insertions, 28 deletions
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 5d3cf2a6..87face7c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
@@ -18,11 +19,14 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
+import Avail
+import Control.Arrow
+import Control.Monad
import Data.List
+import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
import DynFlags (languageExtensions)
import qualified GHC.LanguageExtensions as LangExt
-import FastString
import GHC
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
@@ -44,14 +48,13 @@ processDocStrings dflags pkg gre strs = do
MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing
x -> pure (Just x)
-processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString
- -> ErrMsgM (MDoc Name)
-processDocStringParas dflags pkg gre (HsDocString fs) =
- overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs)
+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
+processDocStringParas dflags pkg gre hds =
+ overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
-processDocString dflags gre (HsDocString fs) =
- rename dflags gre $ parseString dflags (unpackFS fs)
+processDocString dflags gre hds =
+ rename dflags gre $ parseString dflags (unpackHDS hds)
processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
@@ -59,8 +62,8 @@ processModuleHeader dflags pkgName gre safety mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
- Just (L _ (HsDocString fs)) -> do
- let str = unpackFS fs
+ Just (L _ hds) -> do
+ let str = unpackHDS hds
(hmi, doc) = parseModuleHeader dflags pkgName str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
@@ -96,11 +99,9 @@ rename dflags gre = rn
-- 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
+ -- Lookup any GlobalRdrElts that match the choices.
+ case concatMap (\c -> lookupGRE_RdrName c gre) choices of
-- We found no names in the env so we start guessing.
[] ->
case choices of
@@ -119,12 +120,10 @@ rename dflags gre = rn
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier a)
+ [a] -> pure (DocIdentifier (gre_name a))
- -- But when there are multiple names available, default to
- -- type constructors: somewhat awfully GHC returns the
- -- values in the list positionally.
- a:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names
+ -- There are multiple names available.
+ gres -> ambiguous dflags x gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -165,20 +164,38 @@ outOfScope dflags x =
Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
where
warnAndMonospace a = do
- tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope."]
+ tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
+ " If you qualify the identifier, haddock can try to link it\n" ++
+ " it anyway."]
pure (monospaced a)
monospaced a = DocMonospaced (DocString (showPpr dflags a))
--- | Warn about an ambiguous identifier.
-ambiguous :: DynFlags -> RdrName -> Name -> [Name] -> ErrMsgM (Doc Name)
-ambiguous dflags x dflt names = do
- tell [msg]
+-- | Handle ambiguous identifiers.
+--
+-- Prefers local names primarily and type constructors or class names secondarily.
+--
+-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
+ambiguous :: DynFlags
+ -> RdrName
+ -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
+ -> ErrMsgM (Doc Name)
+ambiguous dflags x gres = do
+ let noChildren = map availName (gresToAvailInfo gres)
+ dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
+ msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+ " You may be able to disambiguate the identifier by qualifying it or\n" ++
+ " by hiding some imports.\n" ++
+ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ -- TODO: Once we have a syntax for namespace qualification (#667) we may also
+ -- want to emit a warning when an identifier is a data constructor for a type
+ -- of the same name, but not the only constructor.
+ -- For example, for @data D = C | D@, someone may want to reference the @D@
+ -- constructor.
+ when (length noChildren > 1) $ tell [msg]
pure (DocIdentifier dflt)
where
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") names ++
- " You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by hiding some imports.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
+ isLocalName _ = False
x_str = '\'' : showPpr dflags x ++ "'"
defnLoc = showSDoc dflags . pprNameDefnLoc