Implement new -XTemplateHaskellQuotes pragma

Since f16ddcee0c64a92ab911a7841a8cf64e3ac671fd / D876, `ghc-stage1`
supports a subset of `-XTemplateHaskell`, but since we need Cabal to be
able detect (so `.cabal` files can be specified accordingly, see also
GHC #11102 which omits `TemplateHaskell` from `--supported-extensions`)
whether GHC provides full or only partial `-XTemplateHaskell` support,
the proper way to accomplish this is to split off the
quotation/non-splicing `TemplateHaskell` feature-subset into a new
language pragma `TemplateHaskellQuotes`.

Moreover, `-XTemplateHaskellQuotes` is considered safe under SafeHaskell

This addresses #11121

Reviewers: goldfire, ezyang, dterei, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1511

GHC Trac Issues: #11121

10 files changed, 71 insertions, 34 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e005be25cb..ac27243aa3 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -571,6 +571,7 @@ data ExtensionFlag
    | Opt_ParallelArrays           -- Syntactic support for parallel arrays
    | Opt_Arrows                   -- Arrow-notation syntax
    | Opt_TemplateHaskell
+   | Opt_TemplateHaskellQuotes    -- subset of TH supported by stage1, no splice
    | Opt_QuasiQuotes
    | Opt_ImplicitParams
    | Opt_ImplicitPrelude
@@ -3049,7 +3050,7 @@ fLangFlags = [
 -- See Note [Supporting CLI completion]
   flagSpec' "th"                              Opt_TemplateHaskell
     (\on -> deprecatedForExtension "TemplateHaskell" on
-         >> setTemplateHaskellLoc on),
+         >> checkTemplateHaskellOk on),
   flagSpec' "fi"                              Opt_ForeignFunctionInterface
     (deprecatedForExtension "ForeignFunctionInterface"),
   flagSpec' "ffi"                             Opt_ForeignFunctionInterface
@@ -3237,7 +3238,8 @@ xFlags = [
   flagSpec "Strict"                           Opt_Strict,
   flagSpec "StrictData"                       Opt_StrictData,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
-                                              setTemplateHaskellLoc,
+                                              checkTemplateHaskellOk,
+  flagSpec "TemplateHaskellQuotes"            Opt_TemplateHaskellQuotes,
   flagSpec "TraditionalRecordSyntax"          Opt_TraditionalRecordSyntax,
   flagSpec "TransformListComp"                Opt_TransformListComp,
   flagSpec "TupleSections"                    Opt_TupleSections,
@@ -3350,6 +3352,8 @@ impliedXFlags
 
     -- Duplicate record fields require field disambiguation
     , (Opt_DuplicateRecordFields, turnOn, Opt_DisambiguateRecordFields)
+
+    , (Opt_TemplateHaskell, turnOn, Opt_TemplateHaskellQuotes)
   ]
 
 -- Note [Documenting optimisation flags]
@@ -3589,9 +3593,25 @@ setIncoherentInsts True = do
   l <- getCurLoc
   upd (\d -> d { incoherentOnLoc = l })
 
-setTemplateHaskellLoc :: TurnOnFlag -> DynP ()
-setTemplateHaskellLoc _
+checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
+#ifdef GHCI
+checkTemplateHaskellOk _turn_on
   = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })
+#else
+-- In stage 1, Template Haskell is simply illegal, except with -M
+-- We don't bleat with -M because there's no problem with TH there,
+-- and in fact GHC's build system does ghc -M of the DPH libraries
+-- with a stage1 compiler
+checkTemplateHaskellOk turn_on
+  | turn_on = do dfs <- liftEwM getCmdLineState
+                 case ghcMode dfs of
+                    MkDepend -> return ()
+                    _        -> addErr msg
+  | otherwise = return ()
+  where
+    msg = "Template Haskell requires GHC with interpreter support\n    " ++
+          "Perhaps you are using a stage-1 compiler?"
+#endif
 
 {- **********************************************************************
 %*                                                                      *
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index da9424d5bc..9e57b4be36 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -369,15 +369,15 @@ $tab          { warnTab }
 }
 
 <0> {
-  "[|"        / { ifExtension thEnabled } { token (ITopenExpQuote NoE) }
-  "[||"       / { ifExtension thEnabled } { token (ITopenTExpQuote NoE) }
-  "[e|"       / { ifExtension thEnabled } { token (ITopenExpQuote HasE) }
-  "[e||"      / { ifExtension thEnabled } { token (ITopenTExpQuote HasE) }
-  "[p|"       / { ifExtension thEnabled } { token ITopenPatQuote }
-  "[d|"       / { ifExtension thEnabled } { layout_token ITopenDecQuote }
-  "[t|"       / { ifExtension thEnabled } { token ITopenTypQuote }
-  "|]"        / { ifExtension thEnabled } { token ITcloseQuote }
-  "||]"       / { ifExtension thEnabled } { token ITcloseTExpQuote }
+  "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE) }
+  "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
+  "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE) }
+  "[e||"      / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) }
+  "[p|"       / { ifExtension thQuotesEnabled } { token ITopenPatQuote }
+  "[d|"       / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote }
+  "[t|"       / { ifExtension thQuotesEnabled } { token ITopenTypQuote }
+  "|]"        / { ifExtension thQuotesEnabled } { token ITcloseQuote }
+  "||]"       / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote }
   \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }
   "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }
   "$("        / { ifExtension thEnabled } { token ITparenEscape }
@@ -2002,6 +2002,7 @@ data ExtBits
   | ParrBit
   | ArrowsBit
   | ThBit
+  | ThQuotesBit
   | IpBit
   | OverloadedLabelsBit -- #x overloaded labels
   | ExplicitForallBit -- the 'forall' keyword and '.' symbol
@@ -2041,6 +2042,8 @@ arrowsEnabled :: ExtsBitmap -> Bool
 arrowsEnabled = xtest ArrowsBit
 thEnabled :: ExtsBitmap -> Bool
 thEnabled = xtest ThBit
+thQuotesEnabled :: ExtsBitmap -> Bool
+thQuotesEnabled = xtest ThQuotesBit
 ipEnabled :: ExtsBitmap -> Bool
 ipEnabled = xtest IpBit
 overloadedLabelsEnabled :: ExtsBitmap -> Bool
@@ -2133,6 +2136,7 @@ mkPState flags buf loc =
                .|. ParrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
                .|. ArrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
                .|. ThBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
+               .|. ThQuotesBit                 `setBitIf` xopt Opt_TemplateHaskellQuotes    flags
                .|. QqBit                       `setBitIf` xopt Opt_QuasiQuotes              flags
                .|. IpBit                       `setBitIf` xopt Opt_ImplicitParams           flags
                .|. OverloadedLabelsBit         `setBitIf` xopt Opt_OverloadedLabels         flags
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 8d570ea3b7..95c54625a5 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -63,12 +63,13 @@ import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSp
 rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
 rnBracket e br_body
   = addErrCtxt (quotationCtxtDoc br_body) $
-    do { -- Check that Template Haskell is enabled and available
-         thEnabled <- xoptM Opt_TemplateHaskell
-       ; unless thEnabled $
+    do { -- Check that -XTemplateHaskellQuotes is enabled and available
+         thQuotesEnabled <- xoptM Opt_TemplateHaskellQuotes
+       ; unless thQuotesEnabled $
            failWith ( vcat
                       [ text "Syntax error on" <+> ppr e
-                      , text "Perhaps you intended to use TemplateHaskell" ] )
+                      , text ("Perhaps you intended to use TemplateHaskell"
+                              ++ " or TemplateHaskellQuotes") ] )
 
          -- Check for nested brackets
        ; cur_stage <- getStage
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index 6fac019879..dfc5bb361b 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -185,11 +185,11 @@ GHCi
 Template Haskell
 ~~~~~~~~~~~~~~~~
 
--  The ``TemplateHaskell`` now no longer automatically errors when used
-   with a stage 1 compiler (i.e. GHC without interpreter support); in
-   particular, plain Haskell quotes (not quasi-quotes) can now be
-   compiled without erroring. Splices and quasi-quotes continue to only
-   be supported by a stage 2 compiler.
+-  The new ``-XTemplateHaskellQuotes`` flag allows to use the
+   quotes (not quasi-quotes) subset of ``TemplateHaskell``.  This is
+   particularly useful for use with a stage 1 compiler (i.e. GHC
+   without interpreter support). Also, ``-XTemplateHaskellQuotes`` is
+   considered safe under Safe Haskell.
 
 -  Partial type signatures can now be used in splices, see
    :ref:`pts-where`.
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 424d4b68d1..11cebb17d7 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -9489,10 +9489,15 @@ Syntax
 
 .. index::
    single: -XTemplateHaskell
-
-Template Haskell has the following new syntactic constructions. You need
-to use the flag ``-XTemplateHaskell`` to switch these syntactic extensions
-on.
+   single: -XTemplateHaskellQuotes
+
+Template Haskell has the following new syntactic constructions. You
+need to use the flag ``-XTemplateHaskell`` to switch these syntactic
+extensions on. Alternatively, the ``-XTemplateHaskellQuotes`` flag can
+be used to enable the quotation subset of Template Haskell
+(i.e. without splice syntax). The ``-XTemplateHaskellQuotes``
+extension is considered safe under :ref:`safe-haskell` while
+``-XTemplateHaskell`` is not.
 
 -  A splice is written ``$x``, where ``x`` is an identifier, or
    ``$(...)``, where the "..." is an arbitrary expression. There must be
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 5c087311cc..f58d4c4b8a 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -34,6 +34,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
                              "OverloadedLabels",
+                             "TemplateHaskellQuotes",
                              "MonadFailDesugaring"]
 
 expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/quotes/T10384.hs b/testsuite/tests/quotes/T10384.hs
index 773deb061a..c4d9c70ffe 100644
--- a/testsuite/tests/quotes/T10384.hs
+++ b/testsuite/tests/quotes/T10384.hs
@@ -1,3 +1,3 @@
-{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskellQuotes, RankNTypes, ScopedTypeVariables #-}
 module A where
 x = \(y :: forall a. a -> a) -> [|| y ||]
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index a56a50c010..c34a207292 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -1,5 +1,5 @@
 def f(name, opts):
-    opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
+    opts.extra_hc_opts = '-XTemplateHaskellQuotes -package template-haskell'
 
 setTestOpts(f)
 
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
index 79ff65c2e9..066b56c4bb 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
@@ -1,12 +1,11 @@
 
-SafeLang12.hs:2:14: Warning:
+SafeLang12.hs:2:14: warning:
     -XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell
 
-SafeLang12_B.hs:2:14: Warning:
+SafeLang12_B.hs:2:14: warning:
     -XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell
 [1 of 3] Compiling SafeLang12_B     ( SafeLang12_B.hs, SafeLang12_B.o )
 
-SafeLang12_B.hs:14:67:
-    Syntax error on ''Class
-    Perhaps you intended to use TemplateHaskell
-    In the Template Haskell quotation ''Class
+SafeLang12_B.hs:5:1: error:
+    Language.Haskell.TH: Can't be safely imported!
+    The module itself isn't safe.
diff --git a/utils/mkUserGuidePart/Options/Language.hs b/utils/mkUserGuidePart/Options/Language.hs
index 17416ffbf1..ab3e20f40c 100644
--- a/utils/mkUserGuidePart/Options/Language.hs
+++ b/utils/mkUserGuidePart/Options/Language.hs
@@ -642,6 +642,13 @@ languageOptions =
          , flagReverse = "-XNoTemplateHaskell"
          , flagSince = "6.8.1"
          }
+  , flag { flagName = "-XTemplateHaskellQuotes"
+         , flagDescription = "Enable quotation subset of "++
+                             ":ref:`Template Haskell <template-haskell>`."
+         , flagType = DynamicFlag
+         , flagReverse = "-XNoTemplateHaskellQuotes"
+         , flagSince = "8.0.1"
+         }
   , flag { flagName = "-XNoTraditionalRecordSyntax"
          , flagDescription =
            "Disable support for traditional record syntax "++