TemplateHaskellQuotes: Allow nested spliceswip/th-quotes-relax

There is no issue with nested splices as they do not require any compile
time code execution. All execution is delayed until the top-level
splice.

13 files changed, 83 insertions, 11 deletions

diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 5115052..3f746ee 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -270,9 +270,10 @@ rnSpliceGen run_splice pend_splice splice
                 ; writeMutVar ps_var (pending_splice : ps)
                 ; return (result, fvs) }
 
-        _ ->  do { (splice', fvs1) <- checkNoErrs $
-                                      setStage (Splice splice_type) $
-                                      rnSplice splice
+        _ ->  do { checkTopSpliceAllowed splice
+                 ; (splice', fvs1) <- checkNoErrs $
+                                         setStage (Splice splice_type) $
+                                         rnSplice splice
                    -- checkNoErrs: don't attempt to run the splice if
                    -- renaming it failed; otherwise we get a cascade of
                    -- errors from e.g. unbound variables
@@ -284,6 +285,22 @@ rnSpliceGen run_splice pend_splice splice
                    then Typed
                    else Untyped
 
+
+-- Nested splices are fine without TemplateHaskell because they
+-- are not executed until the top-level splice is run.
+checkTopSpliceAllowed :: HsSplice GhcPs -> RnM ()
+checkTopSpliceAllowed splice = do
+  let (herald, ext) = spliceExtension splice
+  extEnabled <- xoptM ext
+  unless extEnabled
+    (failWith $ text herald <+> text "are not permitted without" <+> ppr ext)
+  where
+     spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)
+     spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
+     spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
+     spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
+     spliceExtension s = pprPanic "spliceExtension" (ppr s)
+
 ------------------
 
 -- | Returns the result of running a splice and the modFinalizers collected
@@ -644,7 +661,8 @@ rnSpliceDecl (XSpliceDecl nec) = noExtCon nec
 rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
 -- Declaration splice at the very top level of the module
 rnTopSpliceDecls splice
-   = do  { (rn_splice, fvs) <- checkNoErrs $
+   =  do { checkTopSpliceAllowed splice
+         ; (rn_splice, fvs) <- checkNoErrs $
                                setStage (Splice Untyped) $
                                rnSplice splice
            -- As always, be sure to checkNoErrs above lest we end up with
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5e7270b..98c422b 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1450,9 +1450,9 @@ varsym_prefix :: Action
 varsym_prefix = sym $ \exts s ->
   if | TypeApplicationsBit `xtest` exts, s == fsLit "@"
      -> return ITtypeApp
-     | ThBit `xtest` exts, s == fsLit "$"
+     | ThQuotesBit `xtest` exts, s == fsLit "$"
      -> return ITdollar
-     | ThBit `xtest` exts, s == fsLit "$$"
+     | ThQuotesBit `xtest` exts, s == fsLit "$$"
      -> return ITdollardollar
      | s == fsLit "!" -> return ITbang
      | s == fsLit "~" -> return ITtilde
@@ -2786,7 +2786,7 @@ srcParseErr options buf len
         last100 = decodePrevNChars 100 buf
         doInLast100 = "do" `isInfixOf` last100
         mdoInLast100 = "mdo" `isInfixOf` last100
-        th_enabled = ThBit `xtest` pExtsBitmap options
+        th_enabled = ThQuotesBit `xtest` pExtsBitmap options
         ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
 
 -- Report a parse failure, giving the span of the previous token as
diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst
index 8f2c260..b1db851 100644
--- a/docs/users_guide/8.12.1-notes.rst
+++ b/docs/users_guide/8.12.1-notes.rst
@@ -46,6 +46,9 @@ Template Haskell
    ``where`` bindings properly. Previously, such fixity declarations would
    be dropped when quoted due to a Template Haskell bug.
 
+ - The ``-XTemplateHaskellQuotes`` extension now allows nested splices as nested
+   splices do not lead directly to compile-time evaluation. (!2288)
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst
index b7e0e4d..7998ced 100644
--- a/docs/users_guide/exts/template_haskell.rst
+++ b/docs/users_guide/exts/template_haskell.rst
@@ -48,7 +48,7 @@ Syntax
 Template Haskell has the following new syntactic constructions. You need to use
 the extension :extension:`TemplateHaskell` to switch these syntactic extensions on.
 Alternatively, the :extension:`TemplateHaskellQuotes` extension can be used to
-enable the quotation subset of Template Haskell (i.e. without splice syntax).
+enable the quotation subset of Template Haskell (i.e. without top-level splices).
 The :extension:`TemplateHaskellQuotes` extension is considered safe under
 :ref:`safe-haskell` while :extension:`TemplateHaskell` is not.
 
diff --git a/testsuite/tests/quotes/TH_double_splice.hs b/testsuite/tests/quotes/TH_double_splice.hs
new file mode 100644
index 0000000..d8a0fae
--- /dev/null
+++ b/testsuite/tests/quotes/TH_double_splice.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module TH_double_splice where
+
+-- Should be a compile time error as TemplateHaskell is not enabled.
+
+foo = [| $($(error "should not happen")) |]
+
diff --git a/testsuite/tests/quotes/TH_double_splice.stderr b/testsuite/tests/quotes/TH_double_splice.stderr
new file mode 100644
index 0000000..34cb933
--- /dev/null
+++ b/testsuite/tests/quotes/TH_double_splice.stderr
@@ -0,0 +1,7 @@
+
+TH_double_splice.hs:6:12: error:
+    • Top-level splices are not permitted without TemplateHaskell
+    • In the untyped splice: $(error "should not happen")
+      In the untyped splice: $($(error "should not happen"))
+      In the Template Haskell quotation
+        [| $($(error "should not happen")) |]
diff --git a/testsuite/tests/quotes/TH_nested_splice.hs b/testsuite/tests/quotes/TH_nested_splice.hs
new file mode 100644
index 0000000..811aa5e
--- /dev/null
+++ b/testsuite/tests/quotes/TH_nested_splice.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module TH_nested_splice where
+
+a = [| 5 |]
+
+b = [| $(a) |]
+
+c = [|| 5 ||]
+
+d = [|| $$(c) ||]
diff --git a/testsuite/tests/quotes/TH_top_splice.hs b/testsuite/tests/quotes/TH_top_splice.hs
new file mode 100644
index 0000000..a7092bf
--- /dev/null
+++ b/testsuite/tests/quotes/TH_top_splice.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module TH_top_splice where
+
+-- Should be a compile time error as TemplateHaskell is not enabled.
+
+foo = $([| 1 |])
+
diff --git a/testsuite/tests/quotes/TH_top_splice.stderr b/testsuite/tests/quotes/TH_top_splice.stderr
new file mode 100644
index 0000000..8ca30c2
--- /dev/null
+++ b/testsuite/tests/quotes/TH_top_splice.stderr
@@ -0,0 +1,4 @@
+
+TH_top_splice.hs:6:7: error:
+    • Top-level splices are not permitted without TemplateHaskell
+    • In the untyped splice: $([| 1 |])
diff --git a/testsuite/tests/quotes/TTH_top_splice.hs b/testsuite/tests/quotes/TTH_top_splice.hs
new file mode 100644
index 0000000..53b8543
--- /dev/null
+++ b/testsuite/tests/quotes/TTH_top_splice.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module TTH_top_splice where
+
+-- Should be a compile time error as TemplateHaskell is not enabled.
+
+qux = $$([|| 1 ||])
+
+
diff --git a/testsuite/tests/quotes/TTH_top_splice.stderr b/testsuite/tests/quotes/TTH_top_splice.stderr
new file mode 100644
index 0000000..ef659c2
--- /dev/null
+++ b/testsuite/tests/quotes/TTH_top_splice.stderr
@@ -0,0 +1,4 @@
+
+TTH_top_splice.hs:6:7: error:
+    • Top-level splices are not permitted without TemplateHaskell
+    • In the typed splice: $$([|| 1 ||])
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index a10da10..46f53bc 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -30,3 +30,7 @@ test('TH_repE3', normal, compile, [''])
 test('TH_abstractFamily', normal, compile_fail, [''])
 test('TH_localname', normal, compile_fail, [''])
 test('TH_typed_csp', normal, compile, [''])
+test('TH_nested_splice', normal, compile, [''])
+test('TH_top_splice', normal, compile_fail, [''])
+test('TTH_top_splice', normal, compile_fail, [''])
+test('TH_double_splice', normal, compile_fail, [''])
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
index 55aa3a5..c7923a0 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
@@ -8,6 +8,5 @@ SafeLang12_B.hs:2:14: warning:
 [2 of 3] Compiling SafeLang12_B     ( SafeLang12_B.hs, SafeLang12_B.o )
 [3 of 3] Compiling Main             ( SafeLang12.hs, SafeLang12.o )
 
-SafeLang12.hs:8:1: error:
-    parse error on input ‘$’
-    Perhaps you intended to use TemplateHaskell
+SafeLang12.hs:1:1: error:
+    Top-level splices are not permitted without TemplateHaskell