[Git][ghc/ghc][wip/amg/fieldselectors] 3 commits: Simplify IncorrectParent
Adam Gundry
gitlab at gitlab.haskell.org
Thu Nov 26 23:16:49 UTC 2020
Adam Gundry pushed to branch wip/amg/fieldselectors at Glasgow Haskell Compiler / GHC
Commits:
3d84bba9 by Adam Gundry at 2020-11-25T21:48:47+00:00
Simplify IncorrectParent
- - - - -
01e161e0 by Adam Gundry at 2020-11-26T22:35:11+00:00
Correct NoFieldSelectors tests in the light of #18999
- - - - -
78970cde by Adam Gundry at 2020-11-26T23:16:21+00:00
WIP: refactor and clean up GHC.Rename.Env
- - - - -
13 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Types/Name/Reader.hs
- testsuite/tests/rename/should_compile/NFSDRF.hs
- testsuite/tests/rename/should_compile/NoFieldSelectors.hs
- testsuite/tests/rename/should_fail/NoFieldSelectorsFail.hs
- testsuite/tests/rename/should_fail/NoFieldSelectorsFail.stderr
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -17,9 +17,9 @@ module GHC.Rename.Env (
lookupLocalOccThLvl_maybe, lookupLocalOccRn,
lookupTypeOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
- LookupOccRnOverloadedResult(..),
- lookupGlobalOccRn_overloaded_sel,
- lookupOccRn_overloaded_expr,
+ LookupOccResult(..),
+ lookupOccRn_overloaded_maybe,
+ lookupGlobalOccRn_overloaded,
ChildLookupResult(..),
lookupSubBndrOcc_helper,
@@ -507,12 +507,14 @@ lookupRecFieldOcc mb_con rdr_name
; case mb_field of
Just (fl, gre) -> do { addUsedGRE True gre
; return (flSelector fl) }
- Nothing -> lookupGlobalOccRn rdr_name }
+ Nothing -> lookupGlobalOccRn' fos rdr_name }
-- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
| 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
+ = lookupGlobalOccRn' fos rdr_name
+ where
+ fos = IncludeFieldsWithoutSelectors
{- Note [DisambiguateRecordFields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -648,14 +650,13 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
case original_gres of
[] -> return NameNotFound
[g] -> return $ IncorrectParent parent
- (gre_name g) (ppr $ gre_name g)
+ (gre_child g)
[p | Just p <- [getParent g]]
gss@(g:gss'@(_:_)) ->
if all isRecFldGRE gss && overload_ok
then return $
IncorrectParent parent
- (gre_name g)
- (ppr $ expectJust "noMatchingParentErr" (greLabel g))
+ (gre_child g)
[p | x <- gss, Just p <- [getParent x]]
else mkNameClashErr $ g NE.:| gss'
@@ -735,8 +736,7 @@ instance Monoid DisambigInfo where
data ChildLookupResult
= NameNotFound -- We couldn't find a suitable name
| IncorrectParent Name -- Parent
- Name -- Name of thing we were looking for
- SDoc -- How to print the name
+ Child -- Child we were looking for
[Name] -- List of possible parents
| FoundChild Parent Child -- We resolved to a child
@@ -752,8 +752,8 @@ combineChildLookupResult (x:xs) = do
instance Outputable ChildLookupResult where
ppr NameNotFound = text "NameNotFound"
ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n
- ppr (IncorrectParent p n td ns) = text "IncorrectParent"
- <+> hsep [ppr p, ppr n, td, ppr ns]
+ ppr (IncorrectParent p n ns) = text "IncorrectParent"
+ <+> hsep [ppr p, ppr n, ppr ns]
lookupSubBndrOcc :: Bool
-> Name -- Parent
@@ -1065,71 +1065,83 @@ when the user writes the following declaration
x = id Int
-}
--- | Look up a global variable, local variable or one or more record selector functions.
--- It does NOT find a record selector created under NoFieldSelectors.
--- See Note [NoFieldSelectors]
-lookupOccRn_overloaded_expr :: DuplicateRecordFields -> RdrName -> RnM (Maybe LookupOccRnOverloadedResult)
-lookupOccRn_overloaded_expr overload_ok rdr_name
- = do { mb_name <- lookupOccRnX_maybe global_lookup LookupOccRnUnique rdr_name
- ; case mb_name of
- Nothing -> fmap @Maybe LookupOccRnUnique <$> lookup_promoted rdr_name
- -- See Note [Promotion].
- -- We try looking up the name as a
- -- type constructor or type variable, if
- -- we failed to look up the name at the term level.
- p -> return p }
- where
- global_lookup :: RdrName -> RnM (Maybe LookupOccRnOverloadedResult)
- global_lookup n =
- runMaybeT . msum . map MaybeT $
- [ lookupGlobalOccRn_overloaded_expr overload_ok n
- , listToMaybe <$> lookupQualifiedNameGHCi n ]
-
-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 ]
+-- | Result of looking up an occurrence that might be an ambiguous field.
+data LookupOccResult
+ = LookupOccName Name
+ -- ^ Occurrence picked out a non-field Name (potentially unbound).
+ | LookupOccFields (NE.NonEmpty FieldLabel)
+ -- ^ Occurrence picked out one or more fields. If ambiguous fields were not
+ -- allowed during lookup, this list will be a singleton.
+
+-- | Get the Name of the result. This assumes ambiguous fields were not allowed
+-- (otherwise it simply returns the first field, without any disambiguation).
+-- Also note that, for fields, this discards the field label and returns the
+-- underlying selector function, which may have a mangled Name (see Note
+-- [FieldLabel] in GHC.Types.FieldLabel).
+nameFromLookupOccResult :: LookupOccResult -> Name
+nameFromLookupOccResult (LookupOccName x) = x
+nameFromLookupOccResult (LookupOccFields xs) = flSelector (NE.head xs)
+
+
+-- | Look up a global variable, local variable or one or more record selector
+-- functions. The 'FieldsOrSelectors' argument controls whether it will include
+-- record fields created under NoFieldSelectors. See Note [NoFieldSelectors].
+-- The 'DuplicateRecordFields' argument controls whether ambiguous fields may be
+-- returned.
+--
+-- This is used for looking up variables in expressions during renaming.
+lookupOccRn_overloaded_maybe
+ :: Bool-> FieldsOrSelectors -> DuplicateRecordFields -> RdrName
+ -> RnM (Maybe LookupOccResult)
+lookupOccRn_overloaded_maybe try_promotion fos overload_ok rdr_name =
+ runMaybeT . msum . map MaybeT $
+ [ fmap LookupOccName <$> lookupLocalOccRn_maybe rdr_name
+ , lookupGlobalOccRn_overloaded_maybe fos overload_ok rdr_name
+ , promoted_lookup
+ ]
+ where
+ -- See Note [Promotion]. We try looking up the name as a type
+ -- constructor or type variable, if we failed to look up the name at the
+ -- term level.
+ promoted_lookup :: RnM (Maybe LookupOccResult)
+ promoted_lookup
+ | try_promotion = fmap LookupOccName <$> lookup_promoted rdr_name
+ | otherwise = pure Nothing
+
+-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe)
lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
-lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id
+lookupOccRn_maybe rdr_name =
+ fmap nameFromLookupOccResult <$>
+ lookupOccRn_overloaded_maybe False ExcludeFieldsWithoutSelectors NoDuplicateRecordFields rdr_name
-lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
-- Looks up a RdrName occurrence in the top-level
-- environment, including using lookupQualifiedNameGHCi
-- for the GHCi case, but first tries to find an Exact or Orig name.
-- No filter function; does not report an error on failure
-- See Note [Errors in lookup functions]
-- Uses addUsedRdrName to record use and deprecations
+--
+-- Used directly only by getLocalNonValBinders (new_assoc).
+lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupGlobalOccRn_maybe rdr_name =
- lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name)
+ fmap nameFromLookupOccResult <$>
+ lookupGlobalOccRn_overloaded_maybe ExcludeFieldsWithoutSelectors
+ NoDuplicateRecordFields
+ rdr_name
+-- Used by exports_from_avail
lookupGlobalOccRn :: RdrName -> RnM Name
+lookupGlobalOccRn = lookupGlobalOccRn' ExcludeFieldsWithoutSelectors
+
+lookupGlobalOccRn' :: FieldsOrSelectors -> 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 =
- lookupExactOrOrig rdr_name id $ do
- mn <- lookupGlobalOccRn_base rdr_name
- case mn of
- Just n -> return n
- Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
- ; unboundName WL_Global rdr_name }
-
--- Looks up a RdrName occurence in the GlobalRdrEnv and with
--- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.
--- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like
--- 'Data.Map.elems' is typed, even if you didn't import Data.Map
-lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name)
-lookupGlobalOccRn_base rdr_name =
- runMaybeT . msum . map MaybeT $
- [ fmap gre_name <$> lookupGreRn_maybe rdr_name
- , listToMaybe . concatMap nameFromLookupOccRnOverloadedResult
- <$> lookupQualifiedNameGHCi rdr_name ]
- -- This test is not expensive,
- -- and only happens for failed lookups
+lookupGlobalOccRn' fos rdr_name =
+ nameFromLookupOccResult <$>
+ lookupGlobalOccRn_overloaded fos NoDuplicateRecordFields rdr_name
lookupInfoOccRn :: RdrName -> RnM [Name]
-- lookupInfoOccRn is intended for use in GHCi's ":info" command
@@ -1142,68 +1154,86 @@ lookupInfoOccRn :: RdrName -> RnM [Name]
lookupInfoOccRn rdr_name =
lookupExactOrOrig rdr_name (:[]) $
do { rdr_env <- getGlobalRdrEnv
- ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)
- ; qual_ns <- concatMap nameFromLookupOccRnOverloadedResult
- <$> lookupQualifiedNameGHCi rdr_name
+ ; let ns = map gre_name (lookupGRE_RdrName' fos rdr_name rdr_env)
+ ; qual_ns <- map childName <$> lookupQualifiedNameGHCi fos rdr_name
; return (ns ++ (qual_ns `minusList` ns)) }
+ where
+ fos = IncludeFieldsWithoutSelectors
--- | A datatype to distinguish record selector functions from regular symbols.
-data LookupOccRnOverloadedResult
- = LookupOccRnUnique Name
- -- ^ non-selector name uniquely refers to x
- -- or there is a name clash
- | LookupOccRnSelectors (NE.NonEmpty FieldLabel)
- -- ^ name refers to one or more record selectors;
- -- If DuplicateRecordFields is disabled, this list will be
- -- a singleton.
-
-nameFromLookupOccRnOverloadedResult :: LookupOccRnOverloadedResult -> [Name]
-nameFromLookupOccRnOverloadedResult (LookupOccRnUnique x) = [x]
-nameFromLookupOccRnOverloadedResult (LookupOccRnSelectors xs) = map flSelector $ NE.toList xs
-
-instance Outputable LookupOccRnOverloadedResult where
- ppr (LookupOccRnUnique x) = text "LookupOccRnUnique " <> ppr x
- ppr (LookupOccRnSelectors xs) = text "LoookupOccRnSelectors " <> ppr xs
-- | Process a list of 'GlobalRdrElt's in 'GreLookupResult' matching the given 'RdrName'
-- and check if it is a unique 'Name' or a set of record selector functions.
-- See Note [NoFieldSelectors]
+
+-- Look up the RdrName in the GlobalRdrEnv
+-- Exactly one binding: records it as "used", return (Just gre)
+-- No bindings: return Nothing
+-- Many bindings: report "ambiguous", return an arbitrary (Just gre)
+-- Uses addUsedRdrName to record use and deprecations
+
lookupGlobalOccRn_resolve
:: DuplicateRecordFields
-> RdrName
-> GreLookupResult
- -> RnM (Maybe LookupOccRnOverloadedResult)
+ -> RnM (Maybe LookupOccResult)
lookupGlobalOccRn_resolve overload_ok rdr_name res = case res of
GreNotFound -> return Nothing
OneNameMatch gre -> return $ Just $ case gre_child gre of
- ChildName name -> LookupOccRnUnique name
- ChildField fl -> LookupOccRnSelectors $ pure fl
- MultipleNames gres
- | fld : flds <- mapMaybe greFieldLabel $ NE.toList gres
- , overload_ok == DuplicateRecordFields || null flds ->
- -- Don't record usage for ambiguous selectors
- -- until we know which is meant
- return $ Just $ LookupOccRnSelectors $ fld NE.:| flds
+ ChildName name -> LookupOccName name
+ ChildField fl -> LookupOccFields $ pure fl
+ MultipleNames (gre NE.:| gres)
+ -- Make sure *all* the names are fields before returning a non-clash result;
+ -- mixing fields and non-fields is not allowed.
+ | overload_ok == DuplicateRecordFields || null gres
+ , Just fld <- greFieldLabel gre
+ , Just flds <- mapM greFieldLabel gres
+ -> return $ Just $ LookupOccFields $ fld NE.:| flds
MultipleNames gres -> do
addNameClashErrRn rdr_name gres
- return $ Just $ LookupOccRnUnique $ gre_name (NE.head gres)
+ return $ Just $ LookupOccName $ gre_name (NE.head gres)
--- | Look up a variable or record selector functions.
-lookupGlobalOccRn_overloaded_expr :: DuplicateRecordFields
+-- | Used when looking up fields in record updates.
+lookupGlobalOccRn_overloaded
+ :: FieldsOrSelectors
+ -> DuplicateRecordFields
+ -> RdrName
+ -> RnM LookupOccResult
+lookupGlobalOccRn_overloaded fos overload_ok rdr_name = do
+ mb <- lookupGlobalOccRn_overloaded_maybe fos overload_ok rdr_name
+ case mb of
+ Just r -> return r
+ Nothing -> do { traceRn "lookupGlobalOccRn_overloaded unbound" (ppr rdr_name)
+ ; LookupOccName <$> unboundName WL_Global rdr_name }
+
+
+-- | Look up a variable or record selector functions. Looks up a RdrName
+-- occurence in the GlobalRdrEnv and with 'lookupQualifiedNameGHCi'.
+-- 'lookupQualifiedNameGHCi' here is used when we're in GHCi and a name like
+-- 'Data.Map.elems' is typed, even if you didn't import "Data.Map".
+lookupGlobalOccRn_overloaded_maybe
+ :: FieldsOrSelectors
+ -> DuplicateRecordFields
-> RdrName
- -> RnM (Maybe LookupOccRnOverloadedResult)
-lookupGlobalOccRn_overloaded_expr overload_ok rdr_name =
- lookupExactOrOrig_maybe rdr_name (fmap LookupOccRnUnique) $
- do { env <- getGlobalRdrEnv
- ; res <- case filter (not . isNoFieldSelectorGRE)
- -- filter out invisible selector functions
- $ lookupGRE_RdrName rdr_name env of
- [] -> return GreNotFound
- [gre] -> do { addUsedGRE True gre
- ; return (OneNameMatch gre) }
- gre : gres -> return $ MultipleNames $ gre NE.:| gres
- ; lookupGlobalOccRn_resolve overload_ok rdr_name res
- }
+ -> RnM (Maybe LookupOccResult)
+lookupGlobalOccRn_overloaded_maybe fos overload_ok rdr_name =
+ lookupExactOrOrig_maybe rdr_name (fmap LookupOccName) $
+ runMaybeT . msum . map MaybeT $
+ [ do res <- lookupGreRn_helper fos rdr_name
+ lookupGlobalOccRn_resolve overload_ok rdr_name res
+ , children_to_lookup_result <$> lookupQualifiedNameGHCi fos rdr_name ]
+ where
+ children_to_lookup_result :: [Child] -> Maybe LookupOccResult
+ children_to_lookup_result [ChildName name] = Just $ LookupOccName name
+ children_to_lookup_result [ChildField fl] = Just $ LookupOccFields (fl NE.:| [])
+ children_to_lookup_result children
+ | overload_ok == DuplicateRecordFields
+ = do (fl:fls) <- mapM to_field children
+ Just $ LookupOccFields (fl NE.:| fls)
+ | otherwise = Nothing
+
+ to_field (ChildField fl) = Just fl
+ to_field (ChildName _) = Nothing
+
{-
Note [NoFieldSelectors]
@@ -1226,20 +1256,6 @@ In order to avoid name clashes, selector names are mangled in the same way as Du
generates @$sel:foo:MkT at .
-}
--- | Look up a variable or record selectors.
--- It MAY find a selector function with NoFieldSelectors.
--- See Note [NoFieldSelectors]
-lookupGlobalOccRn_overloaded_sel :: DuplicateRecordFields
- -> RdrName
- -> RnM (Maybe LookupOccRnOverloadedResult)
-lookupGlobalOccRn_overloaded_sel overload_ok rdr_name =
- lookupExactOrOrig_maybe rdr_name (fmap LookupOccRnUnique) $ runMaybeT $ msum
- [ MaybeT $ do
- { res <- lookupGreRn_helper rdr_name
- ; lookupGlobalOccRn_resolve overload_ok rdr_name res }
- , MaybeT (listToMaybe <$> lookupQualifiedNameGHCi rdr_name)
- ]
-
--------------------------------------------------
-- Lookup in the Global RdrEnv of the module
@@ -1249,22 +1265,6 @@ data GreLookupResult = GreNotFound
| OneNameMatch GlobalRdrElt
| MultipleNames (NE.NonEmpty GlobalRdrElt)
-lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
--- Look up the RdrName in the GlobalRdrEnv
--- Exactly one binding: records it as "used", return (Just gre)
--- No bindings: return Nothing
--- Many bindings: report "ambiguous", return an arbitrary (Just gre)
--- Uses addUsedRdrName to record use and deprecations
-lookupGreRn_maybe rdr_name
- = do
- res <- lookupGreRn_helper 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 (NE.head gres)
- GreNotFound -> return Nothing
{-
@@ -1295,13 +1295,15 @@ is enabled then we defer the selection until the typechecker.
-- Internal Function
-lookupGreRn_helper :: RdrName -> RnM GreLookupResult
-lookupGreRn_helper rdr_name
+lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult
+lookupGreRn_helper fos rdr_name
= do { env <- getGlobalRdrEnv
- ; case lookupGRE_RdrName rdr_name env of
+ ; case lookupGRE_RdrName' fos rdr_name env of
[] -> return GreNotFound
[gre] -> do { addUsedGRE True gre
; return (OneNameMatch gre) }
+ -- Don't record usage for ambiguous names
+ -- until we know which is meant
gre : gres -> return (MultipleNames $ gre NE.:| gres) }
lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
@@ -1310,7 +1312,7 @@ lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
-- Uses addUsedRdrName to record use and deprecations
lookupGreAvailRn rdr_name
= do
- mb_gre <- lookupGreRn_helper rdr_name
+ mb_gre <- lookupGreRn_helper IncludeFieldsWithoutSelectors rdr_name
case mb_gre of
GreNotFound ->
do
@@ -1472,8 +1474,8 @@ this requires some refactoring so leave as a TODO
-lookupQualifiedNameGHCi :: RdrName -> RnM [LookupOccRnOverloadedResult]
-lookupQualifiedNameGHCi rdr_name
+lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [Child]
+lookupQualifiedNameGHCi fos rdr_name
= -- We want to behave as we would for a source file import here,
-- and respect hiddenness of modules/packages, hence loadSrcInterface.
do { dflags <- getDynFlags
@@ -1481,16 +1483,6 @@ lookupQualifiedNameGHCi rdr_name
; go_for_it dflags is_ghci }
where
- -- TODO: this could be done more sensibly
- convert :: [Child] -> [LookupOccRnOverloadedResult]
- convert [ChildName n] = [LookupOccRnUnique n]
- convert children = case mapM to_field children of
- Just (fl:fls) -> [LookupOccRnSelectors (fl NE.:| fls)]
- _ -> []
-
- to_field (ChildField fl) = Just fl
- to_field (ChildName _) = Nothing
-
go_for_it dflags is_ghci
| Just (mod,occ) <- isQual_maybe rdr_name
, is_ghci
@@ -1499,10 +1491,12 @@ lookupQualifiedNameGHCi rdr_name
= do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing
; case res of
Succeeded iface
- -> return $ convert [ child
+ -> return [ child
| avail <- mi_exports iface
, child <- availChildren avail
- , occName child == occ ]
+ , occName child == occ
+ , allow_child child
+ ]
_ -> -- Either we couldn't load the interface, or
-- we could but we didn't find the name in it
@@ -1515,6 +1509,10 @@ lookupQualifiedNameGHCi rdr_name
doc = text "Need to find" <+> ppr rdr_name
+ allow_child (ChildField fl) = (flHasFieldSelector fl == FieldSelectors)
+ || (fos == IncludeFieldsWithoutSelectors)
+ allow_child (ChildName _) = True
+
{-
Note [Looking up signature names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -123,11 +123,11 @@ rnUnboundVar v =
rnExpr (HsVar _ (L l v))
= do { dflags <- getDynFlags
; let overload_ok = xopt_DuplicateRecordFields dflags
- ; mb_name <- lookupOccRn_overloaded_expr overload_ok v
+ ; mb_name <- lookupOccRn_overloaded_maybe True ExcludeFieldsWithoutSelectors overload_ok v
; case mb_name of {
Nothing -> rnUnboundVar v ;
- Just (LookupOccRnUnique name)
+ Just (LookupOccName name)
| name == nilDataConName -- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
-- Note [Empty lists] in GHC.Hs.Expr
@@ -136,9 +136,9 @@ rnExpr (HsVar _ (L l v))
| otherwise
-> finishHsVar (L l name) ;
- Just (LookupOccRnSelectors (s NE.:| [])) -> -- AMG TODO review this
+ Just (LookupOccFields (s NE.:| [])) -> -- AMG TODO review this
return ( HsRecFld noExtField (Unambiguous (flSelector s) (L l v) ), unitFV (flSelector s)) ;
- Just (LookupOccRnSelectors fs@(_ NE.:| _:_)) ->
+ Just (LookupOccFields fs@(_ NE.:| _:_)) ->
return ( HsRecFld noExtField (Ambiguous noExtField (L l v))
, mkFVs $ NE.toList $ fmap flSelector fs); } }
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -58,8 +58,7 @@ import GHC.Rename.Fixity
import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkUnusedRecordWildcard
- , checkDupNames, checkDupAndShadowedNames
- , unknownSubordinateErr )
+ , checkDupNames, checkDupAndShadowedNames )
import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Name
@@ -740,8 +739,6 @@ rnHsRecUpdFields flds
; return (flds1, plusFVs fvss) }
where
- doc = text "constructor field name"
-
rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
@@ -751,16 +748,7 @@ rnHsRecUpdFields flds
; sel <- setSrcSpan loc $
-- Defer renaming of overloaded fields to the typechecker
-- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
- -- AMG TODO: not clear why we need this test, but T11941 fails if we don't
- if overload_ok == DuplicateRecordFields
- then do { mb <- lookupGlobalOccRn_overloaded_sel overload_ok lbl
- ; case mb of
- Nothing ->
- do { addErr
- (unknownSubordinateErr doc lbl)
- ; return Nothing }
- Just r -> return $ Just r }
- else fmap (Just . LookupOccRnUnique) $ lookupGlobalOccRn lbl
+ lookupGlobalOccRn_overloaded IncludeFieldsWithoutSelectors overload_ok lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
@@ -770,13 +758,13 @@ rnHsRecUpdFields flds
; (arg'', fvs) <- rnLExpr arg'
; let fvs' = case sel of -- AMG TODO review this
- Just (LookupOccRnUnique sel_name) -> fvs `addOneFV` sel_name
- Just (LookupOccRnSelectors (fld NE.:| [])) -> fvs `addOneFV` flSelector fld
+ LookupOccName sel_name -> fvs `addOneFV` sel_name
+ LookupOccFields (fld NE.:| []) -> fvs `addOneFV` flSelector fld
_ -> fvs
lbl' = case sel of
- Just (LookupOccRnUnique sel_name) ->
+ LookupOccName sel_name ->
L loc (Unambiguous sel_name (L loc lbl))
- Just (LookupOccRnSelectors (fld NE.:| [])) ->
+ LookupOccFields (fld NE.:| []) ->
L loc (Unambiguous (flSelector fld) (L loc lbl))
_ -> L loc (Ambiguous noExtField (L loc lbl))
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -121,7 +121,7 @@ unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env
fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc
fieldSelectorSuggestions global_env tried_rdr_name
- = case filter isNoFieldSelectorGRE $ lookupGRE_RdrName tried_rdr_name global_env of
+ = case filter isNoFieldSelectorGRE $ lookupGRE_RdrName' IncludeFieldsWithoutSelectors tried_rdr_name global_env of
gre : _ -> text "NB:"
<+> ppr tried_rdr_name
<+> whose gre
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -529,7 +529,7 @@ lookupChildrenExport spec_parent rdr_items =
ChildField fl -> Right (L (getLoc n) fl)
ChildName name -> Left (replaceLWrappedName n name)
}
- IncorrectParent p g td gs -> failWithDcErr p g td gs
+ IncorrectParent p c gs -> failWithDcErr p c gs
-- Note: [Typing Pattern Synonym Exports]
@@ -617,7 +617,7 @@ checkPatSynParent parent NoParent child
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
- _ -> failWithDcErr parent mpat_syn (ppr child) [] }
+ _ -> failWithDcErr parent child [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
@@ -809,11 +809,11 @@ dcErrMsg ty_con what_is thing parents =
[_] -> text "Parent:"
_ -> text "Parents:") <+> fsep (punctuate comma parents)
-failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
-failWithDcErr parent thing thing_doc parents = do
- ty_thing <- tcLookupGlobal thing
+failWithDcErr :: Name -> Child -> [Name] -> TcM a
+failWithDcErr parent child parents = do
+ ty_thing <- tcLookupGlobal (childName child)
failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
- thing_doc (map ppr parents)
+ (ppr child) (map ppr parents)
where
tyThingCategory' :: TyThing -> String
tyThingCategory' (AnId i)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1310,7 +1310,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
= fmap (zip rbnds) $ mapM
- (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
+ (lookupParents IncludeFieldsWithoutSelectors . unLoc . hsRecUpdFieldRdr . unLoc)
rbnds
-- Given a the lists of possible parents for each field,
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -539,7 +539,7 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type
Nothing -> ambiguousSelector lr ;
Just p ->
- do { xs <- lookupParents rdr
+ do { xs <- lookupParents ExcludeFieldsWithoutSelectors rdr
; let parent = RecSelData p
; case lookup parent xs of {
Nothing -> failWithTc (fieldNotInType parent rdr) ;
@@ -592,13 +592,13 @@ tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty
-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
-lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
-lookupParents rdr
+lookupParents :: FieldsOrSelectors -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
+lookupParents fos rdr
= do { env <- getGlobalRdrEnv
-- filter by isRecFldGRE because otherwise a non-selector variable with an overlapping name can get through
-- when NoFieldSelector is enabled
- -- AMG TODO really need a function to do this consistently!
- ; let gres = filter isRecFldGRE $ lookupGRE_RdrName rdr env
+ -- AMG TODO check this, seems implausible
+ ; let gres = filter isRecFldGRE $ lookupGRE_RdrName' fos rdr env
; mapM lookupParent gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1499,11 +1499,8 @@ lookupName :: Bool -- True <=> type namespace
-- False <=> value namespace
-> String -> TcM (Maybe TH.Name)
lookupName is_type_name s
- = do { lcl_env <- getLocalRdrEnv
- ; case lookupLocalRdrEnv lcl_env rdr_name of
- Just n -> return (Just (reifyName n))
- Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
- ; return (fmap reifyName mb_nm) } }
+ = do { mb_nm <- lookupOccRn_maybe rdr_name
+ ; return (fmap reifyName mb_nm) }
where
th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
@@ -1552,18 +1549,10 @@ lookupThName th_name = do
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
lookupThName_maybe th_name
- = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+ = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name)
-- Pick the first that works
-- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
; return (listToMaybe names) }
- where
- lookup rdr_name
- = do { -- Repeat much of lookupOccRn, because we want
- -- to report errors in a TH-relevant way
- ; rdr_env <- getLocalRdrEnv
- ; case lookupLocalRdrEnv rdr_env rdr_name of
- Just name -> return (Just name)
- Nothing -> lookupGlobalOccRn_maybe rdr_name }
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -46,7 +46,7 @@ module GHC.Types.Name.Reader (
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
pprGlobalRdrEnv, globalRdrEnvElts,
- lookupGRE_RdrName, lookupGRE_Name,
+ lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name,
lookupGRE_Child, lookupGRE_FieldLabel,
lookupGRE_Name_OccName,
getGRE_NameQualifier_maybes,
@@ -74,6 +74,7 @@ module GHC.Types.Name.Reader (
-- * Utils
opIsAt,
+ FieldsOrSelectors(..),
) where
#include "HsVersions.h"
@@ -815,11 +816,26 @@ greOccName :: GlobalRdrElt -> OccName
greOccName GRE{gre_child = ChildName n} = nameOccName n
greOccName GRE{gre_child = ChildField fl} = mkVarOccFS (flLabel fl)
+
+-- | When looking up GREs, we may or may not want to include fields that were
+-- defined in modules with @NoFieldSelectors@ enabled.
+data FieldsOrSelectors
+ = IncludeFieldsWithoutSelectors -- ^ Include fields in @NoFieldSelectors@ modules
+ | ExcludeFieldsWithoutSelectors -- ^ Ignore such fields during lookup
+ deriving Eq
+
+filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt]
+filterFieldGREs IncludeFieldsWithoutSelectors = id
+filterFieldGREs ExcludeFieldsWithoutSelectors = filter (not . isNoFieldSelectorGRE)
+
lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
-lookupGRE_RdrName rdr_name env
+lookupGRE_RdrName = lookupGRE_RdrName' ExcludeFieldsWithoutSelectors
+
+lookupGRE_RdrName' :: FieldsOrSelectors -> RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
+lookupGRE_RdrName' fos rdr_name env
= case lookupOccEnv env (rdrNameOcc rdr_name) of
Nothing -> []
- Just gres -> pickGREs rdr_name gres
+ Just gres -> filterFieldGREs fos (pickGREs rdr_name gres)
lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
-- ^ Look for precisely this 'Name' in the environment. This tests
=====================================
testsuite/tests/rename/should_compile/NFSDRF.hs
=====================================
@@ -25,12 +25,12 @@ foo1 = Foo 3 "bar"
foo2 = Foo { foo = 3, bar = "bar" } -- disambiguate foo
-foo3 :: Foo
-foo3 = foo1 { foo = 4 } -- update
+-- foo3 :: Foo
+-- foo3 = foo1 { foo = 4 } -- currently rejected, see #18999
-foo4 = foo1 { bar = "baz" } -- bar is unambiguous
+foo4 = foo1 { bar = "baz" } -- unambiguous
bar0 = Bar { foo = 0, bar' = "bar'" }
-bar1 :: Bar
-bar1 = bar0 { foo = 1 }
+-- bar1 :: Bar
+-- bar1 = bar0 { foo = 1 } -- currently rejected, see #18999
=====================================
testsuite/tests/rename/should_compile/NoFieldSelectors.hs
=====================================
@@ -10,6 +10,7 @@ import Prelude
data Foo = Foo { foo :: Int, bar :: String }
+{-# ANN foo () #-}
foo = 3 -- should not conflict
fooX = foo + 1
@@ -24,6 +25,6 @@ foo1 = Foo 3 "bar"
foo2 = Foo { foo = 3, bar = "bar" } -- disambiguate foo
-foo3 = foo1 { foo = 4 } -- bar is unambiguous
+-- foo3 = foo1 { foo = 4 } -- currently rejected, see #18999
foo4 = foo1 { bar = "baz" } -- bar is unambiguous
=====================================
testsuite/tests/rename/should_fail/NoFieldSelectorsFail.hs
=====================================
@@ -18,3 +18,7 @@ foo3 :: Foo
foo3 = foo1 { foo = 4 } -- update
bar1 = bar0 { foo = 1 }
+
+bar = undefined
+
+foo4 = foo1 { bar = "" } -- currently rejected, see #18999
=====================================
testsuite/tests/rename/should_fail/NoFieldSelectorsFail.stderr
=====================================
@@ -1,18 +1,25 @@
-NoFieldSelectorsFail.hs:15:14:
+NoFieldSelectorsFail.hs:15:14: error:
Ambiguous occurrence ‘foo’
It could refer to
either the field ‘foo’, defined at NoFieldSelectorsFail.hs:10:18
or the field ‘foo’, defined at NoFieldSelectorsFail.hs:9:18
-NoFieldSelectorsFail.hs:18:15:
+NoFieldSelectorsFail.hs:18:15: error:
Ambiguous occurrence ‘foo’
It could refer to
either the field ‘foo’, defined at NoFieldSelectorsFail.hs:10:18
or the field ‘foo’, defined at NoFieldSelectorsFail.hs:9:18
-NoFieldSelectorsFail.hs:20:15:
+NoFieldSelectorsFail.hs:20:15: error:
Ambiguous occurrence ‘foo’
It could refer to
either the field ‘foo’, defined at NoFieldSelectorsFail.hs:10:18
- or the field ‘foo’, defined at NoFieldSelectorsFail.hs:9:18
\ No newline at end of file
+ or the field ‘foo’, defined at NoFieldSelectorsFail.hs:9:18
+
+NoFieldSelectorsFail.hs:24:15: error:
+ Ambiguous occurrence ‘bar’
+ It could refer to
+ either the field ‘bar’, defined at NoFieldSelectorsFail.hs:9:30
+ or ‘NoFieldSelectorsFail.bar’,
+ defined at NoFieldSelectorsFail.hs:22:1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461c9ba829fd4090d7aa11366cc908f1b6a42cb3...78970cde8c63f6243130971fe94181338a63cbc3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461c9ba829fd4090d7aa11366cc908f1b6a42cb3...78970cde8c63f6243130971fe94181338a63cbc3
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/20201126/af2a7833/attachment-0001.html>
More information about the ghc-commits
mailing list