[Git][ghc/ghc][wip/T18599] Add RecordDotUpd syntax
Shayne Fletcher
gitlab at gitlab.haskell.org
Tue Nov 24 02:29:44 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
15fdebc8 by Shayne Fletcher at 2020-11-23T21:29:26-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,23 +153,6 @@ 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)
-
data Fbind b = Fbind (LHsRecField GhcPs (Located b))
| Pbind (LHsProjUpdate GhcPs (Located b))
@@ -187,15 +170,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 +2380,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 +2395,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 +2409,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 +3043,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 +3065,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/15fdebc88d742a5f84bf6ccc0d0525f395d38920
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15fdebc88d742a5f84bf6ccc0d0525f395d38920
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/ed9435f5/attachment-0001.html>
More information about the ghc-commits
mailing list