[Git][ghc/ghc][wip/T18599] Record dot syntax
Shayne Fletcher
gitlab at gitlab.haskell.org
Fri Nov 27 21:15:13 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
4204a403 by Shayne Fletcher at 2020-11-27T16:14:48-05:00
Record dot syntax
- - - - -
29 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Types/Origin.hs
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
- testsuite/tests/parser/should_fail/all.T
- + testsuite/tests/parser/should_run/RecordDotSyntax.hs
- + testsuite/tests/parser/should_run/RecordDotSyntax.stdout
- testsuite/tests/parser/should_run/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3728,6 +3728,7 @@ xFlagsDeps = [
flagSpec "Rank2Types" LangExt.RankNTypes,
flagSpec "RankNTypes" LangExt.RankNTypes,
flagSpec "RebindableSyntax" LangExt.RebindableSyntax,
+ flagSpec "RecordDotSyntax" LangExt.RecordDotSyntax,
depFlagSpec' "RecordPuns" LangExt.RecordPuns
(deprecatedForExtension "NamedFieldPuns"),
flagSpec "RecordWildCards" LangExt.RecordWildCards,
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -12,6 +12,9 @@
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -240,6 +243,26 @@ is Less Cool because
typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
-}
+-- New for RecordDotSyntax.
+
+data ProjUpdate' p arg =
+ ProjUpdate {
+ pu_flds :: [Located FastString]
+ , pu_arg :: arg -- Field's new value e.g. 42
+ }
+ deriving (Data, Functor, Foldable, Traversable)
+
+type ProjUpdate p arg = ProjUpdate' p arg
+type LHsProjUpdate p arg = Located (ProjUpdate p arg)
+type RecUpdProj p = ProjUpdate' p (LHsExpr p)
+type LHsRecUpdProj p = Located (RecUpdProj p)
+
+instance (Outputable arg)
+ => Outputable (ProjUpdate' p arg) where
+ -- TODO: improve in case of pun
+ ppr ProjUpdate { pu_flds = flds, pu_arg = arg } =
+ hcat (punctuate dot (map (ppr . unLoc) flds)) <+> equals <+> ppr arg
+
-- | A Haskell expression.
data HsExpr p
= HsVar (XVar p)
@@ -459,6 +482,51 @@ data HsExpr p
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
+
+ -- | Record field selection e.g @z.x at .
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'
+ --
+ -- This case only arises when the RecordDotSyntax langauge
+ -- extension is enabled.
+
+ | GetField {
+ gf_ext :: XGetField p
+ , gf_expr :: LHsExpr p
+ , gf_field :: Located FastString
+ , gf_getField :: LHsExpr p -- Desugared equivalent 'getField' term.
+ }
+
+ -- Record dot update e.g. @a{foo.bar.baz=1, quux}@.
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,
+ -- 'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot',
+ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
+ --
+ -- This case only arises when the RecordDotSyntax langauge
+ -- extension is enabled.
+
+ | RecordDotUpd {
+ rdupd_ext :: XRecordDotUpd p
+ , rdupd_expr :: LHsExpr p
+ , rdupd_upds :: [LHsRecUpdProj p]
+ , rdupd_setField :: LHsExpr p -- Desugared equivalent 'setField' term.
+ }
+
+ -- | 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 RecordDotSyntax langauge
+ -- extensions is enabled.
+
+ | Projection {
+ proj_ext :: XProjection p
+ , proj_flds :: [Located FastString]
+ , proj_proj :: LHsExpr p -- Desugared equivalent 'getField' term.
+ }
+
-- | Expression with an explicit type signature. @e :: type@
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
@@ -654,6 +722,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 = NoExtField
+
+type instance XProjection GhcPs = NoExtField
+type instance XProjection GhcRn = NoExtField
+type instance XProjection GhcTc = NoExtField
+
+type instance XRecordDotUpd GhcPs = NoExtField
+type instance XRecordDotUpd GhcRn = NoExtField
+type instance XRecordDotUpd GhcTc = NoExtField
+
type instance XExprWithTySig (GhcPass _) = NoExtField
type instance XArithSeq GhcPs = NoExtField
@@ -1188,6 +1268,14 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
= hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
+ppr_expr (GetField { gf_expr = L _ fexp, gf_field = field })
+ = ppr fexp <> dot <> ppr field
+
+ppr_expr (Projection { proj_flds = flds }) = parens (hcat (punctuate dot (map ppr flds)))
+
+ppr_expr (RecordDotUpd { rdupd_expr = L _ aexp, rdupd_upds = rbinds })
+ = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
+
ppr_expr (ExprWithTySig _ expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
@@ -1346,6 +1434,11 @@ hsExprNeedsParens p = go
go (HsBinTick _ _ _ (L _ e)) = go e
go (RecordCon{}) = False
go (HsRecFld{}) = False
+
+ go (Projection{}) = True
+ go (GetField{}) = False -- Remember to have a closer look at this.
+ go (RecordDotUpd{}) = False
+
go (XExpr x)
| GhcTc <- ghcPass @p
= case x of
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -557,6 +557,9 @@ 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 XRecordDotUpd x
type family XExprWithTySig x
type family XArithSeq x
type family XBracket x
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -277,6 +277,12 @@ dsExpr (HsConLikeOut _ con) = dsConLike con
dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
+-- I feel these should have been eliminated by their equivalent
+-- getField expressions by now.
+dsExpr (GetField{}) = panic "dsExpr: GetField"
+dsExpr (Projection{}) = panic "dsExpr: Projection"
+dsExpr (RecordDotUpd{}) = panic "dsExpr: RecordDotUpd"
+
dsExpr (HsLit _ lit)
= do { warnAboutOverflowedLit lit
; dsLit (convertLit lit) }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1154,6 +1154,9 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where
HsSpliceE _ x ->
[ toHie $ L mspan x
]
+ GetField _ _ _ g -> [ toHie $ L mspan (unLoc g) ]
+ Projection _ _ p -> [ toHie $ L mspan (unLoc p) ]
+ RecordDotUpd _ _ _ u -> [ toHie $ L mspan (unLoc u) ]
XExpr x
| GhcTc <- ghcPass @p
, WrapExpr (HsWrap w a) <- x
=====================================
compiler/GHC/Parser.y
=====================================
@@ -39,6 +39,9 @@ module GHC.Parser
)
where
+import Debug.Trace
+import Data.Proxy
+
-- base
import Control.Monad ( unless, liftM, when, (<=<) )
import GHC.Exts
@@ -64,7 +67,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
@@ -641,6 +644,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
@@ -2711,6 +2716,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 (mkGetField l arg $3))
+ _ -> mkGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] }
+
| aexp { $1 }
aexp :: { ECP }
@@ -2800,10 +2821,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 RecordDotSyntaxBit >>= \ dot ->
+ unECP $1 >>= \ $1 ->
+ $3 >>= \ $3 ->
+ amms (mkHsRecordPV dot (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
+ (moc $2:mcc $4:(fst $3))
+ }
| aexp2 { $1 }
aexp2 :: { ECP }
@@ -2832,6 +2855,14 @@ aexp2 :: { ECP }
amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2))
((mop $1:fst $2) ++ [mcp $3]) }
+ -- This case is only possible when 'RecordDotSyntax' is enabled.
+ | '(' projection ')' { ECP $
+ let (loc, (anns, fIELDS)) = $2
+ span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3)
+ expr = mkProjection 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)]))
@@ -2881,6 +2912,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 }
@@ -3297,33 +3336,63 @@ 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 { Fbind (L l _) -> l; Pbind (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 Fbind $ return (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
+ -- 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 Fbind $ 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
+ $5 <- unECP $5
+ fmap Pbind $ mkHsProjUpdatePV (comb2 $1 $5) ($1 : reverse $3) $5
+ }
+
+ -- 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
+ puns <- getBit RecordPunsBit
+ when (not puns) $
+ addError $ Error ErrNamedFieldPunsNotEnabled [] l
+ var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final))
+ fmap Pbind $ mkHsProjUpdatePV l fields var
+ }
+
+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
@@ -3617,6 +3686,10 @@ 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 { sL1 $1 $! snd $ getQVARID $1 }
+
qvarid :: { Located RdrName }
: varid { $1 }
| QVARID { sL1 $1 $! mkQual varName (getQVARID $1) }
=====================================
compiler/GHC/Parser/Errors.hs
=====================================
@@ -148,6 +148,9 @@ data ErrorDesc
| ErrDotsInRecordUpdate
-- ^ Dots used in record update
+ | ErrRecordDotSyntaxInvalid
+ -- ^ Invalid use of record-dot-syntax
+
| ErrPrecedenceOutOfRange !Int
-- ^ Precedence out of range
@@ -335,6 +338,9 @@ data ErrorDesc
| ErrExpectedHyphen
-- ^ Expected a hyphen
+ | ErrNamedFieldPunsNotEnabled
+ -- ^ Named field puns should be enabled
+
| ErrSpaceInSCC
-- ^ Found a space in a SCC
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -233,6 +233,9 @@ pp_err = \case
ErrDotsInRecordUpdate
-> text "You cannot use `..' in a record update"
+ ErrRecordDotSyntaxInvalid
+ -> text "Use of RecordDotSyntax `.' not valid."
+
ErrPrecedenceOutOfRange i
-> text "Precedence out of range: " <> int i
@@ -537,6 +540,9 @@ pp_err = \case
ErrExpectedHyphen
-> text "Expected a hyphen"
+ ErrNamedFieldPunsNotEnabled
+ -> text "For this to work enable NamedFieldPuns"
+
ErrSpaceInSCC
-> text "Spaces are not allowed in SCCs"
@@ -610,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"
-
=====================================
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 -- RecordDotSyntax
| 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 ".", RecordDotSyntaxBit `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 ".", RecordDotSyntaxBit `xtest` exts -> return (ITproj False)
+ | s == fsLit "." -> return ITdot
| otherwise ->
do { addWarning Opt_WarnOperatorWhitespace $
WarnOperatorWhitespace (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 RecordDotSyntaxBit) /= 0 &&
+ xtest RecordDotSyntaxBit 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
@@ -2639,6 +2667,8 @@ data ExtBits
| ImportQualifiedPostBit
| LinearTypesBit
| NoLexicalNegationBit -- See Note [Why not LexicalNegationBit]
+ | RecordPunsBit
+ | RecordDotSyntaxBit
-- Flags that are updated once parsing starts
| InRulePragBit
@@ -2715,6 +2745,8 @@ mkParserOpts warningFlags extensionFlags
.|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost
.|. LinearTypesBit `xoptBit` LangExt.LinearTypes
.|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]
+ .|. RecordPunsBit `xoptBit` LangExt.RecordPuns
+ .|. RecordDotSyntaxBit `xoptBit` LangExt.RecordDotSyntax
optBits =
HaddockBit `setBitIf` isHaddock
.|. RawTokenStreamBit `setBitIf` rawTokStream
=====================================
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 (
+ mkGetField, mkProjection, 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,
@@ -135,6 +137,7 @@ import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Parser.Annotation
+import Data.Either
import Data.List
import Data.Foldable
import GHC.Driver.Flags ( WarningFlag(..) )
@@ -148,6 +151,22 @@ import Data.Kind ( Type )
#include "HsVersions.h"
+data Fbind b = Fbind (LHsRecField GhcPs (Located b))
+ | Pbind (LHsProjUpdate GhcPs (Located b))
+
+fbindsToEithers :: [Fbind b]
+ -> [Either
+ (LHsRecField GhcPs (Located b))
+ (LHsProjUpdate GhcPs (Located b))
+ ]
+fbindsToEithers = fmap fbindToEither
+ where
+ fbindToEither :: Fbind b
+ -> Either
+ (LHsRecField GhcPs (Located b))
+ (LHsProjUpdate GhcPs (Located b))
+ fbindToEither (Fbind x) = Left x
+ fbindToEither (Pbind x) = Right x
{- **********************************************************************
@@ -1267,6 +1286,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 FastString] -> Located b -> PV (LHsProjUpdate GhcPs (Located b))
-- | Disambiguate "\... -> ..." (lambda)
mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
-- | Disambiguate "let ... in ..."
@@ -1323,10 +1344,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 RecordDotSyntax 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)
@@ -1345,7 +1367,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)
@@ -1394,6 +1415,7 @@ instance DisambECP (HsCmd GhcPs) where
type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' = return
ecpFromExp' (L l e) = cmdFail l (ppr e)
+ mkHsProjUpdatePV l _ _ = addFatalError $ Error ErrRecordDotSyntaxInvalid [] 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
@@ -1424,8 +1446,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 $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError $ Error ErrRecordDotSyntaxInvalid [] 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")
@@ -1451,6 +1476,7 @@ instance DisambECP (HsExpr GhcPs) where
addError $ Error (ErrArrowCmdInExpr c) [] l
return (L l hsHoleExpr)
ecpFromExp' = return
+ mkHsProjUpdatePV l fields arg = return $ mkProjUpdate l fields arg
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
@@ -1480,8 +1506,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 Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
- mkHsRecordPV l lrec a (fbinds, ddLoc) = do
- r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
+ mkHsRecordPV dot l lrec a (fbinds, ddLoc) = do
+ r <- mkRecConstrOrUpdate dot 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)
@@ -1509,6 +1535,7 @@ instance DisambECP (PatBuilder GhcPs) where
ecpFromExp' (L l e) = addFatalError $ Error (ErrArrowExprInPat e) [] l
mkHsLamPV l _ = addFatalError $ Error ErrLambdaInPat [] l
mkHsLetPV l _ _ = addFatalError $ Error ErrLetInPat [] l
+ mkHsProjUpdatePV l _ _ = addFatalError $ Error ErrRecordDotSyntaxInvalid [] l
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
@@ -1534,9 +1561,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 $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError $ Error ErrRecordDotSyntaxInvalid [] 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)
@@ -2132,17 +2163,50 @@ 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 $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError $ Error ErrRecordDotSyntaxInvalid [] (getLoc (head ps))
+ else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
+mkRecConstrOrUpdate dot exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError $ Error ErrDotsInRecordUpdate [] dd_loc
- | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
+ | otherwise = mkRdrRecordDotUpd dot exp fs
+
+mkRdrRecordDotUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs)
+mkRdrRecordDotUpd dot exp@(L _ _) fbinds =
+ if not dot
+ then do
+ let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
+ if not (null ps)
+ then
+ -- If RecordDotSyntax is not enabled (as indicated by the
+ -- value of 'dot'), then the lexer can't ever issue an ITproj
+ -- token and so this case is refuted.
+ panic "mkRdrRecordUpd': The impossible happened!"
+ else return $ mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
+ else
+ let updates = toProjUpdates fbinds
+ setField = noLoc $ foldl' fieldUpdate (unLoc exp) updates
+ in return RecordDotUpd {
+ rdupd_ext = noExtField
+ , rdupd_expr = exp
+ , rdupd_upds = updates
+ , rdupd_setField = setField }
+ where
+ toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]
+ toProjUpdates = map (\case { Pbind p -> p
+ ; Fbind f -> recUpdFieldToProjUpdate (fmap mk_rec_upd_field f)
+ })
+
+ fieldUpdate :: HsExpr GhcPs -> LHsRecUpdProj GhcPs -> HsExpr GhcPs
+ fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField lpu) (noLoc acc)
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
@@ -2629,3 +2693,132 @@ mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok))
starSym :: Bool -> String
starSym True = "★"
starSym False = "*"
+
+-----------------------------------------
+-- Bits and pieces for RecordDotSyntax.
+
+mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
+mkParen = noLoc . HsPar noExtField
+
+mkVar :: String -> LHsExpr GhcPs
+mkVar = noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOcc
+
+mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+mkApp x = noLoc . HsApp noExtField x
+
+mkOpApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+mkOpApp x op = noLoc . OpApp noExtField x op
+
+mkAppType :: LHsExpr GhcPs -> GenLocated SrcSpan (HsType (NoGhcTc GhcPs)) -> LHsExpr GhcPs
+mkAppType expr = noLoc . HsAppType noExtField expr . HsWC noExtField
+
+mkSelector :: FastString -> LHsType GhcPs
+mkSelector = noLoc . HsTyLit noExtField . HsStrTy NoSourceText
+
+get_field, set_field :: LHsExpr GhcPs
+get_field = mkVar "getField"
+set_field = mkVar "setField"
+
+-- Test if the expression is a 'getField @"..."' expression.
+isGetField :: LHsExpr GhcPs -> Bool
+isGetField (L _ GetField{}) = True
+isGetField _ = False
+
+zPat :: LPat GhcPs
+zVar, circ :: LHsExpr GhcPs
+zPat = noLoc $ VarPat noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
+zVar = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
+circ = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "."))
+
+-- mkProj' fieldS calculates a projection.
+-- e.g. .x = mkProj' x = \z -> z.x = \z -> (getField @field x)
+-- .x.y = mkProj' [.x, .y] = (.y) . (.x) = (\z -> z.y) . (\z -> z.x)
+mkProj :: [Located FastString] -> LHsExpr GhcPs
+mkProj (field : fieldS) = foldl' f (proj field) fieldS
+ where
+ f acc field = (mkParen . mkOpApp (proj field) circ) acc
+
+ proj f =
+ let body = mkGet zVar f
+ grhs = noLoc $ GRHS noExtField [] body
+ ghrss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))
+ m = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=[zPat], m_grhss=ghrss} in
+ mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated})
+mkProj [] = panic "mkProj': The impossible happened"
+
+-- mkGet arg field calcuates a get_field @field arg expression.
+-- e.g. z.x = mkGet z x = get_field @x z
+mkGet :: LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs
+mkGet arg field = head $ mkGet' [arg] field
+mkGet' :: [LHsExpr GhcPs] -> Located FastString -> [LHsExpr GhcPs]
+mkGet' l@(r : _) (L _ field) = get_field `mkAppType` mkSelector field `mkApp` mkParen r : l
+mkGet' [] _ = panic "mkGet' : The impossible has happened!"
+
+mkGetField :: SrcSpan -> LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs
+mkGetField loc arg field =
+ L loc GetField {
+ gf_ext = noExtField
+ , gf_expr = arg
+ , gf_field = field
+ , gf_getField = mkGet arg field
+ }
+
+mkProjection :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs
+mkProjection _ [] = panic "mkProjection: The impossible has happened!"
+mkProjection loc flds =
+ L loc Projection {
+ proj_ext = noExtField
+ , proj_flds = flds
+ , proj_proj = mkProj flds
+ }
+
+-- e.g. foo.bar.baz.quux = 1
+mkProjUpdate :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> LHsProjUpdate GhcPs (LHsExpr GhcPs)
+mkProjUpdate _ [] _ = panic "mkProjUpdate: The impossible has happened!"
+mkProjUpdate loc flds arg =
+ L loc ProjUpdate {
+ pu_flds = flds
+ , pu_arg = arg
+ }
+
+-- mkSet a field b calculates a set_field @field expression.
+-- e.g mkSet a field b = set_field @"field" a b (read as "set field 'field' on a to b").
+mkSet :: LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
+mkSet a (L _ field) b = set_field `mkAppType` mkSelector field `mkApp` a `mkApp` b
+
+-- mkProjUpdateSetField calculates functions representing dot notation record updates.
+mkProjUpdateSetField :: LHsProjUpdate GhcPs (LHsExpr GhcPs) -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+mkProjUpdateSetField (L _ (ProjUpdate { pu_flds = flds, pu_arg = arg } ))
+ = let {
+ ; final = last flds -- quux
+ ; fields = init flds -- [foo, bar, baz]
+ ; getters = \a -> foldl' mkGet' [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' 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))))
+ where
+ mkSet' :: LHsExpr GhcPs -> (Located FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
+ mkSet' acc (field, g) = mkSet (mkParen g) field (mkParen acc)
+
+-- Transform a regular record field update into a projection update.
+recUpdFieldToProjUpdate :: LHsRecUpdField GhcPs -> LHsRecUpdProj GhcPs
+recUpdFieldToProjUpdate (L l (HsRecField occ arg _)) =
+ mkProjUpdate l [L loc (fsLit f)] (val arg)
+ where
+ (loc, f) = field occ
+
+ val :: LHsExpr GhcPs -> LHsExpr GhcPs
+ val arg = if isPun arg then mkVar $ snd (field occ) else arg
+
+ isPun :: LHsExpr GhcPs -> Bool
+ isPun = \case
+ L _ (HsVar _ (L _ p)) -> p == pun_RDR
+ _ -> False
+
+ field :: Located (AmbiguousFieldOcc GhcPs) -> (SrcSpan, String)
+ field = \case
+ L _ (Ambiguous _ (L loc lbl)) -> (loc, occNameString . rdrNameOcc $ lbl)
+ L _ (Unambiguous _ (L loc lbl)) -> (loc, occNameString . rdrNameOcc $ lbl)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -210,6 +210,32 @@ rnExpr (NegApp _ e _)
; final_e <- mkNegAppRn e' neg_name
; return (final_e, fv_e `plusFV` fv_neg) }
+------------------------------------------
+-- Record dot syntax
+rnExpr (GetField x e f g)
+ = do { (e', _) <- rnLExpr e
+ ; (g', fv) <- rnLExpr g
+ ; return (GetField x e' f g', fv)
+ }
+
+rnExpr (Projection x fs p)
+ = do { (p', fv) <- rnLExpr p
+ ; return (Projection x fs p', fv)
+ }
+
+rnExpr (RecordDotUpd x e us f)
+ = do { (e', _) <- rnLExpr e
+ ; us' <- map fst <$> mapM rnRecUpdProj us
+ ; (f', fv) <- rnLExpr f
+ ; return (RecordDotUpd x e' us' f', fv)
+ }
+ where
+ rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
+ rnRecUpdProj (L l (ProjUpdate fs arg)) = do
+ (arg', fv) <- rnLExpr arg
+ return $ (L l (ProjUpdate { pu_flds = fs, pu_arg = arg' }), fv)
+
+
------------------------------------------
-- Template Haskell extensions
rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -927,6 +927,17 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
tcExpr (ArithSeq _ witness seq) res_ty
= tcArithSeq witness seq res_ty
+{-
+************************************************************************
+* *
+ Record dot syntax
+* *
+************************************************************************
+-}
+tcExpr (GetField _ _ _ (L _ g)) res_ty = tcExpr g res_ty
+tcExpr (Projection _ _ (L _ p)) res_ty = tcExpr p res_ty
+tcExpr (RecordDotUpd _ _ _ (L _ s)) res_ty = tcExpr s res_ty
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -493,6 +493,8 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ e) = lexprCtOrigin e
+exprCtOrigin (GetField _ e _ _) = lexprCtOrigin e
+exprCtOrigin (Projection _ _ _) = SectionOrigin
exprCtOrigin (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
@@ -505,6 +507,7 @@ exprCtOrigin (HsDo {}) = DoOrigin
exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
+exprCtOrigin (RecordDotUpd {}) = Shouldn'tHappenOrigin "record dot update"
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
=====================================
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
=====================================
@@ -147,6 +147,7 @@ data Extension
| CUSKs
| StandaloneKindSignatures
| LexicalNegation
+ | RecordDotSyntax
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
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE RecordDotSyntax #-}
+
+no = Foo { bar.baz = 1 }
+ -- Syntax error: Can't use '.' in construction.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
=====================================
@@ -0,0 +1,2 @@
+ RecordDotSyntaxFail0.hs:3:12:
+ Use of RecordDotSyntax `.' not valid.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE RecordDotSyntax #-}
+
+no Foo { bar.baz = x } = undefined
+ -- Syntax error: Field selector syntax doesn't participate
+ -- in patterns
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
=====================================
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail1.hs:3:10:
+ Use of RecordDotSyntax `.' not valid.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoRecordDotSyntax #-}
+
+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 { bar.baz = Quux { quux = 42 } } } }
+ -- Syntax error: RecordDotSyntax is not enabled
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
=====================================
@@ -0,0 +1 @@
+RecordDotSyntaxFail2.hs:9:15: parse error on input ‘.’
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordDotSyntax #-}
+
+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
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
=====================================
@@ -0,0 +1 @@
+RecordDotSyntaxFail3.hs:22:14: parse error on input ‘(’
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE RecordDotSyntax #-}
+
+data Foo = Foo { foo :: Int }
+
+main = do
+ let a = Foo { foo = 1 }
+ print $ (const "hello") a .foo
+ -- Syntax error: f r .x is illegal.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
=====================================
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail4.hs:7:29: error:
+ parse error on input ‘.’
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -174,3 +174,8 @@ test('T18251d', normal, compile_fail, [''])
test('T18251e', normal, compile_fail, [''])
test('T18251f', normal, compile_fail, [''])
test('T12446', 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, [''])
=====================================
testsuite/tests/parser/should_run/RecordDotSyntax.hs
=====================================
@@ -0,0 +1,138 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordDotSyntax #-}
+-- For "higher kinded data" test.
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- 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
=====================================
testsuite/tests/parser/should_run/RecordDotSyntax.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
=====================================
testsuite/tests/parser/should_run/all.T
=====================================
@@ -19,3 +19,4 @@ test('CountParserDeps',
compile_and_run,
['-package ghc'])
test('LexNegLit', normal, compile_and_run, [''])
+test('RecordDotSyntax', normal, compile_and_run, [''])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 2d06af2fc535dacc4bac45d45e8eb95a7620caac
+Subproject commit 88f8549694b8636dd7dcabe33a4e53db7e342760
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4204a4036edeb83c27193593e2fe5c67c27f705d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4204a4036edeb83c27193593e2fe5c67c27f705d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201127/a40c374d/attachment-0001.html>
More information about the ghc-commits
mailing list