Commit f16ddcee 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.
There are some minor BC changes to template-haskell to make it boot
on GHC 7.8.

Note for reviewer: big diff changes are simply code
being moved out of an ifdef; there was no other substantive
change to that code.
Signed-off-by: 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 ecc3d6be
...@@ -24,11 +24,7 @@ import Name ...@@ -24,11 +24,7 @@ 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
...@@ -645,11 +641,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ...@@ -645,11 +641,7 @@ 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,6 +52,7 @@ Library ...@@ -52,6 +52,7 @@ 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,
...@@ -65,7 +66,6 @@ Library ...@@ -65,7 +66,6 @@ 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,6 +164,7 @@ Library ...@@ -164,6 +164,7 @@ Library
IdInfo IdInfo
Lexeme Lexeme
Literal Literal
DsMeta
Llvm Llvm
Llvm.AbsSyn Llvm.AbsSyn
Llvm.MetaData Llvm.MetaData
...@@ -566,7 +567,6 @@ Library ...@@ -566,7 +567,6 @@ Library
if flag(ghci) if flag(ghci)
Exposed-Modules: Exposed-Modules:
DsMeta
Convert Convert
ByteCodeAsm ByteCodeAsm
ByteCodeGen ByteCodeGen
......
...@@ -3009,7 +3009,7 @@ fLangFlags = [ ...@@ -3009,7 +3009,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
>> checkTemplateHaskellOk on), >> setTemplateHaskellLoc on),
flagSpec' "fi" Opt_ForeignFunctionInterface flagSpec' "fi" Opt_ForeignFunctionInterface
(deprecatedForExtension "ForeignFunctionInterface"), (deprecatedForExtension "ForeignFunctionInterface"),
flagSpec' "ffi" Opt_ForeignFunctionInterface flagSpec' "ffi" Opt_ForeignFunctionInterface
...@@ -3179,7 +3179,7 @@ xFlags = [ ...@@ -3179,7 +3179,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
checkTemplateHaskellOk, setTemplateHaskellLoc,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
flagSpec "TransformListComp" Opt_TransformListComp, flagSpec "TransformListComp" Opt_TransformListComp,
flagSpec "TupleSections" Opt_TupleSections, flagSpec "TupleSections" Opt_TupleSections,
...@@ -3500,28 +3500,9 @@ setIncoherentInsts True = do ...@@ -3500,28 +3500,9 @@ setIncoherentInsts True = do
l <- getCurLoc l <- getCurLoc
upd (\d -> d { incoherentOnLoc = l }) upd (\d -> d { incoherentOnLoc = l })
checkTemplateHaskellOk :: TurnOnFlag -> DynP () setTemplateHaskellLoc :: TurnOnFlag -> DynP ()
#ifdef GHCI setTemplateHaskellLoc _
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,7 +94,6 @@ import Type ( Type ) ...@@ -94,7 +94,6 @@ 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
...@@ -102,6 +101,7 @@ import ConLike ...@@ -102,6 +101,7 @@ 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,9 +196,7 @@ knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, ...@@ -196,9 +196,7 @@ 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
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
This diff is collapsed.
...@@ -16,9 +16,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, ...@@ -16,9 +16,7 @@ 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
...@@ -1234,13 +1232,6 @@ tcTagToEnum loc fun_name arg res_ty ...@@ -1234,13 +1232,6 @@ 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
= do { mb_local_use <- getStageAndBindLevel (idName id) = do { mb_local_use <- getStageAndBindLevel (idName id)
; case mb_local_use of ; case mb_local_use of
...@@ -1303,7 +1294,6 @@ checkCrossStageLifting _ _ = return () ...@@ -1303,7 +1294,6 @@ checkCrossStageLifting _ _ = return ()
polySpliceErr :: Id -> SDoc polySpliceErr :: Id -> SDoc
polySpliceErr id polySpliceErr id
= ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
#endif /* GHCI */
{- {-
Note [Lifting strings] Note [Lifting strings]
......
...@@ -34,6 +34,14 @@ import Name ...@@ -34,6 +34,14 @@ import Name
import TcRnMonad import TcRnMonad
import TcType import TcType
import Outputable
import TcExpr
import SrcLoc
import FastString
import DsMeta
import TcUnify
import TcEnv
#ifdef GHCI #ifdef GHCI
import HscMain import HscMain
-- These imports are the reason that TcSplice -- These imports are the reason that TcSplice
...@@ -45,14 +53,11 @@ import Convert ...@@ -45,14 +53,11 @@ import Convert
import RnExpr import RnExpr
import RnEnv import RnEnv
import RnTypes import RnTypes
import TcExpr
import TcHsSyn import TcHsSyn
import TcSimplify import TcSimplify
import TcUnify
import Type import Type
import Kind import Kind
import NameSet import NameSet
import TcEnv
import TcMType import TcMType
import TcHsType import TcHsType
import TcIface import TcIface
...@@ -81,7 +86,6 @@ import DsExpr ...@@ -81,7 +86,6 @@ import DsExpr
import DsMonad import DsMonad
import Serialized import Serialized
import ErrUtils import ErrUtils
import SrcLoc
import Util import Util
import Data.List ( mapAccumL ) import Data.List ( mapAccumL )
import Unique import Unique
...@@ -92,10 +96,7 @@ import Maybes( MaybeErr(..) ) ...@@ -92,10 +96,7 @@ import Maybes( MaybeErr(..) )
import DynFlags import DynFlags
import Panic import Panic
import Lexeme import Lexeme
import FastString
import Outputable
import DsMeta
import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types -- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Syntax as TH
...@@ -129,10 +130,87 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) ...@@ -129,10 +130,87 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation 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 #ifndef GHCI
tcTypedBracket x _ = failTH x "Template Haskell bracket"
tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
tcSpliceExpr e _ = failTH e "Template Haskell splice" tcSpliceExpr e _ = failTH e "Template Haskell splice"
-- runQuasiQuoteExpr q = failTH q "quasiquote" -- runQuasiQuoteExpr q = failTH q "quasiquote"
...@@ -325,80 +403,8 @@ When a variable is used, we compare ...@@ -325,80 +403,8 @@ When a variable is used, we compare
g1 = $(map ...) is OK g1 = $(map ...) is OK
g2 = $(f ...) is not OK; because we havn't compiled f yet 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 ...@@ -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 :: HsSplice Name -> SDoc
spliceCtxtDoc splice spliceCtxtDoc splice
= hang (ptext (sLit "In the Template Haskell splice")) = hang (ptext (sLit "In the Template Haskell splice"))
......
...@@ -105,7 +105,12 @@ ...@@ -105,7 +105,12 @@
<itemizedlist> <itemizedlist>
<listitem> <listitem>
<para> <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> </para>
</listitem> </listitem>
</itemizedlist> </itemizedlist>
......
...@@ -9571,8 +9571,8 @@ Typed expression splices and quotations are supported.) ...@@ -9571,8 +9571,8 @@ Typed expression splices and quotations are supported.)
<listitem><para> <listitem><para>
If you are building GHC from source, you need at least a stage-2 bootstrap compiler to 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 run Template Haskell splices and quasi-quotes. A stage-1 compiler will only accept regular quotes of Haskell. Reason: TH splices and quasi-quotes
compiles and runs a program, and then looks at the result. So it's important that 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 the program it compiles produces results whose representations are identical to
those of the compiler itself. those of the compiler itself.
</para></listitem> </para></listitem>
......
...@@ -386,7 +386,7 @@ else ...@@ -386,7 +386,7 @@ else
# programs such as GHC and ghc-pkg, that we do not assume the stage0 # programs such as GHC and ghc-pkg, that we do not assume the stage0
# compiler already has installed (or up-to-date enough). # 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" ifeq "$(Windows_Host)" "NO"
ifneq "$(HostOS_CPP)" "ios" ifneq "$(HostOS_CPP)" "ios"
PACKAGES_STAGE0 += terminfo PACKAGES_STAGE0 += terminfo
......
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP, FlexibleInstances #-}
-- | Monadic front-end to Text.PrettyPrint -- | Monadic front-end to Text.PrettyPrint
...@@ -41,6 +41,9 @@ import qualified Text.PrettyPrint as HPJ ...@@ -41,6 +41,9 @@ import qualified Text.PrettyPrint as HPJ
import Control.Monad (liftM, liftM2, ap) import Control.Monad (liftM, liftM2, ap)
import Language.Haskell.TH.Lib.Map ( Map ) import Language.Haskell.TH.Lib.Map ( Map )
import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative( Applicative(..) )
#endif
infixl 6 <> infixl 6 <>
infixl 6 <+> infixl 6 <+>
......
{-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents, {-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents,
RoleAnnotations, DeriveGeneric, FlexibleInstances #-} RoleAnnotations, DeriveGeneric, FlexibleInstances #-}
#if MIN_VERSION_base(4,8,0)
#define HAS_NATURAL
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Language.Haskell.Syntax -- Module : Language.Haskell.Syntax
...@@ -29,16 +33,19 @@ import Data.Char ( isAlpha, isAlphaNum, isUpper ) ...@@ -29,16 +33,19 @@ import Data.Char ( isAlpha, isAlphaNum, isUpper )
import Data.Int import Data.Int
import Data.Word import Data.Word
import Data.Ratio import Data.Ratio
import Numeric.Natural
import GHC.Generics ( Generic ) import GHC.Generics ( Generic )
#ifdef HAS_NATURAL
import Numeric.Natural
#endif
----------------------------------------------------- -----------------------------------------------------
-- --
-- The Quasi class -- The Quasi class
-- --
----------------------------------------------------- -----------------------------------------------------
class Monad m => Quasi m where class (Applicative m, Monad m) => Quasi m where
qNewName :: String -> m Name qNewName :: String -> m Name
-- ^ Fresh names -- ^ Fresh names
...@@ -487,8 +494,10 @@ instance Lift Word32 where ...@@ -487,8 +494,10 @@ instance Lift Word32 where
instance Lift Word64 where instance Lift Word64 where
lift x = return (LitE (IntegerL (fromIntegral x))) lift x = return (LitE (IntegerL (fromIntegral x)))
#ifdef HAS_NATURAL
instance Lift Natural where instance Lift Natural where
lift x = return (LitE (IntegerL (fromIntegral x))) lift x = return (LitE (IntegerL (fromIntegral x)))
#endif
instance Integral a => Lift (Ratio a) where instance Integral a => Lift (Ratio a) where
lift x = return (LitE (RationalL (toRational x))) lift x = return (LitE (RationalL (toRational x)))
......
...@@ -48,9 +48,14 @@ Library ...@@ -48,9 +48,14 @@ Library
Language.Haskell.TH.Lib.Map Language.Haskell.TH.Lib.Map
build-depends: build-depends:
base == 4.8.*, base >= 4.7 && < 4.9,
pretty == 1.1.* pretty == 1.1.*
-- We need to set the package key to template-haskell (without a -- We need to set the package key to template-haskell (without a
-- version number) as it's magic. -- version number) as it's magic.
ghc-options: -Wall -this-package-key template-haskell ghc-options: -Wall
if impl( ghc >= 7.9 )
ghc-options: -this-package-key template-haskell
else
ghc-options: -package-name template-haskell
...@@ -102,6 +102,7 @@ libraries/ghc-prim_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe ...@@ -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 libraries/Win32_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe
# Temporarely disable inline rule shadowing warning # 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 libraries/template-haskell_dist-install_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing
# We need -fno-warn-deprecated-flags to avoid failure with -Werror # We need -fno-warn-deprecated-flags to avoid failure with -Werror
......
T3572
T8633
TH_ppr1
TH_spliceViewPat/TH_spliceViewPat
TOP=../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-}
module A where
x = \(y :: forall a. a -> a) -> [|| y ||]
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 ||]
</