[Git][ghc/ghc][wip/T18599] rework projection syntax
Shayne Fletcher
gitlab at gitlab.haskell.org
Mon Nov 16 00:17:40 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
f3ac563e by Shayne Fletcher at 2020-11-15T19:17:09-05:00
rework projection syntax
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- 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
=====================================
@@ -493,15 +493,14 @@ data HsExpr p
-- langauge extensions is enabled.
-- e.g. .x = Projection {
- -- proj_ext=noExtField, proj_rhs=Nothing, proj_fIELD=x, proj_projection = \z -> z.x
+ -- proj_ext=noExtField, proj_fIELDS=[.x], proj_projection = \z -> z.x
-- },
-- .x.y = Projection {
- -- proj_ext=noExtField, proj_rhs=Just .x, proj_fIELD=y, proj_projection = (\z -> z.y) . (\z -> z.x)
+ -- proj_ext=noExtField, proj_fIELDS=[.x, .y], proj_projection = (\z -> z.y) . (\z -> z.x)
-- }
| Projection
{ proj_ext :: XProjection p
- , proj_rhs :: Maybe (LHsExpr p)
- , proj_fIELD :: Located FastString
+ , proj_fIELDS :: [Located FastString]
, proj_projection :: LHsExpr p -- Equivalent 'getField' term.
}
@@ -1255,10 +1254,8 @@ ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
ppr_expr (GetField { gf_expr = L _ fexp, gf_fIELD = field, gf_getField = _})
= ppr fexp <> dot <> ppr field
-ppr_expr (Projection { proj_rhs = maybeRhs, proj_fIELD = field, proj_projection = _})
- = case maybeRhs of
- Nothing -> dot <> ppr field
- Just e -> ppr e <> dot <> ppr field
+ppr_expr (Projection { proj_fIELDS = _, proj_projection = _})
+ = undefined {- TODO: implement this -}
ppr_expr (ExprWithTySig _ expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
@@ -1415,9 +1412,8 @@ hsExprNeedsParens p = go
go (RecordCon{}) = False
go (HsRecFld{}) = False
- -- Not entirely clear about these.
- go (GetField{}) = False
- go (Projection{}) = False
+ go (Projection{}) = True
+ go (GetField{}) = False -- Remember to have a closer look at this.
go (XExpr x)
| GhcTc <- ghcPass @p
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1165,9 +1165,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where
GetField _ expr _ _ ->
[ toHie expr
]
- Projection _ maybeExpr _ _ ->
- [ toHie maybeExpr
- ]
+ Projection _ _ _ -> []
XExpr x
| GhcTc <- ghcPass @p
, WrapExpr (HsWrap w a) <- x
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2754,7 +2754,12 @@ aexp2 :: { ECP }
((mop $1:fst $2) ++ [mcp $3]) }
-- This case is only possible when 'RecordDotSyntax' is enabled.
- | '(' projection ')' { ecpFromExp $2 }
+ | '(' 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 ->
@@ -2804,13 +2809,13 @@ aexp2 :: { ECP }
Nothing (reverse $3))
[mu AnnOpenB $1,mu AnnCloseB $4] }
-projection :: { LHsExpr GhcPs }
+projection :: { (SrcSpan, ([AddAnn], [Located FastString])) }
projection
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
: projection TIGHT_INFIX_PROJ field
- {% ams (mkProjection (comb3 $1 $2 $3) (Just $1) $3) [mj AnnDot $2] }
- | PREFIX_PROJ field
- {% ams (mkProjection (comb2 $1 $2) Nothing $2) [mj AnnDot $1] }
+ { 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 }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -3009,17 +3009,33 @@ zPat = noLoc $ VarPat noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
zVar = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
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) -> Located FastString -> LHsExpr GhcPs
-mkProj rhs fIELD =
- let body = mkGet zVar fIELD
- 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}
- lhs = mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated}) in
- maybe lhs (mkParen . mkOpApp lhs circ) rhs
+-- 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"
+
+-- -- 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) -> Located FastString -> LHsExpr GhcPs
+-- mkProj rhs fIELD =
+-- let body = mkGet zVar fIELD
+-- 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}
+-- lhs = mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated}) in
+-- maybe lhs (mkParen . mkOpApp lhs circ) rhs
-- mkGet arg fIELD calcuates a get_field @fIELD arg expression.
-- e.g. z.x = mkGet z x = get_field @x z
@@ -3038,15 +3054,24 @@ mkGetField loc arg fIELD =
, gf_getField = mkGet arg fIELD
}
-mkProjection :: SrcSpan -> Maybe (LHsExpr GhcPs) -> Located FastString -> LHsExpr GhcPs
-mkProjection loc maybeRhs fIELD =
+mkProjection :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs
+mkProjection _ [] = panic "mkProjection: The impossible happened"
+mkProjection loc fIELDS =
L loc Projection {
proj_ext = noExtField
- , proj_rhs = maybeRhs
- , proj_fIELD = fIELD
- , proj_projection = mkProj maybeRhs fIELD
+ , proj_fIELDS = 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
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -218,14 +218,9 @@ rnExpr (GetField x e f g)
; return (GetField x e' f g', fv)
}
-rnExpr (Projection x e f p)
- = do { e' <- case e of
- Nothing -> pure Nothing
- Just expr -> do
- (e', _) <- rnLExpr expr
- pure (Just e')
- ; (p', fv) <- rnLExpr p
- ; return (Projection x e' f p', fv)
+rnExpr (Projection x fs p)
+ = do { (p', fv) <- rnLExpr p
+ ; return (Projection x fs p', fv)
}
------------------------------------------
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1037,7 +1037,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 (Projection _ _ (L _ p)) res_ty = tcExpr p res_ty
{-
************************************************************************
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -500,7 +500,7 @@ exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ e) = lexprCtOrigin e
exprCtOrigin (GetField _ e _ _) = lexprCtOrigin e
-exprCtOrigin (Projection _ _ _ _) = SectionOrigin
+exprCtOrigin (Projection _ _ _) = SectionOrigin
exprCtOrigin (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3ac563e1070bd00b66ebc017a490489c7b54f8e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3ac563e1070bd00b66ebc017a490489c7b54f8e
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/20201115/a9a679ae/attachment-0001.html>
More information about the ghc-commits
mailing list