Handle OverloadedRecordDot in TH (#20185)

3 files changed, 31 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: