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
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
......
......@@ -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
......
......@@ -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
{- **********************************************************************
%* *
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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]
......
......@@ -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]
......
......@@ -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)