diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 5293a86371994b514da370709701ea2afe37d9cb..635df5dde74ae27835898c74c9babac7a2a0a539 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -62,6 +62,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) import GHC.Tc.Gen.Match import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) +import GHC.Types.Hint ( GhcHint(SuggestSimilarNames), SimilarName(..) ) import GHC.Tc.Zonk.Type import GHC.Tc.Gen.Expr import GHC.Tc.Gen.App( tcInferSigma ) @@ -73,6 +74,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Instance.Family import GHC.Tc.Gen.Annotation import GHC.Tc.Gen.Bind +import GHC.Tc.Types.LclEnv (getLclEnvTypeEnv) import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule @@ -2779,8 +2781,34 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc $ mkTcRnNotInScope rdr_name NotInScope) + ; when (null names) $ giveErr ; return names } + where + giveErr = do { + ; lcl_env <- getLclEnv + ; names_in_scope <- + map greName + <$> filter (ok_gre <&&> isLocalGRE) + <$> globalRdrEnvElts <$> getGlobalRdrEnv + ; addErrTc $ notInScope names_in_scope lcl_env + } + occ = rdrNameOcc rdr_name + ns = occNameSpace occ + relevant_gres = + RelevantGREs + { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = True } + ok_gre = greIsRelevant relevant_gres ns + similar_names names_in_scope + = map SimilarName $ fuzzyLookup (unpackFS $ occNameFS $ occ) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) names_in_scope + hint names_in_scope = case (similar_names names_in_scope) of + (nm : nms) -> [SuggestSimilarNames rdr_name (nm NE.:| nms)] + _ -> [] + notInScope names_in_scope lcl_env = TcRnNotInScope NotInScope rdr_name [] (hint names_in_scope) + + tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) tcRnLookupName hsc_env name diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 9e4889a0103a233a417572a7c6ac6b085a22922a..5a8a1698127655de7bbf6fabd9cb4f035b1e9a48 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -106,11 +106,10 @@ import GHC.Unit.External import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding -import GHC.Utils.Misc ( HasDebugCallStack, fuzzyLookup, (<&&>) ) +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString import GHC.Data.Bag -import qualified Data.List.NonEmpty as NE import GHC.Data.List.SetOps import GHC.Data.Maybe( MaybeErr(..), orElse ) @@ -121,7 +120,6 @@ import GHC.Types.SourceFile import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.Hint ( GhcHint(SuggestSimilarNames), SimilarName(..) ) import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader @@ -1078,35 +1076,14 @@ notFound name | isUnboundName name -> failM -- If the name really isn't in scope -- don't report it again (#11941) | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name)) - _ -> do - names_in_scope <- - map greName - <$> filter (ok_gre <&&> isLocalGRE) - <$> globalRdrEnvElts <$> getGlobalRdrEnv - failWithTc $ notInScope names_in_scope lcl_env + _ -> failWithTc $ + mkTcRnNotInScope (getRdrName name) (NotInScopeTc (getLclEnvTypeEnv lcl_env)) -- Take care: printing the whole gbl env can -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; -- so let's just not print it! Getting a loop here is -- very unhelpful, because it hides one compiler bug with another } - where - occ = rdrNameOcc rdrName - ns = occNameSpace occ - relevant_gres = - RelevantGREs - { includeFieldSelectors = WantBoth - , lookupVariablesForFields = True - , lookupTyConsAsWell = True } - ok_gre = greIsRelevant relevant_gres ns - rdrName = getRdrName name - similar_names names_in_scope - = map SimilarName $ fuzzyLookup (unpackFS $ occNameFS $ occ) - $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) names_in_scope - hint names_in_scope = case (similar_names names_in_scope) of - (nm : nms) -> [SuggestSimilarNames rdrName (nm NE.:| nms)] - _ -> [] - notInScope names_in_scope lcl_env = TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) rdrName [] (hint names_in_scope) wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name =