[Git][ghc/ghc][wip/amg/fieldselectors] 3 commits: Extend GHCiDRF test to cover ambiguous cases
Adam Gundry
gitlab at gitlab.haskell.org
Fri Nov 27 22:18:32 UTC 2020
Adam Gundry pushed to branch wip/amg/fieldselectors at Glasgow Haskell Compiler / GHC
Commits:
4d869ff4 by Adam Gundry at 2020-11-27T21:46:51+00:00
Extend GHCiDRF test to cover ambiguous cases
- - - - -
1ab5d01d by Adam Gundry at 2020-11-27T21:58:54+00:00
More GHC.Rename.Env cleanup
- - - - -
162738d2 by Adam Gundry at 2020-11-27T22:18:00+00:00
Tweak fieldSelectorSuggestions message
- - - - -
10 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Unbound.hs
- testsuite/tests/ghci/GHCiDRF/GHCiDRF.T
- testsuite/tests/ghci/GHCiDRF/GHCiDRF.hs
- testsuite/tests/ghci/GHCiDRF/GHCiDRF.script
- testsuite/tests/ghci/GHCiDRF/GHCiDRF.stdout
- testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr
- testsuite/tests/rename/should_fail/NFSSuppressed.stderr
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -10,27 +10,38 @@ GHC.Rename.Env contains functions which convert RdrNames into Names.
-}
module GHC.Rename.Env (
+ -- * newTopSrcBinder
newTopSrcBinder,
+
+ -- * Top-level binder occurrences
lookupLocatedTopBndrRn, lookupTopBndrRn,
+
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
- lookupLocalOccRn_maybe, lookupInfoOccRn,
- lookupLocalOccThLvl_maybe, lookupLocalOccRn,
+ lookupInfoOccRn,
+ lookupLocalOccRn,
lookupTypeOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+
LookupOccResult(..),
lookupOccRn_overloaded_maybe,
- lookupGlobalOccRn_overloaded,
+ -- * lookupSubBndrOcc
ChildLookupResult(..),
- lookupSubBndrOcc_helper,
+ lookupInstDeclBndr,
+ lookupFamInstName,
combineChildLookupResult, -- Called by lookupChildrenExport
+ -- * lookupBindGroupOcc
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
- lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
+ -- * Record field occurrences
lookupConstructorFields,
+ lookupRecFieldOcc,
+ lookupRecFieldOcc_update,
+ -- * Export lists
+ lookupSubBndrOcc_helper,
lookupGreAvailRn,
-- Rebindable Syntax
@@ -75,7 +86,7 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Error ( MsgDoc )
import GHC.Builtin.Names( rOOT_MAIN )
-import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) )
+import GHC.Types.Basic ( TupleSort(..) )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique.Set ( uniqSetAny )
@@ -922,12 +933,6 @@ lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
-lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
--- Just look in the local environment
-lookupLocalOccThLvl_maybe name
- = do { lcl_env <- getLclEnv
- ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
-
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
@@ -946,6 +951,7 @@ lookupLocalOccRn rdr_name
Nothing -> unboundName WL_LocalOnly rdr_name }
-- lookupTypeOccRn looks up an optionally promoted RdrName.
+-- Used for looking up type variables.
lookupTypeOccRn :: RdrName -> RnM Name
-- see Note [Demotion]
lookupTypeOccRn rdr_name
@@ -1192,7 +1198,20 @@ lookupGlobalOccRn_resolve overload_ok rdr_name res = case res of
addNameClashErrRn rdr_name gres
return $ Just $ LookupOccName $ gre_name (NE.head gres)
--- | Used when looking up fields in record updates.
+-- | Used when looking up fields in record updates. Returns 'Just' the selector
+-- name, or 'Nothing' if the field is ambiguous. (Also returns 'Just' if the
+-- field is not in scope.)
+lookupRecFieldOcc_update
+ :: DuplicateRecordFields
+ -> RdrName
+ -> RnM (Maybe Name)
+lookupRecFieldOcc_update overload_ok rdr_name = do
+ res <- lookupGlobalOccRn_overloaded IncludeFieldsWithoutSelectors overload_ok rdr_name
+ case res of
+ LookupOccName sel_name -> return (Just sel_name)
+ LookupOccFields (fl NE.:| []) -> return (Just (flSelector fl))
+ LookupOccFields (_ NE.:| _:_) -> return Nothing
+
lookupGlobalOccRn_overloaded
:: FieldsOrSelectors
-> DuplicateRecordFields
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -745,10 +745,10 @@ rnHsRecUpdFields flds
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { let lbl = rdrNameAmbiguousFieldOcc f
- ; sel <- setSrcSpan loc $
+ ; mb_sel <- setSrcSpan loc $
-- Defer renaming of overloaded fields to the typechecker
-- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
- lookupGlobalOccRn_overloaded IncludeFieldsWithoutSelectors overload_ok lbl
+ lookupRecFieldOcc_update overload_ok lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
@@ -757,18 +757,11 @@ rnHsRecUpdFields flds
else return arg
; (arg'', fvs) <- rnLExpr arg'
- ; let fvs' = case sel of -- AMG TODO review this
- LookupOccName sel_name -> fvs `addOneFV` sel_name
- LookupOccFields (fld NE.:| []) -> fvs `addOneFV` flSelector fld
- _ -> fvs
- lbl' = case sel of
- LookupOccName sel_name ->
- L loc (Unambiguous sel_name (L loc lbl))
- LookupOccFields (fld NE.:| []) ->
- L loc (Unambiguous (flSelector fld) (L loc lbl))
- _ -> L loc (Ambiguous noExtField (L loc lbl))
-
- ; return (L l (HsRecField { hsRecFieldLbl = lbl'
+ ; let (lbl', fvs') = case mb_sel of
+ Just sel_name -> (Unambiguous sel_name (L loc lbl), fvs `addOneFV` sel_name)
+ Nothing -> (Ambiguous noExtField (L loc lbl), fvs)
+
+ ; return (L l (HsRecField { hsRecFieldLbl = L loc lbl'
, hsRecFieldArg = arg''
, hsRecPun = pun }), fvs') }
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -16,6 +16,7 @@ module GHC.Rename.Splice (
import GHC.Prelude
import GHC.Types.Name
+import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
@@ -184,6 +185,12 @@ rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (TExpBr x e', fvs) }
+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
+-- Just look in the local environment
+lookupLocalOccThLvl_maybe name
+ = do { lcl_env <- getLclEnv
+ ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
+
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -119,18 +119,24 @@ unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env
extensionSuggestions tried_rdr_name $$
fieldSelectorSuggestions global_env tried_rdr_name
+-- | When the name is in scope as field whose selector has been suppressed by
+-- NoFieldSelectors, display a helpful message explaining this.
fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc
fieldSelectorSuggestions global_env tried_rdr_name
- = case filter isNoFieldSelectorGRE $ lookupGRE_RdrName' IncludeFieldsWithoutSelectors tried_rdr_name global_env of
- gre : _ -> text "NB:"
- <+> ppr tried_rdr_name
- <+> whose gre
- <+> text "field selector that has been suppressed by NoFieldSelectors"
- _ -> Outputable.empty
+ | null gres = Outputable.empty
+ | otherwise = text "NB:"
+ <+> quotes (ppr tried_rdr_name)
+ <+> text "is a field selector" <+> whose
+ $$ text "that has been suppressed by NoFieldSelectors"
where
- whose gre = case gre_par gre of
- NoParent -> text "is a"
- ParentIs parent -> text "is" <+> ppr parent <> text "'s"
+ gres = filter isNoFieldSelectorGRE $
+ lookupGRE_RdrName' IncludeFieldsWithoutSelectors tried_rdr_name global_env
+ parents = [ parent | ParentIs parent <- map gre_par gres ]
+
+ -- parents may be empty if this is a pattern synonym field without a selector
+ whose | null parents = empty
+ | otherwise = text "belonging to the type" <> plural parents
+ <+> pprQuotedList parents
similarNameSuggestions :: WhereLooking -> DynFlags
-> GlobalRdrEnv -> LocalRdrEnv
=====================================
testsuite/tests/ghci/GHCiDRF/GHCiDRF.T
=====================================
@@ -1,4 +1,5 @@
test('GHCiDRF'
, [extra_hc_opts("-fimplicit-import-qualified")
, extra_files(['GHCiDRF.hs'])
+ , combined_output
], ghci_script, ['GHCiDRF.script'])
=====================================
testsuite/tests/ghci/GHCiDRF/GHCiDRF.hs
=====================================
@@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
module GHCiDRF where
-data T = MkT { foo :: Int }
+data T = MkT { foo :: Int, bar :: Int }
+data U = MkU { bar :: Bool }
=====================================
testsuite/tests/ghci/GHCiDRF/GHCiDRF.script
=====================================
@@ -1,2 +1,10 @@
:l GHCiDRF
:t GHCiDRF.foo
+:t GHCiDRF.bar
+:info GHCiDRF.foo
+:info GHCiDRF.bar
+:m - GHCiDRF
+:t GHCiDRF.foo
+:t GHCiDRF.bar
+:info GHCiDRF.foo
+:info GHCiDRF.bar
=====================================
testsuite/tests/ghci/GHCiDRF/GHCiDRF.stdout
=====================================
@@ -1 +1,30 @@
-GHCiDRF.foo :: T -> Int
\ No newline at end of file
+GHCiDRF.foo :: T -> Int
+
+<interactive>:1:1: error:
+ Ambiguous occurrence ‘GHCiDRF.bar’
+ It could refer to
+ either the field ‘bar’, defined at GHCiDRF.hs:4:16
+ or the field ‘bar’, defined at GHCiDRF.hs:3:28
+type T :: *
+data T = MkT {foo :: Int, ...}
+ -- Defined at GHCiDRF.hs:3:16
+type U :: *
+data U = MkU {GHCiDRF.bar :: Bool}
+ -- Defined at GHCiDRF.hs:4:16
+
+type T :: *
+data T = MkT {..., GHCiDRF.bar :: Int}
+ -- Defined at GHCiDRF.hs:3:28
+GHCiDRF.foo :: GHCiDRF.T -> Int
+
+<interactive>:1:1: error: Not in scope: ‘GHCiDRF.bar’
+type GHCiDRF.T :: *
+data GHCiDRF.T = GHCiDRF.MkT {GHCiDRF.foo :: Int, ...}
+ -- Defined at GHCiDRF.hs:3:16
+type GHCiDRF.T :: *
+data GHCiDRF.T = GHCiDRF.MkT {..., GHCiDRF.bar :: Int}
+ -- Defined at GHCiDRF.hs:3:28
+
+type GHCiDRF.U :: *
+data GHCiDRF.U = GHCiDRF.MkU {GHCiDRF.bar :: Bool}
+ -- Defined at GHCiDRF.hs:4:16
=====================================
testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr
=====================================
@@ -1,4 +1,5 @@
records-nofieldselectors.hs:9:12: error:
• Variable not in scope: x :: [a0] -> Int
- NB: x is a field selector that has been suppressed by NoFieldSelectors
+ • NB: ‘x’ is a field selector
+ that has been suppressed by NoFieldSelectors
=====================================
testsuite/tests/rename/should_fail/NFSSuppressed.stderr
=====================================
@@ -1,5 +1,6 @@
-NFSSuppressed.hs:9:5:
- Variable not in scope: foo
- Perhaps you meant data constructor ‘Foo’ (line 7)
- NB: foo is Foo's field selector that has been suppressed by NoFieldSelectors
\ No newline at end of file
+NFSSuppressed.hs:9:5: error:
+ • Variable not in scope: foo
+ • Perhaps you meant data constructor ‘Foo’ (line 7)
+ NB: ‘foo’ is a field selector belonging to the type ‘Foo’
+ that has been suppressed by NoFieldSelectors
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/78970cde8c63f6243130971fe94181338a63cbc3...162738d2f027c54ea7fe081c2308ed5f10a535d7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/78970cde8c63f6243130971fe94181338a63cbc3...162738d2f027c54ea7fe081c2308ed5f10a535d7
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/20201127/c2d4b8c7/attachment-0001.html>
More information about the ghc-commits
mailing list