[Git][ghc/ghc][wip/jade/ast] fixed ambiguity regression
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Wed Sep 25 14:37:53 UTC 2024
Hassan Al-Awwadi pushed to branch wip/jade/ast at Glasgow Haskell Compiler / GHC
Commits:
4775c0fa by Hassan Al-Awwadi at 2024-09-25T16:37:16+02:00
fixed ambiguity regression
- - - - -
17 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Fixity.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -549,6 +549,10 @@ deriving instance Data (FieldOcc GhcRn)
deriving instance Data (FieldOcc GhcTc)
deriving instance Data AmbiguousFieldOcc
+deriving instance Data (UpdFieldOcc GhcPs)
+deriving instance Data (UpdFieldOcc GhcRn)
+deriving instance Data (UpdFieldOcc GhcTc)
+
-- deriving instance (DataId name) => Data (ImportDecl name)
deriving instance Data (ImportDecl GhcPs)
deriving instance Data (ImportDecl GhcRn)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -56,7 +56,8 @@ module GHC.Hs.Type (
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..), noTypeArgs,
-
+ UpdFieldOcc(..), LUpdFieldOcc, mkUpdFieldOcc,
+ updFieldOccRdrName, updFieldOccLRdrName,
FieldOcc(..), LFieldOcc, mkFieldOcc,
fieldOccRdrName, fieldOccLRdrName,
AmbiguousFieldOcc(..),
@@ -1087,14 +1088,38 @@ type instance XCFieldOcc GhcRn = RdrName
type instance XCFieldOcc GhcTc = RdrName
type instance XXFieldOcc GhcPs = DataConCantHappen
-type instance XXFieldOcc GhcRn = AmbiguousFieldOcc
+type instance XXFieldOcc GhcRn = DataConCantHappen
type instance XXFieldOcc GhcTc = DataConCantHappen
+type instance XCUpdFieldOcc GhcPs = NoExtField
+type instance XCUpdFieldOcc GhcRn = NoExtField
+type instance XCUpdFieldOcc GhcTc = NoExtField
+
+type instance XXUpdFieldOcc GhcPs = DataConCantHappen
+type instance XXUpdFieldOcc GhcRn = AmbiguousFieldOcc
+type instance XXUpdFieldOcc GhcTc = DataConCantHappen
+
--------------------------------------------------------------------------------
+mkUpdFieldOcc :: LocatedN RdrName -> UpdFieldOcc GhcPs
+mkUpdFieldOcc rdr@(L l _) = UpdFieldOcc noExtField (L (l2l l) $ mkFieldOcc rdr)
+
mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc rdr = FieldOcc noExtField rdr
+updFieldOccRdrName :: forall p. IsPass p => UpdFieldOcc (GhcPass p) -> RdrName
+updFieldOccRdrName = unLoc . updFieldOccLRdrName
+
+updFieldOccLRdrName :: forall p. IsPass p => UpdFieldOcc (GhcPass p) -> LocatedN RdrName
+updFieldOccLRdrName (UpdFieldOcc _ (L _ fo)) = fieldOccLRdrName fo
+updFieldOccLRdrName (XUpdFieldOcc xfo) = case ghcPass @p of
+ GhcRn -> case xfo of
+ Ambiguous l -> l
+ -- Are these cases required? I don't get a hint that they aren't so
+ -- they are included for now.
+ GhcPs -> case xfo of
+ GhcTc -> case xfo of
+
fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName
fieldOccRdrName fo = case ghcPass @p of
GhcPs -> unLoc $ foLabel fo
@@ -1108,7 +1133,6 @@ fieldOccLRdrName fo = case ghcPass @p of
FieldOcc rdr sel ->
let (L l _) = sel
in L l rdr
- XFieldOcc (Ambiguous l) -> l
GhcTc ->
let (L l _) = foLabel fo
in L l (foExt fo)
@@ -1254,6 +1278,13 @@ instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+instance (IsPass p) => Outputable (UpdFieldOcc (GhcPass p))where
+ ppr = ppr . updFieldOccRdrName
+
+instance (IsPass p) => OutputableBndr (UpdFieldOcc (GhcPass p)) where
+ pprInfixOcc = pprInfixOcc . updFieldOccRdrName
+ pprPrefixOcc = pprPrefixOcc . updFieldOccRdrName
+
ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc
ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)
@@ -1565,3 +1596,4 @@ type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
type instance Anno AmbiguousFieldOcc = SrcSpanAnnA
+type instance Anno (UpdFieldOcc (GhcPass p)) = SrcSpanAnnA
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1539,7 +1539,6 @@ repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ s) = repOverLabel s
repE (HsRecSel _ (FieldOcc _ (L _ x))) = repE (HsVar noExtField (noLocA x))
-repE r@(HsRecSel _ (XFieldOcc _)) = notHandled (ThAmbiguousRecordSelectors r)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
@@ -1817,11 +1816,12 @@ repUpdFields = repListM fieldExpTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp))
rep_fld (L l fld) = case unLoc (hfbLHS fld) of
- FieldOcc _ (L _ sel_name) -> do { fn <- lookupLOcc (L l sel_name)
- ; e <- repLE (hfbRHS fld)
- ; repFieldExp fn e
- }
- (XFieldOcc _) -> notHandled (ThAmbiguousRecordUpdates fld)
+ UpdFieldOcc _ (L _ (FieldOcc _ (L _ sel_name))) ->
+ do { fn <- lookupLOcc (L l sel_name)
+ ; e <- repLE (hfbRHS fld)
+ ; repFieldExp fn e
+ }
+ (XUpdFieldOcc _) -> notHandled (ThAmbiguousRecordUpdates fld)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1257,7 +1257,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
RecordUpd { rupd_expr = expr
, rupd_flds = RegularRecUpdFields { recUpdFields = upds } }->
[ toHie expr
- , toHie $ map (RC RecFieldAssign) upds
+ , case hiePass @p of
+ HieRn -> toHie $ map (RC RecFieldAssign) upds
+ HieTc -> toHie $ map (RC RecFieldAssign) upds
]
RecordUpd { rupd_expr = expr
, rupd_flds = OverloadedRecUpdFields {} }->
@@ -1476,6 +1478,10 @@ instance ( ToHie (RFContext label)
, toHie expr
]
+instance HiePass p => ToHie (RFContext (LocatedA (UpdFieldOcc (GhcPass p)))) where
+ toHie (RFC c rhs (L nspan (UpdFieldOcc _ (L _ fo)))) = concatM
+ [toHie (RFC c rhs (L nspan fo))]
+ toHie (RFC _ _ (L _ (XUpdFieldOcc _))) = concatM []
instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where
toHie (RFC c rhs (L nspan f)) = concatM $
case hiePass @p of
@@ -1483,7 +1489,6 @@ instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where
case f of
FieldOcc _ fld ->
[toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)]
- XFieldOcc (Ambiguous _) -> []
HieTc ->
case f of
FieldOcc _ fld ->
@@ -2073,6 +2078,7 @@ instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where
instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
toHie (C c (FieldOcc _ l)) = toHie (C c l)
toHie (C _ (XFieldOcc _)) = concatM []
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2907,7 +2907,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
True -> do
let qualifiedFields =
[ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'
- , isQual . fieldOccRdrName $ lbl
+ , isQual . updFieldOccRdrName $ lbl
]
case qualifiedFields of
qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $
@@ -2953,7 +2953,7 @@ mk_rec_fields fs (Just s) = HsRecFields { rec_ext = noExtField, rec_flds = fs
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs
mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)
- = HsFieldBind noAnn (L loc (FieldOcc noExtField rdr)) arg pun
+ = HsFieldBind noAnn (L loc $ UpdFieldOcc noExtField (L loc (FieldOcc noExtField rdr))) arg pun
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1526,7 +1526,7 @@ lookupGlobalOccRn_overloaded rdr_name =
return (Just gre) }
getFieldUpdLbl :: IsPass p => LHsRecUpdField (GhcPass p) q -> LocatedN RdrName
-getFieldUpdLbl = fieldOccLRdrName . unLoc . hfbLHS . unLoc
+getFieldUpdLbl = updFieldOccLRdrName . unLoc . hfbLHS . unLoc
-- | Returns all possible collections of field labels for the given
-- record update.
@@ -1623,7 +1623,7 @@ lookupRecUpdFields flds
getUpdFieldLbls :: forall p q. IsPass p
=> [LHsRecUpdField (GhcPass p) q] -> [RdrName]
getUpdFieldLbls
- = map $ fieldOccRdrName
+ = map $ updFieldOccRdrName
. unXRec @(GhcPass p)
. hfbLHS
. unXRec @(GhcPass p)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -417,7 +417,7 @@ rnExpr (OpApp _ e1 op e2)
-- should prevent bad things happening.
; fixity <- case op' of
L _ (HsVar _ (L _ n)) -> lookupFixityRn n
- L _ (HsRecSel _ f) -> fromJust <$> lookupFieldFixityRn f
+ L _ (HsRecSel _ f) -> lookupFieldFixityRn f
_ -> return (Fixity minPrecedence InfixL)
-- c.f. lookupFixity for unbound
=====================================
compiler/GHC/Rename/Fixity.hs
=====================================
@@ -201,6 +201,5 @@ lookupFixityRn_help name
lookupTyFixityRn :: LocatedN Name -> RnM Fixity
lookupTyFixityRn = lookupFixityRn . unLoc
-lookupFieldFixityRn :: FieldOcc GhcRn -> RnM (Maybe Fixity)
-lookupFieldFixityRn (FieldOcc _ n) = Just <$> lookupFixityRn (unLoc n)
-lookupFieldFixityRn _ = pure Nothing
+lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
+lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n)
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1574,13 +1574,7 @@ lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp (NormalOp n) = lookupFixityRn n
lookupFixityOp NegateOp = lookupFixityRn negateName
lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u))
-lookupFixityOp (RecFldOp f) =
- -- We could get rid of this panic by parametrising FieldOcc with (k ::
- -- MaybeAmbiguous), say 'PossiblyAmbiguous | 'Unambiguous, and using
- -- 'PossiblyAmbiguous only for record field updates... but seems overkill
- fromMaybe (panic "lookupFixityOp: RecFldOp should not be ambiguous!") <$>
- lookupFieldFixityRn f
-
+lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
-- Precedence-related error messages
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1054,7 +1054,7 @@ rnHsRecUpdFields flds
-> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars)
rn_flds _ _ [] = return ([], emptyFVs)
rn_flds pun_ok mb_unambig_lbls
- ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f)
+ ((L l (HsFieldBind { hfbLHS = L loc (UpdFieldOcc _ (L _ (FieldOcc _ f)))
, hfbRHS = arg
, hfbPun = pun })):flds)
= do { let lbl = unLoc f
@@ -1066,19 +1066,23 @@ rnHsRecUpdFields flds
; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
- ; let lbl' :: FieldOcc GhcRn
+ ; let lbl' :: UpdFieldOcc GhcRn
lbl' = case mb_unambig_lbls of
{ Just (fl:_) ->
let sel_name = flSelector fl
- in FieldOcc lbl (L (l2l loc) sel_name)
- ; _ -> XFieldOcc (Ambiguous (L (l2l loc) lbl)) }
+ in UpdFieldOcc noExtField (L (l2l loc) (FieldOcc lbl (L (l2l loc) sel_name)))
+ ; _ -> XUpdFieldOcc (Ambiguous (L (l2l loc) lbl)) }
fld' :: LHsRecUpdField GhcRn GhcRn
fld' = L l (HsFieldBind { hfbAnn = noAnn
- , hfbLHS = L loc lbl'
+ , hfbLHS = L (l2l loc) lbl'
, hfbRHS = arg''
, hfbPun = pun })
; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds
; return (fld' : flds', fvs `plusFV` fvs') }
+ -- I have been told this datacon isn't necessary and yet my ghc gets mad at me
+ -- when I don't add it.
+ rn_flds _ _ ((L _ (HsFieldBind { hfbLHS = L _ (XUpdFieldOcc impossible ) })):_)
+ = case impossible of
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds flds = map (hsRecFieldSel . unLoc) flds
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1300,8 +1300,9 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
-- See Note [Disambiguating record updates] in GHC.Rename.Pat.
; (cons, rbinds)
<- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
- ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
- sel_ids = map (unLoc . foLabel) upd_flds
+ ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
+ -- upd_flds has type 'UpdFieldOcc GhcTc' so ufoField is not partial here.
+ sel_ids = map (unLoc . foLabel . unLoc . ufoField) upd_flds
upd_fld_names = map idName sel_ids
relevant_cons = nonDetEltsUniqSet cons
relevant_con = head relevant_cons
@@ -1584,7 +1585,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
-> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField fld_gre (L l upd)
= do { let L loc af = hfbLHS upd
- lbl = fieldOccRdrName af
+ lbl = updFieldOccRdrName af
mb_gre = pickGREs lbl [fld_gre]
-- NB: this GRE can be 'Nothing' when in GHCi.
-- See test T10439.
@@ -1596,7 +1597,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
; sel <- tcLookupId (greName fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
- , hfbLHS = L (l2l loc) $ FieldOcc lbl (L (l2l loc) sel)
+ , hfbLHS = L (l2l loc) (UpdFieldOcc noExtField (L (l2l loc) $ FieldOcc lbl (L (l2l loc) sel)))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
} }
@@ -1688,7 +1689,6 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs
; return Nothing }
where
field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc rdr
-tcRecordField _ _ (L _ (XFieldOcc (Ambiguous _))) _ = pure Nothing
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -567,7 +567,7 @@ tcInferAppHead_maybe :: HsExpr GhcRn
tcInferAppHead_maybe fun
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
- HsRecSel _ f -> tcInferRecSelId f
+ HsRecSel _ f -> Just <$> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
@@ -596,11 +596,11 @@ addHeadCtxt fun_ctxt thing_inside
********************************************************************* -}
tcInferRecSelId :: FieldOcc GhcRn
- -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
+ -> TcM ( (HsExpr GhcTc, TcSigmaType))
tcInferRecSelId (FieldOcc sel_name (L l n))
= do { sel_id <- tc_rec_sel_id
; let expr = HsRecSel noExtField (FieldOcc sel_name (L l sel_id))
- ; return $ Just(expr, idType sel_id)
+ ; return $ (expr, idType sel_id)
}
where
occ :: OccName
@@ -624,7 +624,6 @@ tcInferRecSelId (FieldOcc sel_name (L l n))
-- hence no checkTh stuff here
_ -> failWithTc $ TcRnExpectedValueId thing }
-tcInferRecSelId (XFieldOcc _) = pure Nothing
------------------------
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1654,14 +1654,6 @@ tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of
; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
; return (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel'))) pat'
pun), res) }
- tc_field _
- (L _ (HsFieldBind _ (L _ (XFieldOcc (Ambiguous (L _ _)))) _ _))
- _
- -- I don't like leaving things undefined, and I don't like leaving
- -- leaving pattern not matched. I think I should just throw in this
- -- case, but I don't know exactly how to do that.
- = undefined
-
-- See Note [Omitted record fields and linearity]
check_omitted_fields_multiplicity :: TcM MultiplicityCheckCoercions
check_omitted_fields_multiplicity = do
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1159,7 +1159,7 @@ cvtl e = wrapLA (cvt e)
; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'
- <- mapM (cvtFld (wrapParLA mkFieldOcc))
+ <- mapM (cvtFld (wrapParLA mkUpdFieldOcc))
flds
; return $ RecordUpd noAnn e' $
RegularRecUpdFields
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -686,6 +686,9 @@ type family XXConDeclField x
-- ---------------------------------------------------------------------
-- FieldOcc type families
+type family XCUpdFieldOcc x
+type family XXUpdFieldOcc x
+
type family XCFieldOcc x
type family XXFieldOcc x
=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -326,7 +326,7 @@ type LHsRecUpdField p q = XRec p (HsRecUpdField p q)
type HsRecField p arg = HsFieldBind (LFieldOcc p) arg
-- | Haskell Record Update Field
-type HsRecUpdField p q = HsFieldBind (LFieldOcc p) (LHsExpr q)
+type HsRecUpdField p q = HsFieldBind (LUpdFieldOcc p) (LHsExpr q)
-- | Haskell Field Binding
--
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -50,6 +50,7 @@ module Language.Haskell.Syntax.Type (
HsConDetails(..), noTypeArgs,
+ UpdFieldOcc(..), LUpdFieldOcc,
FieldOcc(..), LFieldOcc,
mapHsOuterImplicit,
@@ -1265,6 +1266,14 @@ The SrcSpan is the span of the original HsPar
* *
************************************************************************
-}
+type LUpdFieldOcc pass = XRec pass (UpdFieldOcc pass)
+
+data UpdFieldOcc pass
+ = UpdFieldOcc {
+ ufoExt :: XCUpdFieldOcc pass,
+ ufoField :: LFieldOcc pass
+ }
+ | XUpdFieldOcc (XXUpdFieldOcc pass)
-- | Located Field Occurrence
type LFieldOcc pass = XRec pass (FieldOcc pass)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4775c0facf18503d21a5544fb61b51f0129ef946
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4775c0facf18503d21a5544fb61b51f0129ef946
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/20240925/90393ae2/attachment-0001.html>
More information about the ghc-commits
mailing list