Handle OverloadedRecordDot in TH (#20185)wip/T20185

12 files changed, 95 insertions, 5 deletions

diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index ceba3042d7..0c1d626581 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -58,7 +58,7 @@ templateHaskellNames = [
     condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
-    labelEName, implicitParamVarEName,
+    labelEName, implicitParamVarEName, getFieldEName, projectionEName,
     -- FieldExp
     fieldExpName,
     -- Body
@@ -288,7 +288,7 @@ varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
-    labelEName, implicitParamVarEName :: Name
+    labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name
 varEName              = libFun (fsLit "varE")              varEIdKey
 conEName              = libFun (fsLit "conE")              conEIdKey
 litEName              = libFun (fsLit "litE")              litEIdKey
@@ -326,6 +326,8 @@ staticEName           = libFun (fsLit "staticE")           staticEIdKey
 unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
 labelEName            = libFun (fsLit "labelE")            labelEIdKey
 implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
+getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey
+projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -813,7 +815,8 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
-    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
+    getFieldEIdKey, projectionEIdKey :: Unique
 varEIdKey              = mkPreludeMiscIdUnique 270
 conEIdKey              = mkPreludeMiscIdUnique 271
 litEIdKey              = mkPreludeMiscIdUnique 272
@@ -847,6 +850,8 @@ unboundVarEIdKey       = mkPreludeMiscIdUnique 299
 labelEIdKey            = mkPreludeMiscIdUnique 300
 implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
 mdoEIdKey              = mkPreludeMiscIdUnique 302
+getFieldEIdKey         = mkPreludeMiscIdUnique 303
+projectionEIdKey       = mkPreludeMiscIdUnique 304
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index ebda80c142..ec7cb058ca 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1496,6 +1496,7 @@ repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
 repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
+repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)
 repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
                    = do { ms' <- mapM repMatchTup ms
                         ; core_ms <- coreListM matchTyConName ms'
@@ -1622,14 +1623,22 @@ repE (HsUnboundVar _ uv)   = do
                                occ   <- occNameLit uv
                                sname <- repNameS occ
                                repUnboundVar sname
+repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do
+  e1 <- repLE e
+  repGetField e1 f
+repE (HsProjection _ xs) = repProjection (map (unLoc . dfoLabel . unLoc) xs)
 repE (XExpr (HsExpanded orig_expr ds_expr))
   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
          then repE ds_expr
          else repE orig_expr }
-
 repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
-repE e                              = notHandled (ThExpressionForm e)
+repE e@(HsBracket{}) = notHandled (ThExpressionForm e)
+repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e)
+repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e)
+repE e@(HsProc{}) = notHandled (ThExpressionForm e)
+repE e@(HsTick{}) = notHandled (ThExpressionForm e)
+repE e@(HsBinTick{}) = notHandled (ThExpressionForm e)
 
 {- Note [Quotation and rebindable syntax]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2921,6 +2930,15 @@ repOverLabel fs = do
                     (MkC s) <- coreStringLit $ unpackFS fs
                     rep2 labelEName [s]
 
+repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp))
+repGetField (MkC exp) fs = do
+  MkC s <- coreStringLit $ unpackFS fs
+  rep2 getFieldEName [exp,s]
+
+repProjection :: [FastString] -> MetaM (Core (M TH.Exp))
+repProjection fs = do
+  MkC xs <- coreList' stringTy <$> mapM (coreStringLit . unpackFS) fs
+  rep2 projectionEName [xs]
 
 ------------ Lists -------------------
 -- turn a list of patterns into a single pattern matching a list
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 8d3df10185..de2602e6c5 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1051,6 +1051,9 @@ cvtl e = wrapLA (cvt e)
                               ; return $ HsVar noExtField (noLocA s') }
     cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)
     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
+    cvt (GetFieldE exp f) = do { e' <- cvtl exp
+                               ; return $ HsGetField noComments e' (L noSrcSpan (DotFieldOcc noAnn (L noSrcSpan (fsLit f)))) }
+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpan . DotFieldOcc noAnn . L noSrcSpan . fsLit) xs
 
 {- | #16895 Ensure an infix expression's operator is a variable/constructor.
 Consider this example:
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index f57861024c..7dcf328574 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -44,6 +44,7 @@ module Language.Haskell.TH.Lib (
         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
         lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,
         letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
+        getFieldE, projectionE,
     -- **** Ranges
     fromE, fromThenE, fromToE, fromThenToE,
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index d921a60e6b..11e53ca701 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -366,6 +366,14 @@ labelE s = pure (LabelE s)
 implicitParamVarE :: Quote m => String -> m Exp
 implicitParamVarE n = pure (ImplicitParamVarE n)
 
+getFieldE :: Quote m => m Exp -> String -> m Exp
+getFieldE e f = do
+  e' <- e
+  pure (GetFieldE e' f)
+
+projectionE :: Quote m => [String] -> m Exp
+projectionE xs = pure (ProjectionE xs)
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: Quote m => m Exp -> m Exp
 fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 6fcf48010d..7ed842ca94 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -223,6 +223,8 @@ pprExp i (StaticE e) = parensIf (i >= appPrec) $
 pprExp _ (UnboundVarE v) = pprName' Applied v
 pprExp _ (LabelE s) = text "#" <> text s
 pprExp _ (ImplicitParamVarE n) = text ('?' : n)
+pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f)
+pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) xs
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 44b33a217b..c219467337 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2233,6 +2233,8 @@ data Exp
                                        -- or constructor name.
   | LabelE String                      -- ^ @{ #x }@ ( Overloaded label )
   | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )
+  | GetFieldE Exp String               -- ^ @{ exp.field }@ ( Overloaded Record Dot )
+  | ProjectionE [String]                -- ^ @(.x)@ or @(.x.y)@ (Record projections)
   deriving( Show, Eq, Ord, Data, Generic )
 
 type FieldExp = (Name,Exp)
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index d5581297f2..f30c9df660 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -3,6 +3,9 @@
 ## 2.19.0.0
 
   * Add `DefaultD` constructor to support Haskell `default` declarations.
+  * Add support for Overloaded Record Dot. 
+    Introduces `getFieldE :: Quote m => m Exp -> String -> m Exp` and
+    `projectionE :: Quote m => [String] -> m Exp`.
 
 ## 2.18.0.0
   * The types of `ConP` and `conP` have been changed to allow for an additional list
diff --git a/testsuite/tests/th/T20185.hs b/testsuite/tests/th/T20185.hs
new file mode 100644
index 0000000000..a48d3fddd4
--- /dev/null
+++ b/testsuite/tests/th/T20185.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Main where
+
+import Language.Haskell.TH
+import T20185a
+
+i :: Int
+i = $(getFieldE [|y|] "bar")
+
+j = $([| x.foo.bar |])
+
+k :: X -> Int
+k = $([| (.foo.bar) |])
+
+main :: IO ()
+main = do
+  print i
+  print j
+  print (k x)
+  putStrLn . pprint =<< [| x.foo.bar |]
+  putStrLn . pprint =<< [| (id x).foo.bar |]
+  putStrLn . pprint =<< [| (id (id x).foo).bar |]
+  putStrLn . pprint =<< [| (.foo.bar) |]
+  putStrLn . pprint =<< [| (.foo.bar) x |]
diff --git a/testsuite/tests/th/T20185.stdout b/testsuite/tests/th/T20185.stdout
new file mode 100644
index 0000000000..7792ee2117
--- /dev/null
+++ b/testsuite/tests/th/T20185.stdout
@@ -0,0 +1,8 @@
+1
+1
+1
+T20185a.x.foo.bar
+(GHC.Base.id T20185a.x).foo.bar
+(GHC.Base.id (GHC.Base.id T20185a.x).foo).bar
+(.foo.bar)
+(.foo.bar) T20185a.x
diff --git a/testsuite/tests/th/T20185a.hs b/testsuite/tests/th/T20185a.hs
new file mode 100644
index 0000000000..ac9adbfd8b
--- /dev/null
+++ b/testsuite/tests/th/T20185a.hs
@@ -0,0 +1,10 @@
+module T20185a where
+
+data X = X { foo :: Y   }
+data Y = Y { bar :: Int }
+
+y :: Y
+y = Y 1
+
+x :: X
+x = X y
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 77ed446d95..f280ab7f57 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -18,6 +18,7 @@ if config.have_ext_interp :
 
 test('TH_mkName', normal, compile, ['-v0'])
 test('TH_overloadedlabels', normal, compile, ['-v0'])
+test('T20185', extra_files(['T20185a.hs']), multimod_compile_and_run, ['T20185', '-v0 ' + config.ghc_th_way_flags])
 test('TH_1tuple', normal, compile_fail, ['-v0'])
 
 test('TH_repE2', normal, compile_and_run, [''])