Support stage 1 Template Haskell (non-quasi) quotes, fixes #10382.

Summary:
This commit adds stage 1 support for Template Haskell
quoting, e.g. [| ... expr ... |], which is useful
for authors of quasiquoter libraries that do not actually
need splices.  The TemplateHaskell extension now does not
unconditionally fail; it only fails if the renamer encounters
a splice that it can't run.

In order to make sure the referenced data structures
are consistent, template-haskell is now a boot library.
There are some minor BC changes to template-haskell to make it boot
on GHC 7.8.

Note for reviewer: big diff changes are simply code
being moved out of an ifdef; there was no other substantive
change to that code.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, goldfire

Subscribers: bgamari, thomie

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

GHC Trac Issues: #10382

55 files changed, 381 insertions, 364 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 42aa22245e..78a6d11632 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -24,11 +24,7 @@ import Name
 import NameEnv
 import FamInstEnv( topNormaliseType )
 
-#ifdef GHCI
-        -- Template Haskell stuff iff bootstrapped
 import DsMeta
-#endif
-
 import HsSyn
 
 import Platform
@@ -645,11 +641,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 -- Template Haskell stuff
 
 dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-#ifdef GHCI
 dsExpr (HsTcBracketOut x ps) = dsBracket x ps
-#else
-dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
-#endif
 dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index c39c83e22c..09c252b3df 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -52,6 +52,7 @@ Library
                    containers >= 0.5 && < 0.6,
                    array      >= 0.1 && < 0.6,
                    filepath   >= 1   && < 1.5,
+                   template-haskell,
                    hpc,
                    transformers,
                    bin-package-db,
@@ -65,7 +66,6 @@ Library
     GHC-Options: -Wall -fno-warn-name-shadowing
 
     if flag(ghci)
-        Build-Depends: template-haskell
         CPP-Options: -DGHCI
         Include-Dirs: ../rts/dist/build @FFIIncludeDir@
 
@@ -164,6 +164,7 @@ Library
         IdInfo
         Lexeme
         Literal
+        DsMeta
         Llvm
         Llvm.AbsSyn
         Llvm.MetaData
@@ -566,7 +567,6 @@ Library
 
     if flag(ghci)
         Exposed-Modules:
-            DsMeta
             Convert
             ByteCodeAsm
             ByteCodeGen
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6e55622331..a0bd8a56dd 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -3009,7 +3009,7 @@ fLangFlags = [
 -- See Note [Supporting CLI completion]
   flagSpec' "th"                              Opt_TemplateHaskell
     (\on -> deprecatedForExtension "TemplateHaskell" on
-         >> checkTemplateHaskellOk on),
+         >> setTemplateHaskellLoc on),
   flagSpec' "fi"                              Opt_ForeignFunctionInterface
     (deprecatedForExtension "ForeignFunctionInterface"),
   flagSpec' "ffi"                             Opt_ForeignFunctionInterface
@@ -3179,7 +3179,7 @@ xFlags = [
   flagSpec "StandaloneDeriving"               Opt_StandaloneDeriving,
   flagSpec "StaticPointers"                   Opt_StaticPointers,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
-                                              checkTemplateHaskellOk,
+                                              setTemplateHaskellLoc,
   flagSpec "TraditionalRecordSyntax"          Opt_TraditionalRecordSyntax,
   flagSpec "TransformListComp"                Opt_TransformListComp,
   flagSpec "TupleSections"                    Opt_TupleSections,
@@ -3500,28 +3500,9 @@ setIncoherentInsts True = do
   l <- getCurLoc
   upd (\d -> d { incoherentOnLoc = l })
 
-checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
-#ifdef GHCI
-checkTemplateHaskellOk turn_on
-  | turn_on && rtsIsProfiled
-  = addErr "You can't use Template Haskell with a profiled compiler"
-  | otherwise
+setTemplateHaskellLoc :: TurnOnFlag -> DynP ()
+setTemplateHaskellLoc _
   = 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/main/HscMain.hs b/compiler/main/HscMain.hs
index 381b902018..eb772bae27 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -94,7 +94,6 @@ import Type             ( Type )
 import PrelNames
 import {- Kind parts of -} Type         ( Kind )
 import CoreLint         ( lintInteractiveExpr )
-import DsMeta           ( templateHaskellNames )
 import VarEnv           ( emptyTidyEnv )
 import Panic
 import ConLike
@@ -102,6 +101,7 @@ import ConLike
 import GHC.Exts
 #endif
 
+import DsMeta           ( templateHaskellNames )
 import Module
 import Packages
 import RdrName
@@ -196,9 +196,7 @@ knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
 knownKeyNames =              -- where templateHaskellNames are defined
     map getName wiredInThings
         ++ basicKnownKeyNames
-#ifdef GHCI
         ++ templateHaskellNames
-#endif
 
 -- -----------------------------------------------------------------------------
 
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 5306b6e800..5d12720e2c 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -19,37 +19,172 @@ import RdrName
 import TcRnMonad
 import Kind
 
-#ifdef GHCI
-import ErrUtils         ( dumpIfSet_dyn_printer )
-import Control.Monad    ( unless, when )
-import DynFlags
-import DsMeta           ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, liftName )
-import LoadIface        ( loadInterfaceForName )
-import Module
 import RnEnv
-import RnPat            ( rnPat )
 import RnSource         ( rnSrcDecls, findSplice )
-import RnTypes          ( rnLHsType )
-import PrelNames        ( isUnboundName )
-import SrcLoc
-import TcEnv            ( checkWellStaged, tcMetaTy )
-import Outputable
+import RnPat            ( rnPat )
+import LoadIface        ( loadInterfaceForName )
 import BasicTypes       ( TopLevelFlag, isTopLevel )
+import Outputable
+import Module
+import SrcLoc
+import DynFlags
 import FastString
+import RnTypes          ( rnLHsType )
+
+import Control.Monad    ( unless, when )
+
+import {-# SOURCE #-} RnExpr   ( rnLExpr )
+
+import PrelNames        ( isUnboundName )
+import TcEnv            ( checkWellStaged )
+import DsMeta           ( liftName )
+
+#ifdef GHCI
+import ErrUtils         ( dumpIfSet_dyn_printer )
+import DsMeta           ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
+import TcEnv            ( tcMetaTy )
 import Hooks
 import Var              ( Id )
 import DsMeta           ( quoteExpName, quotePatName, quoteDecName, quoteTypeName )
 import Util
 
-import {-# SOURCE #-} RnExpr   ( rnLExpr )
 import {-# SOURCE #-} TcExpr   ( tcMonoExpr )
 import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
 #endif
 
-#ifndef GHCI
+{-
+************************************************************************
+*                                                                      *
+        Template Haskell brackets
+*                                                                      *
+************************************************************************
+-}
+
 rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
-rnBracket e _ = failTH e "Template Haskell bracket"
+rnBracket e br_body
+  = addErrCtxt (quotationCtxtDoc br_body) $
+    do { -- Check that Template Haskell is enabled and available
+         thEnabled <- xoptM Opt_TemplateHaskell
+       ; unless thEnabled $
+           failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
+                           , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] )
+
+         -- Check for nested brackets
+       ; cur_stage <- getStage
+       ; case cur_stage of
+           { Splice True  -> checkTc (isTypedBracket br_body) illegalUntypedBracket
+           ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket
+           ; Comp         -> return ()
+           ; Brack {}     -> failWithTc illegalBracket
+           }
+
+         -- Brackets are desugared to code that mentions the TH package
+       ; recordThUse
+
+       ; case isTypedBracket br_body of
+            True  -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
+                                            rn_bracket cur_stage br_body
+                        ; return (HsBracket body', fvs_e) }
+
+            False -> do { ps_var <- newMutVar []
+                        ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+                                            rn_bracket cur_stage br_body
+                        ; pendings <- readMutVar ps_var
+                        ; return (HsRnBracketOut body' pendings, fvs_e) }
+       }
+
+rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
+rn_bracket outer_stage br@(VarBr flg rdr_name)
+  = do { name <- lookupOccRn rdr_name
+       ; this_mod <- getModule
+
+       ; case flg of
+           { -- Type variables can be quoted in TH. See #5721.
+             False -> return ()
+           ; True | nameIsLocalOrFrom this_mod name ->
+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
+                    ; case mb_bind_lvl of
+                        { Nothing -> return ()      -- Can happen for data constructors,
+                                                    -- but nothing needs to be done for them
+
+                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
+                             | isTopLevel top_lvl
+                             -> when (isExternalName name) (keepAlive name)
+                             | otherwise
+                             -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
+                                             (quotedNameStageErr br) }
+                        }
+                    }
+           ; True | otherwise ->  -- Imported thing
+                 discardResult (loadInterfaceForName msg name)
+                     -- Reason for loadInterface: deprecation checking
+                     -- assumes that the home interface is loaded, and
+                     -- this is the only way that is going to happen
+           }
+       ; return (VarBr flg name, unitFV name) }
+  where
+    msg = ptext (sLit "Need interface for Template Haskell quoted Name")
+
+rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
+                            ; return (ExpBr e', fvs) }
+
+rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+
+rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+                            ; return (TypBr t', fvs) }
+
+rn_bracket _ (DecBrL decls)
+  = do { group <- groupDecls decls
+       ; gbl_env  <- getGblEnv
+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
+                          -- The emptyDUs is so that we just collect uses for this
+                          -- group alone in the call to rnSrcDecls below
+       ; (tcg_env, group') <- setGblEnv new_gbl_env $
+                              rnSrcDecls Nothing group
+
+              -- Discard the tcg_env; it contains only extra info about fixity
+        ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
+                   ppr (duUses (tcg_dus tcg_env))))
+        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
+  where
+    groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
+    groupDecls decls
+      = do { (group, mb_splice) <- findSplice decls
+           ; case mb_splice of
+           { Nothing -> return group
+           ; Just (splice, rest) ->
+               do { group' <- groupDecls rest
+                  ; let group'' = appendGroups group group'
+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
+                  }
+           }}
+
+rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
+                             ; return (TExpBr e', fvs) }
+
+quotationCtxtDoc :: HsBracket RdrName -> SDoc
+quotationCtxtDoc br_body
+  = hang (ptext (sLit "In the Template Haskell quotation"))
+         2 (ppr br_body)
+
+illegalBracket :: SDoc
+illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
 
+illegalTypedBracket :: SDoc
+illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
+
+illegalUntypedBracket :: SDoc
+illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
+
+quotedNameStageErr :: HsBracket RdrName -> SDoc
+quotedNameStageErr br
+  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
+        , ptext (sLit "must be used at the same stage at which is is bound")]
+
+#ifndef GHCI
 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
 rnTopSpliceDecls e = failTH e "Template Haskell top splice"
 
@@ -363,120 +498,6 @@ Pat RdrName (the result of running a top-level splice) or a Pat Name
 rnSplicePat.
 -}
 
-{-
-************************************************************************
-*                                                                      *
-        Template Haskell brackets
-*                                                                      *
-************************************************************************
--}
-
-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 $
-           failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
-                           , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] )
-       ; checkTH e "Template Haskell bracket"
-
-         -- Check for nested brackets
-       ; cur_stage <- getStage
-       ; case cur_stage of
-           { Splice True  -> checkTc (isTypedBracket br_body) illegalUntypedBracket
-           ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket
-           ; Comp         -> return ()
-           ; Brack {}     -> failWithTc illegalBracket
-           }
-
-         -- Brackets are desugared to code that mentions the TH package
-       ; recordThUse
-
-       ; case isTypedBracket br_body of
-            True  -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
-                                            rn_bracket cur_stage br_body
-                        ; return (HsBracket body', fvs_e) }
-
-            False -> do { ps_var <- newMutVar []
-                        ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
-                                            rn_bracket cur_stage br_body
-                        ; pendings <- readMutVar ps_var
-                        ; return (HsRnBracketOut body' pendings, fvs_e) }
-       }
-
-rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rn_bracket outer_stage br@(VarBr flg rdr_name)
-  = do { name <- lookupOccRn rdr_name
-       ; this_mod <- getModule
-
-       ; case flg of
-           { -- Type variables can be quoted in TH. See #5721.
-             False -> return ()
-           ; True | nameIsLocalOrFrom this_mod name ->
-                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
-                    ; case mb_bind_lvl of
-                        { Nothing -> return ()      -- Can happen for data constructors,
-                                                    -- but nothing needs to be done for them
-
-                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
-                             | isTopLevel top_lvl
-                             -> when (isExternalName name) (keepAlive name)
-                             | otherwise
-                             -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
-                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
-                                             (quotedNameStageErr br) }
-                        }
-                    }
-           ; True | otherwise ->  -- Imported thing
-                 discardResult (loadInterfaceForName msg name)
-                     -- Reason for loadInterface: deprecation checking
-                     -- assumes that the home interface is loaded, and
-                     -- this is the only way that is going to happen
-           }
-       ; return (VarBr flg name, unitFV name) }
-  where
-    msg = ptext (sLit "Need interface for Template Haskell quoted Name")
-
-rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
-                            ; return (ExpBr e', fvs) }
-
-rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
-
-rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
-                            ; return (TypBr t', fvs) }
-
-rn_bracket _ (DecBrL decls)
-  = do { group <- groupDecls decls
-       ; gbl_env  <- getGblEnv
-       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
-                          -- The emptyDUs is so that we just collect uses for this
-                          -- group alone in the call to rnSrcDecls below
-       ; (tcg_env, group') <- setGblEnv new_gbl_env $
-                              rnSrcDecls Nothing group
-
-              -- Discard the tcg_env; it contains only extra info about fixity
-        ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
-                   ppr (duUses (tcg_dus tcg_env))))
-        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
-  where
-    groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
-    groupDecls decls
-      = do { (group, mb_splice) <- findSplice decls
-           ; case mb_splice of
-           { Nothing -> return group
-           ; Just (splice, rest) ->
-               do { group' <- groupDecls rest
-                  ; let group'' = appendGroups group group'
-                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
-                  }
-           }}
-
-rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
-
-rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
-                             ; return (TExpBr e', fvs) }
-
 spliceCtxt :: HsSplice RdrName -> SDoc
 spliceCtxt splice
   = hang (ptext (sLit "In the") <+> what) 2 (ppr splice)
@@ -533,31 +554,12 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
       = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
              , gen ]
 
-illegalBracket :: SDoc
-illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
-
-illegalTypedBracket :: SDoc
-illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
-
-illegalUntypedBracket :: SDoc
-illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
-
 illegalTypedSplice :: SDoc
 illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")
 
 illegalUntypedSplice :: SDoc
 illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets")
 
-quotedNameStageErr :: HsBracket RdrName -> SDoc
-quotedNameStageErr br
-  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
-        , ptext (sLit "must be used at the same stage at which is is bound")]
-
-quotationCtxtDoc :: HsBracket RdrName -> SDoc
-quotationCtxtDoc br_body
-  = hang (ptext (sLit "In the Template Haskell quotation"))
-         2 (ppr br_body)
-
 -- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
 -- spliceResultDoc expr
 --  = vcat [ hang (ptext (sLit "In the splice:"))
@@ -566,13 +568,6 @@ quotationCtxtDoc br_body
 #endif
 
 checkThLocalName :: Name -> RnM ()
-#ifndef GHCI  /* GHCI and TH is off */
---------------------------------------
--- Check for cross-stage lifting
-checkThLocalName _name
-  = return ()
-
-#else         /* GHCI and TH is on */
 checkThLocalName name
   | isUnboundName name   -- Do not report two errors for
   = return ()            --   $(not_in_scope args)
@@ -638,7 +633,6 @@ check_cross_stage_lifting top_lvl name ps_var
           -- Update the pending splices
         ; ps <- readMutVar ps_var
         ; writeMutVar ps_var (pend_splice : ps) }
-#endif /* GHCI */
 
 {-
 Note [Keeping things alive for Template Haskell]
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 353b2b71fa..155cdb42be 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -16,9 +16,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
 #include "HsVersions.h"
 
 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
-#ifdef GHCI
 import DsMeta( liftStringName, liftName )
-#endif
 
 import HsSyn
 import TcHsSyn
@@ -1234,13 +1232,6 @@ tcTagToEnum loc fun_name arg res_ty
 -}
 
 checkThLocalId :: Id -> TcM ()
-#ifndef GHCI  /* GHCI and TH is off */
---------------------------------------
--- Check for cross-stage lifting
-checkThLocalId _id
-  = return ()
-
-#else         /* GHCI and TH is on */
 checkThLocalId id
   = do  { mb_local_use <- getStageAndBindLevel (idName id)
         ; case mb_local_use of
@@ -1303,7 +1294,6 @@ checkCrossStageLifting _ _ = return ()
 polySpliceErr :: Id -> SDoc
 polySpliceErr id
   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
-#endif /* GHCI */
 
 {-
 Note [Lifting strings]
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index b73f20b283..f6b10838b8 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -34,6 +34,14 @@ import Name
 import TcRnMonad
 import TcType
 
+import Outputable
+import TcExpr
+import SrcLoc
+import FastString
+import DsMeta
+import TcUnify
+import TcEnv
+
 #ifdef GHCI
 import HscMain
         -- These imports are the reason that TcSplice
@@ -45,14 +53,11 @@ import Convert
 import RnExpr
 import RnEnv
 import RnTypes
-import TcExpr
 import TcHsSyn
 import TcSimplify
-import TcUnify
 import Type
 import Kind
 import NameSet
-import TcEnv
 import TcMType
 import TcHsType
 import TcIface
@@ -81,7 +86,6 @@ import DsExpr
 import DsMonad
 import Serialized
 import ErrUtils
-import SrcLoc
 import Util
 import Data.List        ( mapAccumL )
 import Unique
@@ -92,10 +96,7 @@ import Maybes( MaybeErr(..) )
 import DynFlags
 import Panic
 import Lexeme
-import FastString
-import Outputable
 
-import DsMeta
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
 import qualified Language.Haskell.TH.Syntax as TH
@@ -129,10 +130,87 @@ tcSpliceExpr     :: HsSplice Name  -> TcRhoType -> TcM (HsExpr TcId)
 -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
 
 runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
+{-
+************************************************************************
+*                                                                      *
+\subsection{Quoting an expression}
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [How brackets and nested splices are handled]
+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
+tcTypedBracket brack@(TExpBr expr) res_ty
+  = addErrCtxt (quotationCtxtDoc brack) $
+    do { cur_stage <- getStage
+       ; ps_ref <- newMutVar []
+       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices
+                                       -- should get thrown into the constraint set
+                                       -- from outside the bracket
+
+       -- Typecheck expr to make sure it is valid,
+       -- Throw away the typechecked expression but return its type.
+       -- We'll typecheck it again when we splice it in somewhere
+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
+                                tcInferRhoNC expr
+                                -- NC for no context; tcBracket does that
+
+       ; meta_ty <- tcTExpTy expr_ty
+       ; co <- unifyType meta_ty res_ty
+       ; ps' <- readMutVar ps_ref
+       ; texpco <- tcLookupId unsafeTExpCoerceName
+       ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
+                                               (noLoc (HsTcBracketOut brack ps'))))) }
+tcTypedBracket other_brack _
+  = pprPanic "tcTypedBracket" (ppr other_brack)
+
+-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
+tcUntypedBracket brack ps res_ty
+  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
+       ; ps' <- mapM tcPendingSplice ps
+       ; meta_ty <- tcBrackTy brack
+       ; co <- unifyType meta_ty res_ty
+       ; traceTc "tc_bracket done untyped" (ppr meta_ty)
+       ; return (mkHsWrapCo co (HsTcBracketOut brack ps'))  }
+
+---------------
+tcBrackTy :: HsBracket Name -> TcM TcType
+tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName  -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr _)   = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr _)   = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG _)  = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr _)   = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL _)  = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"
+
+---------------
+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
+tcPendingSplice (PendingRnSplice flavour splice_name expr)
+  = do { res_ty <- tcMetaTy meta_ty_name
+       ; expr' <- tcMonoExpr expr res_ty
+       ; return (PendingTcSplice splice_name expr') }
+  where
+     meta_ty_name = case flavour of
+                       UntypedExpSplice  -> expQTyConName
+                       UntypedPatSplice  -> patQTyConName
+                       UntypedTypeSplice -> typeQTyConName
+                       UntypedDeclSplice -> decsQTyConName
+
+---------------
+-- Takes a type tau and returns the type Q (TExp tau)
+tcTExpTy :: TcType -> TcM TcType
+tcTExpTy tau
+  = do { q    <- tcLookupTyCon qTyConName
+       ; texp <- tcLookupTyCon tExpTyConName
+       ; return (mkTyConApp q [mkTyConApp texp [tau]]) }
+
+quotationCtxtDoc :: HsBracket Name -> SDoc
+quotationCtxtDoc br_body
+  = hang (ptext (sLit "In the Template Haskell quotation"))
+         2 (ppr br_body)
+
 
 #ifndef GHCI
-tcTypedBracket   x _   = failTH x "Template Haskell bracket"
-tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
 tcSpliceExpr  e _      = failTH e "Template Haskell splice"
 
 -- runQuasiQuoteExpr q = failTH q "quasiquote"
@@ -325,80 +403,8 @@ When a variable is used, we compare
            g1 = $(map ...)         is OK
            g2 = $(f ...)           is not OK; because we havn't compiled f yet
 
-
-************************************************************************
-*                                                                      *
-\subsection{Quoting an expression}
-*                                                                      *
-************************************************************************
 -}
 
--- See Note [How brackets and nested splices are handled]
--- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
-tcTypedBracket brack@(TExpBr expr) res_ty
-  = addErrCtxt (quotationCtxtDoc brack) $
-    do { cur_stage <- getStage
-       ; ps_ref <- newMutVar []
-       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices
-                                       -- should get thrown into the constraint set
-                                       -- from outside the bracket
-
-       -- Typecheck expr to make sure it is valid,
-       -- Throw away the typechecked expression but return its type.
-       -- We'll typecheck it again when we splice it in somewhere
-       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
-                                tcInferRhoNC expr
-                                -- NC for no context; tcBracket does that
-
-       ; meta_ty <- tcTExpTy expr_ty
-       ; co <- unifyType meta_ty res_ty
-       ; ps' <- readMutVar ps_ref
-       ; texpco <- tcLookupId unsafeTExpCoerceName
-       ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
-                                               (noLoc (HsTcBracketOut brack ps'))))) }
-tcTypedBracket other_brack _
-  = pprPanic "tcTypedBracket" (ppr other_brack)
-
--- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
-tcUntypedBracket brack ps res_ty
-  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
-       ; ps' <- mapM tcPendingSplice ps
-       ; meta_ty <- tcBrackTy brack
-       ; co <- unifyType meta_ty res_ty
-       ; traceTc "tc_bracket done untyped" (ppr meta_ty)
-       ; return (mkHsWrapCo co (HsTcBracketOut brack ps'))  }
-
----------------
-tcBrackTy :: HsBracket Name -> TcM TcType
-tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName  -- Result type is Var (not Q-monadic)
-tcBrackTy (ExpBr _)   = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
-tcBrackTy (TypBr _)   = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcBrackTy (DecBrG _)  = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcBrackTy (PatBr _)   = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
-tcBrackTy (DecBrL _)  = panic "tcBrackTy: Unexpected DecBrL"
-tcBrackTy (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"
-
----------------
-tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
-tcPendingSplice (PendingRnSplice flavour splice_name expr)
-  = do { res_ty <- tcMetaTy meta_ty_name
-       ; expr' <- tcMonoExpr expr res_ty
-       ; return (PendingTcSplice splice_name expr') }
-  where
-     meta_ty_name = case flavour of
-                       UntypedExpSplice  -> expQTyConName
-                       UntypedPatSplice  -> patQTyConName
-                       UntypedTypeSplice -> typeQTyConName
-                       UntypedDeclSplice -> decsQTyConName
-
----------------
--- Takes a type tau and returns the type Q (TExp tau)
-tcTExpTy :: TcType -> TcM TcType
-tcTExpTy tau
-  = do { q    <- tcLookupTyCon qTyConName
-       ; texp <- tcLookupTyCon tExpTyConName
-       ; return (mkTyConApp q [mkTyConApp texp [tau]]) }
-
 {-
 ************************************************************************
 *                                                                      *
@@ -469,11 +475,6 @@ tcTopSplice expr res_ty
 ************************************************************************
 -}
 
-quotationCtxtDoc :: HsBracket Name -> SDoc
-quotationCtxtDoc br_body
-  = hang (ptext (sLit "In the Template Haskell quotation"))
-         2 (ppr br_body)
-
 spliceCtxtDoc :: HsSplice Name -> SDoc
 spliceCtxtDoc splice
   = hang (ptext (sLit "In the Template Haskell splice"))
diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml
index 4dbb0b20cd..9a87588858 100644
--- a/docs/users_guide/7.12.1-notes.xml
+++ b/docs/users_guide/7.12.1-notes.xml
@@ -105,7 +105,12 @@
         <itemizedlist>
             <listitem>
                 <para>
-                    TODO FIXME.
+                    The <literal>TemplateHaskell</literal> 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.
                </para>
            </listitem>
        </itemizedlist>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 20204ca164..303833a291 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -9571,8 +9571,8 @@ Typed expression splices and quotations are supported.)
 
     <listitem><para>
 	    If you are building GHC from source, you need at least a stage-2 bootstrap compiler to
-	      run Template Haskell.  A stage-1 compiler will reject the TH constructs.  Reason: TH
-	      compiles and runs a program, and then looks at the result.  So it's important that
+	      run Template Haskell splices and quasi-quotes.  A stage-1 compiler will only accept regular quotes of Haskell.  Reason: TH splices and quasi-quotes
+	      compile and run a program, and then looks at the result.  So it's important that
 	      the program it compiles produces results whose representations are identical to
 	      those of the compiler itself.
    </para></listitem>
diff --git a/ghc.mk b/ghc.mk
index b9bba13199..2f37be8bac 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -386,7 +386,7 @@ else
 # programs such as GHC and ghc-pkg, that we do not assume the stage0
 # compiler already has installed (or up-to-date enough).
 
-PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers
+PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers template-haskell
 ifeq "$(Windows_Host)" "NO"
 ifneq "$(HostOS_CPP)" "ios"
 PACKAGES_STAGE0 += terminfo
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
index a6b923cc35..68134965a5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP, FlexibleInstances #-}
 
 -- | Monadic front-end to Text.PrettyPrint
 
@@ -41,6 +41,9 @@ import qualified Text.PrettyPrint as HPJ
 import Control.Monad (liftM, liftM2, ap)
 import Language.Haskell.TH.Lib.Map ( Map )
 import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative( Applicative(..) )
+#endif
 
 infixl 6 <> 
 infixl 6 <+>
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 29be27a9a2..8879c62d19 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1,6 +1,10 @@
 {-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents,
              RoleAnnotations, DeriveGeneric, FlexibleInstances #-}
 
+#if MIN_VERSION_base(4,8,0)
+#define HAS_NATURAL
+#endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Language.Haskell.Syntax
@@ -29,16 +33,19 @@ import Data.Char        ( isAlpha, isAlphaNum, isUpper )
 import Data.Int
 import Data.Word
 import Data.Ratio
-import Numeric.Natural
 import GHC.Generics     ( Generic )
 
+#ifdef HAS_NATURAL
+import Numeric.Natural
+#endif
+
 -----------------------------------------------------
 --
 --              The Quasi class
 --
 -----------------------------------------------------
 
-class Monad m => Quasi m where
+class (Applicative m, Monad m) => Quasi m where
   qNewName :: String -> m Name
         -- ^ Fresh names
 
@@ -487,8 +494,10 @@ instance Lift Word32 where
 instance Lift Word64 where
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
+#ifdef HAS_NATURAL
 instance Lift Natural where
   lift x = return (LitE (IntegerL (fromIntegral x)))
+#endif
 
 instance Integral a => Lift (Ratio a) where
   lift x = return (LitE (RationalL (toRational x)))
diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal
index 1c53af392e..bd277d127c 100644
--- a/libraries/template-haskell/template-haskell.cabal
+++ b/libraries/template-haskell/template-haskell.cabal
@@ -48,9 +48,14 @@ Library
         Language.Haskell.TH.Lib.Map
 
     build-depends:
-        base       == 4.8.*,
+        base       >= 4.7 && < 4.9,
         pretty     == 1.1.*
 
     -- We need to set the package key to template-haskell (without a
     -- version number) as it's magic.
-    ghc-options: -Wall -this-package-key template-haskell
+    ghc-options: -Wall
+
+    if impl( ghc >= 7.9 )
+        ghc-options:  -this-package-key template-haskell
+    else
+        ghc-options:  -package-name template-haskell
diff --git a/mk/warnings.mk b/mk/warnings.mk
index 30e13ba6b8..5c41d5f9f4 100644
--- a/mk/warnings.mk
+++ b/mk/warnings.mk
@@ -102,6 +102,7 @@ libraries/ghc-prim_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe
 libraries/Win32_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe
 
 # Temporarely disable inline rule shadowing warning
+libraries/template-haskell_dist-boot_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing
 libraries/template-haskell_dist-install_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing
 
 # We need -fno-warn-deprecated-flags to avoid failure with -Werror
diff --git a/testsuite/tests/quotes/.gitignore b/testsuite/tests/quotes/.gitignore
new file mode 100644
index 0000000000..1c8a416fcd
--- /dev/null
+++ b/testsuite/tests/quotes/.gitignore
@@ -0,0 +1,4 @@
+T3572
+T8633
+TH_ppr1
+TH_spliceViewPat/TH_spliceViewPat
diff --git a/testsuite/tests/quotes/Makefile b/testsuite/tests/quotes/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/quotes/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/quotes/T10384.hs b/testsuite/tests/quotes/T10384.hs
new file mode 100644
index 0000000000..773deb061a
--- /dev/null
+++ b/testsuite/tests/quotes/T10384.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-}
+module A where
+x = \(y :: forall a. a -> a) -> [|| y ||]
diff --git a/testsuite/tests/quotes/T10384.stderr b/testsuite/tests/quotes/T10384.stderr
new file mode 100644
index 0000000000..f2360fd5ba
--- /dev/null
+++ b/testsuite/tests/quotes/T10384.stderr
@@ -0,0 +1,6 @@
+
+T10384.hs:3:37: error:
+    Can't splice the polymorphic local variable ‘y’
+    In the Template Haskell quotation [|| y ||]
+    In the expression: [|| y ||]
+    In the expression: \ (y :: forall a. a -> a) -> [|| y ||]
diff --git a/testsuite/tests/th/T2632.hs b/testsuite/tests/quotes/T2632.hs
index 31429e28d9..71f6350cc2 100644
--- a/testsuite/tests/th/T2632.hs
+++ b/testsuite/tests/quotes/T2632.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
 -- Trac #2632
 
 module MkData where
diff --git a/testsuite/tests/th/T2931.hs b/testsuite/tests/quotes/T2931.hs
index 01e57a934d..43aeda0ece 100644
--- a/testsuite/tests/th/T2931.hs
+++ b/testsuite/tests/quotes/T2931.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
 -- Trac #2931
 
 module Foo where
diff --git a/testsuite/tests/th/T3572.hs b/testsuite/tests/quotes/T3572.hs
index 4717fd2735..4717fd2735 100644
--- a/testsuite/tests/th/T3572.hs
+++ b/testsuite/tests/quotes/T3572.hs
diff --git a/testsuite/tests/th/T3572.stdout b/testsuite/tests/quotes/T3572.stdout
index 9df7a449ff..9df7a449ff 100644
--- a/testsuite/tests/th/T3572.stdout
+++ b/testsuite/tests/quotes/T3572.stdout
diff --git a/testsuite/tests/th/T4056.hs b/testsuite/tests/quotes/T4056.hs
index 211d2b51f4..a9b936987c 100644
--- a/testsuite/tests/th/T4056.hs
+++ b/testsuite/tests/quotes/T4056.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}
 
 module T4056 where
 import Language.Haskell.TH
diff --git a/testsuite/tests/th/T4169.hs b/testsuite/tests/quotes/T4169.hs
index 1fa3ad7cb7..cdef4a2e3a 100644
--- a/testsuite/tests/th/T4169.hs
+++ b/testsuite/tests/quotes/T4169.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
 -- Crashed GHC 6.12
 
 module T4165 where
diff --git a/testsuite/tests/th/T4170.hs b/testsuite/tests/quotes/T4170.hs
index 87ccad6c5b..46319abaf0 100644
--- a/testsuite/tests/th/T4170.hs
+++ b/testsuite/tests/quotes/T4170.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
 module T4170 where
 
 import Language.Haskell.TH
diff --git a/testsuite/tests/th/T5721.hs b/testsuite/tests/quotes/T5721.hs
index 60879c7570..ed5e7e380b 100644
--- a/testsuite/tests/th/T5721.hs
+++ b/testsuite/tests/quotes/T5721.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module T5371 where
 import Language.Haskell.TH
diff --git a/testsuite/tests/th/T6062.hs b/testsuite/tests/quotes/T6062.hs
index 330b3f2b8b..342850e853 100644
--- a/testsuite/tests/th/T6062.hs
+++ b/testsuite/tests/quotes/T6062.hs
@@ -1,3 +1,2 @@
-{-# LANGUAGE TemplateHaskell #-}
 module T6062 where
 x = [| False True |]
diff --git a/testsuite/tests/quotes/T8455.hs b/testsuite/tests/quotes/T8455.hs
new file mode 100644
index 0000000000..69d1271b40
--- /dev/null
+++ b/testsuite/tests/quotes/T8455.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
+module T8455 where
+
+ty = [t| 5 |]
diff --git a/testsuite/tests/th/T8633.hs b/testsuite/tests/quotes/T8633.hs
index 0c73579e12..eb2b3f3a3b 100644
--- a/testsuite/tests/th/T8633.hs
+++ b/testsuite/tests/quotes/T8633.hs
@@ -1,19 +1,19 @@
-module Main where

-import Language.Haskell.TH.Syntax

-

-t1 = case mkName "^.." of

-    Name (OccName ".")  (NameQ (ModName "^")) -> error "bug0"

-    Name (OccName "^..") NameS                -> return ()

-

-t2 = case mkName "Control.Lens.^.." of

-    Name (OccName ".")  (NameQ (ModName "Control.Lens.^")) -> error "bug1"

-    Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return ()

-

-t3 = case mkName "Data.Bits..&." of

-    Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return ()

-

-t4 = case mkName "abcde" of

-    Name (OccName "abcde") NameS -> return ()

-

-main :: IO ()

-main = do t1; t2; t3; t4

+module Main where
+import Language.Haskell.TH.Syntax
+
+t1 = case mkName "^.." of
+    Name (OccName ".")  (NameQ (ModName "^")) -> error "bug0"
+    Name (OccName "^..") NameS                -> return ()
+
+t2 = case mkName "Control.Lens.^.." of
+    Name (OccName ".")  (NameQ (ModName "Control.Lens.^")) -> error "bug1"
+    Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return ()
+
+t3 = case mkName "Data.Bits..&." of
+    Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return ()
+
+t4 = case mkName "abcde" of
+    Name (OccName "abcde") NameS -> return ()
+
+main :: IO ()
+main = do t1; t2; t3; t4
diff --git a/testsuite/tests/th/T8759a.hs b/testsuite/tests/quotes/T8759a.hs
index 3d8089c2fa..37b65d6fcc 100644
--- a/testsuite/tests/th/T8759a.hs
+++ b/testsuite/tests/quotes/T8759a.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module T8759a where
 
diff --git a/testsuite/tests/th/T8759a.stderr b/testsuite/tests/quotes/T8759a.stderr
index ff0fd495df..ff0fd495df 100644
--- a/testsuite/tests/th/T8759a.stderr
+++ b/testsuite/tests/quotes/T8759a.stderr
diff --git a/testsuite/tests/th/T9824.hs b/testsuite/tests/quotes/T9824.hs
index 828c00893c..9a2d6fdfef 100644
--- a/testsuite/tests/th/T9824.hs
+++ b/testsuite/tests/quotes/T9824.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fwarn-unused-matches #-}
 
 module T9824 where
diff --git a/testsuite/tests/th/TH_abstractFamily.hs b/testsuite/tests/quotes/TH_abstractFamily.hs
index 78d7e43931..78d7e43931 100644
--- a/testsuite/tests/th/TH_abstractFamily.hs
+++ b/testsuite/tests/quotes/TH_abstractFamily.hs
diff --git a/testsuite/tests/th/TH_abstractFamily.stderr b/testsuite/tests/quotes/TH_abstractFamily.stderr
index c0aa8d274b..c0aa8d274b 100644
--- a/testsuite/tests/th/TH_abstractFamily.stderr
+++ b/testsuite/tests/quotes/TH_abstractFamily.stderr
diff --git a/testsuite/tests/th/TH_bracket1.hs b/testsuite/tests/quotes/TH_bracket1.hs
index 7dee21ba01..7dee21ba01 100644
--- a/testsuite/tests/th/TH_bracket1.hs
+++ b/testsuite/tests/quotes/TH_bracket1.hs
diff --git a/testsuite/tests/th/TH_bracket2.hs b/testsuite/tests/quotes/TH_bracket2.hs
index 2b06b9eecb..2b06b9eecb 100644
--- a/testsuite/tests/th/TH_bracket2.hs
+++ b/testsuite/tests/quotes/TH_bracket2.hs
diff --git a/testsuite/tests/th/TH_bracket3.hs b/testsuite/tests/quotes/TH_bracket3.hs
index c746d61cd3..c746d61cd3 100644
--- a/testsuite/tests/th/TH_bracket3.hs
+++ b/testsuite/tests/quotes/TH_bracket3.hs
diff --git a/testsuite/tests/quotes/TH_localname.hs b/testsuite/tests/quotes/TH_localname.hs
new file mode 100644
index 0000000000..5bc0e96036
--- /dev/null
+++ b/testsuite/tests/quotes/TH_localname.hs
@@ -0,0 +1,3 @@
+module TH_localname where
+
+x = \y -> [| y |]
diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr
new file mode 100644
index 0000000000..a83c606eb4
--- /dev/null
+++ b/testsuite/tests/quotes/TH_localname.stderr
@@ -0,0 +1,22 @@
+
+TH_localname.hs:3:11: error:
+    No instance for (Lift t0) arising from a use of ‘lift’
+    The type variable ‘t0’ is ambiguous
+    Relevant bindings include
+      y :: t0 (bound at TH_localname.hs:3:6)
+      x :: t0 -> ExpQ (bound at TH_localname.hs:3:1)
+    Note: there are several potential instances:
+      instance (Lift a, Lift b) => Lift (Either a b)
+        -- Defined in ‘Language.Haskell.TH.Syntax’
+      instance Lift a => Lift (Maybe a)
+        -- Defined in ‘Language.Haskell.TH.Syntax’
+      instance Lift Int16 -- Defined in ‘Language.Haskell.TH.Syntax’
+      ...plus 24 others
+    In the expression: lift y
+    In the expression:
+      [| y |]
+      pending(rn) [<y, lift y>]
+    In the expression:
+      \ y
+        -> [| y |]
+           pending(rn) [<y, lift y>]
diff --git a/testsuite/tests/th/TH_ppr1.hs b/testsuite/tests/quotes/TH_ppr1.hs
index 763d7682e0..763d7682e0 100644
--- a/testsuite/tests/th/TH_ppr1.hs
+++ b/testsuite/tests/quotes/TH_ppr1.hs
diff --git a/testsuite/tests/th/TH_ppr1.stdout b/testsuite/tests/quotes/TH_ppr1.stdout
index e969c176c3..e969c176c3 100644
--- a/testsuite/tests/th/TH_ppr1.stdout
+++ b/testsuite/tests/quotes/TH_ppr1.stdout
diff --git a/testsuite/tests/th/TH_reifyType1.hs b/testsuite/tests/quotes/TH_reifyType1.hs
index d8b45db271..d8b45db271 100644
--- a/testsuite/tests/th/TH_reifyType1.hs
+++ b/testsuite/tests/quotes/TH_reifyType1.hs
diff --git a/testsuite/tests/th/TH_reifyType2.hs b/testsuite/tests/quotes/TH_reifyType2.hs
index 85615b5382..85615b5382 100644
--- a/testsuite/tests/th/TH_reifyType2.hs
+++ b/testsuite/tests/quotes/TH_reifyType2.hs
diff --git a/testsuite/tests/th/TH_repE1.hs b/testsuite/tests/quotes/TH_repE1.hs
index 1938a9bdc3..1938a9bdc3 100644
--- a/testsuite/tests/th/TH_repE1.hs
+++ b/testsuite/tests/quotes/TH_repE1.hs
diff --git a/testsuite/tests/th/TH_repE3.hs b/testsuite/tests/quotes/TH_repE3.hs
index 5f0453c1a7..5f0453c1a7 100644
--- a/testsuite/tests/th/TH_repE3.hs
+++ b/testsuite/tests/quotes/TH_repE3.hs
diff --git a/testsuite/tests/th/TH_scope.hs b/testsuite/tests/quotes/TH_scope.hs
index 7674a5d1c0..7674a5d1c0 100644
--- a/testsuite/tests/th/TH_scope.hs
+++ b/testsuite/tests/quotes/TH_scope.hs
diff --git a/testsuite/tests/th/TH_spliceViewPat/A.hs b/testsuite/tests/quotes/TH_spliceViewPat/A.hs
index 0147d2eca2..0147d2eca2 100644
--- a/testsuite/tests/th/TH_spliceViewPat/A.hs
+++ b/testsuite/tests/quotes/TH_spliceViewPat/A.hs
diff --git a/testsuite/tests/th/TH_spliceViewPat/Main.hs b/testsuite/tests/quotes/TH_spliceViewPat/Main.hs
index 675ae99bf9..675ae99bf9 100644
--- a/testsuite/tests/th/TH_spliceViewPat/Main.hs
+++ b/testsuite/tests/quotes/TH_spliceViewPat/Main.hs
diff --git a/testsuite/tests/th/TH_spliceViewPat/Makefile b/testsuite/tests/quotes/TH_spliceViewPat/Makefile
index 4a268530f1..4a268530f1 100644
--- a/testsuite/tests/th/TH_spliceViewPat/Makefile
+++ b/testsuite/tests/quotes/TH_spliceViewPat/Makefile
diff --git a/testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout b/testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout
index 4792e70f33..4792e70f33 100644
--- a/testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout
+++ b/testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout
diff --git a/testsuite/tests/th/TH_spliceViewPat/test.T b/testsuite/tests/quotes/TH_spliceViewPat/test.T
index 21fdff3518..3075ef4b1f 100644
--- a/testsuite/tests/th/TH_spliceViewPat/test.T
+++ b/testsuite/tests/quotes/TH_spliceViewPat/test.T
@@ -1,12 +1,7 @@
 def f(name, opts):
     opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
-    if (ghc_with_interpreter == 0):
-        opts.skip = 1
 
 setTestOpts(f)
-setTestOpts(only_compiler_types(['ghc']))
-setTestOpts(only_ways(['normal','ghci']))
-setTestOpts(when(compiler_profiled(), skip))
 
 test('TH_spliceViewPat',
      extra_clean(['Main.o', 'Main.hi', 'A.o', 'A.hi']),
diff --git a/testsuite/tests/th/TH_tf2.hs b/testsuite/tests/quotes/TH_tf2.hs
index 9f313d4a3e..9f313d4a3e 100644
--- a/testsuite/tests/th/TH_tf2.hs
+++ b/testsuite/tests/quotes/TH_tf2.hs
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
new file mode 100644
index 0000000000..a56a50c010
--- /dev/null
+++ b/testsuite/tests/quotes/all.T
@@ -0,0 +1,31 @@
+def f(name, opts):
+    opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
+
+setTestOpts(f)
+
+test('T2632', normal, compile, [''])
+test('T2931', normal, compile, ['-v0'])
+test('T3572', normal, compile_and_run, [''])
+test('T4056', normal, compile, ['-v0'])
+test('T4169', normal, compile, ['-v0'])
+test('T4170', normal, compile, ['-v0'])
+test('T5721', normal, compile, ['-v0'])
+test('T6062', normal, compile, ['-v0'])
+test('T8455', normal, compile, ['-v0'])
+test('T8633', normal, compile_and_run, [''])
+test('T8759a', normal, compile_fail, ['-v0'])
+test('T9824', normal, compile, ['-v0'])
+test('T10384', normal, compile_fail, [''])
+
+test('TH_tf2', normal, compile, ['-v0'])
+test('TH_ppr1', normal, compile_and_run, [''])
+test('TH_bracket1', normal, compile, [''])
+test('TH_bracket2', normal, compile, [''])
+test('TH_bracket3', normal, compile, [''])
+test('TH_scope', normal, compile, [''])
+test('TH_reifyType1', normal, compile, [''])
+test('TH_reifyType2', normal, compile, [''])
+test('TH_repE1', normal, compile, [''])
+test('TH_repE3', normal, compile, [''])
+test('TH_abstractFamily', normal, compile_fail, [''])
+test('TH_localname', normal, compile_fail, [''])
diff --git a/testsuite/tests/th/T8455.hs b/testsuite/tests/th/T8455.hs
deleted file mode 100644
index 08217b37d1..0000000000
--- a/testsuite/tests/th/T8455.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-{-# LANGUAGE TemplateHaskell, DataKinds #-}
-
-module T8455 where
-
-ty = [t| 5 |]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index dda8274c5b..43c3e89b02 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -1,3 +1,8 @@
+# NOTICE TO DEVELOPERS
+# ~~~~~~~~~~~~~~~~~~~~
+# Adding a TemplateHaskell test?  If it only contains (non-quasi) quotes
+# and no splices, consider adding it to the quotes/ directory instead
+# of the th/ directory; this way, we can test it on the stage 1 compiler too!
 
 # This test needs to come before the setTestOpts calls below, as we want
 # to run it if compiler_profiled.
@@ -16,9 +21,7 @@ setTestOpts(when(compiler_profiled(), skip))
 test('TH_mkName', normal, compile, ['-v0'])
 test('TH_1tuple', normal, compile_fail, ['-v0'])
 
-test('TH_repE1', normal, compile, [''])
 test('TH_repE2', normal, compile_and_run, [''])
-test('TH_repE3', normal, compile, [''])
 test('TH_repPrim', normal, compile, ['-v0'])
 test('TH_repPrim2', normal, compile, ['-v0'])
 test('TH_repUnboxedTuples', normal, compile, ['-v0'])
@@ -67,8 +70,6 @@ test('TH_spliceD2',
 test('TH_reifyDecl1', normal, compile, ['-v0'])
 test('TH_reifyDecl2', normal, compile, ['-v0'])
 
-test('TH_reifyType1', normal, compile, [''])
-test('TH_reifyType2', normal, compile, [''])
 test('TH_reifyMkName', normal, compile, ['-v0'])
 
 test('TH_reifyInstances', normal, compile, ['-v0'])
@@ -99,10 +100,6 @@ test('TH_spliceExpr1', normal, compile, ['-v0'])
 test('TH_spliceE3', normal, compile, ['-v0'])
 test('TH_spliceE4', normal, compile_and_run, [''])
 
-test('TH_bracket1', normal, compile, [''])
-test('TH_bracket2', normal, compile, [''])
-test('TH_bracket3', normal, compile, [''])
-
 test('TH_class1', normal, compile, ['-v0'])
 test('TH_tuple1', normal, compile, ['-v0'])
 test('TH_genEx',
@@ -122,8 +119,6 @@ test('TH_exn2', normal, compile_fail, ['-v0'])
 test('TH_recover', normal, compile_and_run, [''])
 test('TH_dataD1', normal, compile_fail, ['-v0'])
 
-test('TH_ppr1', normal, compile_and_run, [''])
-
 test('TH_fail', normal, compile_fail, ['-v0'])
 test('TH_scopedTvs', normal, compile, ['-v0'])
 
@@ -133,13 +128,10 @@ test('TH_ghci1', normal, ghci_script, ['TH_ghci1.script'])
 
 test('TH_linePragma', normal, compile_fail, ['-v0'])
 
-test('TH_scope', normal, compile, [''])
-test('T2632', normal, compile, [''])
 test('T2700', normal, compile, ['-v0'])
 test('T2817', normal, compile, ['-v0'])
 test('T2713', normal, compile_fail, ['-v0'])
 test('T2674', normal, compile_fail, ['-v0'])
-test('T2931', normal, compile, ['-v0'])
 test('TH_emptycase', normal, compile, ['-v0'])
 
 test('T2386', extra_clean(['T2386_Lib.hi', 'T2386_Lib.o']),
@@ -152,7 +144,6 @@ test('T2685', extra_clean(['T2685a.hi','T2685a.o']),
 test('TH_sections', normal, compile, ['-v0'])
 
 test('TH_tf1', normal, compile, ['-v0'])
-test('TH_tf2', normal, compile, ['-v0'])
 test('TH_tf3', normal, compile, ['-v0'])
 
 test('TH_pragma', normal, compile, ['-v0 -dsuppress-uniques'])
@@ -167,7 +158,6 @@ test('TH_foreignCallingConventions', normal,
 
 test('T3395', normal, compile_fail, ['-v0'])
 test('T3467', normal, compile, [''])
-test('T3572', normal, compile_and_run, [''])
 test('T3100', normal, compile, ['-v0'])
 test('T3920', normal, compile_and_run, ['-v0'])
 
@@ -177,10 +167,8 @@ test('T3845', normal, compile, ['-v0'])
 test('T3899', extra_clean(['T3899a.hi','T3899a.o']),
               multimod_compile,
               ['T3899','-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
-test('T4056', normal, compile, ['-v0'])
 test('T4188', normal, compile, ['-v0'])
 test('T4233', normal, compile, ['-v0'])
-test('T4169', normal, compile, ['-v0'])
 test('T1835', normal, compile_and_run, ['-v0'])
 
 test('TH_viewPatPrint', normal, compile_and_run, [''])
@@ -227,7 +215,6 @@ test('T5665', extra_clean(['T5665a.hi','T5665a.o']),
 test('T5700', extra_clean(['T5700a.hi','T5700a.o']),
               multimod_compile,
               ['T5700','-v0 -ddump-splices ' + config.ghc_th_way_flags])
-test('T5721', normal, compile, ['-v0'])
 
 test('TH_PromotedTuple', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_PromotedList', normal, compile, ['-v0'])
@@ -302,15 +289,12 @@ test('T8333',
      run_command,
      ['$MAKE -s --no-print-directory T8333'])
 
-test('T4170', normal, compile, ['-v0'])
 test('T4124', normal, compile, ['-v0'])
 test('T4128', normal, compile, ['-v0'])
-test('T6062', normal, compile, ['-v0'])
 test('T4364', normal, compile, ['-v0'])
 test('T8412', normal, compile_fail, ['-v0'])
 test('T7667', normal, compile, ['-v0'])
 test('T7667a', normal, compile_fail, ['-v0'])
-test('T8455', normal, compile, ['-v0'])
 test('T8499', normal, compile, ['-v0'])
 test('T7477', normal, compile, ['-v0'])
 test('T8507', normal, compile, ['-v0'])
@@ -322,7 +306,6 @@ test('T8577',
      extra_clean(['T8577a.hi', 'T8577a.o']),
      multimod_compile_fail,
      ['T8577', '-v0 ' + config.ghc_th_way_flags])
-test('T8633', normal, compile_and_run, [''])
 test('T8625', normal, ghci_script, ['T8625.script'])
 test('TH_StaticPointers',
      [ when(compiler_lt('ghc', '7.9'), skip) ],
@@ -331,7 +314,6 @@ test('TH_StaticPointers02',
      [ when(compiler_lt('ghc', '7.9'), skip) ],
      compile_fail, [''])
 test('T8759', normal, compile_fail, ['-v0'])
-test('T8759a', normal, compile_fail, ['-v0'])
 test('T7021',
      extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
 test('T8807', normal, compile, ['-v0'])
@@ -354,7 +336,6 @@ test('T9209', normal, compile_fail, ['-v0'])
 test('T7484', normal, compile_fail, ['-v0'])
 test('T1476', normal, compile, ['-v0'])
 test('T1476b', normal, compile_fail, ['-v0'])
-test('T9824', normal, compile, ['-v0'])
 test('T8031', normal, compile, ['-v0'])
 test('T8624', normal, run_command, ['$MAKE -s --no-print-directory T8624'])
 test('TH_Lift', normal, compile, ['-v0'])
@@ -362,5 +343,3 @@ test('T10047', normal, ghci_script, ['T10047.script'])
 test('T10019', normal, ghci_script, ['T10019.script'])
 test('T10279', normal, compile_fail, ['-v0'])
 test('T10306', normal, compile, ['-v0'])
-
-test('TH_abstractFamily', normal, compile_fail, [''])