0001-PoC-RecordDot.patch

From 9f72a94762e730da15ada2147cd5a6ccb4f90406 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <[email protected]>
Date: Thu, 30 Dec 2021 21:04:11 +0200
Subject: [PATCH] PoC RecordDot

---
 compiler/GHC/Driver/Session.hs                |  3 ++
 compiler/GHC/Hs/Expr.hs                       |  2 +-
 compiler/GHC/HsToCore/Expr.hs                 |  4 +-
 compiler/GHC/Parser/Lexer.x                   | 14 ++---
 compiler/GHC/Rename/Expr.hs                   | 20 ++++---
 compiler/GHC/Tc/Gen/Expr.hs                   | 52 ++++++++++++++++++-
 .../GHC/LanguageExtensions/Type.hs            |  1 +
 7 files changed, 77 insertions(+), 19 deletions(-)

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index d1c29bc824..9d567b455b 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3638,6 +3638,7 @@ xFlagsDeps = [
   flagSpec "Rank2Types"                       LangExt.RankNTypes,
   flagSpec "RankNTypes"                       LangExt.RankNTypes,
   flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,
+  flagSpec "RecordDot"                        LangExt.RecordDot,
   flagSpec "OverloadedRecordDot"              LangExt.OverloadedRecordDot,
   flagSpec "OverloadedRecordUpdate"           LangExt.OverloadedRecordUpdate,
   depFlagSpec' "RecordPuns"                   LangExt.NamedFieldPuns
@@ -3836,6 +3837,8 @@ impliedXFlags
     -- The extensions needed to declare an H98 unlifted data type
     , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)
     , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)
+
+    , (LangExt.OverloadedRecordDot, turnOn, LangExt.RecordDot)
   ]
 
 -- Note [When is StarIsType enabled]
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 6228b7d90e..3db4b66a30 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -316,7 +316,7 @@ type instance XRecordUpd     GhcTc = RecordUpdTc
 
 type instance XGetField     GhcPs = EpAnnCO
 type instance XGetField     GhcRn = NoExtField
-type instance XGetField     GhcTc = DataConCantHappen
+type instance XGetField     GhcTc = DataConCantHappen -- TODO: we ought to preserve this constructor, but annotate it's so enough data is there.
 -- HsGetField is eliminated by the renamer. See [Handling overloaded
 -- and rebindable constructs].
 
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index f818be46a1..a6b48e1c0b 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -237,8 +237,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 --                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr))
 --   ; return core_expr }
 dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExpr (L loc e) =
-  putSrcSpanDsA loc $ dsExpr e
+dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
 
 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
 dsExpr (HsVar    _ (L _ id))           = dsHsVar id
@@ -252,6 +251,7 @@ dsExpr (ExprWithTySig _ e _)  = dsLExpr e
 dsExpr (HsIPVar x _)          = dataConCantHappen x
 
 dsExpr (HsGetField x _ _)     = dataConCantHappen x
+
 dsExpr (HsProjection x _)     = dataConCantHappen x
 
 dsExpr (HsLit _ lit)
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index d74d17be8f..cc4dda804a 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -805,7 +805,7 @@ data Token
   | ITpercent  -- Prefix (%) only, e.g. a %1 -> b
   | ITstar              IsUnicodeSyntax
   | ITdot
-  | ITproj Bool -- Extension: OverloadedRecordDotBit
+  | ITproj Bool -- Extension: RecordDotBit
 
   | ITbiglam                    -- GHC-extension symbols
 
@@ -1649,7 +1649,7 @@ varsym_prefix = sym $ \span exts s ->
      | s == fsLit "-" ->
          return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus
                               -- and don't hit this code path. See Note [Minus tokens]
-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->
+     | s == fsLit ".", RecordDotBit `xtest` exts ->
          return (ITproj True) -- e.g. '(.x)'
      | s == fsLit "." -> return ITdot
      | s == fsLit "!" -> return ITbang
@@ -1675,7 +1675,7 @@ varsym_suffix = sym $ \span _ s ->
 varsym_tight_infix :: Action
 varsym_tight_infix = sym $ \span exts s ->
   if | s == fsLit "@" -> return ITat
-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)
+     | s == fsLit ".", RecordDotBit `xtest` exts  -> return (ITproj False)
      | s == fsLit "." -> return ITdot
      | otherwise ->
          do { addPsMessage
@@ -1700,8 +1700,8 @@ sym con span buf len =
     Just (keyword, NormalSyntax, 0) -> do
       exts <- getExts
       if fs == fsLit "." &&
-         exts .&. (xbit OverloadedRecordDotBit) /= 0 &&
-         xtest OverloadedRecordDotBit exts
+         exts .&. (xbit RecordDotBit) /= 0 &&
+         xtest RecordDotBit exts
       then L span <$!> con span exts fs  -- Process by varsym_*.
       else return $ L span keyword
     Just (keyword, NormalSyntax, i) -> do
@@ -2761,7 +2761,7 @@ data ExtBits
   | ImportQualifiedPostBit
   | LinearTypesBit
   | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]
-  | OverloadedRecordDotBit
+  | RecordDotBit
   | OverloadedRecordUpdateBit
 
   -- Flags that are updated once parsing starts
@@ -2841,7 +2841,7 @@ mkParserOpts extensionFlags diag_opts supported
       .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost
       .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes
       .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]
-      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot
+      .|. RecordDotBit                `xoptBit` LangExt.RecordDot
       .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).
     optBits =
           HaddockBit        `setBitIf` isHaddock
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index c4f12cf243..98738df059 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -318,13 +318,19 @@ rnExpr (NegApp _ e _)
 -- Record dot syntax
 
 rnExpr (HsGetField _ e f)
- = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
-      ; (e, fv_e) <- rnLExpr e
-      ; let f' = rnDotFieldOcc f
-      ; return ( mkExpandedExpr
-                   (HsGetField noExtField e f')
-                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
-               , fv_e `plusFV` fv_getField ) }
+ = do { opt_OverloadedRecordDot <- xoptM LangExt.OverloadedRecordDot
+      ; if opt_OverloadedRecordDot
+        then do {
+          ; (getField, fv_getField) <- lookupSyntaxName getFieldName
+          ; (e, fv_e) <- rnLExpr e
+          ; let f' = rnDotFieldOcc f
+          ; return ( mkExpandedExpr
+                       (HsGetField noExtField e f')
+                       (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
+                   , fv_e `plusFV` fv_getField ) }
+        else do {
+          ; (e', fv_e) <- rnLExpr e
+          ; return (HsGetField noExtField e' (rnDotFieldOcc f), fv_e) }}
 
 rnExpr (HsProjection _ fs)
   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index b6573897e2..371a0eed63 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -84,7 +84,7 @@ import GHC.Core.Class(classTyCon)
 import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
 
 import Data.Function
-import Data.List (partition, sortBy, groupBy, intersect)
+import Data.List (partition, sortBy, groupBy, intersect, find)
 
 {-
 ************************************************************************
@@ -847,7 +847,55 @@ tcExpr (ArithSeq _ witness seq) res_ty
 
 -- These terms have been replaced by desugaring in the renamer. See
 -- Note [Overview of record dot syntax].
-tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
+tcExpr (HsGetField x scrut field) res_ty
+  = do
+  { let field_str = unLoc (dfoLabel (unLoc field))
+  ; (_scrut', scrut_ty) <- tcInferRho scrut
+  ; case tcSplitTyConApp_maybe scrut_ty of
+      Nothing         -> failWithTc $ TcRnCharLiteralOutOfRange 'a' -- TODO: cannot infer the type of scrutinee.
+      -- we could support multiple datacon tycons if we use lookupTyConFieldLabel?
+      Just (tycon, _) -> case tyConSingleDataCon_maybe tycon of
+
+        Nothing      -> failWithTc $ TcRnCharLiteralOutOfRange 'b' -- TODO: the tycon should have just one datacon
+        Just datacon -> case find (\fl -> flLabel fl == field_str) $ dataConFieldLabels datacon of
+
+          Nothing -> failWithTc $ TcRnCharLiteralOutOfRange 'c' -- TODO: the datacon doesn't have such field
+          Just fl -> do
+            -- TODO: we should infer things directly,
+            -- as already know datacon and selector at this point,
+            -- but as a proof-of-concept it's easier to defer to case-expression inference.
+            --
+            { p <- newName $ mkVarOcc "field"
+            ; let matches :: MatchGroup GhcRn (LHsExpr GhcRn)
+                  matches = MG
+                    { mg_ext    = noExtField
+                    , mg_alts   = noLocA $ singleton $ mkHsCaseAlt
+                      (noLocA $ ConPat
+                        { pat_con_ext = noExtField
+                        , pat_con     = noLocA $ getName datacon
+                        , pat_args    = RecCon HsRecFields
+                          { rec_flds   = singleton $ noLocA HsFieldBind
+                            { hfbAnn = noAnn
+                            , hfbLHS = noLocA $ FieldOcc (flSelector fl) (noLocA (mkVarUnqual field_str))
+                            , hfbRHS = noLocA $ VarPat noExtField $ noLocA p
+                            , hfbPun = False
+                            }
+                          , rec_dotdot = Nothing
+                          }
+                        })
+                      (noLocA (HsVar noExtField (noLocA p)))
+                    , mg_origin = Generated
+                    }
+
+            ; let expr :: HsExpr GhcRn
+                  expr = HsCase x scrut matches
+
+            ; traceTc "HsGetField" (ppr scrut_ty <+> ppr tycon)
+            ; traceTc "HsGetField delegate" (ppr expr)
+            ; tcExpr expr res_ty
+            }
+  }
+
 tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
 
 {-
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index ce07116a1e..02a0003cd0 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -147,6 +147,7 @@ data Extension
    | StandaloneKindSignatures
    | LexicalNegation
    | FieldSelectors
+   | RecordDot
    | OverloadedRecordDot
    | OverloadedRecordUpdate
    deriving (Eq, Enum, Show, Generic, Bounded)
-- 
2.34.1

RecordDotDemo.hs

{-# LANGUAGE CPP, NoFieldSelectors, DuplicateRecordFields #-}

-- TOGGLE ME (i.e. define/undefine)
-- #define OVERLOADED

#ifdef OVERLOADED
{-# LANGUAGE OverloadedRecordDot #-}
#else
{-# LANGUAGE RecordDot #-}
#endif

module RecordDotDemo where


-------------------------------------------------------------------------------
-- An example which works with RecordDot and OverloadedRecordDot
-------------------------------------------------------------------------------

data Foo = Foo { foo :: Char, bar :: Int }
data Bar = Bar { foo :: Bool, bar :: Int }

aFoo :: Foo
aFoo = Foo 'z' 42

example :: Foo -> Char
example x = x.foo

-------------------------------------------------------------------------------
-- An example which works with RecordDot only
-------------------------------------------------------------------------------

#ifndef OVERLOADED
-- This example doesn't work with OverloadedRecordDot,
-- but it's fine for just RecordDot.
newtype Poly = Poly { poly :: forall a. a -> a }

example2 :: Poly -> a -> a
example2 x = x.poly
#endif

-------------------------------------------------------------------------------
-- An example which works with OverloadedRecordDot only
-------------------------------------------------------------------------------

#ifdef OVERLOADED
example3 :: Bar -> Int
example3 = aux where
    aux x = x.bar
#endif