Commit 28257cae authored by Edward Z. Yang's avatar Edward Z. Yang

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

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

In order to make sure the referenced data structures
are consistent, template-haskell is now a boot library.

In the following patches, there are:

    - A few extra safety checks which should be enabled
      in stage1
    - Separation of the th/ testsuite into quotes/ which
      can be run on stage1

Note for reviewer: big diff changes are simply code
being moved out of an ifdef; there was no other substantive
change to that code.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, goldfire

Subscribers: bgamari, thomie

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

GHC Trac Issues: #10382
parent 2601a436
......@@ -24,11 +24,7 @@ import Name
import NameEnv
import FamInstEnv( topNormaliseType )
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
import DsMeta
#endif
import HsSyn
import Platform
......@@ -645,11 +641,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- Template Haskell stuff
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI
dsExpr (HsTcBracketOut x ps) = dsBracket x ps
#else
dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
#endif
dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
......
......@@ -52,6 +52,7 @@ Library
containers >= 0.5 && < 0.6,
array >= 0.1 && < 0.6,
filepath >= 1 && < 1.5,
template-haskell,
hpc,
transformers,
bin-package-db,
......@@ -65,7 +66,6 @@ Library
GHC-Options: -Wall -fno-warn-name-shadowing
if flag(ghci)
Build-Depends: template-haskell
CPP-Options: -DGHCI
Include-Dirs: ../rts/dist/build @FFIIncludeDir@
......@@ -164,6 +164,7 @@ Library
IdInfo
Lexeme
Literal
DsMeta
Llvm
Llvm.AbsSyn
Llvm.MetaData
......@@ -566,7 +567,6 @@ Library
if flag(ghci)
Exposed-Modules:
DsMeta
Convert
ByteCodeAsm
ByteCodeGen
......
......@@ -3008,7 +3008,7 @@ fLangFlags = [
-- See Note [Supporting CLI completion]
flagSpec' "th" Opt_TemplateHaskell
(\on -> deprecatedForExtension "TemplateHaskell" on
>> checkTemplateHaskellOk on),
>> setTemplateHaskellLoc on),
flagSpec' "fi" Opt_ForeignFunctionInterface
(deprecatedForExtension "ForeignFunctionInterface"),
flagSpec' "ffi" Opt_ForeignFunctionInterface
......@@ -3178,7 +3178,7 @@ xFlags = [
flagSpec "StandaloneDeriving" Opt_StandaloneDeriving,
flagSpec "StaticPointers" Opt_StaticPointers,
flagSpec' "TemplateHaskell" Opt_TemplateHaskell
checkTemplateHaskellOk,
setTemplateHaskellLoc,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
flagSpec "TransformListComp" Opt_TransformListComp,
flagSpec "TupleSections" Opt_TupleSections,
......@@ -3499,28 +3499,9 @@ setIncoherentInsts True = do
l <- getCurLoc
upd (\d -> d { incoherentOnLoc = l })
checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
#ifdef GHCI
checkTemplateHaskellOk turn_on
| turn_on && rtsIsProfiled
= addErr "You can't use Template Haskell with a profiled compiler"
| otherwise
setTemplateHaskellLoc :: TurnOnFlag -> DynP ()
setTemplateHaskellLoc _
= getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })
#else
-- In stage 1, Template Haskell is simply illegal, except with -M
-- We don't bleat with -M because there's no problem with TH there,
-- and in fact GHC's build system does ghc -M of the DPH libraries
-- with a stage1 compiler
checkTemplateHaskellOk turn_on
| turn_on = do dfs <- liftEwM getCmdLineState
case ghcMode dfs of
MkDepend -> return ()
_ -> addErr msg
| otherwise = return ()
where
msg = "Template Haskell requires GHC with interpreter support\n " ++
"Perhaps you are using a stage-1 compiler?"
#endif
{- **********************************************************************
%* *
......
......@@ -94,7 +94,6 @@ import Type ( Type )
import PrelNames
import {- Kind parts of -} Type ( Kind )
import CoreLint ( lintInteractiveExpr )
import DsMeta ( templateHaskellNames )
import VarEnv ( emptyTidyEnv )
import Panic
import ConLike
......@@ -102,6 +101,7 @@ import ConLike
import GHC.Exts
#endif
import DsMeta ( templateHaskellNames )
import Module
import Packages
import RdrName
......@@ -196,9 +196,7 @@ knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
knownKeyNames = -- where templateHaskellNames are defined
map getName wiredInThings
++ basicKnownKeyNames
#ifdef GHCI
++ templateHaskellNames
#endif
-- -----------------------------------------------------------------------------
......
This diff is collapsed.
......@@ -34,6 +34,14 @@ import Name
import TcRnMonad
import TcType
import Outputable
import TcExpr
import SrcLoc
import FastString
import DsMeta
import TcUnify
import TcEnv
#ifdef GHCI
import HscMain
-- These imports are the reason that TcSplice
......@@ -45,14 +53,11 @@ import Convert
import RnExpr
import RnEnv
import RnTypes
import TcExpr
import TcHsSyn
import TcSimplify
import TcUnify
import Type
import Kind
import NameSet
import TcEnv
import TcMType
import TcHsType
import TcIface
......@@ -81,7 +86,6 @@ import DsExpr
import DsMonad
import Serialized
import ErrUtils
import SrcLoc
import Util
import Data.List ( mapAccumL )
import Unique
......@@ -92,10 +96,7 @@ import Maybes( MaybeErr(..) )
import DynFlags
import Panic
import Lexeme
import FastString
import Outputable
import DsMeta
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
......@@ -129,10 +130,87 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
{-
************************************************************************
* *
\subsection{Quoting an expression}
* *
************************************************************************
-}
-- See Note [How brackets and nested splices are handled]
-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
tcTypedBracket brack@(TExpBr expr) res_ty
= addErrCtxt (quotationCtxtDoc brack) $
do { cur_stage <- getStage
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
-- should get thrown into the constraint set
-- from outside the bracket
-- Typecheck expr to make sure it is valid,
-- Throw away the typechecked expression but return its type.
-- We'll typecheck it again when we splice it in somewhere
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; meta_ty <- tcTExpTy expr_ty
; co <- unifyType meta_ty res_ty
; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName
; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
(noLoc (HsTcBracketOut brack ps'))))) }
tcTypedBracket other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
tcUntypedBracket brack ps res_ty
= do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
; ps' <- mapM tcPendingSplice ps
; meta_ty <- tcBrackTy brack
; co <- unifyType meta_ty res_ty
; traceTc "tc_bracket done untyped" (ppr meta_ty)
; return (mkHsWrapCo co (HsTcBracketOut brack ps')) }
---------------
tcBrackTy :: HsBracket Name -> TcM TcType
tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
---------------
tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
tcPendingSplice (PendingRnSplice flavour splice_name expr)
= do { res_ty <- tcMetaTy meta_ty_name
; expr' <- tcMonoExpr expr res_ty
; return (PendingTcSplice splice_name expr') }
where
meta_ty_name = case flavour of
UntypedExpSplice -> expQTyConName
UntypedPatSplice -> patQTyConName
UntypedTypeSplice -> typeQTyConName
UntypedDeclSplice -> decsQTyConName
---------------
-- Takes a type tau and returns the type Q (TExp tau)
tcTExpTy :: TcType -> TcM TcType
tcTExpTy tau
= do { q <- tcLookupTyCon qTyConName
; texp <- tcLookupTyCon tExpTyConName
; return (mkTyConApp q [mkTyConApp texp [tau]]) }
quotationCtxtDoc :: HsBracket Name -> SDoc
quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr br_body)
#ifndef GHCI
tcTypedBracket x _ = failTH x "Template Haskell bracket"
tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
tcSpliceExpr e _ = failTH e "Template Haskell splice"
-- runQuasiQuoteExpr q = failTH q "quasiquote"
......@@ -325,80 +403,8 @@ When a variable is used, we compare
g1 = $(map ...) is OK
g2 = $(f ...) is not OK; because we havn't compiled f yet
************************************************************************
* *
\subsection{Quoting an expression}
* *
************************************************************************
-}
-- See Note [How brackets and nested splices are handled]
-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
tcTypedBracket brack@(TExpBr expr) res_ty
= addErrCtxt (quotationCtxtDoc brack) $
do { cur_stage <- getStage
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
-- should get thrown into the constraint set
-- from outside the bracket
-- Typecheck expr to make sure it is valid,
-- Throw away the typechecked expression but return its type.
-- We'll typecheck it again when we splice it in somewhere
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; meta_ty <- tcTExpTy expr_ty
; co <- unifyType meta_ty res_ty
; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName
; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
(noLoc (HsTcBracketOut brack ps'))))) }
tcTypedBracket other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
tcUntypedBracket brack ps res_ty
= do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
; ps' <- mapM tcPendingSplice ps
; meta_ty <- tcBrackTy brack
; co <- unifyType meta_ty res_ty
; traceTc "tc_bracket done untyped" (ppr meta_ty)
; return (mkHsWrapCo co (HsTcBracketOut brack ps')) }
---------------
tcBrackTy :: HsBracket Name -> TcM TcType
tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
---------------
tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
tcPendingSplice (PendingRnSplice flavour splice_name expr)
= do { res_ty <- tcMetaTy meta_ty_name
; expr' <- tcMonoExpr expr res_ty
; return (PendingTcSplice splice_name expr') }
where
meta_ty_name = case flavour of
UntypedExpSplice -> expQTyConName
UntypedPatSplice -> patQTyConName
UntypedTypeSplice -> typeQTyConName
UntypedDeclSplice -> decsQTyConName
---------------
-- Takes a type tau and returns the type Q (TExp tau)
tcTExpTy :: TcType -> TcM TcType
tcTExpTy tau
= do { q <- tcLookupTyCon qTyConName
; texp <- tcLookupTyCon tExpTyConName
; return (mkTyConApp q [mkTyConApp texp [tau]]) }
{-
************************************************************************
* *
......@@ -469,11 +475,6 @@ tcTopSplice expr res_ty
************************************************************************
-}
quotationCtxtDoc :: HsBracket Name -> SDoc
quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr br_body)
spliceCtxtDoc :: HsSplice Name -> SDoc
spliceCtxtDoc splice
= hang (ptext (sLit "In the Template Haskell splice"))
......
......@@ -105,7 +105,12 @@
<itemizedlist>
<listitem>
<para>
TODO FIXME.
The <literal>TemplateHaskell</literal> now no longer automatically
errors when used with a stage 1 compiler (i.e. GHC without
interpreter support); in particular, plain
Haskell quotes (not quasi-quotes) can now be compiled without erroring.
Splices and quasi-quotes continue to only be supported by a
stage 2 compiler.
</para>
</listitem>
</itemizedlist>
......
......@@ -9571,8 +9571,8 @@ Typed expression splices and quotations are supported.)
<listitem><para>
If you are building GHC from source, you need at least a stage-2 bootstrap compiler to
run Template Haskell. A stage-1 compiler will reject the TH constructs. Reason: TH
compiles and runs a program, and then looks at the result. So it's important that
run Template Haskell splices and quasi-quotes. A stage-1 compiler will only accept regular quotes of Haskell. Reason: TH splices and quasi-quotes
compile and run a program, and then looks at the result. So it's important that
the program it compiles produces results whose representations are identical to
those of the compiler itself.
</para></listitem>
......
......@@ -386,7 +386,7 @@ else
# programs such as GHC and ghc-pkg, that we do not assume the stage0
# compiler already has installed (or up-to-date enough).
PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers
PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers template-haskell
ifeq "$(Windows_Host)" "NO"
ifneq "$(HostOS_CPP)" "ios"
PACKAGES_STAGE0 += terminfo
......
......@@ -102,6 +102,7 @@ libraries/ghc-prim_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe
libraries/Win32_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe
# Temporarely disable inline rule shadowing warning
libraries/template-haskell_dist-boot_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing
libraries/template-haskell_dist-install_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing
# We need -fno-warn-deprecated-flags to avoid failure with -Werror
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment