[Git][ghc/ghc][wip/T18599] Record dot syntax

Shayne Fletcher gitlab at gitlab.haskell.org
Thu Nov 26 02:38:40 UTC 2020



Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC


Commits:
1d0b97e8 by Shayne Fletcher at 2020-11-25T21:38:23-05:00
Record dot syntax

- - - - -


26 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/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


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/Hs/Expr.hs
=====================================
@@ -12,6 +12,8 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -239,6 +241,26 @@ is Less Cool because
     typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
 -}
 
+-- New for RecordDotSyntax.
+
+data ProjUpdate' p arg =
+  ProjUpdate {
+      pb_fIELDS :: [Located FastString]
+    , pb_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 {pb_fIELDS = flds, pb_arg = arg } =
+    hcat (punctuate dot (map (ppr . unLoc) flds)) <+> equals <+> ppr arg
+
 -- | A Haskell expression.
 data HsExpr p
   = HsVar     (XVar p)
@@ -457,6 +479,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
+  -- extensions is enabled.
+
+  | GetField {
+        gf_ext :: XGetField p
+      , gf_expr :: LHsExpr p
+      , gf_fIELD :: Located FastString
+      , gf_getField :: LHsExpr p -- 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
+  -- extensions is enabled.
+
+  | RecordDotUpd {
+        rdupd_ext :: XRecordDotUpd p
+      , rdupd_expr :: LHsExpr p
+      , rdupd_upds :: [LHsRecUpdProj p]
+      , rdupd_setField :: LHsExpr p -- 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_fIELDS :: [Located FastString]
+      , proj_projection :: LHsExpr p -- Equivalent 'getField' term.
+      }
+
   -- | Expression with an explicit type signature. @e :: type@
   --
   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
@@ -648,6 +715,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
@@ -1193,6 +1272,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_fIELDS = 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)
@@ -1347,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
=====================================
@@ -555,6 +555,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
=====================================
@@ -269,6 +269,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
=====================================
@@ -1162,6 +1162,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
@@ -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,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 }
@@ -2699,10 +2720,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 }
@@ -2730,6 +2753,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)]))
@@ -2778,6 +2809,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 }
@@ -3193,33 +3232,64 @@ 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 l $
+                                text "For this to work, enable NamedFieldPuns."
+                            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
 
@@ -3512,6 +3582,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/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 (
+        mkGetField, mkProjection, isGetField, Fbind(..), -- 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,
@@ -137,6 +138,7 @@ import GHC.Data.FastString
 import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Parser.Annotation
+import Data.Either
 import Data.List
 import Data.Foldable
 import GHC.Driver.Session ( WarningFlag(..), DynFlags )
@@ -151,6 +153,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
 
 {- **********************************************************************
 
@@ -1385,6 +1403,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 ..."
@@ -1441,10 +1461,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)
@@ -1463,7 +1484,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)
@@ -1512,6 +1532,7 @@ instance DisambECP (HsCmd GhcPs) where
   type Body (HsCmd GhcPs) = HsCmd
   ecpFromCmd' = return
   ecpFromExp' (L l e) = cmdFail l (ppr e)
+  mkHsProjUpdatePV l _ _ = cmdFail l (text "Use of RecordDotSyntax `.' not valid.")
   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
@@ -1545,8 +1566,12 @@ 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 (getLoc (head ps))
+            (text "Use of RecordDotSyntax `.' not valid.")
+      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")
@@ -1575,6 +1600,7 @@ instance DisambECP (HsExpr GhcPs) where
         nest 2 (ppr c) ]
     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
@@ -1604,8 +1630,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)
@@ -1662,6 +1688,9 @@ instance DisambECP (PatBuilder GhcPs) where
   ecpFromExp' (L l e) =
     addFatalError l $
       text "Expression syntax in pattern:" <+> ppr e
+  mkHsProjUpdatePV l _ _ =
+    addFatalError l $
+    text "Use of RecordDotSyntax `.' not valid."
   mkHsLamPV l _ = addFatalError l $
     text "Lambda-syntax in pattern." $$
     text "Pattern matching on functions is not possible."
@@ -1692,9 +1721,14 @@ 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 (getLoc (head ps))
+            (text " Use of RecordDotSyntax `.' not valid.")
+     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)
@@ -2331,17 +2365,51 @@ 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))) _ (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 (getLoc (head ps))
+               (text "Use of RecordDotSyntax `.' not valid.")
+        else return (mkRdrRecordCon (L l c) (mk_rec_fields 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 = 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
@@ -2885,3 +2953,129 @@ 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.
+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 happened"
+mkProjection loc fIELDS =
+  L loc Projection {
+      proj_ext = noExtField
+    , proj_fIELDS = fIELDS
+    , proj_projection = mkProj fIELDS
+    }
+
+-- 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
+
+mkProjUpdate :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> LHsProjUpdate GhcPs (LHsExpr GhcPs)
+mkProjUpdate -- e.g {foo.bar.baz.quux = 43}
+  l
+  fIELDS
+  arg = L l $ ProjUpdate { pb_fIELDS=fIELDS, pb_arg=arg }
+
+-- mkProjUpdateSetField calculates functions representing dot notation record updates.
+mkProjUpdateSetField :: LHsProjUpdate GhcPs (LHsExpr GhcPs) -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+mkProjUpdateSetField (L _ (ProjUpdate { pb_fIELDS=fIELDS, pb_arg=arg} ))
+  = 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 -> (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 { pb_fIELDS = fs, pb_arg = arg' }), fv)
+
+
 ------------------------------------------
 -- Template Haskell extensions
 rnExpr e@(HsBracket _ br_body) = rnBracket e br_body


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1029,6 +1029,17 @@ tcExpr e@(HsRecFld _ f) 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
=====================================
@@ -499,6 +499,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"
@@ -511,6 +513,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
=====================================
@@ -173,3 +173,8 @@ test('T18251c', normal, compile_fail, [''])
 test('T18251d', normal, compile_fail, [''])
 test('T18251e', normal, compile_fail, [''])
 test('T18251f', 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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d0b97e843ec8aefa7e394ce35c843c6cc1808fa

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d0b97e843ec8aefa7e394ce35c843c6cc1808fa
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/20201125/7f647660/attachment-0001.html>


More information about the ghc-commits mailing list