[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Don't use substTyUnchecked in newMetaTyVar
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jul 17 02:28:24 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
eb1a6ab1 by sheaf at 2023-07-16T09:20:45-04:00
Don't use substTyUnchecked in newMetaTyVar
There were some comments that explained that we needed to use an
unchecked substitution function because of issue #12931, but that
has since been fixed, so we should be able to use substTy instead now.
- - - - -
ccd70d7f by sheaf at 2023-07-16T22:28:01-04:00
rnImports: var shouldn't import NoFldSelectors
In an import declaration such as
import M ( var )
the import of the variable "var" should **not** bring into scope record
fields named "var" which are defined with NoFieldSelectors.
Doing so can cause spurious "unused import" warnings, as reported in
ticket #23557.
Fixes #23557
- - - - -
86cb5da2 by sheaf at 2023-07-16T22:28:01-04:00
Suggest similar names in imports
This commit adds similar name suggestions when importing. For example
module A where { spelling = 'o' }
module B where { import B ( speling ) }
will give rise to the error message:
Module ‘A’ does not export ‘speling’.
Suggested fix: Perhaps use ‘spelling’
This also provides hints when users try to import record fields defined
with NoFieldSelectors.
- - - - -
95c01b41 by Alan Zimmerman at 2023-07-16T22:28:02-04:00
EPA: Store leading AnnSemi for decllist in al_rest
This simplifies the markAnnListA implementation in ExactPrint
- - - - -
20 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Name/Reader.hs
- testsuite/tests/overloadedrecflds/should_compile/T22106_C.stderr
- + testsuite/tests/overloadedrecflds/should_compile/T23557.hs
- + testsuite/tests/overloadedrecflds/should_compile/T23557_aux.hs
- testsuite/tests/overloadedrecflds/should_compile/all.T
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- + testsuite/tests/rename/should_fail/SimilarNamesImport.hs
- + testsuite/tests/rename/should_fail/SimilarNamesImport.stderr
- + testsuite/tests/rename/should_fail/SimilarNamesImport_aux.hs
- testsuite/tests/rename/should_fail/all.T
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1707,9 +1707,9 @@ cvars1 :: { [RecordPatSynField GhcPs] }
where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }
: 'where' '{' decls '}' {% amsrl (sLL $1 $> (snd $ unLoc $3))
- (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }
+ (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) (mj AnnWhere $1: (fst $ unLoc $3)) []) }
| 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))
- (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}
+ (AnnList (Just $ glR $3) Nothing Nothing (mj AnnWhere $1: (fst $ unLoc $3)) []) }
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
@@ -1822,9 +1822,9 @@ where_inst :: { Located ([AddEpAnn]
-- Declarations in binding groups other than classes and instances
--
-decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }
+decls :: { Located ([AddEpAnn], OrdList (LHsDecl GhcPs)) }
: decls ';' decl {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ((fst $ unLoc $1) ++ (msemi $2)
+ then return (sLL $1 $> ((fst $ unLoc $1) ++ (msemiA $2)
, unitOL $3))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
@@ -1835,7 +1835,7 @@ decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }
return (rest `seq` this `seq` these `seq`
(sLL $1 $> (fst $ unLoc $1, these))) }
| decls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemi $2)
+ then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemiA $2)
,snd $ unLoc $1)))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
@@ -1846,9 +1846,9 @@ decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }
| {- empty -} { noLoc ([],nilOL) }
decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }
- : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)
+ : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)
+ | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []
,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
@@ -4282,6 +4282,9 @@ mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]
msemi :: Located e -> [TrailingAnn]
msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]
+msemiA :: Located e -> [AddEpAnn]
+msemiA l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)]
+
msemim :: Located e -> Maybe EpaLocation
msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -497,7 +497,7 @@ patch_anchor r1 (Anchor r0 op) = Anchor r op
fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed
fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
- = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)
+ = (EpAnn (widenAnchor anchor (r ++ map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -38,6 +38,8 @@ import GHC.Driver.Ppr
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( warnUnusedTopBinds )
+import GHC.Rename.Unbound
+import qualified GHC.Rename.Unbound as Unbound
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env
@@ -67,6 +69,7 @@ import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Avail
import GHC.Types.FieldLabel
+import GHC.Types.Hint
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Basic ( TopLevelFlag(..) )
@@ -308,7 +311,7 @@ Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in
--
-- 4. A boolean 'AnyHpcUsage' which is true if the imported module
-- used HPC.
-rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)
+rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)
-> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImportDecl this_mod
(L loc decl@(ImportDecl { ideclName = loc_imp_mod_name
@@ -1228,11 +1231,11 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
= failLookupWith (QualImportError rdr)
| otherwise
= case lookups of
- [] -> failLookupWith (BadImport ie BadImportIsParent)
+ [] -> failLookupWith (BadImport ie IsNotSubordinate)
item:items -> return $ item :| items
where
lookups = concatMap nonDetNameEnvElts
- $ lookupOccEnv_WithFields imp_occ_env (rdrNameOcc rdr)
+ $ lookupImpOccEnv (RelevantGREsFOS WantNormal) imp_occ_env (rdrNameOcc rdr)
lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])]
lookup_lie (L loc ieRdr)
@@ -1252,7 +1255,7 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
-- 'BadImportW' is only constructed below in 'handle_bad_import', in
-- the 'EverythingBut' case, so that's what we pass to
-- 'badImportItemErr'.
- reason <- badImportItemErr iface decl_spec ie BadImportIsParent all_avails
+ reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails
pure (TcRnDodgyImports (DodgyImportsHiding reason))
warning_msg (DeprecatedExport n w) =
pure (TcRnPragmaWarning {
@@ -1338,7 +1341,7 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
dc_name = lookup_parent ie (setRdrNameSpace tc srcDataName)
in
case catIELookupM [ tc_name, dc_name ] of
- [] -> failLookupWith (BadImport ie BadImportIsParent)
+ [] -> failLookupWith (BadImport ie IsNotSubordinate)
names -> return ( [mkIEThingAbs tc' l (imp_item name) | name <- names], [])
| otherwise
-> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc')
@@ -1354,7 +1357,8 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
-- See Note [Importing DuplicateRecordFields]
case lookupChildren subnames rdr_ns of
- Failed rdrs -> failLookupWith (BadImport (IEThingWith (deprecation, ann) ltc wc rdrs ) BadImportIsSubordinate)
+ Failed rdrs -> failLookupWith $
+ BadImport (IEThingWith (deprecation, ann) ltc wc rdrs) IsSubordinate
-- We are trying to import T( a,b,c,d ), and failed
-- to find 'b' and 'd'. So we make up an import item
-- to report as failing, namely T( b, d ).
@@ -1382,7 +1386,9 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
where n = greName gre
handle_bad_import m = catchIELookup m $ \err -> case err of
- BadImport ie _ | want_hiding == EverythingBut -> return ([], [BadImportW ie])
+ BadImport ie _
+ | want_hiding == EverythingBut
+ -> return ([], [BadImportW ie])
_ -> failLookupWith err
mk_depr_export_warning gre
@@ -1398,11 +1404,13 @@ data IELookupWarning
| DodgyImport GlobalRdrElt
| DeprecatedExport Name (WarningTxt GhcRn)
-data BadImportIsSubordinate = BadImportIsParent | BadImportIsSubordinate
+-- | Is this import/export item a subordinate or not?
+data IsSubordinate
+ = IsSubordinate | IsNotSubordinate
data IELookupError
= QualImportError RdrName
- | BadImport (IE GhcPs) BadImportIsSubordinate
+ | BadImport (IE GhcPs) IsSubordinate
| IllegalImport
failLookupWith :: IELookupError -> IELookupM a
@@ -1486,6 +1494,23 @@ mkImportOccEnv hsc_env decl_spec all_avails =
else item1
-- Discard standalone pattern P in favour of T(P).
+-- | Essentially like @lookupGRE env (LookupOccName occ which_gres)@,
+-- but working with 'ImpOccItem's instead of 'GlobalRdrElt's.
+lookupImpOccEnv :: WhichGREs GREInfo
+ -> OccEnv (NameEnv ImpOccItem) -> OccName -> [NameEnv ImpOccItem]
+lookupImpOccEnv which_gres env occ =
+ mapMaybe relevant_items $ lookupOccEnv_AllNameSpaces env occ
+ where
+ is_relevant :: ImpOccItem -> Bool
+ is_relevant (ImpOccItem { imp_item = gre }) =
+ greIsRelevant which_gres (occNameSpace occ) gre
+ relevant_items :: NameEnv ImpOccItem -> Maybe (NameEnv ImpOccItem)
+ relevant_items nms
+ | let nms' = filterNameEnv is_relevant nms
+ = if isEmptyNameEnv nms'
+ then Nothing
+ else Just nms'
+
{-
************************************************************************
* *
@@ -2134,21 +2159,42 @@ DRFPatSynExport for a test of this.
-}
badImportItemErr
- :: ModIface -> ImpDeclSpec -> IE GhcPs -> BadImportIsSubordinate
+ :: ModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinate
-> [AvailInfo]
-> TcRn ImportLookupReason
badImportItemErr iface decl_spec ie sub avails = do
patsyns_enabled <- xoptM LangExt.PatternSynonyms
expl_ns_enabled <- xoptM LangExt.ExplicitNamespaces
- pure (ImportLookupBad (importErrorKind expl_ns_enabled) iface decl_spec ie patsyns_enabled)
+ dflags <- getDynFlags
+ hsc_env <- getTopEnv
+ let rdr_env = mkGlobalRdrEnv
+ $ gresFromAvails hsc_env (Just imp_spec) all_avails
+ pure (ImportLookupBad (importErrorKind dflags rdr_env expl_ns_enabled) iface decl_spec ie patsyns_enabled)
where
- importErrorKind expl_ns_enabled
+ importErrorKind dflags rdr_env expl_ns_enabled
| any checkIfTyCon avails = case sub of
- BadImportIsParent -> BadImportAvailTyCon expl_ns_enabled
- BadImportIsSubordinate -> BadImportNotExportedSubordinates unavailableChildren
+ IsNotSubordinate -> BadImportAvailTyCon expl_ns_enabled
+ IsSubordinate -> BadImportNotExportedSubordinates unavailableChildren
| any checkIfVarName avails = BadImportAvailVar
| Just con <- find checkIfDataCon avails = BadImportAvailDataCon (availOccName con)
- | otherwise = BadImportNotExported
+ | otherwise = BadImportNotExported suggs
+ where
+ suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr
+ similar_names =
+ similarNameSuggestions (Unbound.LF WL_Anything WL_Global)
+ dflags rdr_env emptyLocalRdrEnv rdr
+ similar_suggs =
+ case NE.nonEmpty $ mapMaybe imported_item $ similar_names of
+ Just similar -> [ SuggestSimilarNames rdr similar ]
+ Nothing -> [ ]
+
+ -- Only keep imported items, and set the "HowInScope" to
+ -- "Nothing" to avoid printing "imported from..." in the suggestion
+ -- error message.
+ imported_item (SimilarRdrName rdr_name (Just (ImportedBy {})))
+ = Just (SimilarRdrName rdr_name Nothing)
+ imported_item _ = Nothing
+
checkIfDataCon = checkIfAvailMatches isDataConName
checkIfTyCon = checkIfAvailMatches isTyConName
checkIfVarName =
@@ -2164,9 +2210,12 @@ badImportItemErr iface decl_spec ie sub avails = do
Nothing -> False
Avail{} -> False
availOccName = occName . availName
- importedFS = occNameFS . rdrNameOcc $ ieName ie
- unavailableChildren = map (rdrNameOcc) $ case ie of
- IEThingWith _ _ _ ns -> map (ieWrappedName . unLoc) ns
+ rdr = ieName ie
+ importedFS = occNameFS $ rdrNameOcc rdr
+ imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
+ all_avails = mi_exports iface
+ unavailableChildren = case ie of
+ IEThingWith _ _ _ ns -> map (rdrNameOcc . ieWrappedName . unLoc) ns
_ -> panic "importedChildren failed pattern match: no children"
addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn ()
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -15,6 +15,8 @@ module GHC.Rename.Unbound
, reportUnboundName
, reportUnboundName'
, unknownNameSuggestions
+ , similarNameSuggestions
+ , fieldSelectorSuggestions
, WhatLooking(..)
, WhereLooking(..)
, LookingFor(..)
@@ -225,7 +227,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
all_possibilities :: [(String, SimilarName)]
all_possibilities = case what_look of
WL_None -> []
- _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc))
+ _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ LocallyBoundAt loc))
| (r,loc) <- local_possibilities local_env ]
++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
@@ -256,7 +258,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]
global_possibilities global_env
- | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how)
+ | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how))
| gre <- globalRdrEnvElts global_env
, isGreOk looking_for gre
, let occ = greOccName gre
@@ -271,7 +273,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
rdr_unqual = mkRdrUnqual occ
, correct_name_space occ
, sim <- case (unquals_in_scope gre, quals_only gre) of
- (how:_, _) -> [ SimilarRdrName rdr_unqual how ]
+ (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ]
([], pr:_) -> [ pr ] -- See Note [Only-quals]
([], []) -> [] ]
@@ -299,7 +301,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
quals_only :: GlobalRdrElt -> [SimilarName]
-- Ones for which *only* the qualified version is in scope
quals_only (gre at GRE { gre_imp = is })
- = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec))
+ = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec))
| i <- bagToList is, let ispec = is_decl i, is_qual ispec ]
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -62,9 +62,11 @@ import GHC.Driver.Backend
import GHC.Hs
import GHC.Tc.Errors.Types
+import GHC.Tc.Types.BasicTypes
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank (Rank(..))
+import GHC.Tc.Types.TH
import GHC.Tc.Utils.TcType
import GHC.Types.Error
@@ -116,8 +118,6 @@ import Data.List ( groupBy, sortBy, tails
, partition, unfoldr )
import Data.Ord ( comparing )
import Data.Bifunctor
-import GHC.Tc.Types.TH
-import GHC.Tc.Types.BasicTypes
defaultTcRnMessageOpts :: TcRnMessageOpts
@@ -3085,12 +3085,12 @@ instance Diagnostic TcRnMessage where
let mod_name = moduleName $ is_mod is
occ = rdrNameOcc $ ieName ie
in case k of
- BadImportAvailVar -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]
- BadImportNotExported -> noHints
- BadImportAvailTyCon ex_ns ->
+ BadImportAvailVar -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]
+ BadImportNotExported suggs -> suggs
+ BadImportAvailTyCon ex_ns ->
[useExtensionInOrderTo empty LangExt.ExplicitNamespaces | not ex_ns]
++ [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]
- BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]
+ BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]
BadImportNotExportedSubordinates{} -> noHints
TcRnImportLookup{}
-> noHints
@@ -5343,7 +5343,7 @@ pprImportLookup = \case
hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon)
2 (vcat msgs)
in case k of
- BadImportNotExported ->
+ BadImportNotExported _ ->
vcat
[ text "Module" <+> pprImpDeclSpec iface decl_spec <+>
text "does not export" <+> quotes (ppr ie) <> dot
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -5250,7 +5250,7 @@ data WhenMatching
data BadImportKind
-- | Module does not export...
- = BadImportNotExported
+ = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant
-- | Missing @type@ keyword when importing a type.
-- e.g. `import TypeLits( (+) )`, where TypeLits exports a /type/ (+), not a /term/ (+)
-- Then we want to suggest using `import TypeLits( type (+) )`
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1001,16 +1001,7 @@ new_meta_tv_x info subst tv
; let subst1 = extendTvSubstWithClone subst tv new_tv
; return (subst1, new_tv) }
where
- substd_kind = substTyUnchecked subst (tyVarKind tv)
- -- NOTE: #12549 is fixed so we could use
- -- substTy here, but the tc_infer_args problem
- -- is not yet fixed so leaving as unchecked for now.
- -- OLD NOTE:
- -- Unchecked because we call newMetaTyVarX from
- -- tcInstTyBinder, which is called from tcInferTyApps
- -- which does not yet take enough trouble to ensure
- -- the in-scope set is right; e.g. #12785 trips
- -- if we use substTy here
+ substd_kind = substTy subst (tyVarKind tv)
newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
newMetaTyVarTyAtLevel tc_lvl kind
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -515,7 +515,7 @@ data HowInScope
data SimilarName
= SimilarName Name
- | SimilarRdrName RdrName HowInScope
+ | SimilarRdrName RdrName (Maybe HowInScope)
-- | Something is promoted to the type-level without a promotion tick.
data UntickedPromotedThing
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -353,18 +353,17 @@ pprSimilarName :: NameSpace -> SimilarName -> SDoc
pprSimilarName _ (SimilarName name)
= quotes (ppr name) <+> parens (pprDefinedAt name)
pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
- = case how_in_scope of
- LocallyBoundAt loc ->
- pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc'
- where
- loc' = case loc of
- UnhelpfulSpan l -> parens (ppr l)
- RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))
- ImportedBy is ->
- pp_ns rdr_name <+> quotes (ppr rdr_name) <+>
- parens (text "imported from" <+> ppr (moduleName $ is_mod is))
-
+ = pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc
where
+ loc = case how_in_scope of
+ Nothing -> empty
+ Just scope -> case scope of
+ LocallyBoundAt loc ->
+ case loc of
+ UnhelpfulSpan l -> parens (ppr l)
+ RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))
+ ImportedBy is ->
+ parens (text "imported from" <+> ppr (moduleName $ is_mod is))
pp_ns :: RdrName -> SDoc
pp_ns rdr | ns /= tried_ns = pprNameSpace ns
| otherwise = empty
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -1313,19 +1313,19 @@ lookupGRE env = \case
--
-- This allows us to first look in e.g. the data 'NameSpace', and then fall back
-- to the type/class 'NameSpace'.
-highestPriorityGREs :: forall info prio
+highestPriorityGREs :: forall gre prio
. Ord prio
- => (GlobalRdrEltX info -> Maybe prio)
+ => (gre -> Maybe prio)
-- ^ priority function
-- lower value <=> higher priority
- -> [GlobalRdrEltX info] -> [GlobalRdrEltX info]
+ -> [gre] -> [gre]
highestPriorityGREs priority gres =
take_highest_prio $ NE.group $ sort
[ S.Arg prio gre
| gre <- gres
, prio <- maybeToList $ priority gre ]
where
- take_highest_prio :: [NE.NonEmpty (S.Arg prio (GlobalRdrEltX info))] -> [GlobalRdrEltX info]
+ take_highest_prio :: [NE.NonEmpty (S.Arg prio gre)] -> [gre]
take_highest_prio [] = []
take_highest_prio (fs:_) = map (\ (S.Arg _ gre) -> gre) $ NE.toList fs
{-# INLINEABLE highestPriorityGREs #-}
=====================================
testsuite/tests/overloadedrecflds/should_compile/T22106_C.stderr
=====================================
@@ -1,6 +1,6 @@
-T22106_C.hs:5:9: error: [GHC-88464]
- Variable not in scope: bar
+T22106_C.hs:3:21: error: [GHC-61689]
+ Module ‘T22106_aux’ does not export ‘bar’.
Suggested fix:
Notice that ‘bar’ is a field selector belonging to the type ‘T22106_aux.T’
that has been suppressed by NoFieldSelectors.
=====================================
testsuite/tests/overloadedrecflds/should_compile/T23557.hs
=====================================
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Werror=unused-imports #-}
+
+module T23557 (main) where
+
+import T23557_aux (foo)
+
+main :: IO ()
+main = print foo
+
+-- We should not get an unused import for the import of the field selector "foo",
+-- because the module we are importing from uses NoFieldSelectors.
=====================================
testsuite/tests/overloadedrecflds/should_compile/T23557_aux.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoFieldSelectors #-}
+
+module T23557_aux where
+
+foo :: Int
+foo = 23
+
+data Foo = Foo {
+ foo :: Int
+}
=====================================
testsuite/tests/overloadedrecflds/should_compile/all.T
=====================================
@@ -50,9 +50,9 @@ test('BootFldReexport'
test('T23220'
, [req_th, extra_files(['T23220_aux.hs'])]
, multimod_compile, ['T23220_aux.hs T23220.hs', '-v0'])
-
test('T22106_A', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_A', '-v0'])
test('T22106_B', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_B', '-v0'])
test('T22106_C', [extra_files(['T22106_aux.hs'])], multimod_compile_fail, ['T22106_C', '-v0'])
test('T22106_D', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_D', '-v0'])
test('T23279', [extra_files(['T23279_aux.hs'])], multimod_compile, ['T23279', '-v0'])
+test('T23557', [extra_files(['T23557_aux.hs'])], multimod_compile, ['T23557', '-v0'])
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1517,17 +1517,12 @@
(AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:34:13 })))
(Just
(AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:34:31 })))
- []
- [(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:14 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:15 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:16 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:17 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:18 }))])
+ [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:14 }))
+ ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:15 }))
+ ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:16 }))
+ ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:17 }))
+ ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:18 }))]
+ [])
(EpaComments
[]))
(ValBinds
=====================================
testsuite/tests/rename/should_fail/SimilarNamesImport.hs
=====================================
@@ -0,0 +1,3 @@
+module SimilarNamesImport where
+
+import SimilarNamesImport_aux ( dyzzy, Wabble, wabble, Trizzle(bizzy) )
=====================================
testsuite/tests/rename/should_fail/SimilarNamesImport.stderr
=====================================
@@ -0,0 +1,16 @@
+
+SimilarNamesImport.hs:3:33: error: [GHC-61689]
+ Module ‘SimilarNamesImport_aux’ does not export ‘dyzzy’.
+ Suggested fix:
+ Perhaps use one of these: record field of MkD ‘dizzy’, ‘xyzzy’
+
+SimilarNamesImport.hs:3:40: error: [GHC-61689]
+ Module ‘SimilarNamesImport_aux’ does not export ‘Wabble’.
+ Suggested fix: Perhaps use ‘Wibble’
+
+SimilarNamesImport.hs:3:48: error: [GHC-61689]
+ Module ‘SimilarNamesImport_aux’ does not export ‘wabble’.
+
+SimilarNamesImport.hs:3:56: error: [GHC-61689]
+ Module ‘SimilarNamesImport_aux’ does not export ‘Trizzle’.
+ Suggested fix: Perhaps use one of these: ‘Drizzle’, ‘Frizzle’
=====================================
testsuite/tests/rename/should_fail/SimilarNamesImport_aux.hs
=====================================
@@ -0,0 +1,11 @@
+module SimilarNamesImport_aux where
+
+xyzzy :: Double
+xyzzy = exp $ pi * sqrt 163
+
+
+data Drizzle = MkD { dizzy :: Int }
+data Frizzle = MkE { fizzy :: Bool }
+
+data Wibble
+
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -199,6 +199,7 @@ test('RnUnexpectedStandaloneDeriving', normal, compile_fail, [''])
test('RnStupidThetaInGadt', normal, compile_fail, [''])
test('PackageImportsDisabled', normal, compile_fail, [''])
test('ImportLookupIllegal', normal, compile_fail, [''])
+test('SimilarNamesImport', [extra_files(['SimilarNamesImport_aux.hs'])], multimod_compile_fail, ['SimilarNamesImport', '-v0'])
test('T23510a', normal, compile_fail, [''])
test('T16635a', normal, compile_fail, [''])
test('T16635b', normal, compile_fail, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1176,32 +1176,27 @@ markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss
-- ---------------------------------------------------------------------
markAnnList :: (Monad m, Monoid w)
- => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
-markAnnList reallyTrail ann action = do
- markAnnListA reallyTrail ann $ \a -> do
+ => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
+markAnnList ann action = do
+ markAnnListA ann $ \a -> do
r <- action
return (a,r)
markAnnListA :: (Monad m, Monoid w)
- => Bool -> EpAnn AnnList
+ => EpAnn AnnList
-> (EpAnn AnnList -> EP w m (EpAnn AnnList, a))
-> EP w m (EpAnn AnnList, a)
-markAnnListA _ EpAnnNotUsed action = do
+markAnnListA EpAnnNotUsed action = do
action EpAnnNotUsed
-markAnnListA reallyTrail an action = do
+markAnnListA an action = do
debugM $ "markAnnListA: an=" ++ showAst an
an0 <- markLensMAA an lal_open
- an1 <- if (not reallyTrail)
- then markTrailingL an0 lal_trailing
- else return an0
- an2 <- markEpAnnAllL an1 lal_rest AnnSemi
- (an3, r) <- action an2
- an4 <- markLensMAA an3 lal_close
- an5 <- if reallyTrail
- then markTrailingL an4 lal_trailing
- else return an4
- debugM $ "markAnnListA: an5=" ++ showAst an
- return (an5, r)
+ an1 <- markEpAnnAllL an0 lal_rest AnnSemi
+ (an2, r) <- action an1
+ an3 <- markLensMAA an2 lal_close
+ an4 <- markTrailingL an3 lal_trailing
+ debugM $ "markAnnListA: an4=" ++ showAst an
+ return (an4, r)
-- ---------------------------------------------------------------------
@@ -2297,12 +2292,12 @@ instance ExactPrint (HsLocalBinds GhcPs) where
when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc)
_ -> return ()
- (an1, valbinds') <- markAnnList False an0 $ markAnnotatedWithLayout valbinds
+ (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds
debugM $ "exact HsValBinds: an1=" ++ showAst an1
return (HsValBinds an1 valbinds')
exact (HsIPBinds an bs) = do
- (as, ipb) <- markAnnList True an (markEpAnnL an lal_rest AnnWhere
+ (as, ipb) <- markAnnList an (markEpAnnL an lal_rest AnnWhere
>> markAnnotated bs
>>= \bs' -> return (HsIPBinds an bs'::HsLocalBinds GhcPs))
case ipb of
@@ -2845,7 +2840,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- (an',stmts') <- markAnnListA True an $ \a -> exactDo a do_or_list_comp stmts
+ (an',stmts') <- markAnnListA an $ \a -> exactDo a do_or_list_comp stmts
return (HsDo an' do_or_list_comp stmts')
exact (ExplicitList an es) = do
@@ -3379,7 +3374,7 @@ instance (
exact (RecStmt an stmts a b c d e) = do
debugM $ "RecStmt"
an0 <- markEpAnnL an lal_rest AnnRec
- (an1, stmts') <- markAnnList True an0 (markAnnotated stmts)
+ (an1, stmts') <- markAnnList an0 (markAnnotated stmts)
return (RecStmt an1 stmts' a b c d e)
-- ---------------------------------------------------------------------
@@ -4400,7 +4395,7 @@ instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where
an0 <- markEpAnnL an lal_rest AnnHiding
p <- getPosP
debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p
- (an1, ies') <- markAnnList True an0 (markAnnotated ies)
+ (an1, ies') <- markAnnList an0 (markAnnotated ies)
return (L (SrcSpanAnn an1 l) ies')
instance (ExactPrint (Match GhcPs (LocatedA body)))
@@ -4423,7 +4418,7 @@ instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr Gh
setAnnotationAnchor = setAnchorAn
exact (L (SrcSpanAnn an l) stmts) = do
debugM $ "LocatedL [ExprLStmt"
- (an'', stmts') <- markAnnList True an $ do
+ (an'', stmts') <- markAnnList an $ do
case snocView stmts of
Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
debugM $ "LocatedL [ExprLStmt: snocView"
@@ -4450,7 +4445,7 @@ instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
setAnnotationAnchor = setAnchorAn
exact (L (SrcSpanAnn an l) fs) = do
debugM $ "LocatedL [LConDeclField"
- (an', fs') <- markAnnList True an (markAnnotated fs)
+ (an', fs') <- markAnnList an (markAnnotated fs)
return (L (SrcSpanAnn an' l) fs')
instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
@@ -4458,7 +4453,7 @@ instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
setAnnotationAnchor = setAnchorAn
exact (L (SrcSpanAnn an l) bf) = do
debugM $ "LocatedL [LBooleanFormula"
- (an', bf') <- markAnnList True an (markAnnotated bf)
+ (an', bf') <- markAnnList an (markAnnotated bf)
return (L (SrcSpanAnn an' l) bf')
-- ---------------------------------------------------------------------
@@ -4616,7 +4611,7 @@ instance ExactPrint (Pat GhcPs) where
return (BangPat an0 pat')
exact (ListPat an pats) = do
- (an', pats') <- markAnnList True an (markAnnotated pats)
+ (an', pats') <- markAnnList an (markAnnotated pats)
return (ListPat an' pats')
exact (TuplePat an pats boxity) = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857fdb005d35eb65047fd6a39d290c8230762584...95c01b41970b100966a091138ea2276721139a30
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857fdb005d35eb65047fd6a39d290c8230762584...95c01b41970b100966a091138ea2276721139a30
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230716/23327878/attachment-0001.html>
More information about the ghc-commits
mailing list