summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Builtin/Names.hs12
-rw-r--r--compiler/GHC/Driver/Session.hs2
-rw-r--r--compiler/GHC/Hs/Expr.hs65
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs11
-rw-r--r--compiler/GHC/HsToCore/Expr.hs9
-rw-r--r--compiler/GHC/HsToCore/Quote.hs7
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs7
-rw-r--r--compiler/GHC/Parser.y95
-rw-r--r--compiler/GHC/Parser/Errors.hs9
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs10
-rw-r--r--compiler/GHC/Parser/Lexer.x42
-rw-r--r--compiler/GHC/Parser/PostProcess.hs151
-rw-r--r--compiler/GHC/Rename/Expr.hs121
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs26
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs28
-rw-r--r--compiler/GHC/ThToHs.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs135
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs2
-rw-r--r--docs/users_guide/exts/hasfield.rst5
-rw-r--r--docs/users_guide/exts/overloaded_record_dot.rst34
-rw-r--r--docs/users_guide/exts/overloaded_record_update.rst61
-rw-r--r--docs/users_guide/exts/records.rst2
-rw-r--r--libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs2
-rw-r--r--testsuite/tests/driver/T4437.hs2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs17
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs4
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs5
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs40
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr13
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs8
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr25
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs140
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr36
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs26
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr15
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs11
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs24
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr1
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs8
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs17
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs11
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr5
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs9
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr4
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs37
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr25
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs8
-rw-r--r--testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr9
-rw-r--r--testsuite/tests/parser/should_fail/all.T14
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax1.hs141
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax1.stdout38
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax2.hs33
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax2.stdout12
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax3.hs14
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax3.stdout3
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax4.hs9
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntax4.stdout1
-rw-r--r--testsuite/tests/parser/should_run/RecordDotSyntaxA.hs6
-rw-r--r--testsuite/tests/parser/should_run/all.T4
m---------utils/haddock0
66 files changed, 1552 insertions, 75 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
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 3d6500d342..9967a78314 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -40,6 +40,7 @@ import Language.Haskell.Syntax.Binds
-- others:
import GHC.Tc.Types.Evidence
import GHC.Core
+import GHC.Core.DataCon (FieldLabelString)
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.Fixity
@@ -59,6 +60,110 @@ import qualified Data.Data as Data (Fixity(..))
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
+{- Note [RecordDotSyntax field updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The extensions @OverloadedRecordDot@ @OverloadedRecordUpdate@ together
+enable record updates like @a{foo.bar.baz = 1}@. Introducing this
+syntax slightly complicates parsing. This note explains how it's done.
+
+In the event a record is being constructed or updated, it's this
+production that's in play:
+@
+aexp1 -> aexp1 '{' fbinds '}' {
+ ...
+ mkHsRecordPV ... $1 (snd $3)
+}
+@
+@fbinds@ is a list of field bindings. @mkHsRecordPV@ is a function of
+the @DisambECP b@ typeclass, see Note [Ambiguous syntactic
+categories].
+
+The "normal" rules for an @fbind@ are:
+@
+fbind
+ : qvar '=' texp
+ | qvar
+@
+These rules compute values of @LHsRecField GhcPs (Located b)@. They
+apply in the context of record construction, record updates, record
+patterns and record expressions. That is, @b@ ranges over @HsExpr
+GhcPs@, @HsPat GhcPs@ and @HsCmd GhcPs@.
+
+When @OverloadedRecordDot@ and @OverloadedRecordUpdate@ are both
+enabled, two additional @fbind@ rules are admitted:
+@
+ | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
+ | field TIGHT_INFIX_PROJ fieldToUpdate
+@
+
+These rules only make sense when parsing record update expressions
+(that is, patterns and commands cannot be parsed by these rules and
+neither record constructions).
+
+The results of these new rules cannot be represented by @LHsRecField
+GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We
+minimize modifying existing code by having these new rules calculate
+@LHsRecProj GhcPs (Located b)@ ("record projection") values instead:
+@
+newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString]
+type RecProj arg = HsRecField' FieldLabelStrings arg
+type LHsRecProj p arg = Located (RecProj arg)
+@
+
+The @fbind@ rule is then given the type @fbind :: { forall b.
+DisambECP b => PV (Fbind b) }@ accomodating both alternatives:
+@
+type Fbind b = Either
+ (LHsRecField GhcPs (Located b))
+ ( LHsRecProj GhcPs (Located b))
+@
+
+In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular
+updates vs. projection updates by means of the @rupd_flds@ member
+type, an @Either@ instance:
+@
+ | RecordUpd
+ { rupd_ext :: XRecordUpd p
+ , rupd_expr :: LHsExpr p
+ , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p]
+ }
+@
+Here,
+@
+type RecUpdProj p = RecProj (LHsExpr p)
+type LHsRecUpdProj p = Located (RecUpdProj p)
+@
+and @Left@ values indicating regular record update, @Right@ values
+updates desugared to @setField@s.
+
+If @OverloadedRecordUpdate@ is enabled, any updates parsed as
+@LHsRecField GhcPs@ values are converted to @LHsRecUpdProj GhcPs@
+values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess').
+-}
+
+-- | RecordDotSyntax field updates
+
+newtype FieldLabelStrings =
+ FieldLabelStrings [Located FieldLabelString]
+ deriving (Data)
+
+instance Outputable FieldLabelStrings where
+ ppr (FieldLabelStrings flds) =
+ hcat (punctuate dot (map (ppr . unLoc) flds))
+
+-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
+-- [RecordDotSyntax field updates].
+type RecProj arg = HsRecField' FieldLabelStrings arg
+
+-- The phantom type parameter @p@ is for symmetry with @LHsRecField p
+-- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process).
+type LHsRecProj p arg = Located (RecProj arg)
+
+-- These two synonyms are used in the definition of syntax @RecordUpd@
+-- below.
+type RecUpdProj p = RecProj (LHsExpr p)
+type LHsRecUpdProj p = Located (RecUpdProj p)
+
{-
************************************************************************
* *
@@ -356,16 +461,44 @@ data HsExpr p
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,
-- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@
+ -- 'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot',
+ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| RecordUpd
{ rupd_ext :: XRecordUpd p
, rupd_expr :: LHsExpr p
- , rupd_flds :: [LHsRecUpdField p]
+ , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p]
}
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
+ -- | Record field selection e.g @z.x@.
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'
+ --
+ -- This case only arises when the OverloadedRecordDot langauge
+ -- extension is enabled.
+
+ | HsGetField {
+ gf_ext :: XGetField p
+ , gf_expr :: LHsExpr p
+ , gf_field :: Located FieldLabelString
+ }
+
+ -- | Record field selector. e.g. @(.x)@ or @(.x.y)@
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'
+ -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'
+ --
+ -- This case only arises when the OverloadedRecordDot langauge
+ -- extensions is enabled.
+
+ | HsProjection {
+ proj_ext :: XProjection p
+ , proj_flds :: [Located FieldLabelString]
+ }
+
-- | Expression with an explicit type signature. @e :: type@
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 16b11b3e30..f843bee1a2 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -387,6 +387,8 @@ type family XDo x
type family XExplicitList x
type family XRecordCon x
type family XRecordUpd x
+type family XGetField x
+type family XProjection x
type family XExprWithTySig x
type family XArithSeq x
type family XBracket x
diff --git a/docs/users_guide/exts/hasfield.rst b/docs/users_guide/exts/hasfield.rst
index d83d3f15bd..5682c9f901 100644
--- a/docs/users_guide/exts/hasfield.rst
+++ b/docs/users_guide/exts/hasfield.rst
@@ -102,6 +102,8 @@ are generated for each datatype definition:
instance (Eq a, a ~ b) => HasField "unSilly" (Silly a) b
+See :ref:`overloaded-record-dot` for an application of solving ``HasField`` constraints to implementing "record dot syntax".
+
.. _virtual-record-fields:
Virtual record fields
@@ -172,6 +174,3 @@ constraint will not be solved automatically (as described above), but in the
interests of simplicity we do not permit users to define their own instances
either. If a field is not in scope, the corresponding instance is still
prohibited, to avoid conflicts in downstream modules.
-
-
-
diff --git a/docs/users_guide/exts/overloaded_record_dot.rst b/docs/users_guide/exts/overloaded_record_dot.rst
new file mode 100644
index 0000000000..26f29b352c
--- /dev/null
+++ b/docs/users_guide/exts/overloaded_record_dot.rst
@@ -0,0 +1,34 @@
+.. _overloaded-record-dot:
+
+Overloaded record dot
+---------------------
+
+.. extension:: OverloadedRecordDot
+ :shortdesc: Record '.' syntax
+
+ :since: 9.2.0
+
+ Provides record '.' syntax e.g. ``x.foo``
+
+When ``OverloadedRecordDot`` is enabled one can write ``a.b`` to mean the ``b`` field of the ``a`` record expression.
+
+Example:
+
+.. code-block:: haskell
+
+ {-# LANGUAGE OverloadedRecordDot #-}
+ {-# LANGUAGE DuplicateRecordFields #-}
+
+ data Person = Person { name :: String }
+ data Company = Company { name :: String, owner :: Person }
+
+ main = do
+ let c = Company { name = "Acme Corp."
+ , owner = Person { name = "Wile E. Coyote" } }
+ print $ c.name ++ " is run by " ++ c.owner.name
+
+You may also write ``(.b)`` to mean a function that "projects the ``b`` field from its argument". For example, ``(.b) a`` means the same thing as ``a.b``).
+
+``OverloadedRecordDot`` is normally implemented by desugaring record ``.`` expressions to ``GHC.Records.getField`` expressions. By enabling ``OverloadedRecordDot`` and ``RebindableSyntax`` together it is possible to desugar ``.`` expressions into your own ``getField`` implementations.
+
+When considering ``a.b``, the ``b`` field that is meant is determined by solving ``HasField`` constraints. See :ref:`solving-hasfield-constraints`.
diff --git a/docs/users_guide/exts/overloaded_record_update.rst b/docs/users_guide/exts/overloaded_record_update.rst
new file mode 100644
index 0000000000..2e9df747dc
--- /dev/null
+++ b/docs/users_guide/exts/overloaded_record_update.rst
@@ -0,0 +1,61 @@
+.. _overloaded-record-update:
+
+Overloaded record update
+------------------------
+
+.. extension:: OverloadedRecordUpdate
+ :shortdesc: Record '.' syntax record updates
+
+ :since: 9.2.0
+
+ Provides record '.' syntax in record updates e.g. ``x{foo.bar = 1}``.
+
+**EXPERIMENTAL**
+*This design of this extension may well change in the future. It would be inadvisable to start using this extension for long-lived libraries just yet.*
+
+It's usual (but not required) that this extension be used in conjunction with :ref:`overloaded-record-dot`.
+
+Example:
+
+.. code-block:: haskell
+
+ {-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds, FlexibleInstances #-}
+ {-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+ {-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax #-}
+
+ import Prelude
+
+ class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+ getField :: forall x r a . HasField x r a => r -> a
+ getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+ setField :: forall x r a . HasField x r a => r -> a -> r
+ setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+ data Person = Person { name :: String } deriving Show
+ instance HasField "name" Person String where
+ hasField r = (\x -> case r of Person { .. } -> Person { name = x, .. }, name r)
+
+ data Company = Company { company :: String, owner :: Person } deriving Show
+ instance HasField "company" Company String where
+ hasField r = (\x -> case r of Company { .. } -> Company { company = x, .. }, company r)
+ instance HasField "owner" Company Person where
+ hasField r = (\x -> case r of Company { .. } -> Company { owner = x, .. }, owner r)
+
+ main = do
+ let c = Company {company = "Acme Corp.", owner = Person { name = "Wile E. Coyote" }}
+
+ -- Top-level update
+ print $ c{company = "Acme United"} -- Company {company = "Acme United", owner = Person {name = "Wile E. Coyote"}}
+
+ -- Nested update
+ print $ c{owner.name = "Walter C. Johnsen"} -- Company {company = "Acme Corp.", owner = Person {name = "Walter C. Johnsen"}}
+
+ -- Punned update
+ let name = "Walter C. Johnsen"
+ print $ c{owner.name} -- Company {company = "Acme Corp.", owner = Person {name = "Walter C. Johnsen"}}
+
+``OverloadedRecordUpdate`` works by desugaring record ``.`` update expressions to expressions involving the functions ``setField`` and ``getField``. Note that all record updates will be desugared to ``setField`` expressions whether they use ``.`` notation or not.
+
+At this time, ``RebindableSyntax`` must be enabled when ``OverloadedRecordUpdate`` is and users are required to provide definitions for ``getField`` and ``setField``. We anticipate this restriction to be lifted in a future release of GHC with builtin support for ``setField``.
diff --git a/docs/users_guide/exts/records.rst b/docs/users_guide/exts/records.rst
index 9395cf4666..b1e3f84a7c 100644
--- a/docs/users_guide/exts/records.rst
+++ b/docs/users_guide/exts/records.rst
@@ -14,3 +14,5 @@ Records
record_puns
record_wildcards
hasfield
+ overloaded_record_dot
+ overloaded_record_update
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index a3c3e2edfe..b75977c74c 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -146,6 +146,8 @@ data Extension
| StandaloneKindSignatures
| LexicalNegation
| FieldSelectors
+ | OverloadedRecordDot
+ | OverloadedRecordUpdate
deriving (Eq, Enum, Show, Generic, Bounded)
-- 'Ord' and 'Bounded' are provided for GHC API users (see discussions
-- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 27be970d22..cbcbefc573 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -41,6 +41,8 @@ expectedGhcOnlyExtensions =
, "AlternativeLayoutRule"
, "AlternativeLayoutRuleTransitional"
, "FieldSelectors"
+ , "OverloadedRecordDot"
+ , "OverloadedRecordUpdate"
]
expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs
new file mode 100644
index 0000000000..22b5aed888
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedRecordUpdate #-}
+
+module RecordDotSyntaxA where
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+data Foo = Foo {foo :: Int}
+instance HasField "foo" Foo Int where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs
new file mode 100644
index 0000000000..f7692ec778
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+no = Foo { bar.baz = 1 }
+ -- Syntax error: Can't use '.' in construction.
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
new file mode 100644
index 0000000000..6e4a3fbae6
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
@@ -0,0 +1,2 @@
+ RecordDotSyntaxFail0.hs:3:12:
+ Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
new file mode 100644
index 0000000000..78b4f1072c
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+no Foo { bar.baz = x } = undefined
+ -- Syntax error: Field selector syntax doesn't participate
+ -- in patterns
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
new file mode 100644
index 0000000000..f1ab2b9f95
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail1.hs:3:10:
+ Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs
new file mode 100644
index 0000000000..cc76b469d5
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+{-# LANGUAGE RebindableSyntax #-}
+import Prelude
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Bar'
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+instance HasField "foo" Foo Bar where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+
+-- 'Bar' has a 'bar' field of type 'Baz'
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+instance HasField "bar" Bar Baz where
+ hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
+
+-- 'Baz' has a 'baz' field of type 'Quux'
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+instance HasField "baz" Baz Quux where
+ hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
+
+-- 'Quux' has a 'quux' field of type 'Int'
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+instance HasField "quux" Quux Int where
+ hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+ let quux = "Expecto patronum!"
+ print $ a{foo.bar.baz.quux} -- Type error. Does a{foo.bar.baz.quux} get underlined?
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
new file mode 100644
index 0000000000..38d9616489
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
@@ -0,0 +1,13 @@
+RecordDotSyntaxFail10.hs:40:11:
+ Couldn't match type ‘Int’ with ‘[Char]’
+ arising from a functional dependency between:
+ constraint ‘HasField "quux" Quux String’
+ arising from a use of ‘setField’
+ instance ‘HasField "quux" Quux Int’
+ at RecordDotSyntaxFail10.hs:34:10-33
+ In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’
+ In a stmt of a 'do' block: print $ a {foo.bar.baz.quux}
+ In the expression:
+ do let a = ...
+ let quux = "Expecto patronum!"
+ print $ a {foo.bar.baz.quux}
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs
new file mode 100644
index 0000000000..62f9bd8f23
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+data Foo = Foo { foo :: Bar }
+data Bar = Bar { bar :: Int }
+
+main = do
+ let a = Foo { foo = Bar { bar = 1 }}
+ print $ (.foo.bar.baz) a -- Oops, what is baz?
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
new file mode 100644
index 0000000000..4ca1005185
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
@@ -0,0 +1,25 @@
+RecordDotSyntaxFail11.hs:8:3:
+ Ambiguous type variable ‘a0’ arising from a use of ‘print’
+ prevents the constraint ‘(Show a0)’ from being solved.
+ Probable fix: use a type annotation to specify what ‘a0’ should be.
+ These potential instances exist:
+ instance Show Ordering -- Defined in ‘GHC.Show’
+ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
+ instance Show Integer -- Defined in ‘GHC.Show’
+ ...plus 23 others
+ ...plus N instances involving out-of-scope types
+ (use -fprint-potential-instances to see them all)
+ In the first argument of ‘($)’, namely ‘print’
+ In a stmt of a 'do' block: print $ (foo.bar.baz) a
+ In the expression:
+ do let a = ...
+ print $ (foo.bar.baz) a
+
+RecordDotSyntaxFail11.hs:8:11:
+ No instance for (GHC.Records.HasField "baz" Int a0)
+ arising from a use of ‘GHC.Records.getField’
+ In the second argument of ‘($)’, namely ‘(foo.bar.baz) a’
+ In a stmt of a 'do' block: print $ (foo.bar.baz) a
+ In the expression:
+ do let a = ...
+ print $ (foo.bar.baz) a
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs
new file mode 100644
index 0000000000..ba7f7effed
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+-- For "higher kinded data" test.
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# LANGUAGE RebindableSyntax #-}
+import Prelude
+
+-- Choice (C2a).
+
+import Data.Function -- for &
+import Data.Functor.Identity
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Bar'
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+instance HasField "foo" Foo Bar where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+
+-- 'Bar' has a 'bar' field of type 'Baz'
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+instance HasField "bar" Bar Baz where
+ hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
+
+-- 'Baz' has a 'baz' field of type 'Quux'
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+instance HasField "baz" Baz Quux where
+ hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
+
+-- 'Quux' has a 'quux' field of type 'Int'
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+instance HasField "quux" Quux Int where
+ hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)
+
+-- 'Corge' has a '&&&' field of type 'Int'
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
+instance HasField "&&&" Corge Int where
+ hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
+-- Note : Dot notation is not available for fields with operator
+-- names.
+
+-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
+data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
+instance HasField "f" Grault Foo where
+ hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r)
+instance HasField "g" Grault Foo where
+ hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r)
+
+-- "Higher kinded data"
+-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/)
+type family H f a where
+ H Identity a = a
+ H f a = f a
+data P f = P
+ { n :: H f String
+ }
+-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34.
+instance (a ~ H f String) => HasField "n" (P f) a where
+ hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r)
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+ let b = Corge{ (&&&) = 12 };
+ let c = Grault {
+ f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ }
+
+ -- A "selector" is an expression like '(.a)' or '(.a.b)'.
+ putStrLn "-- selectors:"
+ print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+ print $ (.foo.bar.baz) a -- Quux { quux = 42 }
+ print $ (.foo.bar.baz.quux) a -- 42
+ print $ ((&&&) b) -- 12
+ -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
+ print $ getField @"&&&" b -- 12
+
+ -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
+ putStrLn "-- selections:"
+ print $ a.foo.bar.baz.quux -- 42
+ print $ a.foo.bar.baz -- Quux { quux = 42 }
+ print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+ print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (const "hello") a.foo -- f r.x means f (r.x)
+ -- print $ f a .foo -- f r .x is illegal
+ print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
+ -- print $ f (g a) .foo -- f (g r) .x is illegal
+ print $ a.foo
+ & (.bar.baz.quux) -- 42
+ print $ (a.foo
+ ).bar.baz.quux -- 42
+ print $ (+) a.foo.bar.baz.quux 1 -- 43
+ print $ (+) (id a).foo.bar.baz.quux 1 -- 43
+ print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43
+
+ -- An "update" is an expression like 'r{ a.b = 12 }'.
+ putStrLn "-- updates:"
+ print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
+ print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } }
+ let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } }
+ print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } }
+ print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } }
+ print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } }
+ print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } }
+
+ -- A "punned update" is an expression like 'r{ a.b }' (where it is
+ -- understood that 'b' is a variable binding in the environment of
+ -- the field update - enabled only when the extension
+ -- 'NamedFieldPuns' is in effect).
+ putStrLn "-- punned updates:"
+ let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } }
+ print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4
+ f <- pure a
+ g <- pure a
+ print $ c{ f } -- 42, 1
+ print $ c{ f, g } -- 42, 42
+ print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4
+
+ putStrLn "-- misc:"
+ -- Higher kinded test.
+ let p = P { n = Just "me" } :: P Maybe
+ Just me <- pure p.n
+ putStrLn $ me
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr
new file mode 100644
index 0000000000..6ef0a51754
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr
@@ -0,0 +1,36 @@
+
+RecordDotSyntaxFail12.hs:123:25:
+ Illegal use of punning for field ‘quux’
+ Use NamedFieldPuns to permit this
+
+RecordDotSyntaxFail12.hs:123:46:
+ Illegal use of punning for field ‘baz’
+ Use NamedFieldPuns to permit this
+
+RecordDotSyntaxFail12.hs:123:65:
+ Illegal use of punning for field ‘bar’
+ Use NamedFieldPuns to permit this
+
+RecordDotSyntaxFail12.hs:124:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:125:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:126:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:127:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:129:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:132:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:133:11:
+ For this to work enable NamedFieldPuns.
+
+RecordDotSyntaxFail12.hs:134:11:
+ For this to work enable NamedFieldPuns.
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs
new file mode 100644
index 0000000000..7050145b9d
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RebindableSyntax #-}
+import Prelude
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Int'
+data Foo = Foo { foo :: Int } deriving (Show, Eq)
+instance HasField "foo" Foo Int where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+main = do
+ let a = Foo {foo = 12};
+ -- let foo = 13;
+ print $ a {foo}
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
new file mode 100644
index 0000000000..8b5369731f
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
@@ -0,0 +1,15 @@
+
+RecordDotSyntaxFail13.hs:26:11:
+ Couldn't match type ‘Int’ with ‘Foo -> Int’
+ arising from a functional dependency between:
+ constraint ‘HasField "foo" Foo (Foo -> Int)’
+ << This should not appear in error messages. If you see this
+ in an error message, please report a bug mentioning ‘record update’ at
+ https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>
+ instance ‘HasField "foo" Foo Int’
+ at RecordDotSyntaxFail13.hs:21:10-31
+ In the second argument of ‘($)’, namely ‘a {foo}’
+ In a stmt of a 'do' block: print $ a {foo}
+ In the expression:
+ do let a = ...
+ print $ a {foo}
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
new file mode 100644
index 0000000000..39a3e0256b
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordDot #-} -- Enable '.'
+{-# LANGUAGE NoOverloadedRecordUpdate #-} -- Definitely not enable overloaded updates.
+
+data Foo = Foo { foo :: Bar }
+data Bar = Bar { bar :: Baz }
+data Baz = Baz { baz :: Quux }
+data Quux = Quux { quux :: Int }
+
+no :: Foo -> Foo
+no foo = foo { bar.baz = Quux { quux = 42 } } } }
+-- For this to work, OverloadedRecordUpdate must be enabled
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
new file mode 100644
index 0000000000..5430e37bc9
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail2.hs:10:10:
+ OverloadedRecordUpdate needs to be enabled
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
new file mode 100644
index 0000000000..ae1a1fa797
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Corge' has a '&&&' field of type 'Int'
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
+instance HasField "&&&" Corge Int where
+ hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
+
+main = do
+ let b = Corge { (&&&) = 12 };
+ print $ (b.(&&&))
+ -- Syntax error: Dot notation is not available for fields with
+ -- operator names
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
new file mode 100644
index 0000000000..674b0c1e50
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
@@ -0,0 +1 @@
+RecordDotSyntaxFail3.hs:22:14: parse error on input ‘(’
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
new file mode 100644
index 0000000000..b921cbc4b2
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+data Foo = Foo { foo :: Int }
+
+main = do
+ let a = Foo { foo = 1 }
+ print $ (const "hello") a .foo
+ -- Syntax error: f r .x is illegal.
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
new file mode 100644
index 0000000000..4ffc9df51e
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail4.hs:7:29: error:
+ parse error on input ‘.’
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs
new file mode 100644
index 0000000000..c261a571b7
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+{-# LANGUAGE NoRebindableSyntax #-}
+
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+
+ -- An "update" is an expression like 'r{ a.b = 12 }'.
+ --
+ -- We don't support these (in the case Rebindable Syntax is off) yet
+ -- (waiting on HasField support).
+ putStrLn "-- updates:"
+ print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr
new file mode 100644
index 0000000000..efe360222c
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail5.hs:17:11:
+ RebindableSyntax is required if OverloadedRecordUpdate is enabled.
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs
new file mode 100644
index 0000000000..8265f56914
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax #-}
+
+module Main where
+
+import qualified RecordDotSyntaxA as A
+
+main = do
+ let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable.
+ print $ A.foo bar -- Application of a selector. Also reasonable.
+ let baz = bar{A.foo = 2} -- An update with a qualified field; not supported!
+ print $ A.foo baz
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr
new file mode 100644
index 0000000000..c53990475b
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr
@@ -0,0 +1,5 @@
+[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o )
+ [2 of 2] Compiling Main ( RecordDotSyntaxFail6.hs, RecordDotSyntaxFail6.o )
+
+ RecordDotSyntaxFail6.hs:10:17:
+ Fields cannot be qualified when OverloadedRecordUpdate is enabled
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs
new file mode 100644
index 0000000000..0d3d92b431
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main where
+
+import qualified RecordDotSyntaxA as A
+
+main = do
+ let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable.
+ print $ (bar.A.foo) -- A field selection where the field is qualified; parse error on input ‘A.foo’.
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr
new file mode 100644
index 0000000000..feee41589f
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr
@@ -0,0 +1,4 @@
+[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o )
+[2 of 2] Compiling Main ( RecordDotSyntaxFail7.hs, RecordDotSyntaxFail7.o )
+
+RecordDotSyntaxFail7.hs:9:16: parse error on input ‘A.foo’
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
new file mode 100644
index 0000000000..3b6fcc97e2
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax#-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+
+import Prelude
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Bar'
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+instance HasField "foo" Foo Bar where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+
+-- 'Bar' has a 'bar' field of type 'Baz'
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+instance HasField "bar" Bar Baz where
+ hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
+
+-- 'Baz' has a 'baz' field of type 'Quux'
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+instance HasField "baz" Baz Quux where
+ hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
+
+-- 'Quux' has a 'quux' field of type 'Int'
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+-- Forget to write this type's 'HasField' instance
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+ print $ a.foo.bar.baz.quux
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
new file mode 100644
index 0000000000..8bf921b79f
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
@@ -0,0 +1,25 @@
+RecordDotSyntaxFail8.hs:37:3:
+ Ambiguous type variable ‘a0’ arising from a use of ‘print’
+ prevents the constraint ‘(Show a0)’ from being solved.
+ Probable fix: use a type annotation to specify what ‘a0’ should be.
+ These potential instances exist:
+ instance Show Ordering -- Defined in ‘GHC.Show’
+ instance Show Bar -- Defined at RecordDotSyntaxFail8.hs:22:41
+ instance Show Baz -- Defined at RecordDotSyntaxFail8.hs:27:42
+ ...plus 27 others
+ ...plus N instances involving out-of-scope types
+ (use -fprint-potential-instances to see them all)
+ In the first argument of ‘($)’, namely ‘print’
+ In a stmt of a 'do' block: print $ ....baz.quux
+ In the expression:
+ do let a = ...
+ print $ ....quux
+
+RecordDotSyntaxFail8.hs:37:11:
+ No instance for (HasField "quux" Quux a0)
+ arising from selecting the field ‘quux’
+ In the second argument of ‘($)’, namely ‘....baz.quux’
+ In a stmt of a 'do' block: print $ ....baz.quux
+ In the expression:
+ do let a = ...
+ print $ ....quux
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs
new file mode 100644
index 0000000000..b262215215
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+data Foo = Foo { foo :: Int } deriving Show
+
+main = do
+ let a = Foo { foo = 42 }
+ let _ = a.foo :: String -- Type error. Does a.foo get underlined?
+ undefined
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
new file mode 100644
index 0000000000..ee15f9fc6b
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
@@ -0,0 +1,9 @@
+RecordDotSyntaxFail9.hs:7:11:
+ Couldn't match type ‘Int’ with ‘[Char]’
+ arising from selecting the field ‘foo’
+ In the expression: a.foo :: String
+ In a pattern binding: _ = a.foo :: String
+ In the expression:
+ do let a = ...
+ let _ = ...
+ undefined
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 88a37ec2ba..21d66337e9 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -175,3 +175,17 @@ test('T18251e', normal, compile_fail, [''])
test('T18251f', normal, compile_fail, [''])
test('T12446', normal, compile_fail, [''])
test('T17045', normal, compile_fail, [''])
+test('RecordDotSyntaxFail0', normal, compile_fail, [''])
+test('RecordDotSyntaxFail1', normal, compile_fail, [''])
+test('RecordDotSyntaxFail2', normal, compile_fail, [''])
+test('RecordDotSyntaxFail3', normal, compile_fail, [''])
+test('RecordDotSyntaxFail4', normal, compile_fail, [''])
+test('RecordDotSyntaxFail5', normal, compile_fail, [''])
+test('RecordDotSyntaxFail6', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail6', ''])
+test('RecordDotSyntaxFail7', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail7', ''])
+test('RecordDotSyntaxFail8', normal, compile_fail, [''])
+test('RecordDotSyntaxFail9', normal, compile_fail, [''])
+test('RecordDotSyntaxFail10', normal, compile_fail, [''])
+test('RecordDotSyntaxFail11', normal, compile_fail, [''])
+test('RecordDotSyntaxFail12', normal, compile_fail, [''])
+test('RecordDotSyntaxFail13', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.hs b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs
new file mode 100644
index 0000000000..2d14218f83
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+-- For "higher kinded data" test.
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# LANGUAGE RebindableSyntax #-}
+import Prelude
+
+-- Choice (C2a).
+
+import Data.Function -- for &
+import Data.Functor.Identity
+
+class HasField x r a | x r -> a where
+ hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Bar'
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+instance HasField "foo" Foo Bar where
+ hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+
+-- 'Bar' has a 'bar' field of type 'Baz'
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+instance HasField "bar" Bar Baz where
+ hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
+
+-- 'Baz' has a 'baz' field of type 'Quux'
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+instance HasField "baz" Baz Quux where
+ hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
+
+-- 'Quux' has a 'quux' field of type 'Int'
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+instance HasField "quux" Quux Int where
+ hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)
+
+-- 'Corge' has a '&&&' field of type 'Int'
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
+instance HasField "&&&" Corge Int where
+ hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
+-- Note : Dot notation is not available for fields with operator
+-- names.
+
+-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
+data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
+instance HasField "f" Grault Foo where
+ hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r)
+instance HasField "g" Grault Foo where
+ hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r)
+
+-- "Higher kinded data"
+-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/)
+type family H f a where
+ H Identity a = a
+ H f a = f a
+data P f = P
+ { n :: H f String
+ }
+-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34.
+instance (a ~ H f String) => HasField "n" (P f) a where
+ hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r)
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+ let b = Corge{ (&&&) = 12 };
+ let c = Grault {
+ f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ }
+
+ -- A "selector" is an expression like '(.a)' or '(.a.b)'.
+ putStrLn "-- selectors:"
+ print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+ print $ (.foo.bar.baz) a -- Quux { quux = 42 }
+ print $ (.foo.bar.baz.quux) a -- 42
+ print $ ((&&&) b) -- 12
+ -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
+ print $ getField @"&&&" b -- 12
+
+ -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
+ putStrLn "-- selections:"
+ print $ a.foo.bar.baz.quux -- 42
+ print $ a.foo.bar.baz -- Quux { quux = 42 }
+ print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+ print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (const "hello") a.foo -- f r.x means f (r.x)
+ -- print $ f a .foo -- f r .x is illegal
+ print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
+ -- print $ f (g a) .foo -- f (g r) .x is illegal
+ print $ a.foo
+ & (.bar.baz.quux) -- 42
+ print $ (a.foo
+ ).bar.baz.quux -- 42
+ print $ (+) a.foo.bar.baz.quux 1 -- 43
+ print $ (+) (id a).foo.bar.baz.quux 1 -- 43
+ print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43
+
+ -- An "update" is an expression like 'r{ a.b = 12 }'.
+ putStrLn "-- updates:"
+ print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
+ print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } }
+ let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } }
+ print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } }
+ print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } }
+ print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } }
+ print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } }
+
+ -- A "punned update" is an expression like 'r{ a.b }' (where it is
+ -- understood that 'b' is a variable binding in the environment of
+ -- the field update - enabled only when the extension
+ -- 'NamedFieldPuns' is in effect).
+ putStrLn "-- punned updates:"
+ let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+ print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } }
+ print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4
+ f <- pure a
+ g <- pure a
+ print $ c{ f } -- 42, 1
+ print $ c{ f, g } -- 42, 42
+ print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4
+
+ putStrLn "-- misc:"
+ -- Higher kinded test.
+ let p = P { n = Just "me" } :: P Maybe
+ Just me <- pure p.n
+ putStrLn $ me
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout
new file mode 100644
index 0000000000..9582e17da9
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout
@@ -0,0 +1,38 @@
+-- selectors:
+Bar {bar = Baz {baz = Quux {quux = 42}}}
+Baz {baz = Quux {quux = 42}}
+Quux {quux = 42}
+42
+12
+12
+-- selections:
+42
+Quux {quux = 42}
+Baz {baz = Quux {quux = 42}}
+Bar {bar = Baz {baz = Quux {quux = 42}}}
+"hello"
+"hello"
+42
+42
+43
+43
+43
+-- updates:
+Quux {quux = 2}
+Bar {bar = Baz {baz = Quux {quux = 1}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 44}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 45}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 46}}}}
+Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 3}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}}
+-- punned updates:
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}
+Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}}
+Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 1}}}}}
+Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}}
+Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}}
+-- misc:
+me
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.hs b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs
new file mode 100644
index 0000000000..89c520009f
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoRebindableSyntax #-}
+
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+
+main = do
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+
+ -- A "selector" is an expression like '(.a)' or '(.a.b)'.
+ putStrLn "-- selectors:"
+ print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+ print $ (.foo.bar.baz) a -- Quux { quux = 42 }
+ print $ (.foo.bar.baz.quux) a -- 42
+
+ -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
+ putStrLn "-- selections:"
+ print $ a.foo.bar.baz.quux -- 42
+ print $ a.foo.bar.baz -- Quux { quux = 42 }
+ print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+ print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+
+ -- An "update" is an expression like 'r{ a.b = 12 }'.
+ --
+ -- We don't support these (in the case Rebindable Syntax is off) yet
+ -- (waiting on HasField support).
+ --
+ -- Regular updates are fine though!
+ print $ a{foo=(foo a){bar = (bar (foo a)){baz = (baz (bar (foo a))){quux = quux (baz (bar (foo a))) + 1}}}}
+ print $ a{foo=(a.foo){bar = (a.foo.bar){baz = (a.foo.bar.baz){quux = a.foo.bar.baz.quux + 1}}}}
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout
new file mode 100644
index 0000000000..6755663e6a
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout
@@ -0,0 +1,12 @@
+-- selectors:
+Bar {bar = Baz {baz = Quux {quux = 42}}}
+Baz {baz = Quux {quux = 42}}
+Quux {quux = 42}
+42
+-- selections:
+42
+Quux {quux = 42}
+Baz {baz = Quux {quux = 42}}
+Bar {bar = Baz {baz = Quux {quux = 42}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}}
+Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}}
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.hs b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs
new file mode 100644
index 0000000000..1ee7565573
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main where
+
+import qualified RecordDotSyntaxA as A
+
+
+main = do
+ print $ id A.n -- Foo {foo = 2}; f M.x means f (M.x)
+ print $ id A.n.foo -- 2; f M.n.x means f (M.n.x)
+
+ let bar = A.Foo {A.foo = 1}
+ print $ bar.foo -- Ok; 1
+ -- print $ bar.A.foo -- parse error on input 'A.foo'
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout
new file mode 100644
index 0000000000..0de59d2464
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout
@@ -0,0 +1,3 @@
+Foo {foo = 2}
+2
+1
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.hs b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs
new file mode 100644
index 0000000000..924ed03bde
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main where
+
+import qualified RecordDotSyntaxA as A
+
+main = do
+ let bar = A.Foo {A.foo = 1}
+ print $ bar{A.foo = 2} -- Qualified labels ok in regular updates.
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout
new file mode 100644
index 0000000000..43c812f394
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout
@@ -0,0 +1 @@
+Foo {foo = 2}
diff --git a/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs
new file mode 100644
index 0000000000..907d6a23f6
--- /dev/null
+++ b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs
@@ -0,0 +1,6 @@
+module RecordDotSyntaxA where
+
+data Foo = Foo { foo :: Int } deriving Show
+
+n :: Foo
+n = Foo {foo = 2}
diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T
index 064ef8fffd..caf0e2bc65 100644
--- a/testsuite/tests/parser/should_run/all.T
+++ b/testsuite/tests/parser/should_run/all.T
@@ -23,3 +23,7 @@ test('CountParserDeps',
compile_and_run,
['-package ghc'])
test('LexNegLit', normal, compile_and_run, [''])
+test('RecordDotSyntax1', normal, compile_and_run, [''])
+test('RecordDotSyntax2', normal, compile_and_run, [''])
+test('RecordDotSyntax3', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax3', ''])
+test('RecordDotSyntax4', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax4', ''])
diff --git a/utils/haddock b/utils/haddock
-Subproject 8241d9e700e043b86b609c334494c4632848389
+Subproject 65868397a59e61b575c70c0757dddbbba9cb5ac