Commit 5c459eef authored by Edward Z. Yang's avatar Edward Z. Yang

Revert stage 1 template-haskell. This is a combination of 5 commits.

Revert "Quick fix: drop base bound on template-haskell."

This reverts commit 3c70ae03.

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

This reverts commit 9a43b2c1.

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

This reverts commit eb0ed403.

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

This reverts commit 21c72e7d.

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

This reverts commit 28257cae.
parent 3c70ae03
...@@ -24,7 +24,11 @@ import Name ...@@ -24,7 +24,11 @@ import Name
import NameEnv import NameEnv
import FamInstEnv( topNormaliseType ) import FamInstEnv( topNormaliseType )
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
import DsMeta import DsMeta
#endif
import HsSyn import HsSyn
import Platform import Platform
...@@ -641,7 +645,11 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ...@@ -641,7 +645,11 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- Template Haskell stuff -- Template Haskell stuff
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI
dsExpr (HsTcBracketOut x ps) = dsBracket x ps dsExpr (HsTcBracketOut x ps) = dsBracket x ps
#else
dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
#endif
dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension -- Arrow notation extension
......
...@@ -52,7 +52,6 @@ Library ...@@ -52,7 +52,6 @@ Library
containers >= 0.5 && < 0.6, containers >= 0.5 && < 0.6,
array >= 0.1 && < 0.6, array >= 0.1 && < 0.6,
filepath >= 1 && < 1.5, filepath >= 1 && < 1.5,
template-haskell,
hpc, hpc,
transformers, transformers,
bin-package-db, bin-package-db,
...@@ -66,6 +65,7 @@ Library ...@@ -66,6 +65,7 @@ Library
GHC-Options: -Wall -fno-warn-name-shadowing GHC-Options: -Wall -fno-warn-name-shadowing
if flag(ghci) if flag(ghci)
Build-Depends: template-haskell
CPP-Options: -DGHCI CPP-Options: -DGHCI
Include-Dirs: ../rts/dist/build @FFIIncludeDir@ Include-Dirs: ../rts/dist/build @FFIIncludeDir@
...@@ -164,7 +164,6 @@ Library ...@@ -164,7 +164,6 @@ Library
IdInfo IdInfo
Lexeme Lexeme
Literal Literal
DsMeta
Llvm Llvm
Llvm.AbsSyn Llvm.AbsSyn
Llvm.MetaData Llvm.MetaData
...@@ -567,6 +566,7 @@ Library ...@@ -567,6 +566,7 @@ Library
if flag(ghci) if flag(ghci)
Exposed-Modules: Exposed-Modules:
DsMeta
Convert Convert
ByteCodeAsm ByteCodeAsm
ByteCodeGen ByteCodeGen
......
...@@ -3008,7 +3008,7 @@ fLangFlags = [ ...@@ -3008,7 +3008,7 @@ fLangFlags = [
-- See Note [Supporting CLI completion] -- See Note [Supporting CLI completion]
flagSpec' "th" Opt_TemplateHaskell flagSpec' "th" Opt_TemplateHaskell
(\on -> deprecatedForExtension "TemplateHaskell" on (\on -> deprecatedForExtension "TemplateHaskell" on
>> setTemplateHaskellLoc on), >> checkTemplateHaskellOk on),
flagSpec' "fi" Opt_ForeignFunctionInterface flagSpec' "fi" Opt_ForeignFunctionInterface
(deprecatedForExtension "ForeignFunctionInterface"), (deprecatedForExtension "ForeignFunctionInterface"),
flagSpec' "ffi" Opt_ForeignFunctionInterface flagSpec' "ffi" Opt_ForeignFunctionInterface
...@@ -3178,7 +3178,7 @@ xFlags = [ ...@@ -3178,7 +3178,7 @@ xFlags = [
flagSpec "StandaloneDeriving" Opt_StandaloneDeriving, flagSpec "StandaloneDeriving" Opt_StandaloneDeriving,
flagSpec "StaticPointers" Opt_StaticPointers, flagSpec "StaticPointers" Opt_StaticPointers,
flagSpec' "TemplateHaskell" Opt_TemplateHaskell flagSpec' "TemplateHaskell" Opt_TemplateHaskell
setTemplateHaskellLoc, checkTemplateHaskellOk,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
flagSpec "TransformListComp" Opt_TransformListComp, flagSpec "TransformListComp" Opt_TransformListComp,
flagSpec "TupleSections" Opt_TupleSections, flagSpec "TupleSections" Opt_TupleSections,
...@@ -3499,9 +3499,28 @@ setIncoherentInsts True = do ...@@ -3499,9 +3499,28 @@ setIncoherentInsts True = do
l <- getCurLoc l <- getCurLoc
upd (\d -> d { incoherentOnLoc = l }) upd (\d -> d { incoherentOnLoc = l })
setTemplateHaskellLoc :: TurnOnFlag -> DynP () checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
setTemplateHaskellLoc _ #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 }) = 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
{- ********************************************************************** {- **********************************************************************
%* * %* *
......
...@@ -94,6 +94,7 @@ import Type ( Type ) ...@@ -94,6 +94,7 @@ import Type ( Type )
import PrelNames import PrelNames
import {- Kind parts of -} Type ( Kind ) import {- Kind parts of -} Type ( Kind )
import CoreLint ( lintInteractiveExpr ) import CoreLint ( lintInteractiveExpr )
import DsMeta ( templateHaskellNames )
import VarEnv ( emptyTidyEnv ) import VarEnv ( emptyTidyEnv )
import Panic import Panic
import ConLike import ConLike
...@@ -101,7 +102,6 @@ import ConLike ...@@ -101,7 +102,6 @@ import ConLike
import GHC.Exts import GHC.Exts
#endif #endif
import DsMeta ( templateHaskellNames )
import Module import Module
import Packages import Packages
import RdrName import RdrName
...@@ -196,7 +196,9 @@ knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, ...@@ -196,7 +196,9 @@ knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
knownKeyNames = -- where templateHaskellNames are defined knownKeyNames = -- where templateHaskellNames are defined
map getName wiredInThings map getName wiredInThings
++ basicKnownKeyNames ++ basicKnownKeyNames
#ifdef GHCI
++ templateHaskellNames ++ templateHaskellNames
#endif
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -19,172 +19,37 @@ import RdrName ...@@ -19,172 +19,37 @@ import RdrName
import TcRnMonad import TcRnMonad
import Kind import Kind
import RnEnv #ifdef GHCI
import RnSource ( rnSrcDecls, findSplice ) import ErrUtils ( dumpIfSet_dyn_printer )
import RnPat ( rnPat ) import Control.Monad ( unless, when )
import DynFlags
import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, liftName )
import LoadIface ( loadInterfaceForName ) import LoadIface ( loadInterfaceForName )
import BasicTypes ( TopLevelFlag, isTopLevel )
import Outputable
import Module import Module
import SrcLoc import RnEnv
import DynFlags import RnPat ( rnPat )
import FastString import RnSource ( rnSrcDecls, findSplice )
import RnTypes ( rnLHsType ) import RnTypes ( rnLHsType )
import Control.Monad ( unless, when )
import {-# SOURCE #-} RnExpr ( rnLExpr )
import PrelNames ( isUnboundName ) import PrelNames ( isUnboundName )
import TcEnv ( checkWellStaged ) import SrcLoc
import DsMeta ( liftName ) import TcEnv ( checkWellStaged, tcMetaTy )
import Outputable
#ifdef GHCI import BasicTypes ( TopLevelFlag, isTopLevel )
import ErrUtils ( dumpIfSet_dyn_printer ) import FastString
import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
import TcEnv ( tcMetaTy )
import Hooks import Hooks
import Var ( Id ) import Var ( Id )
import DsMeta ( quoteExpName, quotePatName, quoteDecName, quoteTypeName ) import DsMeta ( quoteExpName, quotePatName, quoteDecName, quoteTypeName )
import Util import Util
import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif #endif
{- #ifndef GHCI
************************************************************************
* *
Template Haskell brackets
* *
************************************************************************
-}
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e br_body rnBracket e _ = failTH e "Template Haskell bracket"
= 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 :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
rnTopSpliceDecls e = failTH e "Template Haskell top splice" 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 ...@@ -498,6 +363,120 @@ Pat RdrName (the result of running a top-level splice) or a Pat Name
rnSplicePat. 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 :: HsSplice RdrName -> SDoc
spliceCtxt splice spliceCtxt splice
= hang (ptext (sLit "In the") <+> what) 2 (ppr splice) = hang (ptext (sLit "In the") <+> what) 2 (ppr splice)
...@@ -554,12 +533,31 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src ...@@ -554,12 +533,31 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ] , 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 :: SDoc
illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets") illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")
illegalUntypedSplice :: SDoc illegalUntypedSplice :: SDoc
illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets") 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 :: OutputableBndr id => LHsExpr id -> SDoc
-- spliceResultDoc expr -- spliceResultDoc expr
-- = vcat [ hang (ptext (sLit "In the splice:")) -- = vcat [ hang (ptext (sLit "In the splice:"))
...@@ -568,6 +566,13 @@ illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brac ...@@ -568,6 +566,13 @@ illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brac
#endif #endif
checkThLocalName :: Name -> RnM () 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 checkThLocalName name
| isUnboundName name -- Do not report two errors for | isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args) = return () -- $(not_in_scope args)
...@@ -633,6 +638,7 @@ check_cross_stage_lifting top_lvl name ps_var ...@@ -633,6 +638,7 @@ check_cross_stage_lifting top_lvl name ps_var
-- Update the pending splices -- Update the pending splices
; ps <- readMutVar ps_var ; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) } ; writeMutVar ps_var (pend_splice : ps) }
#endif /* GHCI */
{- {-
Note [Keeping things alive for Template Haskell] Note [Keeping things alive for Template Haskell]
......
...@@ -16,7 +16,9 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, ...@@ -16,7 +16,9 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
#ifdef GHCI
import DsMeta( liftStringName, liftName ) import DsMeta( liftStringName, liftName )
#endif
import HsSyn import HsSyn
import TcHsSyn import TcHsSyn
...@@ -1232,6 +1234,13 @@ tcTagToEnum loc fun_name arg res_ty ...@@ -1232,6 +1234,13 @@ tcTagToEnum loc fun_name arg res_ty
-} -}
checkThLocalId :: Id -> TcM () 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 checkThLocalId id