summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Errors/Hole.hs16
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs170
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs45
-rw-r--r--compiler/GHC/Tc/Module.hs14
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs2
-rw-r--r--compiler/GHC/Tc/TyCl.hs5
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs37
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs7
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs14
11 files changed, 148 insertions, 170 deletions
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index 32091e7836..6514968b39 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -22,7 +22,8 @@ import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Types.Name
-import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )
+import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..)
+ , globalRdrEnvElts, greMangledName, grePrintableName )
import GHC.Builtin.Names ( gHC_ERR )
import GHC.Types.Id
import GHC.Types.Var.Set
@@ -441,8 +442,7 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit _ (RawHoleFit sd) = sd
pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
hang display 2 provenance
- where name = getName hfCand
- tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap
+ where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap
where pprArg b arg = case binderArgFlag b of
-- See Note [Explicit Case Statement for Specificity]
(Invisible spec) -> case spec of
@@ -471,7 +471,10 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches
holeDisp = if sMs then holeVs
else sep $ replicate (length hfMatches) $ text "_"
- occDisp = pprPrefixOcc name
+ occDisp = case hfCand of
+ GreHFCand gre -> pprPrefixOcc (grePrintableName gre)
+ NameHFCand name -> pprPrefixOcc name
+ IdHFCand id_ -> pprPrefixOcc id_
tyDisp = ppWhen sTy $ dcolon <+> ppr hfType
has = not . null
wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))
@@ -490,7 +493,8 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
provenance = ppWhen sProv $ parens $
case hfCand of
GreHFCand gre -> pprNameProvenance gre
- _ -> text "bound at" <+> ppr (getSrcLoc name)
+ NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name)
+ IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_)
getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]
getLocalBindings tidy_orig ct_loc
@@ -784,7 +788,7 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
#if __GLASGOW_HASKELL__ <= 810
IdHFCand id -> idName id
#endif
- GreHFCand gre -> gre_name gre
+ GreHFCand gre -> greMangledName gre
NameHFCand name -> name
discard_it = go subs seen maxleft ty elts
keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid)
diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
index 23943a8617..9c00c23cd1 100644
--- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
+++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
@@ -56,11 +56,11 @@ instance NamedThing HoleFitCandidate where
getName hfc = case hfc of
IdHFCand cid -> idName cid
NameHFCand cname -> cname
- GreHFCand cgre -> gre_name cgre
+ GreHFCand cgre -> greMangledName cgre
getOccName hfc = case hfc of
IdHFCand cid -> occName cid
NameHFCand cname -> occName cname
- GreHFCand cgre -> occName (gre_name cgre)
+ GreHFCand cgre -> occName (greMangledName cgre)
instance HasOccName HoleFitCandidate where
occName = getOccName
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 0e730a0b84..4d0c8da8e3 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -147,7 +147,7 @@ accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
Just (Just (acc', y)) -> (acc', Just y)
_ -> (acc, Nothing)
-type ExportOccMap = OccEnv (Name, IE GhcPs)
+type ExportOccMap = OccEnv (GreName, IE GhcPs)
-- Tracks what a particular exported OccName
-- in an export list refers to, and which item
-- it came from. It's illegal to export two distinct things
@@ -248,13 +248,9 @@ exports_from_avail Nothing rdr_env _imports _this_mod
-- Even though we don't check whether this is actually a data family
-- only data families can locally define subordinate things (`ns` here)
-- without locally defining (and instead importing) the parent (`n`)
- fix_faminst (AvailTC n ns flds) =
- let new_ns =
- case ns of
- [] -> [n]
- (p:_) -> if p == n then ns else n:ns
- in AvailTC n new_ns flds
-
+ fix_faminst avail@(AvailTC n ns)
+ | availExportsDecl avail = avail
+ | otherwise = AvailTC n (NormalGreName n:ns)
fix_faminst avail = avail
@@ -273,8 +269,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-- See Note [Avails of associated data families]
expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
- expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p })
- | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]
+ expand_tyty_gre (gre@GRE { gre_par = ParentIs p })
+ | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }]
expand_tyty_gre gre = [gre]
imported_modules = [ imv_name imv
@@ -355,10 +351,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
(n, avail, flds) <- lookup_ie_all ie n'
let name = unLoc n
return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n))
- , AvailTC name (name:avail) flds)
+ , availTC name (name:avail) flds)
- lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
+ lookup_ie ie@(IEThingWith _ l wc sub_rdrs)
= do
(lname, subs, avails, flds)
<- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
@@ -367,9 +363,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
NoIEWildcard -> return (lname, [], [])
IEWildcard _ -> lookup_ie_all ie l
let name = unLoc lname
- return (IEThingWith noExtField (replaceLWrappedName l name) wc subs
- (flds ++ (map noLoc all_flds)),
- AvailTC name (name : avails ++ all_avail)
+ let flds' = flds ++ (map noLoc all_flds)
+ return (IEThingWith flds' (replaceLWrappedName l name) wc subs,
+ availTC name (name : avails ++ all_avail)
(map unLoc flds ++ all_flds))
@@ -420,15 +416,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
-classifyGREs = partitionEithers . map classifyGRE
-
-classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
-classifyGRE gre = case gre_par gre of
- FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
- FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
- _ -> Left n
- where
- n = gre_name gre
+classifyGREs = partitionGreNames . map gre_name
-- Renaming and typechecking of exports happens after everything else has
-- been typechecked.
@@ -529,11 +517,12 @@ lookupChildrenExport spec_parent rdr_items =
NameNotFound -> do { ub <- reportUnboundName unboundName
; let l = getLoc n
; return (Left (L l (IEName (L l ub))))}
- FoundFL fls -> return $ Right (L (getLoc n) fls)
- FoundName par name -> do { checkPatSynParent spec_parent par name
- ; return
- $ Left (replaceLWrappedName n name) }
- IncorrectParent p g td gs -> failWithDcErr p g td gs
+ FoundChild par child -> do { checkPatSynParent spec_parent par child
+ ; return $ case child of
+ FieldGreName fl -> Right (L (getLoc n) fl)
+ NormalGreName name -> Left (replaceLWrappedName n name)
+ }
+ IncorrectParent p c gs -> failWithDcErr p c gs
-- Note: [Typing Pattern Synonym Exports]
@@ -595,33 +584,30 @@ lookupChildrenExport spec_parent rdr_items =
checkPatSynParent :: Name -- ^ Alleged parent type constructor
-- User wrote T( P, Q )
-> Parent -- The parent of P we discovered
- -> Name -- ^ Either a
+ -> GreName -- ^ Either a
-- a) Pattern Synonym Constructor
-- b) A pattern synonym selector
-> TcM () -- Fails if wrong parent
checkPatSynParent _ (ParentIs {}) _
= return ()
-checkPatSynParent _ (FldParent {}) _
- = return ()
-
-checkPatSynParent parent NoParent mpat_syn
+checkPatSynParent parent NoParent gname
| isUnboundName parent -- Avoid an error cascade
= return ()
| otherwise
= do { parent_ty_con <- tcLookupTyCon parent
- ; mpat_syn_thing <- tcLookupGlobal mpat_syn
+ ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname)
-- 1. Check that the Id was actually from a thing associated with patsyns
; case mpat_syn_thing of
AnId i | isId i
, RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
- -> handle_pat_syn (selErr i) parent_ty_con p
+ -> handle_pat_syn (selErr gname) parent_ty_con p
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
- _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
+ _ -> failWithDcErr parent gname [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
@@ -669,40 +655,47 @@ checkPatSynParent parent NoParent mpat_syn
check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
-> RnM ExportOccMap
check_occs ie occs avails
- -- 'names' and 'fls' are the entities specified by 'ie'
- = foldlM check occs names_with_occs
+ -- 'avails' are the entities specified by 'ie'
+ = foldlM check occs children
where
- -- Each Name specified by 'ie', paired with the OccName used to
- -- refer to it in the GlobalRdrEnv
- -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail).
- --
- -- We check for export clashes using the selector Name, but need
- -- the field label OccName for presenting error messages.
- names_with_occs = availsNamesWithOccs avails
-
- check occs (name, occ)
- = case lookupOccEnv occs name_occ of
- Nothing -> return (extendOccEnv occs name_occ (name, ie))
+ children = concatMap availGreNames avails
+
+ -- Check for distinct children exported with the same OccName (an error) or
+ -- for duplicate exports of the same child (a warning).
+ check :: ExportOccMap -> GreName -> RnM ExportOccMap
+ check occs child
+ = case try_insert occs child of
+ Right occs' -> return occs'
- Just (name', ie')
- | name == name' -- Duplicate export
+ Left (child', ie')
+ | greNameMangledName child == greNameMangledName child' -- Duplicate export
-- But we don't want to warn if the same thing is exported
-- by two different module exports. See ticket #4478.
-> do { warnIfFlag Opt_WarnDuplicateExports
- (not (dupExport_ok name ie ie'))
- (dupExportWarn occ ie ie')
+ (not (dupExport_ok child ie ie'))
+ (dupExportWarn child ie ie')
; return occs }
| otherwise -- Same occ name but different names: an error
-> do { global_env <- getGlobalRdrEnv ;
- addErr (exportClashErr global_env occ name' name ie' ie) ;
+ addErr (exportClashErr global_env child' child ie' ie) ;
return occs }
+
+ -- Try to insert a child into the map, returning Left if there is something
+ -- already exported with the same OccName
+ try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap
+ try_insert occs child
+ = case lookupOccEnv occs name_occ of
+ Nothing -> Right (extendOccEnv occs name_occ (child, ie))
+ Just x -> Left x
where
- name_occ = nameOccName name
+ -- For fields, we check for export clashes using the (OccName of the)
+ -- selector Name
+ name_occ = nameOccName (greNameMangledName child)
-dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
--- The Name is exported by both IEs. Is that ok?
+dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool
+-- The GreName is exported by both IEs. Is that ok?
-- "No" iff the name is mentioned explicitly in both IEs
-- or one of the IEs mentions the name *alone*
-- "Yes" otherwise
@@ -728,13 +721,13 @@ dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
-- import Foo
-- data instance T Int = TInt
-dupExport_ok n ie1 ie2
+dupExport_ok child ie1 ie2
= not ( single ie1 || single ie2
|| (explicit_in ie1 && explicit_in ie2) )
where
explicit_in (IEModuleContents {}) = False -- module M
explicit_in (IEThingAll _ r)
- = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..)
+ = occName child == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..)
explicit_in _ = True
single IEVar {} = True
@@ -788,9 +781,9 @@ exportItemErr export_item
text "attempts to export constructors or class methods that are not visible here" ]
-dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
-dupExportWarn occ_name ie1 ie2
- = hsep [quotes (ppr occ_name),
+dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc
+dupExportWarn child ie1 ie2
+ = hsep [quotes (ppr child),
text "is exported by", quotes (ppr ie1),
text "and", quotes (ppr ie2)]
@@ -806,11 +799,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 -> GreName -> [Name] -> TcM a
+failWithDcErr parent child parents = do
+ ty_thing <- tcLookupGlobal (greNameMangledName child)
failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
- thing_doc (map ppr parents)
+ (ppr child) (map ppr parents)
where
tyThingCategory' :: TyThing -> String
tyThingCategory' (AnId i)
@@ -818,32 +811,37 @@ failWithDcErr parent thing thing_doc parents = do
tyThingCategory' i = tyThingCategory i
-exportClashErr :: GlobalRdrEnv -> OccName
- -> Name -> Name
+exportClashErr :: GlobalRdrEnv
+ -> GreName -> GreName
-> IE GhcPs -> IE GhcPs
-> MsgDoc
-exportClashErr global_env occ name1 name2 ie1 ie2
+exportClashErr global_env child1 child2 ie1 ie2
= vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
- , ppr_export ie1' name1'
- , ppr_export ie2' name2' ]
+ , ppr_export child1' gre1' ie1'
+ , ppr_export child2' gre2' ie2'
+ ]
where
- ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
- quotes (ppr_name name))
- 2 (pprNameProvenance (get_gre name)))
+ occ = occName child1
+
+ ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
+ quotes (ppr_name child))
+ 2 (pprNameProvenance gre))
-- DuplicateRecordFields means that nameOccName might be a mangled
-- $sel-prefixed thing, in which case show the correct OccName alone
- ppr_name name
- | nameOccName name == occ = ppr name
- | otherwise = ppr occ
+ -- (but otherwise show the Name so it will have a module qualifier)
+ ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl
+ | otherwise = ppr (flSelector fl)
+ ppr_name (NormalGreName name) = ppr name
-- get_gre finds a GRE for the Name, so that we can show its provenance
- get_gre name
- = fromMaybe (pprPanic "exportClashErr" (ppr name))
- (lookupGRE_Name_OccName global_env name occ)
- get_loc name = greSrcSpan (get_gre name)
- (name1', ie1', name2', ie2') =
- case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of
- LT -> (name1, ie1, name2, ie2)
- GT -> (name2, ie2, name1, ie1)
+ gre1 = get_gre child1
+ gre2 = get_gre child2
+ get_gre child
+ = fromMaybe (pprPanic "exportClashErr" (ppr child))
+ (lookupGRE_GreName global_env child)
+ (child1', gre1', ie1', child2', gre2', ie2') =
+ case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of
+ LT -> (child1, gre1, ie1, child2, gre2, ie2)
+ GT -> (child2, gre2, ie2, child1, gre1, ie1)
EQ -> panic "exportClashErr: clashing exports have idential location"
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 15ca20b738..14c55d1627 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -1356,12 +1356,12 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
Just gre -> do { unless (null (tail xs)) $ do
let L loc _ = hsRecFieldLbl (unLoc upd)
setSrcSpan loc $ addUsedGRE True gre
- ; lookupSelector (upd, gre_name gre) }
+ ; lookupSelector (upd, greMangledName gre) }
-- The field doesn't belong to this parent, so report
-- an error but keep going through all the fields
Nothing -> do { addErrTc (fieldNotInType p
(unLoc (hsRecUpdFieldRdr (unLoc upd))))
- ; lookupSelector (upd, gre_name (snd (head xs))) }
+ ; lookupSelector (upd, greMangledName (snd (head xs))) }
-- Given a (field update, selector name) pair, look up the
-- selector to give a field update with an unambiguous Id
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 524d97077d..e5806637b0 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -493,11 +493,12 @@ tc_rec_sel_id lbl sel_name
= do { thing <- tcLookup sel_name
; case thing of
ATcId { tct_id = id }
- -> do { check_local_id occ id
+ -> do { check_naughty occ id
+ ; check_local_id id
; return id }
AGlobal (AnId id)
- -> do { check_global_id occ id
+ -> do { check_naughty occ id
; return id }
-- A global cannot possibly be ill-staged
-- nor does it need the 'lifting' treatment
@@ -545,7 +546,7 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type
Just gre ->
do { addUsedGRE True gre
- ; return (gre_name gre) } } } } }
+ ; return (greMangledName gre) } } } } }
-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
@@ -596,10 +597,10 @@ lookupParents rdr
; mapM lookupParent gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
- lookupParent gre = do { id <- tcLookupId (gre_name gre)
+ lookupParent gre = do { id <- tcLookupId (greMangledName gre)
; case recordSelectorTyCon_maybe id of
Just rstc -> return (rstc, gre)
- Nothing -> failWithTc (notSelector (gre_name gre)) }
+ Nothing -> failWithTc (notSelector (greMangledName gre)) }
fieldNotInType :: RecSelParent -> RdrName -> SDoc
@@ -758,12 +759,14 @@ tc_infer_id id_name
; global_env <- getGlobalRdrEnv
; case thing of
ATcId { tct_id = id }
- -> do { check_local_id occ id
+ -> do { check_local_id id
; return_id id }
AGlobal (AnId id)
- -> do { check_global_id occ id
- ; return_id id }
+ -> return_id id
+ -- A global cannot possibly be ill-staged
+ -- nor does it need the 'lifting' treatment
+ -- Hence no checkTh stuff here
AGlobal (AConLike cl) -> case cl of
RealDataCon con -> return_data_con con
@@ -798,8 +801,6 @@ tc_infer_id id_name
= text "Illegal term-level use of the type constructor"
<+> quotes (ppr (tyConName ty_con))
- occ = nameOccName id_name
-
return_id id = return (HsVar noExtField (noLoc id), idType id)
return_data_con con
@@ -845,19 +846,11 @@ tc_infer_id id_name
, mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)
}
-check_local_id :: OccName -> Id -> TcM ()
-check_local_id occ id
- = do { check_naughty occ id -- See Note [HsVar: naughty record selectors]
- ; checkThLocalId id
+check_local_id :: Id -> TcM ()
+check_local_id id
+ = do { checkThLocalId id
; tcEmitBindingUsage $ unitUE (idName id) One }
-check_global_id :: OccName -> Id -> TcM ()
-check_global_id occ id
- = check_naughty occ id -- See Note [HsVar: naughty record selectors]
- -- A global cannot possibly be ill-staged
- -- nor does it need the 'lifting' treatment
- -- Hence no checkTh stuff here
-
check_naughty :: OccName -> TcId -> TcM ()
check_naughty lbl id
| isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
@@ -868,15 +861,7 @@ nonBidirectionalErr name = failWithTc $
text "non-bidirectional pattern synonym"
<+> quotes (ppr name) <+> text "used in an expression"
-{- Note [HsVar: naughty record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-All record selectors should really be HsRecFld (ambiguous or
-unambiguous), but currently not all of them are: see #18452. So we
-need to check for naughty record selectors in tc_infer_id, as well as
-in tc_rec_sel_id.
-
-Remove this code when fixing #18452.
-
+{-
Note [Linear fields generalization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As per Note [Polymorphisation of linear fields], linear field of data
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 8da6031597..8f3cec19d0 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -1491,7 +1491,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
foe_binds
; fo_gres = fi_gres `unionBags` foe_gres
- ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)
+ ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre)
emptyFVs fo_gres
; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
@@ -1556,11 +1556,11 @@ tcPreludeClashWarn warnFlag name = do
where
isLocalDef = gre_lcl x == True
-- Names are identical ...
- nameClashes = nameOccName (gre_name x) == nameOccName name
+ nameClashes = nameOccName (greMangledName x) == nameOccName name
-- ... but not the actual definitions, because we don't want to
-- warn about a bad definition of e.g. <> in Data.Semigroup, which
-- is the (only) proper place where this should be defined
- isNotInProperModule = gre_name x /= name
+ isNotInProperModule = greMangledName x /= name
-- List of all offending definitions
clashingElts :: [GlobalRdrElt]
@@ -1569,9 +1569,9 @@ tcPreludeClashWarn warnFlag name = do
; traceTc "tcPreludeClashWarn/prelude_functions"
(hang (ppr name) 4 (sep [ppr clashingElts]))
- ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep
+ ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep
[ text "Local definition of"
- , (quotes . ppr . nameOccName . gre_name) x
+ , (quotes . ppr . nameOccName . greMangledName) x
, text "clashes with a future Prelude name." ]
$$
text "This will become an error in a future release." )
@@ -2489,7 +2489,7 @@ isGHCiMonad hsc_env ty
let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
case occIO of
Just [n] -> do
- let name = gre_name n
+ let name = greMangledName n
ghciClass <- tcLookupClass ghciIoClassName
userTyCon <- tcLookupTyCon name
let userTy = mkTyConApp userTyCon []
@@ -2857,7 +2857,7 @@ loadUnqualIfaces hsc_env ictxt
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
- , let name = gre_name gre
+ , let name = greMangledName gre
, nameIsFromExternalPackage home_unit name
, isTcOcc (nameOccName name) -- Types and classes only
, unQualOK gre ] -- In scope unqualified
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index d01f8992b5..1a5aacdbe1 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -1465,7 +1465,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
; addUsedGREs gre_list
-- If a newtype constructor was imported, don't warn about not
-- importing it...
- ; traverse_ keepAlive $ map gre_name gre_list
+ ; traverse_ keepAlive $ map greMangledName gre_list
-- ...and similarly, if a newtype constructor was defined in the same
-- module, don't warn about it being unused.
-- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 50d4f72610..b912baa04d 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4152,9 +4152,8 @@ checkPartialRecordField all_cons fld
(sep [text "Use of partial record field selector" <> colon,
nest 2 $ quotes (ppr occ_name)])
where
- sel_name = flSelector fld
- loc = getSrcSpan sel_name
- occ_name = getOccName sel_name
+ loc = getSrcSpan (flSelector fld)
+ occ_name = occName fld
(cons_with_field, cons_without_field) = partition has_field all_cons
has_field con = fld `elem` (dataConFieldLabels con)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 13b5da759f..ae9dd613d3 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -57,6 +57,7 @@ import GHC.Types.Id.Make
import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
+import GHC.Rename.Env
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Error
@@ -95,7 +96,7 @@ recoverPSB (PSB { psb_id = L _ name
; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
; return (emptyBag, gbl_env) }
where
- (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
+ (_arg_names, is_infix) = collectPatSynArgInfo details
mk_placeholder matcher_name
= mkPatSyn name is_infix
([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])
@@ -144,7 +145,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
= addPatSynCtxt lname $
do { traceTc "tcInferPatSynDecl {" $ ppr name
- ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+ ; let (arg_names, is_infix) = collectPatSynArgInfo details
; (tclvl, wanted, ((lpat', args), pat_ty))
<- pushLevelAndCaptureConstraints $
tcInferPat PatSyn lpat $
@@ -184,6 +185,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
; mapM_ dependentArgErr bad_args
; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
+ ; rec_fields <- lookupConstructorFields name
; tc_patsyn_finish lname dir is_infix lpat'
(mkTyVarBinders InferredSpec univ_tvs
, req_theta, ev_binds, req_dicts)
@@ -355,7 +357,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
, ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ]
; let decl_arity = length arg_names
- (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+ (arg_names, is_infix) = collectPatSynArgInfo details
; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
Right stuff -> return stuff
@@ -440,6 +442,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
; traceTc "tcCheckPatSynDecl }" $ ppr name
+ ; rec_fields <- lookupConstructorFields name
; tc_patsyn_finish lname dir is_infix lpat'
(skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
(skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
@@ -623,21 +626,12 @@ a pattern synonym. What about the /building/ side?
-}
collectPatSynArgInfo :: HsPatSynDetails GhcRn
- -> ([Name], [Name], Bool)
+ -> ([Name], Bool)
collectPatSynArgInfo details =
case details of
- PrefixCon _ names -> (map unLoc names, [], False)
- InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
- RecCon names -> (vars, sels, False)
- where
- (vars, sels) = unzip (map splitRecordPatSyn names)
- where
- splitRecordPatSyn :: RecordPatSynField (Located Name)
- -> (Name, Name)
- splitRecordPatSyn (RecordPatSynField
- { recordPatSynPatVar = L _ patVar
- , recordPatSynSelectorId = L _ selId })
- = (patVar, selId)
+ PrefixCon _ names -> (map unLoc names, False)
+ InfixCon name1 name2 -> (map unLoc [name1, name2], True)
+ RecCon names -> (map (unLoc . recordPatSynPatVar) names, False)
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
@@ -663,7 +657,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name
-> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types
-> TcType -- ^ Pattern type
- -> [Name] -- ^ Selector names
+ -> [FieldLabel] -- ^ Selector names
-- ^ Whether fields, empty if not record PatSyn
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish lname dir is_infix lpat'
@@ -709,13 +703,6 @@ tc_patsyn_finish lname dir is_infix lpat'
ex_tvs prov_theta
arg_tys pat_ty
- -- TODO: Make this have the proper information
- ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
- , flIsOverloaded = False
- , flSelector = name }
- field_labels' = map mkFieldLabel field_labels
-
-
-- Make the PatSyn itself
; let patSyn = mkPatSyn (unLoc lname) is_infix
(univ_tvs, req_theta)
@@ -723,7 +710,7 @@ tc_patsyn_finish lname dir is_infix lpat'
arg_tys
pat_ty
matcher_id builder_id
- field_labels'
+ field_labels
-- Selectors
; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 7fff1a9e35..c1888c7f36 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -174,7 +174,8 @@ checkHsigIface tcg_env gr sig_iface
-- The hsig did NOT define this function; that means it must
-- be a reexport. In this case, make sure the 'Name' of the
-- reexport matches the 'Name exported here.
- | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
+ | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do
+ let name' = greMangledName gre
when (name /= name') $ do
-- See Note [Error reporting bad reexport]
-- TODO: Actually this error swizzle doesn't work
@@ -751,7 +752,7 @@ mergeSignatures
let ifaces = lcl_iface : ext_ifaces
-- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
- let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+ let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)
| (occ, f) <- concatMap mi_fixities ifaces
, rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
@@ -951,7 +952,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
let avails = calculateAvails home_unit
impl_iface False{- safe -} NotBoot ImportedBySystem
- fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+ fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)
| (occ, f) <- mi_fixities impl_iface
, rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
updGblEnv (\tcg_env -> tcg_env {
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index a1ca04b487..93a43795dc 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -625,7 +625,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_dir = dir }))
= do { id' <- zonkIdBndr env id
; (env1, lpat') <- zonkPat env lpat
- ; let details' = zonkPatSynDetails env1 details
+ ; details' <- zonkPatSynDetails env1 details
; (_env2, dir') <- zonkPatSynDir env1 dir
; return $ PatSynBind x $
bind { psb_id = L loc id'
@@ -635,13 +635,17 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails GhcTc
- -> HsPatSynDetails GhcTc
+ -> TcM (HsPatSynDetails GhcTc)
zonkPatSynDetails env (PrefixCon _ as)
- = PrefixCon noTypeArgs (map (zonkLIdOcc env) as)
+ = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as)
zonkPatSynDetails env (InfixCon a1 a2)
- = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+ = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
zonkPatSynDetails env (RecCon flds)
- = RecCon (map (fmap (zonkLIdOcc env)) flds)
+ = RecCon <$> mapM (zonkPatSynField env) flds
+
+zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
+zonkPatSynField env (RecordPatSynField x y) =
+ RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc
-> TcM (ZonkEnv, HsPatSynDir GhcTc)
View Lorry Controller Status