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.)

11 files changed, 69 insertions, 0 deletions

diff --git a/testsuite/tests/th/TH_typed1.hs b/testsuite/tests/th/TH_typed1.hs
new file mode 100644
index 0000000000..f50131f88b
--- /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 0000000000..44cf16f8da
--- /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 0000000000..67f32766ce
--- /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 0000000000..5b548bb8b2
--- /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 0000000000..b9477b27f0
--- /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 0000000000..bf5d8ec7c9
--- /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 0000000000..622b20bd2a
--- /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 0000000000..9852f09b42
--- /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 0000000000..e04b129c50
--- /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 0000000000..62698d2161
--- /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 20586f17b8..60f02a9c2e 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, [''])