From cf65cf16c89414273c4f6b2d090d4b2fffb90759 Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Sun, 21 Feb 2021 11:48:17 -0500 Subject: Implement record dot syntax --- compiler/GHC/Tc/Gen/Expr.hs | 26 ++++++++++++++++++++++---- compiler/GHC/Tc/Types/Origin.hs | 4 ++++ compiler/GHC/Tc/Utils/Zonk.hs | 28 +++++++++++++++++++--------- 3 files changed, 45 insertions(+), 13 deletions(-) (limited to 'compiler/GHC/Tc') diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index dc0d244fc1..a74af6e564 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -639,7 +639,11 @@ following. -} -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty +-- Record updates via dot syntax are replaced by desugared expressions +-- in the renamer. See Note [Overview of record dot syntax] in +-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here +-- and panic otherwise. +tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty = ASSERT( notNull rbnds ) do { -- STEP -2: typecheck the record_expr, the record to be updated (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr @@ -805,11 +809,12 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty , rupd_out_tys = result_inst_tys , rupd_wrap = req_wrap } expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $ - mkLHsWrapCo co_scrut record_expr' - , rupd_flds = rbinds' + mkLHsWrapCo co_scrut record_expr' + , rupd_flds = Left rbinds' , rupd_ext = upd_tc } ; tcWrapResult expr expr' rec_res_ty res_ty } +tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!" {- @@ -825,6 +830,19 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty tcExpr (ArithSeq _ witness seq) res_ty = tcArithSeq witness seq res_ty +{- +************************************************************************ +* * + Record dot syntax +* * +************************************************************************ +-} + +-- These terms have been replaced by desugaring in the renamer. See +-- Note [Overview of record dot syntax]. +tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented" +tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented" + {- ************************************************************************ * * @@ -1274,7 +1292,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." ] where - rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds, rupd_ext = noExtField } + rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } loc = getLoc (head rbnds) {- diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 648bf5ce12..b1dd472d75 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -375,6 +375,7 @@ data CtOrigin | AssocFamPatOrigin -- When matching the patterns of an associated -- family instance with that of its parent class | SectionOrigin + | HasFieldOrigin FastString | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty @@ -478,6 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name +exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) @@ -493,6 +495,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (HsProjection _ _) = SectionOrigin exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" @@ -629,6 +632,7 @@ pprCtO IfOrigin = text "an if expression" pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin = text "an operator section" +pprCtO (HasFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)] pprCtO AssocFamPatOrigin = text "the LHS of a family instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4d4860c7e1..90717063f7 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -946,21 +946,31 @@ zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } -zonkExpr env (RecordUpd { rupd_flds = rbinds +-- Record updates via dot syntax are replaced by desugared expressions +-- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This +-- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. +zonkExpr env (RecordUpd { rupd_flds = Left rbinds , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) + , rupd_ext = RecordUpdTc { + rupd_cons = cons + , rupd_in_tys = in_tys + , rupd_out_tys = out_tys + , rupd_wrap = req_wrap }}) = do { new_expr <- zonkLExpr env expr ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys ; new_rbinds <- zonkRecUpdFields env rbinds ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } + ; return ( + RecordUpd { + rupd_expr = new_expr + , rupd_flds = Left new_rbinds + , rupd_ext = RecordUpdTc { + rupd_cons = cons + , rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys + , rupd_wrap = new_recwrap }}) } +zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!" zonkExpr env (ExprWithTySig _ e ty) = do { e' <- zonkLExpr env e -- cgit v1.2.1