[Git][ghc/ghc][wip/T18599] First steps towards T18599
Shayne Fletcher
gitlab at gitlab.haskell.org
Sun Aug 23 21:00:26 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
44010729 by Shayne Fletcher at 2020-08-23T16:59:14-04:00
First steps towards T18599
- - - - -
7 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/ThToHs.hs
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
- + record-dot-syntax-tests/Test.hs
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3727,6 +3727,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/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
@@ -68,7 +71,7 @@ import GHC.Prelude
-- compiler/basicTypes
import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore )
+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore, mkVarOcc, occNameString, occNameFS )
import GHC.Core.DataCon ( DataCon, dataConName )
import GHC.Types.SrcLoc
import GHC.Unit.Module
@@ -95,7 +98,7 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nil
manyDataConTyCon)
}
-%expect 232 -- shift/reduce conflicts
+%expect 234 -- shift/reduce conflicts
{- Last updated: 08 June 2020
@@ -551,6 +554,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 }
'{' { L _ ITocurly } -- special symbols
@@ -2610,6 +2615,20 @@ fexp :: { ECP }
fmap ecpFromExp $
ams (sLL $1 $> $ HsStatic noExtField $2)
[mj AnnStatic $1] }
+
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | fexp TIGHT_INFIX_PROJ field
+ {% do { ; $1 <- runPV (unECP $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'.
+ ; return . ecpFromExp $ case $1 of
+ L _ (HsApp _ f arg) | not $ isGet f -> f `mkApp` mkGet arg $3
+ _ -> mkGet $1 $3
+ }}
+
| aexp { $1 }
aexp :: { ECP }
@@ -2699,10 +2718,12 @@ aexp :: { ECP }
aexp1 :: { ECP }
: aexp1 '{' fbinds '}' { ECP $
+ getBit RecordDotSyntaxBit >>= \ dot ->
unECP $1 >>= \ $1 ->
$3 >>= \ $3 ->
- amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
+ amms (mkHsRecordPV dot (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
(moc $2:mcc $4:(fst $3)) }
+ | aexp1 '{' pbinds '}' {% runPV (unECP $1) >>= \ $1 -> fmap ecpFromExp $ applyFieldUpdates $1 $3 }
| aexp2 { $1 }
aexp2 :: { ECP }
@@ -2730,6 +2751,9 @@ 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 ')' { ecpFromExp $2 }
+
| '(#' texp '#)' { ECP $
unECP $2 >>= \ $2 ->
amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
@@ -2778,6 +2802,12 @@ aexp2 :: { ECP }
Nothing (reverse $3))
[mu AnnOpenB $1,mu AnnCloseB $4] }
+projection :: { LHsExpr GhcPs }
+projection
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : projection TIGHT_INFIX_PROJ field { mkProj (Just $1) $3 }
+ | PREFIX_PROJ field { mkProj Nothing $2 }
+
splice_exp :: { LHsExpr GhcPs }
: splice_untyped { mapLoc (HsSpliceE noExtField) $1 }
| splice_typed { mapLoc (HsSpliceE noExtField) $1 }
@@ -3191,7 +3221,7 @@ qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
(mj AnnLet $1:(fst $ unLoc $2)) }
-----------------------------------------------------------------------------
--- Record Field Update/Construction
+-- Record construction (expressions & patterns), top-level updates.
fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) }
: fbinds1 { $1 }
@@ -3220,6 +3250,49 @@ fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
+-----------------------------------------------------------------------------
+-- Nested updates (strictly expressions; patterns do not participate in updates).
+
+pbinds :: { [LHsExpr GhcPs -> LHsExpr GhcPs] }
+ : pbinds1 { $1 }
+
+pbinds1 :: { [LHsExpr GhcPs -> LHsExpr GhcPs] }
+ : pbind ',' pbinds1 { $1 : $3 }
+ | pbind { [$1] }
+
+pbind :: { LHsExpr GhcPs -> LHsExpr GhcPs }
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
+ {%do { ; let { top = $1 -- foo
+ ; fields = top : reverse $3 -- [foo, bar, baz, quux]
+ }
+ ; arg <- runPV (unECP $5)
+ ; return $ mkFieldUpdater fields arg
+ }}
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | field TIGHT_INFIX_PROJ fieldToUpdate
+ {%do { ; recordPuns <- getBit RecordPunsBit
+ ; if not recordPuns
+ then do {
+ ; addFatalError noSrcSpan $
+ text "For this to work, enable NamedFieldPuns."
+ }
+ else do {
+ ; let { ; top = $1 -- foo
+ ; fields = top : reverse $3 -- [foo, bar, baz, quux]
+ ; final = last fields -- quux
+ ; arg = mkVar $ unpackFS final
+ }
+ ; return $ mkFieldUpdater fields arg
+ }
+ }}
+
+fieldToUpdate :: { [FastString] }
+fieldToUpdate
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 }
+ | field { [$1] }
+
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
@@ -3512,6 +3585,10 @@ qvar :: { Located RdrName }
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
+field :: { FastString }
+ : VARID { getVARID $1 }
+ | QVARID { snd $ getQVARID $1 }
+
qvarid :: { Located RdrName }
: varid { $1 }
| QVARID { sL1 $1 $! mkQual varName (getQVARID $1) }
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -618,6 +618,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"
@@ -779,6 +792,7 @@ data Token
| ITtypeApp -- Prefix (@) only, e.g. f @t
| ITstar IsUnicodeSyntax
| ITdot
+ | ITproj Bool -- RecordDotSyntax
| ITbiglam -- GHC-extension symbols
@@ -1585,6 +1599,9 @@ varsym_prefix = sym $ \exts s ->
| s == fsLit "-" -- Only when LexicalNegation is on, otherwise we get ITminus and
-- don't hit this code path. See Note [Minus tokens]
-> return ITprefixminus
+ | RecordDotSyntaxBit `xtest` exts, s == fsLit "."
+ -> return (ITproj True) -- e.g. '(.x)'
+ | s == fsLit "." -> return ITdot
| s == fsLit "!" -> return ITbang
| s == fsLit "~" -> return ITtilde
| otherwise -> return (ITvarsym s)
@@ -1594,17 +1611,28 @@ varsym_suffix :: Action
varsym_suffix = sym $ \_ s ->
if | s == fsLit "@"
-> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
+ | s == fsLit "."
+ -> return ITdot
| otherwise -> return (ITvarsym s)
-- See Note [Whitespace-sensitive operator parsing]
varsym_tight_infix :: Action
-varsym_tight_infix = sym $ \_ s ->
- if | s == fsLit "@" -> return ITat
+varsym_tight_infix = sym $ \exts s ->
+ if | s == fsLit "@"
+ -> return ITat
+ | RecordDotSyntaxBit `xtest` exts, s == fsLit "."
+ -> return (ITproj False)
+ | s == fsLit "."
+ -> return ITdot
| otherwise -> return (ITvarsym 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 (\_exts s -> return $ ITconsym s)
@@ -1612,8 +1640,13 @@ consym = sym (\_exts s -> return $ ITconsym s)
sym :: (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 exts fs -- Process by varsym_*.
+ else return $ L span keyword
Just (keyword, NormalSyntax, i) -> do
exts <- getExts
if exts .&. i /= 0
@@ -2619,6 +2652,8 @@ data ExtBits
| ImportQualifiedPostBit
| LinearTypesBit
| NoLexicalNegationBit -- See Note [Why not LexicalNegationBit]
+ | RecordPunsBit
+ | RecordDotSyntaxBit
-- Flags that are updated once parsing starts
| InRulePragBit
@@ -2709,6 +2744,8 @@ mkParserFlags' warningFlags extensionFlags homeUnitId
.|. 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
=====================================
@@ -19,6 +19,7 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Parser.PostProcess (
+ mkApp, mkGet, mkVar, mkFieldUpdater, mkProj, isGet, applyFieldUpdates, -- RecordDot
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
@@ -31,7 +32,7 @@ module GHC.Parser.PostProcess (
mkFamDecl, mkLHsSigType,
mkInlinePragma,
mkPatSynMatchGroup,
- mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+ mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
@@ -1441,6 +1442,7 @@ 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 ->
@@ -1463,7 +1465,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)
@@ -1545,7 +1546,7 @@ 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 $
+ mkHsRecordPV _ l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
mkHsSectionR_PV l op c = cmdFail l $
@@ -1604,8 +1605,8 @@ instance DisambECP (HsExpr GhcPs) where
mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType 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)
@@ -1692,7 +1693,7 @@ 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
+ mkHsRecordPV _ l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
checkRecordSyntax (L l r)
mkHsNegAppPV l (L lp p) = do
@@ -2331,23 +2332,26 @@ checkPrecP (L l (_,i)) (L _ ol)
, getRdrName unrestrictedFunTyCon ]
mkRecConstrOrUpdate
- :: LHsExpr GhcPs
+ :: Bool
+ -> LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
-mkRecConstrOrUpdate exp _ (fs,dd)
+mkRecConstrOrUpdate dot exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
- | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
+ | otherwise = return (mkRdrRecordUpd dot 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 }
+mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
+mkRdrRecordUpd dot exp flds
+ -- If RecordDotSyntax is in effect produce a set_field expression.
+ | dot = unLoc $ foldl' mkSetField exp flds
+ | otherwise = RecordUpd { rupd_ext = noExtField
+ , rupd_expr = exp
+ , rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
@@ -2885,3 +2889,105 @@ starSym False = "*"
forallSym :: Bool -> String
forallSym True = "∀"
forallSym False = "forall"
+
+-----------------------------------------
+-- 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.
+isGet :: LHsExpr GhcPs -> Bool
+isGet (L _ (HsAppType _ (L _ (HsVar _ (L _ name))) _)) = occNameString (rdrNameOcc name) == "getField"
+isGet _ = 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 rhs fIELD calculates a projection.
+-- e.g. .x = mkProj Nothing x = \z -> z.x = \z -> (getField @fIELD x)
+-- .x.y = mkProj Just(.x) y = (.y) . (.x) = (\z -> z.y) . (\z -> z.x)
+mkProj :: Maybe (LHsExpr GhcPs) -> FastString -> LHsExpr GhcPs
+mkProj rhs fIELD =
+ let body = mkGet zVar fIELD
+ 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}
+ lhs = mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated}) in
+ maybe lhs (mkParen . mkOpApp lhs circ) rhs
+
+-- mkGet arg fIELD calcuates a get_field @fIELD arg expression.
+-- e.g. z.x = mkGet z x = get_field @x z
+mkGet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs
+mkGet arg fIELD = head $ mkGet' [arg] fIELD
+mkGet' :: [LHsExpr GhcPs] -> FastString -> [LHsExpr GhcPs]
+mkGet' l@(r : _) fIELD = get_field `mkAppType` mkSelector fIELD `mkApp` mkParen r : l
+mkGet' [] _ = panic "mkGet' : The impossible has happened!"
+
+-- 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 -> FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
+mkSet a fIELD b = set_field `mkAppType` mkSelector fIELD `mkApp` a `mkApp` b
+
+-- mkFieldUpdater calculates functions representing dot notation record updates.
+mkFieldUpdater :: [FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
+ fIELDS -- [foo, bar, baz, quux]
+ arg -- This is 'texp' (43 in the example).
+ = let {
+ ; final = last fIELDS -- quux
+ ; fields = init fIELDS -- [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 -> (FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
+ mkSet' acc (fIELD, g) = mkSet (mkParen g) fIELD (mkParen acc)
+
+-- Called from mkRdrRecordUpd.
+mkSetField :: LHsExpr GhcPs -> LHsRecUpdField GhcPs -> LHsExpr GhcPs
+mkSetField e (L _ (HsRecField occ arg _)) = mkSet e (fsLit $ field occ) (val arg)
+ where
+ val :: LHsExpr GhcPs -> LHsExpr GhcPs
+ val arg = if isPun arg then mkVar $ field occ else arg
+
+ isPun :: LHsExpr GhcPs -> Bool
+ isPun = \case
+ L _ (HsVar _ (L _ p)) -> p == pun_RDR
+ _ -> False
+
+ field :: Located (AmbiguousFieldOcc GhcPs) -> String
+ field = \case
+ L _ (Ambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
+ L _ (Unambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
+ _ -> "" -- Extension ctor.
+
+applyFieldUpdates :: LHsExpr GhcPs -> [LHsExpr GhcPs -> LHsExpr GhcPs] -> P (LHsExpr GhcPs)
+applyFieldUpdates a updates = return $ foldl' apply a updates
+ where apply r update = update r
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1009,7 +1009,7 @@ cvtl e = wrapL (cvt e)
; flds'
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
- ; return $ mkRdrRecordUpd e' flds' }
+ ; return $ mkRdrRecordUpd False e' 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
=====================================
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
=====================================
record-dot-syntax-tests/Test.hs
=====================================
@@ -0,0 +1,116 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordDotSyntax #-}
+
+-- Choice (C2a).
+
+import Data.Function -- for &
+
+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)
+
+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} -- Can't mix top-level and nested updates (limitation of this prototype).
+ print $ c{f}{g.foo.bar.baz.quux = 4} -- Workaround; 42, 4
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4401072933a2098c67a4dd96960ea813213d58bf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4401072933a2098c67a4dd96960ea813213d58bf
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/20200823/966b93cf/attachment-0001.html>
More information about the ghc-commits
mailing list