Revert stage 1 template-haskell. This is a combination of 5 commits.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 9 May 2015 16:43:18 +0000 (09:43 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 9 May 2015 16:45:38 +0000 (09:45 -0700)
Revert "Quick fix: drop base bound on template-haskell."

This reverts commit 3c70ae032e4361b203dfcf22b0a424e8838a5037.

Revert "Always do polymorphic typed quote check, c.f. #10384"

This reverts commit 9a43b2c1f78b3cf684646af64b9b67dc8079f58f.

Revert "RnSplice's staging test should be applied for quotes in stage1."

This reverts commit eb0ed4030374af542c0a459480d32c8d4525e48d.

Revert "Split off quotes/ from th/ for tests that can be done on stage1 compiler."

This reverts commit 21c72e7d38c96ac80d31addf67ae4b3c7a6c3bbb.

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

This reverts commit 28257cae77023f2ccc4cc1c0cd1fbbd329947a00.

53 files changed:
compiler/deSugar/DsExpr.hs
compiler/ghc.cabal.in
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/rename/RnSplice.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcSplice.hs
docs/users_guide/7.12.1-notes.xml
docs/users_guide/glasgow_exts.xml
ghc.mk
libraries/template-haskell/template-haskell.cabal
mk/warnings.mk
testsuite/tests/quotes/.gitignore [deleted file]
testsuite/tests/quotes/Makefile [deleted file]
testsuite/tests/quotes/T10384.hs [deleted file]
testsuite/tests/quotes/T10384.stderr [deleted file]
testsuite/tests/quotes/T8455.hs [deleted file]
testsuite/tests/quotes/TH_localname.hs [deleted file]
testsuite/tests/quotes/TH_localname.stderr [deleted file]
testsuite/tests/quotes/all.T [deleted file]
testsuite/tests/th/T2632.hs [moved from testsuite/tests/quotes/T2632.hs with 85% similarity]
testsuite/tests/th/T2931.hs [moved from testsuite/tests/quotes/T2931.hs with 70% similarity]
testsuite/tests/th/T3572.hs [moved from testsuite/tests/quotes/T3572.hs with 100% similarity]
testsuite/tests/th/T3572.stdout [moved from testsuite/tests/quotes/T3572.stdout with 100% similarity]
testsuite/tests/th/T4056.hs [moved from testsuite/tests/quotes/T4056.hs with 73% similarity]
testsuite/tests/th/T4169.hs [moved from testsuite/tests/quotes/T4169.hs with 85% similarity]
testsuite/tests/th/T4170.hs [moved from testsuite/tests/quotes/T4170.hs with 80% similarity]
testsuite/tests/th/T5721.hs [moved from testsuite/tests/quotes/T5721.hs with 59% similarity]
testsuite/tests/th/T6062.hs [moved from testsuite/tests/quotes/T6062.hs with 54% similarity]
testsuite/tests/th/T8455.hs [new file with mode: 0644]
testsuite/tests/th/T8633.hs [moved from testsuite/tests/quotes/T8633.hs with 96% similarity]
testsuite/tests/th/T8759a.hs [moved from testsuite/tests/quotes/T8759a.hs with 51% similarity]
testsuite/tests/th/T8759a.stderr [moved from testsuite/tests/quotes/T8759a.stderr with 100% similarity]
testsuite/tests/th/T9824.hs [moved from testsuite/tests/quotes/T9824.hs with 71% similarity]
testsuite/tests/th/TH_abstractFamily.hs [moved from testsuite/tests/quotes/TH_abstractFamily.hs with 100% similarity]
testsuite/tests/th/TH_abstractFamily.stderr [moved from testsuite/tests/quotes/TH_abstractFamily.stderr with 100% similarity]
testsuite/tests/th/TH_bracket1.hs [moved from testsuite/tests/quotes/TH_bracket1.hs with 100% similarity]
testsuite/tests/th/TH_bracket2.hs [moved from testsuite/tests/quotes/TH_bracket2.hs with 100% similarity]
testsuite/tests/th/TH_bracket3.hs [moved from testsuite/tests/quotes/TH_bracket3.hs with 100% similarity]
testsuite/tests/th/TH_ppr1.hs [moved from testsuite/tests/quotes/TH_ppr1.hs with 100% similarity]
testsuite/tests/th/TH_ppr1.stdout [moved from testsuite/tests/quotes/TH_ppr1.stdout with 100% similarity]
testsuite/tests/th/TH_reifyType1.hs [moved from testsuite/tests/quotes/TH_reifyType1.hs with 100% similarity]
testsuite/tests/th/TH_reifyType2.hs [moved from testsuite/tests/quotes/TH_reifyType2.hs with 100% similarity]
testsuite/tests/th/TH_repE1.hs [moved from testsuite/tests/quotes/TH_repE1.hs with 100% similarity]
testsuite/tests/th/TH_repE3.hs [moved from testsuite/tests/quotes/TH_repE3.hs with 100% similarity]
testsuite/tests/th/TH_scope.hs [moved from testsuite/tests/quotes/TH_scope.hs with 100% similarity]
testsuite/tests/th/TH_spliceViewPat/A.hs [moved from testsuite/tests/quotes/TH_spliceViewPat/A.hs with 100% similarity]
testsuite/tests/th/TH_spliceViewPat/Main.hs [moved from testsuite/tests/quotes/TH_spliceViewPat/Main.hs with 100% similarity]
testsuite/tests/th/TH_spliceViewPat/Makefile [moved from testsuite/tests/quotes/TH_spliceViewPat/Makefile with 100% similarity]
testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout [moved from testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout with 100% similarity]
testsuite/tests/th/TH_spliceViewPat/test.T [moved from testsuite/tests/quotes/TH_spliceViewPat/test.T with 58% similarity]
testsuite/tests/th/TH_tf2.hs [moved from testsuite/tests/quotes/TH_tf2.hs with 100% similarity]
testsuite/tests/th/all.T

index 78a6d11..42aa222 100644 (file)
@@ -24,7 +24,11 @@ import Name
 import NameEnv
 import FamInstEnv( topNormaliseType )
 
+#ifdef GHCI
+        -- Template Haskell stuff iff bootstrapped
 import DsMeta
+#endif
+
 import HsSyn
 
 import Platform
@@ -641,7 +645,11 @@ 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
index 09c252b..c39c83e 100644 (file)
@@ -52,7 +52,6 @@ Library
                    containers >= 0.5 && < 0.6,
                    array      >= 0.1 && < 0.6,
                    filepath   >= 1   && < 1.5,
-                   template-haskell,
                    hpc,
                    transformers,
                    bin-package-db,
@@ -66,6 +65,7 @@ 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,7 +164,6 @@ Library
         IdInfo
         Lexeme
         Literal
-        DsMeta
         Llvm
         Llvm.AbsSyn
         Llvm.MetaData
@@ -567,6 +566,7 @@ Library
 
     if flag(ghci)
         Exposed-Modules:
+            DsMeta
             Convert
             ByteCodeAsm
             ByteCodeGen
index 1feb358..d8f5169 100644 (file)
@@ -3008,7 +3008,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
@@ -3178,7 +3178,7 @@ xFlags = [
   flagSpec "StandaloneDeriving"               Opt_StandaloneDeriving,
   flagSpec "StaticPointers"                   Opt_StaticPointers,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
-                                              setTemplateHaskellLoc,
+                                              checkTemplateHaskellOk,
   flagSpec "TraditionalRecordSyntax"          Opt_TraditionalRecordSyntax,
   flagSpec "TransformListComp"                Opt_TransformListComp,
   flagSpec "TupleSections"                    Opt_TupleSections,
@@ -3499,9 +3499,28 @@ setIncoherentInsts True = do
   l <- getCurLoc
   upd (\d -> d { incoherentOnLoc = l })
 
-setTemplateHaskellLoc :: TurnOnFlag -> DynP ()
-setTemplateHaskellLoc _
+checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
+#ifdef GHCI
+checkTemplateHaskellOk turn_on
+  | turn_on && rtsIsProfiled
+  = addErr "You can't use Template Haskell with a profiled compiler"
+  | otherwise
   = 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
 
 {- **********************************************************************
 %*                                                                      *
index eb772ba..381b902 100644 (file)
@@ -94,6 +94,7 @@ import Type             ( Type )
 import PrelNames
 import {- Kind parts of -} Type         ( Kind )
 import CoreLint         ( lintInteractiveExpr )
+import DsMeta           ( templateHaskellNames )
 import VarEnv           ( emptyTidyEnv )
 import Panic
 import ConLike
@@ -101,7 +102,6 @@ import ConLike
 import GHC.Exts
 #endif
 
-import DsMeta           ( templateHaskellNames )
 import Module
 import Packages
 import RdrName
@@ -196,7 +196,9 @@ knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
 knownKeyNames =              -- where templateHaskellNames are defined
     map getName wiredInThings
         ++ basicKnownKeyNames
+#ifdef GHCI
         ++ templateHaskellNames
+#endif
 
 -- -----------------------------------------------------------------------------
 
index 5d12720..5306b6e 100644 (file)
@@ -19,172 +19,37 @@ import RdrName
 import TcRnMonad
 import Kind
 
-import RnEnv
-import RnSource         ( rnSrcDecls, findSplice )
-import RnPat            ( rnPat )
+#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 BasicTypes       ( TopLevelFlag, isTopLevel )
-import Outputable
 import Module
-import SrcLoc
-import DynFlags
-import FastString
+import RnEnv
+import RnPat            ( rnPat )
+import RnSource         ( rnSrcDecls, findSplice )
 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 SrcLoc
+import TcEnv            ( checkWellStaged, tcMetaTy )
+import Outputable
+import BasicTypes       ( TopLevelFlag, isTopLevel )
+import FastString
 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
 
-{-
-************************************************************************
-*                                                                      *
-        Template Haskell brackets
-*                                                                      *
-************************************************************************
--}
-
+#ifndef GHCI
 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") ] )
-
-         -- 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)")
+rnBracket e _ = failTH e "Template Haskell bracket"
 
-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"
 
@@ -498,6 +363,120 @@ 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)
@@ -554,12 +533,31 @@ 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:"))
@@ -568,6 +566,13 @@ illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brac
 #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)
@@ -633,6 +638,7 @@ 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]
index 155cdb4..353b2b7 100644 (file)
@@ -16,7 +16,9 @@ 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
@@ -1232,6 +1234,13 @@ 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
@@ -1294,6 +1303,7 @@ checkCrossStageLifting _ _ = return ()
 polySpliceErr :: Id -> SDoc
 polySpliceErr id
   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
+#endif /* GHCI */
 
 {-
 Note [Lifting strings]
index f6b1083..b73f20b 100644 (file)
@@ -34,14 +34,6 @@ 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
@@ -53,11 +45,14 @@ 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
@@ -86,6 +81,7 @@ import DsExpr
 import DsMonad
 import Serialized
 import ErrUtils
+import SrcLoc
 import Util
 import Data.List        ( mapAccumL )
 import Unique
@@ -96,7 +92,10 @@ 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
@@ -130,87 +129,10 @@ 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"
@@ -403,8 +325,80 @@ 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]]) }
+
 {-
 ************************************************************************
 *                                                                      *
@@ -475,6 +469,11 @@ 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"))
index 9a87588..4dbb0b2 100644 (file)
         <itemizedlist>
             <listitem>
                 <para>
-                    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.
+                    TODO FIXME.
                </para>
            </listitem>
        </itemizedlist>
index 303833a..20204ca 100644 (file)
@@ -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 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
+             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
              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 2f37be8..b9bba13 100644 (file)
--- 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 template-haskell
+PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers
 ifeq "$(Windows_Host)" "NO"
 ifneq "$(HostOS_CPP)" "ios"
 PACKAGES_STAGE0 += terminfo
index 60a800c..1c53af3 100644 (file)
@@ -48,7 +48,7 @@ Library
         Language.Haskell.TH.Lib.Map
 
     build-depends:
-        base,
+        base       == 4.8.*,
         pretty     == 1.1.*
 
     -- We need to set the package key to template-haskell (without a
index 5c41d5f..30e13ba 100644 (file)
@@ -102,7 +102,6 @@ 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
deleted file mode 100644 (file)
index 1c8a416..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-T3572
-T8633
-TH_ppr1
-TH_spliceViewPat/TH_spliceViewPat
diff --git a/testsuite/tests/quotes/Makefile b/testsuite/tests/quotes/Makefile
deleted file mode 100644 (file)
index 9a36a1c..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-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
deleted file mode 100644 (file)
index 773deb0..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-{-# 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
deleted file mode 100644 (file)
index f2360fd..0000000
+++ /dev/null
@@ -1,6 +0,0 @@
-
-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/quotes/T8455.hs b/testsuite/tests/quotes/T8455.hs
deleted file mode 100644 (file)
index 69d1271..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-
-module T8455 where
-
-ty = [t| 5 |]
diff --git a/testsuite/tests/quotes/TH_localname.hs b/testsuite/tests/quotes/TH_localname.hs
deleted file mode 100644 (file)
index 5bc0e96..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-module TH_localname where
-
-x = \y -> [| y |]
diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr
deleted file mode 100644 (file)
index a83c606..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-
-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/quotes/all.T b/testsuite/tests/quotes/all.T
deleted file mode 100644 (file)
index a56a50c..0000000
+++ /dev/null
@@ -1,31 +0,0 @@
-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, [''])
similarity index 85%
rename from testsuite/tests/quotes/T2632.hs
rename to testsuite/tests/th/T2632.hs
index 71f6350..31429e2 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 -- Trac #2632
 
 module MkData where
similarity index 70%
rename from testsuite/tests/quotes/T2931.hs
rename to testsuite/tests/th/T2931.hs
index 43aeda0..01e57a9 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 -- Trac #2931
 
 module Foo where
similarity index 73%
rename from testsuite/tests/quotes/T4056.hs
rename to testsuite/tests/th/T4056.hs
index a9b9369..211d2b5 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell, TypeFamilies, RankNTypes, FlexibleContexts #-}
 
 module T4056 where
 import Language.Haskell.TH
similarity index 85%
rename from testsuite/tests/quotes/T4169.hs
rename to testsuite/tests/th/T4169.hs
index cdef4a2..1fa3ad7 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 -- Crashed GHC 6.12
 
 module T4165 where
similarity index 80%
rename from testsuite/tests/quotes/T4170.hs
rename to testsuite/tests/th/T4170.hs
index 46319ab..87ccad6 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 module T4170 where
 
 import Language.Haskell.TH
similarity index 59%
rename from testsuite/tests/quotes/T5721.hs
rename to testsuite/tests/th/T5721.hs
index ed5e7e3..60879c7 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
 
 module T5371 where
 import Language.Haskell.TH
similarity index 54%
rename from testsuite/tests/quotes/T6062.hs
rename to testsuite/tests/th/T6062.hs
index 342850e..330b3f2 100644 (file)
@@ -1,2 +1,3 @@
+{-# LANGUAGE TemplateHaskell #-}
 module T6062 where
 x = [| False True |]
diff --git a/testsuite/tests/th/T8455.hs b/testsuite/tests/th/T8455.hs
new file mode 100644 (file)
index 0000000..08217b3
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell, DataKinds #-}
+
+module T8455 where
+
+ty = [t| 5 |]
similarity index 96%
rename from testsuite/tests/quotes/T8633.hs
rename to testsuite/tests/th/T8633.hs
index eb2b3f3..0c73579 100644 (file)
@@ -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\r
+import Language.Haskell.TH.Syntax\r
+\r
+t1 = case mkName "^.." of\r
+    Name (OccName ".")  (NameQ (ModName "^")) -> error "bug0"\r
+    Name (OccName "^..") NameS                -> return ()\r
+\r
+t2 = case mkName "Control.Lens.^.." of\r
+    Name (OccName ".")  (NameQ (ModName "Control.Lens.^")) -> error "bug1"\r
+    Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return ()\r
+\r
+t3 = case mkName "Data.Bits..&." of\r
+    Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return ()\r
+\r
+t4 = case mkName "abcde" of\r
+    Name (OccName "abcde") NameS -> return ()\r
+\r
+main :: IO ()\r
+main = do t1; t2; t3; t4\r
similarity index 51%
rename from testsuite/tests/quotes/T8759a.hs
rename to testsuite/tests/th/T8759a.hs
index 37b65d6..3d8089c 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
 
 module T8759a where
 
similarity index 71%
rename from testsuite/tests/quotes/T9824.hs
rename to testsuite/tests/th/T9824.hs
index 9a2d6fd..828c008 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fwarn-unused-matches #-}
 
 module T9824 where
similarity index 58%
rename from testsuite/tests/quotes/TH_spliceViewPat/test.T
rename to testsuite/tests/th/TH_spliceViewPat/test.T
index 3075ef4..21fdff3 100644 (file)
@@ -1,7 +1,12 @@
 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']),
index 43c3e89..dda8274 100644 (file)
@@ -1,8 +1,3 @@
-# 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.
@@ -21,7 +16,9 @@ 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'])
@@ -70,6 +67,8 @@ 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'])
@@ -100,6 +99,10 @@ 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',
@@ -119,6 +122,8 @@ 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'])
 
@@ -128,10 +133,13 @@ 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']),
@@ -144,6 +152,7 @@ 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'])
@@ -158,6 +167,7 @@ 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'])
 
@@ -167,8 +177,10 @@ 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, [''])
@@ -215,6 +227,7 @@ 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'])
@@ -289,12 +302,15 @@ 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'])
@@ -306,6 +322,7 @@ 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) ],
@@ -314,6 +331,7 @@ 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'])
@@ -336,6 +354,7 @@ 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'])
@@ -343,3 +362,5 @@ 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, [''])