[Git][ghc/ghc][wip/T18599] Add an HsExpr case 'GetField'
Shayne Fletcher
gitlab at gitlab.haskell.org
Sun Aug 30 18:04:30 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
634e8b86 by Shayne Fletcher at 2020-08-30T13:42:08-04:00
Add an HsExpr case 'GetField'
Some syntax is added for get field expressions but we don't yet have the parser create terms of that syntax.
- Adds a new AST node 'GetField';
- Give definitions for known incomplete pattern matches;
- Update the parser to compute `Located FastString`s for fields.
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Types/Origin.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -457,6 +457,21 @@ data HsExpr p
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
+ -- | Record projections
+
+ -- A get_field @fIELD arg expression.
+ -- e.g. z.x = GetField {
+ -- gf_ext=noExtField, gf_expr=z, gf_fIELD=x, gf_getField = getField @"x" z
+ -- }.
+ | GetField
+ { gf_ext :: XGetField p
+ , gf_expr :: LHsExpr p
+ , gf_fIELD :: Located FastString
+ , gf_getField :: LHsExpr p -- Equivalent 'getField' term.
+ }
+ -- Expressions of this case only arise when the RecordDotSyntax
+ -- langauge extensions is enabled.
+
-- | Expression with an explicit type signature. @e :: type@
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
@@ -580,6 +595,9 @@ data RecordUpdTc = RecordUpdTc
, rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
}
+-- | Extra data fields for a 'GetField', added by the type checker
+data GetFieldTc = GetFieldTc
+
-- | HsWrap appears only in typechecker output
-- Invariant: The contained Expr is *NOT* itself an HsWrap.
-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr".
@@ -648,6 +666,10 @@ 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 = GetFieldTc
+
type instance XExprWithTySig (GhcPass _) = NoExtField
type instance XArithSeq GhcPs = NoExtField
@@ -1193,6 +1215,9 @@ 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, gf_getField = _})
+ = ppr fexp <> dot <> ppr field
+
ppr_expr (ExprWithTySig _ expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
@@ -1347,6 +1372,10 @@ hsExprNeedsParens p = go
go (HsBinTick _ _ _ (L _ e)) = go e
go (RecordCon{}) = False
go (HsRecFld{}) = False
+ -- To be honest I'm not sure right now but we know that projection
+ -- has higher precedence than application since f r.a.b parses as
+ -- f (r.a.b) so I'm going to with False for the moment.
+ go (GetField{}) = False
go (XExpr x)
| GhcTc <- ghcPass @p
= case x of
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -555,6 +555,7 @@ type family XDo x
type family XExplicitList x
type family XRecordCon x
type family XRecordUpd x
+type family XGetField x
type family XExprWithTySig x
type family XArithSeq x
type family XBracket x
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -345,6 +345,7 @@ deriving instance Data (ArithSeqInfo GhcTc)
deriving instance Data RecordConTc
deriving instance Data RecordUpdTc
+deriving instance Data GetFieldTc
deriving instance Data CmdTopTc
deriving instance Data PendingRnSplice
deriving instance Data PendingTcSplice
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -269,6 +269,10 @@ 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 (HsLit _ lit)
= do { warnAboutOverflowedLit lit
; dsLit (convertLit lit) }
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3281,13 +3281,13 @@ pbind :: { LHsExpr GhcPs -> LHsExpr GhcPs }
; let { ; top = $1 -- foo
; fields = top : reverse $3 -- [foo, bar, baz, quux]
; final = last fields -- quux
- ; arg = mkVar $ unpackFS final
+ ; arg = mkVar $ unpackFS (unLoc final)
}
; return $ mkFieldUpdater fields arg
}
}}
-fieldToUpdate :: { [FastString] }
+fieldToUpdate :: { [Located FastString] }
fieldToUpdate
-- See Note [Whitespace-sensitive operator parsing] in Lexer.x
: fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 }
@@ -3585,9 +3585,9 @@ qvar :: { Located RdrName }
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
-field :: { FastString }
- : VARID { getVARID $1 }
- | QVARID { snd $ getQVARID $1 }
+field :: { Located FastString }
+ : VARID { sL1 $1 $! getVARID $1 }
+ | QVARID { sL1 $1 $! snd $ getQVARID $1 }
qvarid :: { Located RdrName }
: varid { $1 }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2929,7 +2929,7 @@ circ = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "."))
-- mkProj rhs fIELD calculates a projection.
-- e.g. .x = mkProj Nothing x = \z -> z.x = \z -> (getField @fIELD x)
-- .x.y = mkProj Just(.x) y = (.y) . (.x) = (\z -> z.y) . (\z -> z.x)
-mkProj :: Maybe (LHsExpr GhcPs) -> FastString -> LHsExpr GhcPs
+mkProj :: Maybe (LHsExpr GhcPs) -> Located FastString -> LHsExpr GhcPs
mkProj rhs fIELD =
let body = mkGet zVar fIELD
grhs = noLoc $ GRHS noExtField [] body
@@ -2940,19 +2940,19 @@ mkProj rhs fIELD =
-- mkGet arg fIELD calcuates a get_field @fIELD arg expression.
-- e.g. z.x = mkGet z x = get_field @x z
-mkGet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs
+mkGet :: LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs
mkGet arg fIELD = head $ mkGet' [arg] fIELD
-mkGet' :: [LHsExpr GhcPs] -> FastString -> [LHsExpr GhcPs]
-mkGet' l@(r : _) fIELD = get_field `mkAppType` mkSelector fIELD `mkApp` mkParen r : l
+mkGet' :: [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!"
-- mkSet a fIELD b calculates a set_field @fIELD expression.
-- e.g mkSet a fIELD b = set_field @"fIELD" a b (read as "set field 'fIELD' on a to b").
-mkSet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
-mkSet a fIELD b = set_field `mkAppType` mkSelector fIELD `mkApp` a `mkApp` b
+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 :: [FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+mkFieldUpdater :: [Located FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
fIELDS -- [foo, bar, baz, quux]
arg -- This is 'texp' (43 in the example).
@@ -2967,26 +2967,26 @@ mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
in \a -> foldl' mkSet' arg (zips a)
-- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
where
- mkSet' :: LHsExpr GhcPs -> (FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
+ mkSet' :: 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 _)) = mkSet e (fsLit $ field occ) (val arg)
+mkSetField e (L _ (HsRecField occ arg _)) =
+ let (loc, f) = field occ in mkSet e (L loc (fsLit f)) (val arg)
where
val :: LHsExpr GhcPs -> LHsExpr GhcPs
- val arg = if isPun arg then mkVar $ field occ else arg
+ 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) -> String
+ field :: Located (AmbiguousFieldOcc GhcPs) -> (SrcSpan, String)
field = \case
- L _ (Ambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
- L _ (Unambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
- _ -> "" -- Extension ctor.
+ 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
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -499,6 +499,7 @@ 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 (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/634e8b86483e8dabc2194e5d1705eff668025fce
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/634e8b86483e8dabc2194e5d1705eff668025fce
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/20200830/fe0a2723/attachment-0001.html>
More information about the ghc-commits
mailing list