[Git][ghc/ghc][wip/T18599] Imlement Outputable for new syntax

[Shayne Fletcher]

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


Commits:
b4b3f656 by Shayne Fletcher at 2020-11-24T11:04:16-05:00
Imlement Outputable for new syntax

- - - - -


1 changed file:

- compiler/GHC/Hs/Expr.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -241,14 +241,8 @@ 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
---   }
+-- New for RecordDotSyntax.
+
 data ProjUpdate' p arg =
   ProjUpdate {
       pb_fIELDS :: [Located FastString]
@@ -261,6 +255,12 @@ type LHsProjUpdate p arg = Located (ProjUpdate p arg)
 type RecUpdProj p = ProjUpdate' p (LHsExpr p)
 type LHsRecUpdProj p = Located (RecUpdProj p)
 
+instance (Outputable arg)
+      => Outputable (ProjUpdate' p arg) where
+  -- TODO: improve in case of pun
+  ppr ProjUpdate {pb_fIELDS = flds, pb_arg = arg } =
+    hcat (punctuate dot (map (ppr . unLoc) flds)) <+> equals <+> ppr arg
+
 -- | A Haskell expression.
 data HsExpr p
   = HsVar     (XVar p)
@@ -480,55 +480,48 @@ data HsExpr p
   -- not the family tycon
 
 
-  -- | Record field selection.
-  -- Expressions of these cases arise only when the RecordDotSyntax
-  -- langauge extensions is enabled.
-
-  -- 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.
-       }
+  -- | Record field selection e.g @z.x at .
+  --
+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'
+  --
+  -- This case only arises when the RecordDotSyntax langauge
+  -- extensions is enabled.
+
+  | GetField {
+        gf_ext :: XGetField p
+      , gf_expr :: LHsExpr p
+      , gf_fIELD :: Located FastString
+      , gf_getField :: LHsExpr p -- Equivalent 'getField' term.
+      }
 
-  -- Record update.
+  -- Record dot update e.g. @a{foo.bar.baz=1, quux}@.
   --
   --  - '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.
-
-  -- 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
-  -- },
+  --         'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnClose' @'}'@
+  --
+  -- This case only arises when the RecordDotSyntax langauge
+  -- extensions is enabled.
+
+  | RecordDotUpd {
+        rdupd_ext :: XRecordDotUpd p
+      , rdupd_expr :: LHsExpr p
+      , rdupd_upds :: [LHsRecUpdProj p]
+      , rdupd_setField :: LHsExpr p -- 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. e.g. @(.x)@ or @(.x.y)@
+  --
+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'
+  --         'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'
+  --
+  -- This case only arises when the RecordDotSyntax langauge
+  -- extensions is enabled.
 
-  -- | 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)
-  --           }
-  | Projection
-       { proj_ext :: XProjection p
-       , proj_fIELDS :: [Located FastString]
-       , proj_projection :: LHsExpr p -- Equivalent 'getField' term.
-       }
+  | Projection {
+        proj_ext :: XProjection p
+      , proj_fIELDS :: [Located FastString]
+      , proj_projection :: LHsExpr p -- Equivalent 'getField' term.
+      }
 
   -- | Expression with an explicit type signature. @e :: type@
   --
@@ -1282,14 +1275,13 @@ 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_expr (GetField { gf_expr = L _ fexp, gf_fIELD = field })
   = ppr fexp <> dot <> ppr field
 
-ppr_expr (Projection { proj_fIELDS = _, proj_projection = _})
- = undefined {- TODO: implement this -}
+ppr_expr (Projection { proj_fIELDS = flds }) = parens (hcat (punctuate dot (map ppr flds)))
 
-ppr_expr (RecordDotUpd { rdupd_expr = _, rdupd_upds = _, rdupd_setField =_ })
- = undefined {- TODO: implement this -}
+ppr_expr (RecordDotUpd { rdupd_expr = L _ aexp, rdupd_upds = rbinds })
+ = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
 ppr_expr (ExprWithTySig _ expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4b3f656e5a1fad25f68b7bc50a6091dd210d73b
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/20201124/f5641f27/attachment-0001.html>