From ebd8918b7c50ae51921664e24fac0de4376ffcf9 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Mon, 27 Mar 2023 20:55:15 +0300
Subject: [PATCH] Allow generation of TTH syntax with TH
In other words allow generation of typed splices and brackets with
Untyped Template Haskell.
That is useful in cases where a library is build with TTH in mind,
but we still want to generate some auxiliary declarations,
where TTH cannot help us, but untyped TH can.
Such example is e.g. `staged-sop` which works with TTH,
but we would like to derive `Generic` declarations with TH.
An alternative approach is to use `unsafeCodeCoerce`, but then the
derived `Generic` instances would be type-checked only at use sites,
i.e. much later. Also `-ddump-splices` output is quite ugly:
user-written instances would use TTH brackets, not `unsafeCodeCoerce`.
This commit doesn't allow generating of untyped template splices
and brackets with untyped TH, as I don't know why one would want to do
that (instead of merging the splices, e.g.)
---
compiler/GHC/ThToHs.hs | 4 ++++
libraries/template-haskell/Language/Haskell/TH/Lib.hs | 2 +-
.../Language/Haskell/TH/Lib/Internal.hs | 6 ++++++
libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 2 ++
.../template-haskell/Language/Haskell/TH/Syntax.hs | 2 ++
libraries/template-haskell/changelog.md | 4 ++++
testsuite/tests/th/TH_typed1.hs | 7 +++++++
testsuite/tests/th/TH_typed1.stdout | 1 +
testsuite/tests/th/TH_typed2.hs | 7 +++++++
testsuite/tests/th/TH_typed2.stdout | 1 +
testsuite/tests/th/TH_typed3.hs | 10 ++++++++++
testsuite/tests/th/TH_typed3.stderr | 9 +++++++++
testsuite/tests/th/TH_typed4.hs | 7 +++++++
testsuite/tests/th/TH_typed4.stderr | 10 ++++++++++
testsuite/tests/th/TH_typed5.hs | 10 ++++++++++
testsuite/tests/th/TH_typed5.stdout | 2 ++
testsuite/tests/th/all.T | 5 +++++
17 files changed, 88 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/th/TH_typed1.hs
create mode 100644 testsuite/tests/th/TH_typed1.stdout
create mode 100644 testsuite/tests/th/TH_typed2.hs
create mode 100644 testsuite/tests/th/TH_typed2.stdout
create mode 100644 testsuite/tests/th/TH_typed3.hs
create mode 100644 testsuite/tests/th/TH_typed3.stderr
create mode 100644 testsuite/tests/th/TH_typed4.hs
create mode 100644 testsuite/tests/th/TH_typed4.stderr
create mode 100644 testsuite/tests/th/TH_typed5.hs
create mode 100644 testsuite/tests/th/TH_typed5.stdout
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 724f15f60210..39da7e0c5155 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1157,6 +1157,10 @@ cvtl e = wrapLA (cvt e)
(L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
(L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs
+ cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e
+ ; return $ HsTypedSplice (noAnn, noAnn) e' }
+ cvt (TypedBracketE e) = do { e' <- cvtl e
+ ; return $ HsTypedBracket noAnn e' }
{- | #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 b52de5b0d39a..d6107f9dac0b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -44,7 +44,7 @@ module Language.Haskell.TH.Lib (
appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,
multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,
- fieldExp, getFieldE, projectionE,
+ fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE,
-- **** 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 8d0cf5adde74..eeeff941fa29 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -380,6 +380,12 @@ getFieldE e f = do
projectionE :: Quote m => NonEmpty String -> m Exp
projectionE xs = pure (ProjectionE xs)
+typedSpliceE :: Quote m => m Exp -> m Exp
+typedSpliceE = fmap TypedSpliceE
+
+typedBracketE :: Quote m => m Exp -> m Exp
+typedBracketE = fmap TypedBracketE
+
-- ** '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 034d2687b3b3..dbe3cb85dfd5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -232,6 +232,8 @@ 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) $ toList xs
+pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]"
+pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e
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 6d96d414c636..8398bafd5371 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2385,6 +2385,8 @@ data Exp
| ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter )
| GetFieldE Exp String -- ^ @{ exp.field }@ ( Overloaded Record Dot )
| ProjectionE (NonEmpty String) -- ^ @(.x)@ or @(.x.y)@ (Record projections)
+ | TypedBracketE Exp -- ^ @[|| e ||]@
+ | TypedSpliceE Exp -- ^ @$$e@
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 f6ed4d6b5f11..5a62f6e12408 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -8,6 +8,10 @@
This change enables TemplateHaskell support for `DuplicateRecordFields`.
+ * Add support for generating typed splices and brackets in untyped Template Haskell
+ Introduces `typedSpliceE :: Quote m => m Exp -> m Exp` and
+ `typedBracketE :: Quote m => m Exp -> m Exp`
+
## 2.20.0.0
* The `Ppr.pprInfixT` function has gained a `Precedence` argument.
diff --git a/testsuite/tests/th/TH_typed1.hs b/testsuite/tests/th/TH_typed1.hs
new file mode 100644
index 000000000000..f50131f88ba6
--- /dev/null
+++ b/testsuite/tests/th/TH_typed1.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $$( $(typedBracketE [| 'x' |]) )
diff --git a/testsuite/tests/th/TH_typed1.stdout b/testsuite/tests/th/TH_typed1.stdout
new file mode 100644
index 000000000000..44cf16f8da03
--- /dev/null
+++ b/testsuite/tests/th/TH_typed1.stdout
@@ -0,0 +1 @@
+'x'
diff --git a/testsuite/tests/th/TH_typed2.hs b/testsuite/tests/th/TH_typed2.hs
new file mode 100644
index 000000000000..67f32766ceb3
--- /dev/null
+++ b/testsuite/tests/th/TH_typed2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $( typedSpliceE $ typedBracketE [| 'y' |] )
diff --git a/testsuite/tests/th/TH_typed2.stdout b/testsuite/tests/th/TH_typed2.stdout
new file mode 100644
index 000000000000..5b548bb8b21d
--- /dev/null
+++ b/testsuite/tests/th/TH_typed2.stdout
@@ -0,0 +1 @@
+'y'
diff --git a/testsuite/tests/th/TH_typed3.hs b/testsuite/tests/th/TH_typed3.hs
new file mode 100644
index 000000000000..b9477b27f006
--- /dev/null
+++ b/testsuite/tests/th/TH_typed3.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+-- test parenthesis around splice
+main = do
+ print $( typedSpliceE $ typedBracketE [| 'z' |] )
+ print $( typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |]) )
diff --git a/testsuite/tests/th/TH_typed3.stderr b/testsuite/tests/th/TH_typed3.stderr
new file mode 100644
index 000000000000..bf5d8ec7c981
--- /dev/null
+++ b/testsuite/tests/th/TH_typed3.stderr
@@ -0,0 +1,9 @@
+TH_typed3.hs:9:12-53: Splicing expression
+ typedSpliceE $ typedBracketE [| 'z' |] ======> $$[|| 'z' ||]
+TH_typed3.hs:10:12-69: Splicing expression
+ typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |])
+ ======>
+ $$(id [|| 'z' ||])
+TH_typed3.hs:9:12-53: Splicing expression [|| 'z' ||] ======> 'z'
+TH_typed3.hs:10:12-69: Splicing expression
+ id [|| 'z' ||] ======> 'z'
diff --git a/testsuite/tests/th/TH_typed4.hs b/testsuite/tests/th/TH_typed4.hs
new file mode 100644
index 000000000000..622b20bd2a82
--- /dev/null
+++ b/testsuite/tests/th/TH_typed4.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $$( $$(unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' :: Code Q (Code Q Char)) )
diff --git a/testsuite/tests/th/TH_typed4.stderr b/testsuite/tests/th/TH_typed4.stderr
new file mode 100644
index 000000000000..9852f09b42af
--- /dev/null
+++ b/testsuite/tests/th/TH_typed4.stderr
@@ -0,0 +1,10 @@
+TH_typed4.hs:7:20-96: Splicing expression
+ unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' ::
+ Code Q (Code Q Char)
+ ======>
+ [|| 'a' ||]
+TH_typed4.hs:7:16-98: Splicing expression
+ $$(unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' ::
+ Code Q (Code Q Char))
+ ======>
+ 'a'
diff --git a/testsuite/tests/th/TH_typed5.hs b/testsuite/tests/th/TH_typed5.hs
new file mode 100644
index 000000000000..e04b129c5070
--- /dev/null
+++ b/testsuite/tests/th/TH_typed5.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+
+main = do
+ putStrLn =<< fmap pprint (typedSpliceE $ typedBracketE [| 'z' |])
+ putStrLn =<< fmap pprint (typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |]))
diff --git a/testsuite/tests/th/TH_typed5.stdout b/testsuite/tests/th/TH_typed5.stdout
new file mode 100644
index 000000000000..62698d2161de
--- /dev/null
+++ b/testsuite/tests/th/TH_typed5.stdout
@@ -0,0 +1,2 @@
+$$[||'z'||]
+$$(GHC.Base.id [||'z'||])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 20586f17b843..60f02a9c2e21 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -559,3 +559,8 @@ test('T22819', normal, compile, ['-v0'])
test('TH_fun_par', normal, compile, [''])
test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T23203', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed1', normal, compile_and_run, [''])
+test('TH_typed2', normal, compile_and_run, [''])
+test('TH_typed3', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed4', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed5', normal, compile_and_run, [''])
--
GitLab