diff options
| -rw-r--r-- | compiler/GHC/Builtin/Names/TH.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 3 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 1 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs | 8 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 2 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 2 | ||||
| -rw-r--r-- | libraries/template-haskell/changelog.md | 3 | ||||
| -rw-r--r-- | testsuite/tests/th/T20185.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/th/T20185.stdout | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/T20185a.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
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, ['']) |