[Git][ghc/ghc][wip/T18599] Make progress adding syntax for projection updates.
Shayne Fletcher
gitlab at gitlab.haskell.org
Sun Nov 8 16:01:23 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
bcab57b7 by Shayne Fletcher at 2020-11-08T11:00:49-05:00
Make progress adding syntax for projection updates.
- - - - -
4 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- record-dot-syntax-test.sh
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -457,6 +457,7 @@ data HsExpr p
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
+
-- | Record field selection.
-- Expressions of these cases arise only when the RecordDotSyntax
-- langauge extensions is enabled.
@@ -471,6 +472,22 @@ data HsExpr p
, gf_getField :: LHsExpr p -- Equivalent 'getField' term.
}
+ -- Record update.
+ -- 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.
+ -- }
+
-- | Record field selector.
-- Expressions of these cases arise only when the RecordDotSyntax
-- langauge extensions is enabled.
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3235,7 +3235,8 @@ fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) }
: fbind ',' fbinds1
{ $1 >>= \ $1 ->
$3 >>= \ $3 ->
- -- addAnnotation (gl (fbindToRecField $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)) }
@@ -3260,7 +3261,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
| field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
{ do
$5 <- unECP $5
- fmap Pbind $ mkHsFieldUpdaterPV (comb2 $1 $5) ($1 : reverse $3) $5
+ fmap Pbind $ mkHsProjUpdatePV (comb2 $1 $5) ($1 : reverse $3) $5
}
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
@@ -3275,7 +3276,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
addError l $
text "For this to work, enable NamedFieldPuns."
var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final))
- fmap Pbind $ mkHsFieldUpdaterPV l fields var
+ fmap Pbind $ mkHsProjUpdatePV l fields var
}
fieldToUpdate :: { [Located FastString] }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -19,7 +19,7 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Parser.PostProcess (
- mkGetField, mkProjection, mkFieldUpdater, isGetField, Fbind(..), -- RecordDot
+ mkGetField, mkProjection, isGetField, Fbind(..), -- RecordDot
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
@@ -153,16 +153,49 @@ import Data.Kind ( Type )
#include "HsVersions.h"
-data Fbind b =
- Fbind (LHsRecField GhcPs (Located b)) | Pbind (Located (Located b -> Located b))
-
-fbindsToEithers :: [Fbind b] -> [Either (LHsRecField GhcPs (Located b)) (Located (Located b -> Located b))]
+-- 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))
+
+fbindsToEithers :: [Fbind b]
+ -> [Either
+ (LHsRecField GhcPs (Located b))
+ (LHsProjUpdate GhcPs (Located b))
+ ]
fbindsToEithers = fmap fbindToEither
where
- fbindToEither :: Fbind b -> Either (LHsRecField GhcPs (Located b)) (Located (Located b -> Located b))
+ fbindToEither :: Fbind b
+ -> Either
+ (LHsRecField GhcPs (Located b))
+ (LHsProjUpdate GhcPs (Located b))
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
@@ -1397,7 +1430,7 @@ class b ~ (Body b) GhcPs => DisambECP b where
-- | 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.
- mkHsFieldUpdaterPV :: SrcSpan -> [Located FastString] -> Located b -> PV (Located (Located b -> Located b))
+ 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 ..."
@@ -1525,7 +1558,7 @@ instance DisambECP (HsCmd GhcPs) where
type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' = return
ecpFromExp' (L l e) = cmdFail l (ppr e)
- mkHsFieldUpdaterPV l _ _ = cmdFail l (text "Use of RecordDotSyntax `.' not valid.")
+ 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
@@ -1593,7 +1626,7 @@ instance DisambECP (HsExpr GhcPs) where
nest 2 (ppr c) ]
return (L l hsHoleExpr)
ecpFromExp' = return
- mkHsFieldUpdaterPV l fields arg = return $ mkFieldUpdater l fields arg
+ 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
@@ -1681,7 +1714,7 @@ instance DisambECP (PatBuilder GhcPs) where
ecpFromExp' (L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
- mkHsFieldUpdaterPV l _ _ =
+ mkHsProjUpdatePV l _ _ =
addFatalError l $
text "Use of RecordDotSyntax `.' not valid."
mkHsLamPV l _ = addFatalError l $
@@ -2376,7 +2409,7 @@ mkRecConstrOrUpdate dot exp _ (fs,dd)
| otherwise = mkRdrRecordUpd' dot exp fs
mkRdrRecordUpd' :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs)
-mkRdrRecordUpd' dot exp@(L lexp _) fbinds =
+mkRdrRecordUpd' dot exp@(L _ _) fbinds =
if not dot
then do
let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
@@ -2388,16 +2421,15 @@ mkRdrRecordUpd' dot exp@(L lexp _) fbinds =
panic "mkRdrRecordUpd': The impossible happened!"
else return $ mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
else
- return $ foldl' fieldUpdate (unLoc exp) fbinds
+ return $ foldl' fieldUpdate (unLoc exp) (toProjUpdates fbinds)
where
- fieldUpdate :: HsExpr GhcPs -> Fbind (HsExpr GhcPs) -> HsExpr GhcPs
- fieldUpdate acc f =
- case f of
- -- Remember to sort out issues with location info here.
- Fbind field ->
- let updField = fmap mk_rec_upd_field field
- in unLoc $ foldl' mkSetField (noLoc acc) [updField]
- Pbind (L _ fieldUpdater) -> unLoc (fieldUpdater (noLoc acc))
+ 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 (L _ pu) = unLoc ((pb_func pu) (noLoc acc))
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
@@ -3020,9 +3052,9 @@ mkProjection loc maybeRhs fIELD =
mkSet :: LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
mkSet a (L _ fIELD) b = set_field `mkAppType` mkSelector fIELD `mkApp` a `mkApp` b
--- mkFieldUpdater calculates functions representing dot notation record updates.
-mkFieldUpdater :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> Located (LHsExpr GhcPs -> LHsExpr GhcPs)
-mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
+-- 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).
@@ -3034,17 +3066,19 @@ mkFieldUpdater -- 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 $ \a -> foldl' mkSet' arg (zips 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)
--- Called from mkRdrRecordUpd.
-mkSetField :: LHsExpr GhcPs -> LHsRecUpdField GhcPs -> LHsExpr GhcPs
-mkSetField e (L _ (HsRecField occ arg _)) =
- let (loc, f) = field occ in mkSet e (L loc (fsLit f)) (val arg)
+-- Transform a regular record field update into a projection update.
+recUpdFieldToProjUpdate :: LHsRecUpdField GhcPs -> LHsProjUpdate GhcPs (LHsExpr 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
@@ -3057,7 +3091,3 @@ mkSetField e (L _ (HsRecField occ arg _)) =
field = \case
L _ (Ambiguous _ (L loc lbl)) -> (loc, occNameString . rdrNameOcc $ lbl)
L _ (Unambiguous _ (L loc lbl)) -> (loc, occNameString . rdrNameOcc $ lbl)
-
-applyFieldUpdates :: LHsExpr GhcPs -> [LHsExpr GhcPs -> LHsExpr GhcPs] -> P (LHsExpr GhcPs)
-applyFieldUpdates a updates = return $ foldl' apply a updates
- where apply r update = update r
=====================================
record-dot-syntax-test.sh
=====================================
@@ -15,7 +15,7 @@ tests=( \
test () {
printf "make test TEST=$%s\n" $1
- make test TEST=$1
+ make test TEST=$1 > /dev/null
}
for t in "${tests[@]}"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcab57b7f4e598af68bfa3ecd1395f87f2676fe7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcab57b7f4e598af68bfa3ecd1395f87f2676fe7
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/20201108/b7b0566e/attachment-0001.html>
More information about the ghc-commits
mailing list