diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Builtin/Names.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 65 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Parser.y | 95 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 42 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 151 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 121 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types/Origin.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 28 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 2 |
17 files changed, 530 insertions, 71 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 6f9aec86cb..93ea664739 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -332,6 +332,9 @@ basicKnownKeyNames fromListNName, toListName, + -- Overloaded record dot, record update + getFieldName, setFieldName, + -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, @@ -1527,6 +1530,11 @@ fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey +-- HasField class ops +getFieldName, setFieldName :: Name +getFieldName = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey +setFieldName = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey + -- Class Show showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey @@ -2548,6 +2556,10 @@ unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 +-- HasField class ops +getFieldClassOpKey, setFieldClassOpKey :: Unique +getFieldClassOpKey = mkPreludeMiscIdUnique 572 +setFieldClassOpKey = mkPreludeMiscIdUnique 573 ------------------------------------------------------ -- ghc-bignum uses 600-699 uniques diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index e0ef09eba8..3633edf48c 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3554,6 +3554,8 @@ xFlagsDeps = [ flagSpec "Rank2Types" LangExt.RankNTypes, flagSpec "RankNTypes" LangExt.RankNTypes, flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + flagSpec "OverloadedRecordDot" LangExt.OverloadedRecordDot, + flagSpec "OverloadedRecordUpdate" LangExt.OverloadedRecordUpdate, depFlagSpec' "RecordPuns" LangExt.RecordPuns (deprecatedForExtension "NamedFieldPuns"), flagSpec "RecordWildCards" LangExt.RecordWildCards, diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index ab6ebadd06..42ae115dab 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -287,6 +287,18 @@ type instance XRecordUpd GhcPs = NoExtField type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc +type instance XGetField GhcPs = NoExtField +type instance XGetField GhcRn = NoExtField +type instance XGetField GhcTc = Void +-- HsGetField is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XProjection GhcPs = NoExtField +type instance XProjection GhcRn = NoExtField +type instance XProjection GhcTc = Void +-- HsProjection is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + type instance XExprWithTySig (GhcPass _) = NoExtField type instance XArithSeq GhcPs = NoExtField @@ -509,8 +521,15 @@ ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) GhcRn -> ppr con GhcTc -> ppr con -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) - = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) + = case flds of + Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) + +ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) + = ppr fexp <> dot <> ppr field + +ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (punctuate dot (map ppr flds))) ppr_expr (ExprWithTySig _ expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) @@ -655,6 +674,8 @@ hsExprNeedsParens p = go go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False + go (HsProjection{}) = True + go (HsGetField{}) = False go (XExpr x) | GhcTc <- ghcPass @p = case x of @@ -828,7 +849,47 @@ A general recipe to follow this approach for new constructs could go as follows: - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we typecheck the desugared expression while reporting the original one in errors +-} +{- Note [Overview of record dot syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the note that explains all the moving parts for record dot +syntax. + +The language extensions @OverloadedRecordDot@ and +@OverloadedRecordUpdate@ (providing "record dot syntax") are +implemented using the techniques of Note [Rebindable syntax and +HsExpansion]. + +When OverloadedRecordDot is enabled: +- Field selection expressions + - e.g. foo.bar.baz + - Have abstract syntax HsGetField + - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions +- Field selector expressions e.g. (.x.y) + - Have abstract syntax HsProjection + - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions + +When OverloadedRecordUpdate is enabled: +- Record update expressions + - e.g. a{foo.bar=1, quux="corge", baz} + - Have abstract syntax RecordUpd + - With rupd_flds containting a Right + - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr) + - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions + - Note that this is true for all record updates even for those that do not involve '.' + +When OverloadedRecordDot is enabled and RebindableSyntax is not +enabled the name 'getField' is resolved to GHC.Records.getField. When +OverloadedRecordDot is enabled and RebindableSyntax is enabled the +name 'getField' is whatever in-scope name that is. + +When OverloadedRecordUpd is enabled and RebindableSyntax is not +enabled it is an error for now (temporary while we wait on native +setField support; see +https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When +OverloadedRecordUpd is enabled and RebindableSyntax is enabled the +names 'getField' and 'setField' are whatever in-scope names they are. -} -- See Note [Rebindable syntax and HsExpansion] just above. diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 9aadaff9fd..3a8c106b90 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -595,10 +595,14 @@ addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) = do { rec_binds' <- addTickHsRecordBinds rec_binds ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = flds' }) } + ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } addTickHsExpr (ExprWithTySig x e ty) = liftM3 ExprWithTySig @@ -627,6 +631,8 @@ addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr e@(HsGetField {}) = return e +addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = liftM2 (HsProc x) (addTickLPat pat) @@ -987,7 +993,6 @@ addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr ; return (L l (HsRecField id expr' pun)) } - addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = liftM From diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 50d9594e3c..387963827e 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -276,6 +276,9 @@ dsExpr (ExprWithTySig _ e _) = dsLExpr e dsExpr (HsConLikeOut _ con) = dsConLike con dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" +dsExpr (HsGetField x _ _) = absurd x +dsExpr (HsProjection x _) = absurd x + dsExpr (HsLit _ lit) = do { warnAboutOverflowedLit lit ; dsLit (convertLit lit) } @@ -603,7 +606,11 @@ we want, namely -} -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields +dsExpr RecordUpd { rupd_flds = Right _} = + -- Not possible due to elimination in the renamer. See Note + -- [Handling overloaded and rebindable constructs] + panic "The impossible happened" +dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields , rupd_ext = RecordUpdTc { rupd_cons = cons_to_upd , rupd_in_tys = in_inst_tys diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index d3453fcd56..149c683d83 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1581,10 +1581,15 @@ repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) +repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds }) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } +repE (RecordUpd { rupd_flds = Right _ }) + = do + -- Not possible due to elimination in the renamer. See Note + -- [Handling overloaded and rebindable constructs] + panic "The impossible has happened!" repE (ExprWithTySig _ e wc_ty) = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $ diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 3fe14085a9..4c75399ee0 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1118,10 +1118,13 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where con_name = case hiePass @p of -- Like ConPat HieRn -> con HieTc -> fmap conLikeName con - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + RecordUpd {rupd_expr = expr, rupd_flds = Left upds}-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds ] + RecordUpd {rupd_expr = expr, rupd_flds = Right _}-> + [ toHie expr + ] ExprWithTySig _ expr sig -> [ toHie expr , toHie $ TS (ResolvedScopes [mkLScope expr]) sig @@ -1159,6 +1162,8 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where HsSpliceE _ x -> [ toHie $ L mspan x ] + HsGetField {} -> [] + HsProjection {} -> [] XExpr x | GhcTc <- ghcPass @p , WrapExpr (HsWrap w a) <- x diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index ff380f8c75..df581b1898 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -64,7 +64,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS ) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Fixity @@ -658,6 +658,8 @@ are the most common patterns, rewritten as regular expressions for clarity: '-<<' { L _ (ITLarrowtail _) } -- for arrow notation '>>-' { L _ (ITRarrowtail _) } -- for arrow notation '.' { L _ ITdot } + PREFIX_PROJ { L _ (ITproj True) } -- RecordDotSyntax + TIGHT_INFIX_PROJ { L _ (ITproj False) } -- RecordDotSyntax PREFIX_AT { L _ ITtypeApp } PREFIX_PERCENT { L _ ITpercent } -- for linear types @@ -2737,6 +2739,22 @@ fexp :: { ECP } fmap ecpFromExp $ ams (sLL $1 $> $ HsStatic noExtField $2) [mj AnnStatic $1] } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | fexp TIGHT_INFIX_PROJ field + {% runPV (unECP $1) >>= \ $1 -> + -- Suppose lhs is an application term e.g. 'f a' + -- and rhs is '.b'. Usually we want the parse 'f + -- (a.b)' rather than '(f a).b.'. However, if lhs + -- is a projection 'r.a' (say) then we want the + -- parse '(r.a).b'. + fmap ecpFromExp $ ams (case $1 of + L _ (HsApp _ f arg) | not $ isGetField f -> + let l = comb2 arg $3 in + L (getLoc f `combineSrcSpans` l) + (HsApp noExtField f (mkRdrGetField l arg $3)) + _ -> mkRdrGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] } + | aexp { $1 } aexp :: { ECP } @@ -2826,10 +2844,12 @@ aexp :: { ECP } aexp1 :: { ECP } : aexp1 '{' fbinds '}' { ECP $ - unECP $1 >>= \ $1 -> - $3 >>= \ $3 -> - amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) - (moc $2:mcc $4:(fst $3)) } + getBit OverloadedRecordUpdateBit >>= \ overloaded -> + unECP $1 >>= \ $1 -> + $3 >>= \ $3 -> + amms (mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) + (moc $2:mcc $4:(fst $3)) + } | aexp2 { $1 } aexp2 :: { ECP } @@ -2858,6 +2878,14 @@ aexp2 :: { ECP } amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) ((mop $1:fst $2) ++ [mcp $3]) } + -- This case is only possible when 'OverloadedRecordDotBit' is enabled. + | '(' projection ')' { ECP $ + let (loc, (anns, fIELDS)) = $2 + span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3) + expr = mkRdrProjection span (reverse fIELDS) + in amms (ecpFromExp' expr) ([mop $1] ++ reverse anns ++ [mcp $3]) + } + | '(#' texp '#)' { ECP $ unECP $2 >>= \ $2 -> amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) @@ -2907,6 +2935,14 @@ aexp2 :: { ECP } Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } +projection :: { (SrcSpan, ([AddAnn], [Located FastString])) } +projection + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer + : projection TIGHT_INFIX_PROJ field + { let (loc, (anns, fs)) = $1 in + (combineSrcSpans (combineSrcSpans loc (gl $2)) (gl $3), (mj AnnDot $2 : anns, $3 : fs)) } + | PREFIX_PROJ field { (comb2 $1 $2, ([mj AnnDot $1], [$2])) } + splice_exp :: { LHsExpr GhcPs } : splice_untyped { mapLoc (HsSpliceE noExtField) $1 } | splice_typed { mapLoc (HsSpliceE noExtField) $1 } @@ -3323,33 +3359,65 @@ qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } +fbinds :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } : fbinds1 { $1 } | {- empty -} { return ([],([], Nothing)) } -fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } +fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } : fbind ',' fbinds1 { $1 >>= \ $1 -> $3 >>= \ $3 -> - addAnnotation (gl $1) AnnComma (gl $2) >> + let gl' = \case { Left (L l _) -> l; Right (L l _) -> l } in + addAnnotation (gl' $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } | fbind { $1 >>= \ $1 -> return ([],([$1], Nothing)) } | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } -fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } +fbind :: { forall b. DisambECP b => PV (Fbind b) } : qvar '=' texp { unECP $3 >>= \ $3 -> - ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) - [mj AnnEqual $2] } + fmap Left $ ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] + } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... | qvar { placeHolderPunRhs >>= \rhs -> - return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } + fmap Left $ return (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True) + } -- In the punning case, use a place-holder -- The renamer fills in the final value + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp + { do + let top = $1 + fields = top : reverse $3 + final = last fields + l = comb2 top final + isPun = False + $5 <- unECP $5 + fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun + } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | field TIGHT_INFIX_PROJ fieldToUpdate + { do + let top = $1 + fields = top : reverse $3 + final = last fields + l = comb2 top final + isPun = True + var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final)) + fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun + } + +fieldToUpdate :: { [Located FastString] } +fieldToUpdate + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 } + | field { [$1] } + ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -3649,6 +3717,9 @@ qvar :: { Located RdrName } -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. +field :: { Located FastString } + : VARID { sL1 $1 $! getVARID $1 } + qvarid :: { Located RdrName } : varid { $1 } | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index f0f4372c8a..83812f7673 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -153,6 +153,15 @@ data PsErrorDesc | PsErrPrecedenceOutOfRange !Int -- ^ Precedence out of range + | PsErrOverloadedRecordDotInvalid + -- ^ Invalid use of record dot syntax `.' + + | PsErrOverloadedRecordUpdateNotEnabled + -- ^ `OverloadedRecordUpdate` is not enabled. + + | PsErrOverloadedRecordUpdateNoQualifiedFields + -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled. + | PsErrInvalidDataCon !(HsType GhcPs) -- ^ Cannot parse data constructor in a data/newtype declaration diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 8e083b0141..47c8104fd1 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -234,6 +234,15 @@ pp_err = \case PsErrPrecedenceOutOfRange i -> text "Precedence out of range: " <> int i + PsErrOverloadedRecordDotInvalid + -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" + + PsErrOverloadedRecordUpdateNoQualifiedFields + -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled" + + PsErrOverloadedRecordUpdateNotEnabled + -> text "OverloadedRecordUpdate needs to be enabled" + PsErrInvalidDataCon t -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 (ppr t) @@ -607,4 +616,3 @@ pp_hint = \case perhaps_as_pat :: SDoc perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" - diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index b7a3daced5..71fccbe7c5 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -616,6 +616,19 @@ $tab { warnTab } -- | | ordinary operator or type operator, -- | | e.g. xs ~ 3, (~ x), Int ~ Bool -- ----------+---------------+------------------------------------------ +-- . | prefix | ITproj True +-- | | field projection, +-- | | e.g. .x +-- | tight infix | ITproj False +-- | | field projection, +-- | | e.g. r.x +-- | suffix | ITdot +-- | | function composition, +-- | | e.g. f. g +-- | loose infix | ITdot +-- | | function composition, +-- | | e.g. f . g +-- ----------+---------------+------------------------------------------ -- $ $$ | prefix | ITdollar, ITdollardollar -- | | untyped or typed Template Haskell splice, -- | | e.g. $(f x), $$(f x), $$"str" @@ -777,6 +790,7 @@ data Token | ITpercent -- Prefix (%) only, e.g. a %1 -> b | ITstar IsUnicodeSyntax | ITdot + | ITproj Bool -- Extension: OverloadedRecordDotBit | ITbiglam -- GHC-extension symbols @@ -1594,6 +1608,9 @@ varsym_prefix = sym $ \span exts s -> | s == fsLit "-" -> return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus -- and don't hit this code path. See Note [Minus tokens] + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> + return (ITproj True) -- e.g. '(.x)' + | s == fsLit "." -> return ITdot | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise -> @@ -1614,8 +1631,10 @@ varsym_suffix = sym $ \span _ s -> -- See Note [Whitespace-sensitive operator parsing] varsym_tight_infix :: Action -varsym_tight_infix = sym $ \span _ s -> +varsym_tight_infix = sym $ \span exts s -> if | s == fsLit "@" -> return ITat + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) + | s == fsLit "." -> return ITdot | otherwise -> do { addWarning Opt_WarnOperatorWhitespace $ PsWarnOperatorWhitespace (mkSrcSpanPs span) s @@ -1624,7 +1643,11 @@ varsym_tight_infix = sym $ \span _ s -> -- See Note [Whitespace-sensitive operator parsing] varsym_loose_infix :: Action -varsym_loose_infix = sym (\_ _ s -> return $ ITvarsym s) +varsym_loose_infix = sym $ \_ _ s -> + if | s == fsLit "." + -> return ITdot + | otherwise + -> return $ ITvarsym s consym :: Action consym = sym (\_span _exts s -> return $ ITconsym s) @@ -1632,8 +1655,13 @@ consym = sym (\_span _exts s -> return $ ITconsym s) sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> - return $ L span keyword + Just (keyword, NormalSyntax, 0) -> do + exts <- getExts + if fs == fsLit "." && + exts .&. (xbit OverloadedRecordDotBit) /= 0 && + xtest OverloadedRecordDotBit exts + then L span <$!> con span exts fs -- Process by varsym_*. + else return $ L span keyword Just (keyword, NormalSyntax, i) -> do exts <- getExts if exts .&. i /= 0 @@ -2641,6 +2669,8 @@ data ExtBits | ImportQualifiedPostBit | LinearTypesBit | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] + | OverloadedRecordDotBit + | OverloadedRecordUpdateBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2716,7 +2746,9 @@ mkParserOpts warningFlags extensionFlags .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost .|. LinearTypesBit `xoptBit` LangExt.LinearTypes - .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot + .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 3159902647..234df36be9 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -15,6 +16,7 @@ -- Functions over HsSyn specialised to RdrName. module GHC.Parser.PostProcess ( + mkRdrGetField, mkRdrProjection, isGetField, Fbind, -- RecordDot mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkSpliceDecl, @@ -27,7 +29,7 @@ module GHC.Parser.PostProcess ( mkFamDecl, mkInlinePragma, mkPatSynMatchGroup, - mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkRecConstrOrUpdate, mkTyClD, mkInstD, mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, @@ -107,7 +109,7 @@ module GHC.Parser.PostProcess ( import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import GHC.Core.DataCon ( DataCon, dataConTyCon ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, FieldLabelString ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader @@ -135,7 +137,8 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc import GHC.Parser.Annotation -import Data.List (findIndex) +import Data.Either +import Data.List import Data.Foldable import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic @@ -148,7 +151,6 @@ import Data.Kind ( Type ) #include "HsVersions.h" - {- ********************************************************************** Construction functions for Rdr stuff @@ -1243,6 +1245,10 @@ ecpFromExp a = ECP (ecpFromExp' a) ecpFromCmd :: LHsCmd GhcPs -> ECP ecpFromCmd a = ECP (ecpFromCmd' a) +-- The 'fbinds' parser rule produces values of this type. See Note +-- [RecordDotSyntax field updates]. +type Fbind b = Either (LHsRecField GhcPs (Located b)) (LHsRecProj GhcPs (Located b)) + -- | Disambiguate infix operators. -- See Note [Ambiguous syntactic categories] class DisambInfixOp b where @@ -1270,6 +1276,8 @@ class b ~ (Body b) GhcPs => DisambECP b where ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) -- | Return an expression without ambiguity, or fail in a non-expression context. ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) + -- | This can only be satified by expressions. + mkHsProjUpdatePV :: SrcSpan -> Located [Located FieldLabelString] -> Located b -> Bool -> PV (LHsRecProj GhcPs (Located b)) -- | Disambiguate "\... -> ..." (lambda) mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Disambiguate "let ... in ..." @@ -1326,10 +1334,11 @@ class b ~ (Body b) GhcPs => DisambECP b where mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: + Bool -> -- Is OverloadedRecordUpdate in effect? SrcSpan -> SrcSpan -> Located b -> - ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> + ([Fbind b], Maybe SrcSpan) -> PV (Located b) -- | Disambiguate "-a" (negation) mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) @@ -1348,7 +1357,6 @@ class b ~ (Body b) GhcPs => DisambECP b where -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas rejectPragmaPV :: Located b -> PV () - {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (This Note is about the code in GHC, not about the user code that we are parsing) @@ -1397,6 +1405,7 @@ instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return ecpFromExp' (L l e) = cmdFail l (ppr e) + mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs @@ -1427,8 +1436,11 @@ instance DisambECP (HsCmd GhcPs) where mkHsExplicitListPV l xs = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) mkHsSplicePV (L l sp) = cmdFail l (ppr sp) - mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ - ppr a <+> ppr (mk_rec_fields fbinds ddLoc) + mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ let pp_op = fromMaybe (panic "cannot print infix operator") @@ -1454,6 +1466,7 @@ instance DisambECP (HsExpr GhcPs) where addError $ PsError (PsErrArrowCmdInExpr c) [] l return (L l hsHoleExpr) ecpFromExp' = return + mkHsProjUpdatePV l fields arg isPun = return $ mkRdrProjUpdate l fields arg isPun mkHsLamPV l mg = return $ L l (HsLam noExtField mg) mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs @@ -1483,8 +1496,8 @@ instance DisambECP (HsExpr GhcPs) where mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig)) mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp - mkHsRecordPV l lrec a (fbinds, ddLoc) = do - r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) + mkHsRecordPV opts l lrec a (fbinds, ddLoc) = do + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) checkRecordSyntax (L l r) mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) @@ -1512,6 +1525,7 @@ instance DisambECP (PatBuilder GhcPs) where ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] l mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l mkHsLetPV l _ _ = addFatalError $ PsError PsErrLetInPat [] l + mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 @@ -1537,9 +1551,13 @@ instance DisambECP (PatBuilder GhcPs) where ps <- traverse checkLPat xs return (L l (PatBuilderPat (ListPat noExtField ps))) mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV l _ a (fbinds, ddLoc) = do - r <- mkPatRec a (mk_rec_fields fbinds ddLoc) - checkRecordSyntax (L l r) + mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + else do + r <- mkPatRec a (mk_rec_fields fs ddLoc) + checkRecordSyntax (L l r) mkHsNegAppPV l (L lp p) = do lit <- case p of PatBuilderOverLit pos_lit -> return (L lp pos_lit) @@ -2135,23 +2153,71 @@ checkPrecP (L l (_,i)) (L _ ol) , getRdrName unrestrictedFunTyCon ] mkRecConstrOrUpdate - :: LHsExpr GhcPs + :: Bool + -> LHsExpr GhcPs -> SrcSpan - -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) + -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs) - -mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _lrec (fbinds,dd) | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp _ (fs,dd) + = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLoc (head ps)) + else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc - | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) - -mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs -mkRdrRecordUpd exp flds - = RecordUpd { rupd_ext = noExtField - , rupd_expr = exp - , rupd_flds = flds } + | otherwise = mkRdrRecordUpd overloaded_update exp fs + +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do + -- We do not need to know if OverloadedRecordDot is in effect. We do + -- however need to know if OverloadedRecordUpdate (passed in + -- overloaded_on) is in effect because it affects the Left/Right nature + -- of the RecordUpd value we calculate. + let (fs, ps) = partitionEithers fbinds + fs' = map (fmap mk_rec_upd_field) fs + case overloaded_on of + False | not $ null ps -> + -- A '.' was found in an update and OverloadedRecordUpdate isn't on. + addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] loc + False -> + -- This is just a regular record update. + return RecordUpd { + rupd_ext = noExtField + , rupd_expr = exp + , rupd_flds = Left fs' } + True -> do + let qualifiedFields = + [ L l lbl | L _ (HsRecField (L l lbl) _ _) <- fs' + , isQual . rdrNameAmbiguousFieldOcc $ lbl + ] + if not $ null qualifiedFields + then + addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) + else -- This is a RecordDotSyntax update. + return RecordUpd { + rupd_ext = noExtField + , rupd_expr = exp + , rupd_flds = Right (toProjUpdates fbinds) } + where + toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] + toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) + + -- Convert a top-level field update like {foo=2} or {bar} (punned) + -- to a projection update. + recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs + recFieldToProjUpdate (L l (HsRecField (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + -- The idea here is to convert the label to a singleton [FastString]. + let f = occNameFS . rdrNameOcc $ rdr + in mkRdrProjUpdate l (L loc [L loc f]) (punnedVar f) pun + where + -- If punning, compute HsVar "f" otherwise just arg. This + -- has the effect that sentinel HsVar "pun-rhs" is replaced + -- by HsVar "f" here, before the update is written to a + -- setField expressions. + punnedVar :: FastString -> LHsExpr GhcPs + punnedVar f = if not pun then arg else noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOccFS $ f mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds @@ -2632,3 +2698,36 @@ mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) starSym :: Bool -> String starSym True = "★" starSym False = "*" + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. + +-- Test if the expression is a 'getField @"..."' expression. +isGetField :: LHsExpr GhcPs -> Bool +isGetField (L _ HsGetField{}) = True +isGetField _ = False + +mkRdrGetField :: SrcSpan -> LHsExpr GhcPs -> Located FieldLabelString -> LHsExpr GhcPs +mkRdrGetField loc arg field = + L loc HsGetField { + gf_ext = noExtField + , gf_expr = arg + , gf_field = field + } + +mkRdrProjection :: SrcSpan -> [Located FieldLabelString] -> LHsExpr GhcPs +mkRdrProjection _ [] = panic "mkRdrProjection: The impossible has happened!" +mkRdrProjection loc flds = + L loc HsProjection { + proj_ext = noExtField + , proj_flds = flds + } + +mkRdrProjUpdate :: SrcSpan -> Located [Located FieldLabelString] -> LHsExpr GhcPs -> Bool -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate _ (L _ []) _ _ = panic "mkRdrProjUpdate: The impossible has happened!" +mkRdrProjUpdate loc (L l flds) arg isPun = + L loc HsRecField { + hsRecFieldLbl = L l (FieldLabelStrings flds) + , hsRecFieldArg = arg + , hsRecPun = isPun + } diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index fad921265a..1ffbc4371a 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -304,6 +304,25 @@ rnExpr (NegApp _ e _) ; return (final_e, fv_e `plusFV` fv_neg) } ------------------------------------------ +-- Record dot syntax + +rnExpr (HsGetField _ e f) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (e, fv_e) <- rnLExpr e + ; return ( mkExpandedExpr + (HsGetField noExtField e f) + (mkGetField getField e f) + , fv_e `plusFV` fv_getField ) } + +rnExpr (HsProjection _ fs) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; circ <- lookupOccRn compose_RDR + ; return ( mkExpandedExpr + (HsProjection noExtField fs) + (mkProjection getField circ fs) + , unitFV circ `plusFV` fv_getField) } + +------------------------------------------ -- Template Haskell extensions rnExpr e@(HsBracket _ br_body) = rnBracket e br_body @@ -406,11 +425,28 @@ rnExpr (RecordCon { rcon_con = con_id ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' - , rupd_flds = rbinds' } - , fvExpr `plusFV` fvRbinds) } + = case rbinds of + Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + do { ; (e, fv_e) <- rnLExpr expr + ; (rs, fv_rs) <- rnHsRecUpdFields flds + ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs ) + } + Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + do { ; unlessXOptM LangExt.RebindableSyntax $ + addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld] + ; punsEnabled <-xoptM LangExt.RecordPuns + ; unless (null punnedFields || punsEnabled) $ + addErr $ text "For this to work enable NamedFieldPuns." + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnLExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; return ( mkExpandedExpr + (RecordUpd noExtField e (Right us)) + (mkRecordDotUpd getField setField e us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) + } rnExpr (ExprWithTySig _ expr pty) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty @@ -2497,6 +2533,12 @@ genLHsVar nm = wrapGenSpan $ genHsVar nm genHsVar :: Name -> HsExpr GhcRn genHsVar nm = HsVar noExtField $ wrapGenSpan nm +genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn +genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan + +genHsTyLit :: FastString -> HsType GhcRn +genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText + wrapGenSpan :: a -> Located a -- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion] @@ -2510,3 +2552,72 @@ mkExpandedExpr -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion' mkExpandedExpr a b = XExpr (HsExpanded a b) + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. +-- +-- See Note [Overview of record dot syntax] in GHC.Hs.Expr. + +-- mkGetField arg field calcuates a get_field @field arg expression. +-- e.g. z.x = mkGetField z x = get_field @x z +mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn +mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field) + +-- mkSetField a field b calculates a set_field @field expression. +-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b"). +mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn +mkSetField set_field a (L _ field) b = + genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b + +mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn] +mkGet get_field l@(r : _) (L _ field) = + wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l +mkGet _ [] _ = panic "mkGet : The impossible has happened!" + +mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn +mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) + +-- mkProjection fields calculates a projection. +-- e.g. .x = mkProjection [x] = getField @"x" +-- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x" +mkProjection :: Name -> Name -> [Located FieldLabelString] -> HsExpr GhcRn +mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields + where + f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn + f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] + + proj :: Located FieldLabelString -> HsExpr GhcRn + proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f +mkProjection _ _ [] = panic "mkProjection: The impossible happened" + +-- mkProjUpdateSetField calculates functions representing dot notation record updates. +-- e.g. Suppose an update like foo.bar = 1. +-- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). +mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) +mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds)), hsRecFieldArg = arg } )) + = let { + ; final = last flds -- quux + ; fields = init flds -- [foo, bar, baz] + ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow. + -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a] + ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow. + -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)] + } + in (\a -> foldl' (mkSet set_field) arg (zips a)) + -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux)))) + +mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn +mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates + where + fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn + fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc) + +rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars) +rnHsUpdProjs us = do + (u, fvs) <- unzip <$> mapM rnRecUpdProj us + pure (u, plusFVs fvs) + where + rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) + rnRecUpdProj (L l (HsRecField fs arg pun)) + = do { (arg, fv) <- rnLExpr arg + ; return $ (L l (HsRecField { hsRecFieldLbl = fs, hsRecFieldArg = arg, hsRecPun = pun}), fv) } 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!" {- @@ -828,6 +833,19 @@ tcExpr (ArithSeq _ 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" + +{- +************************************************************************ +* * Template Haskell * * ************************************************************************ @@ -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 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 12f65d36ca..29976e4b89 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1020,7 +1020,7 @@ cvtl e = wrapL (cvt e) ; flds' <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds - ; return $ mkRdrRecordUpd e' flds' } + ; return $ RecordUpd noExtField e' (Left flds') } cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain |