diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/LexParseRn.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 73 |
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 |