[Git][ghc/ghc][wip/T18599] Add RecordDotUpd syntax

Shayne Fletcher gitlab at gitlab.haskell.org
Tue Nov 24 02:11:01 UTC 2020



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


Commits:
9565c153 by Shayne Fletcher at 2020-11-23T21:10:49-05:00
Add RecordDotUpd syntax

- - - - -


7 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Types/Origin.hs


Changes:

=====================================
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
+
+-- e.g. "foo.bar.baz = 42" is
+--   ProjUpdate {
+--       pb_fIELDS=["foo","bar","baz"]
+--     , pb_exp=42
+--     , pb_func=\a -> setField@"foo" a .... 42
+--   }
+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)
+
 -- | A Haskell expression.
 data HsExpr p
   = HsVar     (XVar p)
@@ -473,31 +495,35 @@ data HsExpr p
        }
 
   -- Record update.
+  --
+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,
+  --         'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDotdot',
+  --         'GHC.Parser.Annotation.AnnClose' @'}'@
+
   -- Expressions of these cases arise only when the RecordDotSyntax
   -- langauge extensions is enabled.
 
-  -- We call this RecordDotUpd in sympathy with RecordUpd.
-
   -- e.g. a{foo.bar.baz=1, quux} = RecordDotUpd {
   --   rdupd_ext=noExtField, rdupd_expr=a, rdupd_updates=[...], rdupd_setField=setField@"quux" (setField@"foo"...a... 1) quux
   -- },
-  -- | RecordDotUpd
-  --   { rdupd_ext :: XRecordDotUpd
-  --   , rdupd_expr :: LHsExpr GhcPs
-  --   , rdupd_updates :: [LHsProjUpdate GhcPs (LHsExpr GhcPs)]
-  --   , rdupd_setField :: LHsExpr GhcPs -- Equivalent 'setField' term.
-  --   }
+
+  | RecordDotUpd
+    { rdupd_ext :: XRecordDotUpd p
+    , rdupd_expr :: LHsExpr p
+    , rdupd_upds :: [LHsRecUpdProj p]
+    , rdupd_setField :: LHsExpr p -- Equivalent 'setField' term.
+    }
 
   -- | Record field selector.
   -- Expressions of these cases arise only when the RecordDotSyntax
   -- langauge extensions is enabled.
 
-  -- e.g. .x = Projection {
-  --   proj_ext=noExtField, proj_fIELDS=[.x], proj_projection = \z -> z.x
-  --  },
-  -- .x.y = Projection {
-  --   proj_ext=noExtField, proj_fIELDS=[.x, .y], proj_projection = (\z -> z.y) . (\z -> z.x)
-  -- }
+  -- e.g. (.x) = Projection {
+  --             proj_ext=noExtField, proj_fIELDS=[.x], proj_projection = \z -> z.x
+  --           },
+  --    (.x.y) = Projection {
+  --             proj_ext=noExtField, proj_fIELDS=[.x, .y], proj_projection = (\z -> z.y) . (\z -> z.x)
+  --           }
   | Projection
        { proj_ext :: XProjection p
        , proj_fIELDS :: [Located FastString]
@@ -629,6 +655,7 @@ data RecordUpdTc = RecordUpdTc
 
 data GetFieldTc = GetFieldTc
 data ProjectionTc = ProjectionTc
+data RecordDotUpdTc = RecordDotUpdTc
 
 -- | HsWrap appears only in typechecker output
 -- Invariant: The contained Expr is *NOT* itself an HsWrap.
@@ -706,6 +733,10 @@ 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
@@ -1257,6 +1288,9 @@ ppr_expr (GetField { gf_expr = L _ fexp, gf_fIELD = field, gf_getField = _})
 ppr_expr (Projection { proj_fIELDS = _, proj_projection = _})
  = undefined {- TODO: implement this -}
 
+ppr_expr (RecordDotUpd { rdupd_expr = _, rdupd_upds = _, rdupd_setField =_ })
+ = undefined {- TODO: implement this -}
+
 ppr_expr (ExprWithTySig _ expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
@@ -1414,6 +1448,7 @@ hsExprNeedsParens p = go
 
     go (Projection{})                 = True
     go (GetField{})                   = False  -- Remember to have a closer look at this.
+    go (RecordDotUpd{})               = False
 
     go (XExpr x)
       | GhcTc <- ghcPass @p


=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -557,6 +557,7 @@ 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
=====================================
@@ -273,6 +273,7 @@ dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
 -- 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


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -153,22 +153,22 @@ import Data.Kind       ( Type )
 
 #include "HsVersions.h"
 
--- e.g. "foo.bar.baz = 42" is
---   ProjBind {
---       pb_fIELDS=["foo","bar","baz"]
---     , pb_exp=42
---     , pb_func=\a -> setField@"foo" a .... 42
---   }
-data ProjUpdate' p arg =
-  ProjUpdate {
-      pb_fIELDS :: [Located FastString]
-    , pb_arg :: arg -- Field's new value e.g. 42
-    , pb_func :: arg -> arg
-    }
-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)
+-- -- e.g. "foo.bar.baz = 42" is
+-- --   ProjUpdate {
+-- --       pb_fIELDS=["foo","bar","baz"]
+-- --     , pb_exp=42
+-- --     , pb_func=\a -> setField@"foo" a .... 42
+-- --   }
+-- data ProjUpdate' p arg =
+--   ProjUpdate {
+--       pb_fIELDS :: [Located FastString]
+--     , pb_arg :: arg -- Field's new value e.g. 42
+--     , pb_func :: arg -> arg
+--     }
+-- 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)
 
 data Fbind b = Fbind (LHsRecField GhcPs (Located b))
              | Pbind (LHsProjUpdate GhcPs (Located b))
@@ -187,15 +187,6 @@ fbindsToEithers = fmap fbindToEither
     fbindToEither (Fbind x) = Left x
     fbindToEither (Pbind x) = Right x
 
--- Next fix mkRdrRecordUpd' to return one of these.
---  RecordDotUpdate {
---       rdupd_ext :: XRecordDotUpdate
---     , rdupd_expr :: LHsExpr GhcPs
---     , rdupd_updates :: [LHsRecUpdProj GhcPs]
---     , rupd_setField :: LHsExpr GhcPs -- The equivalent setField term.
---   }
---
-
 {- **********************************************************************
 
   Construction functions for Rdr stuff
@@ -2406,10 +2397,10 @@ mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _ (fbinds,dd)
         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 = mkRdrRecordUpd' dot exp fs
+  | otherwise = mkRdrRecordDotUpd dot exp fs
 
-mkRdrRecordUpd' :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs)
-mkRdrRecordUpd' dot exp@(L _ _) fbinds =
+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
@@ -2421,7 +2412,13 @@ mkRdrRecordUpd' dot exp@(L _ _) fbinds =
         panic "mkRdrRecordUpd': The impossible happened!"
       else return $ mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
   else
-     return $ foldl' fieldUpdate (unLoc exp) (toProjUpdates fbinds)
+     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
@@ -2429,7 +2426,7 @@ mkRdrRecordUpd' dot exp@(L _ _) fbinds =
                         })
 
     fieldUpdate :: HsExpr GhcPs -> LHsRecUpdProj GhcPs -> HsExpr GhcPs
-    fieldUpdate acc (L _ pu) = unLoc ((pb_func pu) (noLoc acc))
+    fieldUpdate acc lpu =  unLoc $ (mkProjUpdateSetField lpu) (noLoc acc)
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
 mkRdrRecordUpd exp flds
@@ -3063,26 +3060,20 @@ mkProjection loc fIELDS =
     , proj_projection = mkProj fIELDS
     }
 
--- mkProjection :: SrcSpan -> Maybe (LHsExpr GhcPs) -> Located FastString -> LHsExpr GhcPs
--- mkProjection loc maybeRhs fIELD =
---   L loc Projection {
---       proj_ext = noExtField
---     , proj_rhs = maybeRhs
---     , proj_fIELD = fIELD
---     , proj_projection = mkProj maybeRhs fIELD
---     }
-
 -- 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 calculates functions representing dot notation record updates.
 mkProjUpdate :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> LHsProjUpdate GhcPs (LHsExpr GhcPs)
 mkProjUpdate -- e.g {foo.bar.baz.quux = 43}
   l
-  fIELDS -- [foo, bar, baz, quux]
-  arg -- This is 'texp' (43 in the example).
+  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]
@@ -3091,12 +3082,32 @@ mkProjUpdate -- e.g {foo.bar.baz.quux = 43}
       ; 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 L l $ ProjUpdate { pb_fIELDS=fIELDS, pb_arg=arg, pb_func=(\a -> foldl' mkSet' arg (zips 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)
 
+-- -- mkProjUpdate calculates functions representing dot notation record updates.
+-- mkProjUpdate :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> LHsProjUpdate GhcPs (LHsExpr GhcPs)
+-- mkProjUpdate -- e.g {foo.bar.baz.quux = 43}
+--   l
+--   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 L l $ ProjUpdate { pb_fIELDS=fIELDS, pb_arg=arg, pb_func=(\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 _)) =


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -223,6 +223,19 @@ rnExpr (Projection x fs 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
=====================================
@@ -1038,6 +1038,7 @@ tcExpr (ArithSeq _ witness seq) res_ty
 -}
 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
=====================================
@@ -513,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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9565c1533e19c65df0e949d07f0b14d905f9dcd9

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9565c1533e19c65df0e949d07f0b14d905f9dcd9
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/20201123/8bbc65a8/attachment-0001.html>


More information about the ghc-commits mailing list