diff options
| -rw-r--r-- | compiler/basicTypes/RdrName.hs | 7 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 459 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 12 | ||||
| -rw-r--r-- | compiler/rename/RnPat.hs | 6 | ||||
| -rw-r--r-- | compiler/rename/RnUtils.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnExports.hs | 219 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/LookupSub.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/LookupSubA.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/LookupSubB.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/all.T | 1 |
12 files changed, 357 insertions, 377 deletions
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 3693373792..9e59c971d5 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -34,7 +34,8 @@ module RdrName ( -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, isStar, + isUniStar, -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, @@ -258,6 +259,10 @@ isExact_maybe :: RdrName -> Maybe Name isExact_maybe (Exact n) = Just n isExact_maybe _ = Nothing +isStar, isUniStar :: RdrName -> Bool +isStar = (fsLit "*" ==) . occNameFS . rdrNameOcc +isUniStar = (fsLit "ā
" ==) . occNameFS . rdrNameOcc + {- ************************************************************************ * * diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index db11287b26..d7facdc4f0 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -753,9 +753,9 @@ checkTyClHdr is_cls ty = goL head (args ++ acc) ann fixity go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix - | occNameFS (rdrNameOcc star) == fsLit "*" + | isStar star = return (L loc (nameRdrName starKindTyConName), [], fix, ann) - | occNameFS (rdrNameOcc star) == fsLit "ā
" + | isUniStar star = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 12c8557b96..902c10a379 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -5,7 +5,7 @@ RnEnv contains functions which convert RdrNames into Names. -} -{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-} module RnEnv ( newTopSrcBinder, @@ -17,6 +17,11 @@ module RnEnv ( lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, + lookupSubBndrOcc_helper, + ChildLookupResult(..), + + combineChildLookupResult, + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigCtxtOccRn, @@ -58,13 +63,12 @@ import ConLike import DataCon import TyCon import PrelNames ( rOOT_MAIN ) -import ErrUtils ( MsgDoc ) -import BasicTypes ( pprWarningTxtForMsg ) +import ErrUtils ( MsgDoc, ErrMsg ) +import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..)) import SrcLoc import Outputable import Util import Maybes -import BasicTypes ( TopLevelFlag(..) ) import DynFlags import FastString import Control.Monad @@ -72,6 +76,7 @@ import ListSetOps ( minusList ) import qualified GHC.LanguageExtensions as LangExt import RnUnbound import RnUtils +import Data.Functor (($>)) {- ********************************************************* @@ -223,6 +228,8 @@ OccName. We use OccName.isSymOcc to detect that case, which isn't terribly efficient, but there seems to be no better way. -} +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance lookupTopBndrRn :: RdrName -> RnM Name lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n case nopt of @@ -250,20 +257,9 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- The Haskell parser checks for the illegal qualified name in Haskell -- source files, so we don't need to do so here. -lookupTopBndrRn_maybe rdr_name - | Just name <- isExact_maybe rdr_name - = do { name' <- lookupExactOcc name; return (Just name') } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - -- This deals with the case of derived bindings, where - -- we don't bother to call newTopSrcBinder first - -- We assume there is no "parent" name - = do { loc <- getSrcSpanM - ; n <- newGlobalBinder rdr_mod rdr_occ loc - ; return (Just n)} - - | otherwise - = do { -- Check for operators in type or class declarations +lookupTopBndrRn_maybe rdr_name = + lookupExactOrOrig rdr_name Just $ + do { -- Check for operators in type or class declarations -- See Note [Type and class operator definitions] let occ = rdrNameOcc rdr_name ; when (isTcOcc occ && isSymOcc occ) @@ -388,7 +384,6 @@ lookupInstDeclBndr cls what rdr where doc = what <+> text "of class" <+> quotes (ppr cls) - ----------------------------------------------- lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) -- Used for TyData and TySynonym family instances only, @@ -420,6 +415,18 @@ lookupConstructorFields con_name ; traceTc "lookupCF 2" (ppr con) ; return (conLikeFieldLabels con) } } + +-- In CPS style as `RnM r` is monadic +lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = res <$> lookupExactOcc n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = res <$> lookupOrig rdr_mod rdr_occ + | otherwise = k + + + ----------------------------------------------- -- Used for record construction and pattern matching -- When the -XDisambiguateRecordFields flag is on, take account of the @@ -445,8 +452,186 @@ lookupRecFieldOcc parent doc rdr_name Right n -> return n } | otherwise + -- This use of Global is right as we are looking up a selector which + -- can only be defined at the top level. = lookupGlobalOccRn rdr_name + + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName + -> RnM ChildLookupResult +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name + | isUnboundName parent + -- Avoid an error cascade + = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + + let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) + -- Disambiguate the lookup based on the parent information. + -- The remaining GREs are things that we *could* export here, note that + -- this includes things which have `NoParent`. Those are sorted in + -- `checkPatSynParent`. + traceRn "parent" (ppr parent) + traceRn "lookupExportChild original_gres:" (ppr original_gres) + traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres) + case picked_gres original_gres of + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + -- Convert into FieldLabel if necessary + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g@GRE{gre_name, gre_par} = do + addUsedGRE warn_if_deprec g + return $ case gre_par of + FldParent _ mfs -> + FoundFL (fldParentToFieldLabel gre_name mfs) + _ -> FoundName gre_par gre_name + + fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel + fldParentToFieldLabel name mfs = + case mfs of + Nothing -> + let fs = occNameFS (nameOccName name) + in FieldLabel fs False name + Just fs -> FieldLabel fs True name + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + overload_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> return $ IncorrectParent parent + (gre_name g) (ppr $ gre_name g) + [p | Just p <- [getParent g]] + gss@(g:_:_) -> + if all isRecFldGRE gss && overload_ok + then return $ + IncorrectParent parent + (gre_name g) + (ppr $ expectJust "noMatchingParentErr" (greLabel g)) + [p | x <- gss, Just p <- [getParent x]] + else mkNameClashErr gss + + mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundName (gre_par (head gres)) (gre_name (head gres))) + + getParent :: GlobalRdrElt -> Maybe Name + getParent (GRE { gre_par = p } ) = + case p of + ParentIs cur_parent -> Just cur_parent + FldParent { par_is = cur_parent } -> Just cur_parent + NoParent -> Nothing + + picked_gres :: [GlobalRdrElt] -> DisambigInfo + picked_gres gres + | isUnqual rdr_name + = mconcat (map right_parent gres) + | otherwise + = mconcat (map right_parent (pickGREs rdr_name gres)) + + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent p + | Just cur_parent <- getParent p + = if parent == cur_parent + then DisambiguatedOccurrence p + else NoOccurrence + | otherwise + = UniqueOccurrence p + + +-- This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- The GRE could never be exported. It has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- The parent of the GRE is the correct parent + | AmbiguousOccurrence [GlobalRdrElt] + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Monoid DisambigInfo where + mempty = NoOccurrence + -- This is the key line: We prefer disambiguated occurrences to other + -- names. + _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g' + + + NoOccurrence `mappend` m = m + m `mappend` NoOccurrence = m + UniqueOccurrence g `mappend` UniqueOccurrence g' + = AmbiguousOccurrence [g, g'] + UniqueOccurrence g `mappend` AmbiguousOccurrence gs + = AmbiguousOccurrence (g:gs) + AmbiguousOccurrence gs `mappend` UniqueOccurrence g' + = AmbiguousOccurrence (g':gs) + AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs ++ gs') +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + = NameNotFound -- We couldn't find a suitable name + | NameErr ErrMsg -- We found an unambiguous name + -- but there's another error + -- we should abort from + | IncorrectParent Name -- Parent + Name -- Name of thing we were looking for + SDoc -- How to print the name + [Name] -- List of possible parents + | FoundName Parent Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL + +-- | Specialised version of msum for RnM ChildLookupResult +combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult +combineChildLookupResult [] = return NameNotFound +combineChildLookupResult (x:xs) = do + res <- x + case res of + NameNotFound -> combineChildLookupResult xs + _ -> return res + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundName _p n) = text "Found:" <+> ppr n + ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls + ppr (NameErr _) = text "Error" + ppr (IncorrectParent p n td ns) = text "IncorrectParent" + <+> hsep [ppr p, ppr n, td, ppr ns] + lookupSubBndrOcc :: Bool -> Name -- Parent -> SDoc @@ -454,57 +639,18 @@ lookupSubBndrOcc :: Bool -> RnM (Either MsgDoc Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n <- lookupExactOcc n - ; return (Right n) } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Right n) } +lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do + res <- + lookupExactOrOrig rdr_name (FoundName NoParent) $ + -- This happens for built-in classes, see mod052 for example + lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + case res of + NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) + FoundName _p n -> return (Right n) + FoundFL fl -> return (Right (flSelector fl)) + NameErr err -> reportError err $> (Right $ mkUnboundNameRdr rdr_name) + IncorrectParent {} -> return $ Left (unknownSubordinateErr doc rdr_name) - | isUnboundName the_parent - -- Avoid an error cascade from malformed decls: - -- instance Int where { foo = e } - -- We have already generated an error in rnLHsInstDecl - = return (Right (mkUnboundNameRdr rdr_name)) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! - -- The latter does pickGREs, but we want to allow 'x' - -- even if only 'M.x' is in scope - ; traceRn "lookupSubBndrOcc" - (vcat [ ppr the_parent, ppr rdr_name - , ppr gres, ppr (pick_gres rdr_name gres)]) - ; case pick_gres rdr_name gres of - (gre:_) -> do { addUsedGRE warn_if_deprec gre - -- Add a usage; this is an *occurrence* site - -- Note [Usage for sub-bndrs] - ; return (Right (gre_name gre)) } - -- If there is more than one local GRE for the - -- same OccName 'f', that will be reported separately - -- as a duplicate top-level binding for 'f' - [] -> do { ns <- lookupQualifiedNameGHCi rdr_name - ; case ns of - (n:_) -> return (Right n) -- Unlikely to be more than one...? - [] -> return (Left (unknownSubordinateErr doc rdr_name)) - } } - where - -- If Parent = NoParent, just do a normal lookup - -- If Parent = Parent p then find all GREs that - -- (a) have parent p - -- (b) for Unqual, are in scope qualified or unqualified - -- for Qual, are in scope with that qualification - pick_gres rdr_name gres - | isUnqual rdr_name = filter right_parent gres - | otherwise = filter right_parent (pickGREs rdr_name gres) - - right_parent (GRE { gre_par = p }) - | ParentIs parent <- p = parent == the_parent - | FldParent { par_is = parent } <- p = parent == the_parent - | otherwise = False {- Note [Family instance binders] @@ -684,8 +830,8 @@ lookupKindOccRn rdr_name ; if | typeintype -> lookupTypeOccRn rdr_name -- With -XNoTypeInType, treat any usage of * in kinds as in scope -- this is a dirty hack, but then again so was the old * kind. - | is_star rdr_name -> return starKindTyConName - | is_uni_star rdr_name -> return unicodeStarKindTyConName + | isStar rdr_name -> return starKindTyConName + | isUniStar rdr_name -> return unicodeStarKindTyConName | otherwise -> lookupOccRn rdr_name } -- lookupPromotedOccRn looks up an optionally promoted RdrName. @@ -732,7 +878,7 @@ lookup_demoted rdr_name dflags , quotes (ppr name) <> dot ] star_info - | is_star rdr_name || is_uni_star rdr_name + | isStar rdr_name || isUniStar rdr_name = if xopt LangExt.TypeInType dflags then text "NB: With TypeInType, you must import" <+> ppr rdr_name <+> text "from Data.Kind" @@ -741,9 +887,6 @@ lookup_demoted rdr_name dflags | otherwise = empty -is_star, is_uni_star :: RdrName -> Bool -is_star = (fsLit "*" ==) . occNameFS . rdrNameOcc -is_uni_star = (fsLit "ā
" ==) . occNameFS . rdrNameOcc badVarInType :: RdrName -> RnM Name badVarInType rdr_name @@ -782,29 +925,27 @@ The final result (after the renamer) will be: HsTyVar ("Zero", DataName) -} --- Use this version to get tracing --- --- lookupOccRn_maybe, lookupOccRn_maybe' :: RdrName -> RnM (Maybe Name) --- lookupOccRn_maybe rdr_name --- = do { mb_res <- lookupOccRn_maybe' rdr_name --- ; gbl_rdr_env <- getGlobalRdrEnv --- ; local_rdr_env <- getLocalRdrEnv --- ; traceRn $ text "lookupOccRn_maybe" <+> --- vcat [ ppr rdr_name <+> ppr (getUnique (rdrNameOcc rdr_name)) --- , ppr mb_res --- , text "Lcl env" <+> ppr local_rdr_env --- , text "Gbl env" <+> ppr [ (getUnique (nameOccName (gre_name (head gres'))),gres') | gres <- occEnvElts gbl_rdr_env --- , let gres' = filter isLocalGRE gres, not (null gres') ] ] --- ; return mb_res } +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name + , globalLookup rdr_name ] lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) --- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just name -> return (Just name) ; - Nothing -> do - ; lookupGlobalOccRn_maybe rdr_name } } +lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id + +lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name])) +lookupOccRn_overloaded overload_ok + = lookupOccRnX_maybe global_lookup Left + where + global_lookup :: RdrName -> RnM (Maybe (Either Name [Name])) + global_lookup n = + runMaybeT . msum . map MaybeT $ + [ lookupGlobalOccRn_overloaded overload_ok n + , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ] + + lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level @@ -812,29 +953,19 @@ lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- for the GHCi case -- No filter function; does not report an error on failure -- Uses addUsedRdrName to record use and deprecations -lookupGlobalOccRn_maybe rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n' <- lookupExactOcc n; return (Just n') } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Just n) } - - | otherwise - = do { mb_gre <- lookupGreRn_maybe rdr_name - ; case mb_gre of { - Just gre -> return (Just (gre_name gre)) ; - Nothing -> - do { ns <- lookupQualifiedNameGHCi rdr_name +lookupGlobalOccRn_maybe rdr_name = + lookupExactOrOrig rdr_name Just $ + runMaybeT . msum . map MaybeT $ + [ fmap gre_name <$> lookupGreRn_maybe rdr_name + , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] -- This test is not expensive, -- and only happens for failed lookups - ; case ns of - (n:_) -> return (Just n) -- Unlikely to be more than one...? - [] -> return Nothing } } } lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. Adds an error message if the RdrName is not in scope. +-- You usually want to use "lookupOccRn" which also looks in the local +-- environment. lookupGlobalOccRn rdr_name = do { mb_name <- lookupGlobalOccRn_maybe rdr_name ; case mb_name of @@ -847,16 +978,9 @@ lookupInfoOccRn :: RdrName -> RnM [Name] -- It finds all the GREs that RdrName could mean, not complaining -- about ambiguity, but rather returning them all -- C.f. Trac #9881 -lookupInfoOccRn rdr_name - | Just n <- isExact_maybe rdr_name -- e.g. (->) - = return [n] - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return [n] } - - | otherwise - = do { rdr_env <- getGlobalRdrEnv +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (:[]) $ + do { rdr_env <- getGlobalRdrEnv ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) ; qual_ns <- lookupQualifiedNameGHCi rdr_name ; return (ns ++ (qual_ns `minusList` ns)) } @@ -870,62 +994,31 @@ lookupInfoOccRn rdr_name -- * Just (Right xs) -> name refers to one or more record selectors; -- if overload_ok was False, this list will be -- a singleton. -lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name])) -lookupOccRn_overloaded overload_ok rdr_name - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just name -> return (Just (Left name)) ; - Nothing -> do - { mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name - ; case mb_name of { - Just name -> return (Just name) ; - Nothing -> do - { ns <- lookupQualifiedNameGHCi rdr_name - -- This test is not expensive, - -- and only happens for failed lookups - ; case ns of - (n:_) -> return $ Just $ Left n -- Unlikely to be more than one...? - [] -> return Nothing } } } } } - -lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name])) -lookupGlobalOccRn_overloaded overload_ok rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n' <- lookupExactOcc n; return (Just (Left n')) } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Just (Left n)) } - | otherwise - = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of - [] -> return Nothing - [gre] | isRecFldGRE gre - -> do { addUsedGRE True gre - ; let - fld_occ :: FieldOcc Name - fld_occ - = FieldOcc (noLoc rdr_name) (gre_name gre) - ; return (Just (Right [fld_occ])) } - | otherwise - -> do { addUsedGRE True gre - ; return (Just (Left (gre_name gre))) } - gres | all isRecFldGRE gres && overload_ok - -- Don't record usage for ambiguous selectors - -- until we know which is meant - -> return - (Just (Right - (map (FieldOcc (noLoc rdr_name) . gre_name) - gres))) - gres -> do { addNameClashErrRn rdr_name gres - ; return (Just (Left (gre_name (head gres)))) } } +lookupGlobalOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) +lookupGlobalOccRn_overloaded overload_ok rdr_name = + lookupExactOrOrig rdr_name (Just . Left) $ + do { res <- lookupGreRn_helper rdr_name + ; case res of + GreNotFound -> return Nothing + OneNameMatch gre -> do + let wrapper = if isRecFldGRE gre then Right . (:[]) else Left + return $ Just (wrapper (gre_name gre)) + MultipleNames gres | all isRecFldGRE gres && overload_ok -> + -- Don't record usage for ambiguous selectors + -- until we know which is meant + return $ Just (Right (map gre_name gres)) + MultipleNames gres -> do + addNameClashErrRn rdr_name gres + return (Just (Left (gre_name (head gres)))) } -------------------------------------------------- -- Lookup in the Global RdrEnv of the module -------------------------------------------------- -data GreLookupResult = NameNotFound +data GreLookupResult = GreNotFound | OneNameMatch GlobalRdrElt | MultipleNames [GlobalRdrElt] @@ -941,9 +1034,10 @@ lookupGreRn_maybe rdr_name case res of OneNameMatch gre -> return $ Just gre MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) addNameClashErrRn rdr_name gres return $ Just (head gres) - _ -> return Nothing + GreNotFound -> return Nothing {- @@ -978,7 +1072,7 @@ lookupGreRn_helper :: RdrName -> RnM GreLookupResult lookupGreRn_helper rdr_name = do { env <- getGlobalRdrEnv ; case lookupGRE_RdrName rdr_name env of - [] -> return NameNotFound + [] -> return GreNotFound [gre] -> do { addUsedGRE True gre ; return (OneNameMatch gre) } gres -> return (MultipleNames gres) } @@ -991,7 +1085,7 @@ lookupGreAvailRn rdr_name = do mb_gre <- lookupGreRn_helper rdr_name case mb_gre of - NameNotFound -> + GreNotFound -> do traceRn "lookupGreAvailRn" (ppr rdr_name) name <- unboundName WL_Global rdr_name @@ -1003,7 +1097,8 @@ lookupGreAvailRn rdr_name return (unbound_name, avail unbound_name) -- Returning an unbound name here prevents an error -- cascade - OneNameMatch gre -> return (gre_name gre, availFromGRE gre) + OneNameMatch gre -> + return (gre_name gre, availFromGRE gre) {- @@ -1131,10 +1226,16 @@ all: we try to load the interface if we don't already have it, just as if there was an "import qualified M" declaration for every module. +For example, writing `Data.List.sort` will load the interface file for +`Data.List` as if the user had written `import qualified Data.List`. + If we fail we just return Nothing, rather than bleating about "attempting to use module āDā (./D.hs) which is not loaded" which is what loadSrcInterface does. +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + Note [Safe Haskell and GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We DONT do this Safe Haskell as we need to check imports. We can @@ -1142,6 +1243,8 @@ and should instead check the qualified import but at the moment this requires some refactoring so leave as a TODO -} + + lookupQualifiedNameGHCi :: RdrName -> RnM [Name] lookupQualifiedNameGHCi rdr_name = -- We want to behave as we would for a source file import here, @@ -1298,8 +1401,8 @@ lookupBindGroupOcc ctxt what rdr_name (gre:_) -> return (Right (gre_name gre)) } lookup_group bound_names -- Look in the local envt (not top level) - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; case mname of Just n | n `elemNameSet` bound_names -> return (Right n) | otherwise -> bale_out_with local_msg diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index ce22784bde..cf0326e3bf 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -121,12 +121,12 @@ rnExpr (HsVar (L l v)) | otherwise -> finishHsVar (L l name) ; - Just (Right [f@(FieldOcc (L _ fn) s)]) -> - return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s)) - , unitFV (selectorFieldOcc f)) ; - Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v) - PlaceHolder) - , mkFVs (map selectorFieldOcc fs)); + Just (Right [s]) -> + return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s)) + , unitFV s) ; + Just (Right fs@(_:_:_)) -> + return ( HsRecFld (Ambiguous (L l v) PlaceHolder) + , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } rnExpr (HsIPVar v) diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index ac3cf64cb7..7c4663c080 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -754,13 +754,13 @@ rnHsRecUpdFields flds ; let fvs' = case sel of Left sel_name -> fvs `addOneFV` sel_name - Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name + Right [sel_name] -> fvs `addOneFV` sel_name Right _ -> fvs lbl' = case sel of Left sel_name -> L loc (Unambiguous (L loc lbl) sel_name) - Right [FieldOcc lbl sel_name] -> - L loc (Unambiguous lbl sel_name) + Right [sel_name] -> + L loc (Unambiguous (L loc lbl) sel_name) Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder) ; return (L l (HsRecField { hsRecFieldLbl = lbl' diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index cdeb84883b..85977d6073 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -90,7 +90,6 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) - -- This function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- @@ -341,6 +340,7 @@ checkTupSize tup_size nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), nest 2 (text "Workaround: use nested tuples or define a data type")]) + {- ************************************************************************ * * diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index 1389e745df..7fd9a51b1a 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -12,8 +12,7 @@ import TcMType import TcType import RnNames import RnEnv -import RnUnbound ( reportUnboundName, mkUnboundNameRdr ) -import RnUtils ( addNameClashErrRn ) +import RnUnbound ( reportUnboundName ) import ErrUtils import Id import IdInfo @@ -31,7 +30,6 @@ import DataCon import PatSyn import FastString import Maybes -import qualified GHC.LanguageExtensions as LangExt import Util (capitalise) @@ -147,7 +145,7 @@ tcRnExports explicit_mod exports case mb_r of Just r -> return r Nothing -> addMessages msgs >> failM - else checkNoErrs $ do_it + else checkNoErrs do_it ; let final_ns = availsToNameSetWithSelectors final_avails ; traceRn "rnExports: Exports:" (ppr final_avails) @@ -399,28 +397,6 @@ isDoc _ = False -- --- Records the result of looking up a child. -data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | NameErr ErrMsg -- We found an unambiguous name - -- but there's another error - -- we should abort from - | FoundName Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL - -instance Outputable ChildLookupResult where - ppr NameNotFound = text "NameNotFound" - ppr (FoundName n) = text "Found:" <+> ppr n - ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls - ppr (NameErr _) = text "Error" - --- Left biased accumulation monoid. Chooses the left-most positive occurrence. -instance Monoid ChildLookupResult where - mempty = NameNotFound - NameNotFound `mappend` m2 = m2 - NameErr m `mappend` _ = NameErr m -- Abort from the first error - FoundName n1 `mappend` _ = FoundName n1 - FoundFL fls `mappend` _ = FoundFL fls lookupChildrenExport :: Name -> [Located RdrName] -> RnM ([Located Name], [Located FieldLabel]) @@ -443,11 +419,12 @@ lookupChildrenExport parent rdr_items = doOne n = do let bareName = unLoc n - lkup v = lookupExportChild parent (setRdrNameSpace bareName v) - - name <- tryChildLookupResult $ map lkup $ - (choosePossibleNamespaces (rdrNameSpace bareName)) + lkup v = lookupSubBndrOcc_helper False True + parent (setRdrNameSpace bareName v) + name <- combineChildLookupResult . map lkup $ + choosePossibleNamespaces (rdrNameSpace bareName) + traceRn "lookupChildrenExport" (ppr name) -- Default to data constructors for slightly better error -- messages let unboundName :: RdrName @@ -455,158 +432,26 @@ lookupChildrenExport parent rdr_items = then bareName else setRdrNameSpace bareName dataName - case name of + -- Might need to check here for FLs as well + name' <- case name of + FoundName NoParent n -> checkPatSynParent parent n + _ -> return name + + traceRn "lookupChildrenExport" (ppr name') + + case name' of NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName FoundFL fls -> return $ Right (L (getLoc n) fls) - FoundName name -> return $ Left (L (getLoc n) name) + FoundName _p name -> return $ Left (L (getLoc n) name) NameErr err_msg -> reportError err_msg >> failM - -tryChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult -tryChildLookupResult [x] = x -tryChildLookupResult (x:xs) = do - res <- x - case res of - FoundFL {} -> return res - FoundName {} -> return res - NameErr {} -> return res - _ -> tryChildLookupResult xs -tryChildLookupResult _ = panic "tryChildLookupResult:empty list" - + IncorrectParent p g td gs -> do + mkDcErrMsg p g td gs >>= reportError + failM -- | Also captures the current context mkNameErr :: SDoc -> TcM ChildLookupResult -mkNameErr errMsg = do - tcinit <- tcInitTidyEnv - NameErr <$> mkErrTcM (tcinit, errMsg) - - --- | Used in export lists to lookup the children. -lookupExportChild :: Name -> RdrName -> RnM ChildLookupResult -lookupExportChild parent rdr_name - | isUnboundName parent - -- Avoid an error cascade - = return (FoundName (mkUnboundNameRdr rdr_name)) - - | otherwise = do - gre_env <- getGlobalRdrEnv - - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) - -- Disambiguate the lookup based on the parent information. - -- The remaining GREs are things that we *could* export here, note that - -- this includes things which have `NoParent`. Those are sorted in - -- `checkPatSynParent`. - traceRn "lookupExportChild original_gres:" (ppr original_gres) - case picked_gres original_gres of - NoOccurrence -> - noMatchingParentErr original_gres - UniqueOccurrence g -> - checkPatSynParent parent (gre_name g) - DisambiguatedOccurrence g -> - checkFld g - AmbiguousOccurrence gres -> - mkNameClashErr gres - where - -- Convert into FieldLabel if necessary - checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name, gre_par} = do - addUsedGRE True g - return $ case gre_par of - FldParent _ mfs -> do - FoundFL (fldParentToFieldLabel gre_name mfs) - _ -> FoundName gre_name - - fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel - fldParentToFieldLabel name mfs = - case mfs of - Nothing -> - let fs = occNameFS (nameOccName name) - in FieldLabel fs False name - Just fs -> FieldLabel fs True name - - -- Called when we fine no matching GREs after disambiguation but - -- there are three situations where this happens. - -- 1. There were none to begin with. - -- 2. None of the matching ones were the parent but - -- a. They were from an overloaded record field so we can report - -- a better error - -- b. The original lookup was actually ambiguous. - -- For example, the case where overloading is off and two - -- record fields are in scope from different record - -- constructors, neither of which is the parent. - noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult - noMatchingParentErr original_gres = do - overload_ok <- xoptM LangExt.DuplicateRecordFields - case original_gres of - [] -> return NameNotFound - [g] -> mkDcErrMsg parent (gre_name g) [p | Just p <- [getParent g]] - gss@(g:_:_) -> - if all isRecFldGRE gss && overload_ok - then mkNameErr (dcErrMsg parent "record selector" - (expectJust "noMatchingParentErr" (greLabel g)) - [ppr p | x <- gss, Just p <- [getParent x]]) - else mkNameClashErr gss - - mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult - mkNameClashErr gres = do - addNameClashErrRn rdr_name gres - return (FoundName (gre_name (head gres))) - - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - FldParent { par_is = cur_parent } -> Just cur_parent - NoParent -> Nothing - - picked_gres :: [GlobalRdrElt] -> DisambigInfo - picked_gres gres - | isUnqual rdr_name = mconcat (map right_parent gres) - | otherwise = mconcat (map right_parent (pickGREs rdr_name gres)) - - - right_parent :: GlobalRdrElt -> DisambigInfo - right_parent p - | Just cur_parent <- getParent p - = if parent == cur_parent - then DisambiguatedOccurrence p - else NoOccurrence - | otherwise - = UniqueOccurrence p - --- This domain specific datatype is used to record why we decided it was --- possible that a GRE could be exported with a parent. -data DisambigInfo - = NoOccurrence - -- The GRE could never be exported. It has the wrong parent. - | UniqueOccurrence GlobalRdrElt - -- The GRE has no parent. It could be a pattern synonym. - | DisambiguatedOccurrence GlobalRdrElt - -- The parent of the GRE is the correct parent - | AmbiguousOccurrence [GlobalRdrElt] - -- For example, two normal identifiers with the same name are in - -- scope. They will both be resolved to "UniqueOccurrence" and the - -- monoid will combine them to this failing case. - -instance Monoid DisambigInfo where - mempty = NoOccurrence - -- This is the key line: We prefer disambiguated occurrences to other - -- names. Notice that two disambiguated occurences are not ambiguous as - -- there is an internal invariant that a list of `DisambigInfo` arises - -- from a list of GREs which all have the same OccName. Thus, if we ever - -- have two DisambiguatedOccurences then they must have arisen from the - -- same GRE and hence it's safe to discard one. - _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g' - DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g' - - - NoOccurrence `mappend` m = m - m `mappend` NoOccurrence = m - UniqueOccurrence g `mappend` UniqueOccurrence g' = AmbiguousOccurrence [g, g'] - UniqueOccurrence g `mappend` AmbiguousOccurrence gs = AmbiguousOccurrence (g:gs) - AmbiguousOccurrence gs `mappend` UniqueOccurrence g' = AmbiguousOccurrence (g':gs) - AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs' = AmbiguousOccurrence (gs ++ gs') - +mkNameErr errMsg = NameErr <$> mkErrTc errMsg @@ -672,7 +517,10 @@ checkPatSynParent :: Name -- ^ Type constructor -- a) Pattern Synonym Constructor -- b) A pattern synonym selector -> TcM ChildLookupResult -checkPatSynParent parent mpat_syn = do +checkPatSynParent parent mpat_syn + | isUnboundName parent -- Avoid an error cascade + = return (FoundName NoParent mpat_syn) + | otherwise = do parent_ty_con <- tcLookupTyCon parent mpat_syn_thing <- tcLookupGlobal mpat_syn let expected_res_ty = @@ -687,9 +535,9 @@ checkPatSynParent parent mpat_syn = do | isId i -> case idDetails i of RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p - _ -> mkDcErrMsg parent mpat_syn [] + _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) [] AConLike (PatSynCon p) -> handlePatSyn (psErr p) p - _ -> mkDcErrMsg parent mpat_syn [] + _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) [] where psErr = exportErrCtxt "pattern synonym" @@ -709,11 +557,11 @@ checkPatSynParent parent mpat_syn = do -- 2. See note [Types of TyCon] | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr -- 3. Is the head a type variable? - | Nothing <- mtycon = return (FoundName mpat_syn) + | Nothing <- mtycon = return (FoundName (ParentIs parent) mpat_syn) -- 4. Ok. Check they are actually the same type constructor. | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError -- 5. We passed! - | otherwise = return (FoundName mpat_syn) + | otherwise = return (FoundName (ParentIs parent) mpat_syn) where (_, _, _, _, _, res_ty) = patSynSig pat_syn @@ -839,11 +687,11 @@ dupExportWarn occ_name ie1 ie2 text "is exported by", quotes (ppr ie1), text "and", quotes (ppr ie2)] -dcErrMsg :: Outputable a => Name -> String -> a -> [SDoc] -> SDoc +dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc dcErrMsg ty_con what_is thing parents = text "The type constructor" <+> quotes (ppr ty_con) <+> text "is not the parent of the" <+> text what_is - <+> quotes (ppr thing) <> char '.' + <+> quotes thing <> char '.' $$ text (capitalise what_is) <> text "s can only be exported with their parent type constructor." $$ (case parents of @@ -851,10 +699,11 @@ dcErrMsg ty_con what_is thing parents = [_] -> text "Parent:" _ -> text "Parents:") <+> fsep (punctuate comma parents) -mkDcErrMsg :: Name -> Name -> [Name] -> TcM ChildLookupResult -mkDcErrMsg parent thing parents = do +mkDcErrMsg :: Name -> Name -> SDoc -> [Name] -> TcM ErrMsg +mkDcErrMsg parent thing thing_doc parents = do ty_thing <- tcLookupGlobal thing - mkNameErr (dcErrMsg parent (tyThingCategory' ty_thing) thing (map ppr parents)) + mkErrTc $ + dcErrMsg parent (tyThingCategory' ty_thing) thing_doc (map ppr parents) where tyThingCategory' :: TyThing -> String tyThingCategory' (AnId i) diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 53a8c8c28e..812ed0a266 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -78,7 +78,7 @@ module TcRnMonad( -- * Error message generation (type checker) addErrTc, addErrsTc, - addErrTcM, mkErrTcM, + addErrTcM, mkErrTcM, mkErrTc, failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, @@ -1197,6 +1197,10 @@ mkErrTcM (tidy_env, err_msg) err_info <- mkErrInfo tidy_env ctxt ; mkLongErrAt loc err_msg err_info } +mkErrTc :: MsgDoc -> TcM ErrMsg +mkErrTc msg = do { env0 <- tcInitTidyEnv + ; mkErrTcM (env0, msg) } + -- The failWith functions add an error message and cause failure failWithTc :: MsgDoc -> TcM a -- Add an error message and fail diff --git a/testsuite/tests/rename/should_compile/LookupSub.hs b/testsuite/tests/rename/should_compile/LookupSub.hs new file mode 100644 index 0000000000..a6daba9b20 --- /dev/null +++ b/testsuite/tests/rename/should_compile/LookupSub.hs @@ -0,0 +1,11 @@ +{-# Language NoImplicitPrelude #-} +module LookupSub where +import qualified LookupSubA +import qualified LookupSubB + +data FD = FD + +getEcho = FD + +instance LookupSubA.IODevice FD where + getEcho = getEcho diff --git a/testsuite/tests/rename/should_compile/LookupSubA.hs b/testsuite/tests/rename/should_compile/LookupSubA.hs new file mode 100644 index 0000000000..afcb84ec3a --- /dev/null +++ b/testsuite/tests/rename/should_compile/LookupSubA.hs @@ -0,0 +1,4 @@ +module LookupSubA where + +class IODevice a where + getEcho :: a diff --git a/testsuite/tests/rename/should_compile/LookupSubB.hs b/testsuite/tests/rename/should_compile/LookupSubB.hs new file mode 100644 index 0000000000..64555c2949 --- /dev/null +++ b/testsuite/tests/rename/should_compile/LookupSubB.hs @@ -0,0 +1,3 @@ +module LookupSubB where + +getEcho = undefined diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index e7ad719278..0b46f90e17 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -151,3 +151,4 @@ test('T12597', normal, compile, ['']) test('T12548', normal, compile, ['']) test('T13132', normal, compile, ['']) test('T13646', normal, compile, ['']) +test('LookupSub', [], multimod_compile, ['LookupSub', '-v0']) |