module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
- runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
+ runQuasiQuoteExpr, runQuasiQuotePat,
+ runQuasiQuoteDecl, runQuasiQuoteType,
+ runAnnotation ) where
#include "HsVersions.h"
import RnEnv
import RdrName
import RnTypes
+import TcPat
import TcExpr
import TcHsSyn
import TcSimplify
import TypeRep
import Name
import NameEnv
+import NameSet
import PrelNames
import HscTypes
import OccName
import ErrUtils
import SrcLoc
import Outputable
+import Util ( dropList )
+import Data.List ( mapAccumL )
import Unique
import Data.Maybe
import BasicTypes
import Panic
import FastString
import Exception
+import Control.Monad ( when )
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
-kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
+kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
-- None of these functions add constraints to the LIE
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
-runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
+runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
+runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
+runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
+runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
+
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
-kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
+kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
+runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q)
+runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q)
runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
#else
\end{code}
-- it again when we actually use it.
; pending_splices <- newMutVar []
; lie_var <- getLIEVar
+ ; let brack_stage = Brack cur_stage pending_splices lie_var
+
+ ; (meta_ty, lie) <- setStage brack_stage $
+ getLIE $
+ tc_bracket cur_stage brack
- ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
- (getLIE (tc_bracket cur_stage brack))
; tcSimplifyBracket lie
-- Make the expected type have the right shape
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
- -- Result type is Expr (= Q Exp)
+ -- Result type is ExpQ (= Q Exp)
tc_bracket _ (TypBr typ)
= do { _ <- tcHsSigTypeNC ThBrackCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
-tc_bracket _ (DecBr decls)
+tc_bracket _ (DecBrG decls)
= do { _ <- tcTopSrcDecls emptyModDetails decls
- -- Typecheck the declarations, dicarding the result
- -- We'll get all that stuff later, when we splice it in
+ -- Typecheck the declarations, dicarding the result
+ -- We'll get all that stuff later, when we splice it in
- ; decl_ty <- tcMetaTy decTyConName
- ; q_ty <- tcMetaTy qTyConName
- ; return (mkAppTy q_ty (mkListTy decl_ty))
- -- Result type is Q [Dec]
- }
+ -- Top-level declarations in the bracket get unqualified names
+ -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
+
+ ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
+
+tc_bracket _ (PatBr pat)
+ = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+ ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ ->
+ return ()
+ ; tcMetaTy patQTyConName }
+ -- Result type is PatQ (= Q Pat)
-tc_bracket _ (PatBr _)
- = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
+tc_bracket _ (DecBrL _)
+ = panic "tc_bracket: Unexpected DecBrL"
quotedNameStageErr :: Name -> SDoc
quotedNameStageErr v
Very like splicing an expression, but we don't yet share code.
\begin{code}
-kcSpliceType (HsSplice name hs_expr)
+kcSpliceType splice@(HsSplice name hs_expr) fvs
= setSrcSpan (getLoc hs_expr) $ do
{ stage <- getStage
; case stage of {
-- Here (h 4) :: Q Type
-- but $(h 4) :: a i.e. any type, of any kind
- -- We return a HsSpliceTyOut, which serves to convey the kind to
- -- the ensuing TcHsType.dsHsType, which makes up a non-committal
- -- type variable of a suitable kind
; kind <- newKindVar
- ; return (HsSpliceTyOut kind, kind)
+ ; return (HsSpliceTy splice fvs kind, kind)
}}}
kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
-- Type sig at top of file:
-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceDecls expr
- = do { meta_dec_ty <- tcMetaTy decTyConName
- ; meta_q_ty <- tcMetaTy qTyConName
- ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
+ = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
-- Run the expression
Workshop 2007).
Briefly, one writes
- [:p| stuff |]
+ [p| stuff |]
and the arbitrary string "stuff" gets parsed by the parser 'p', whose
type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
defined in another module, because we are going to run it here. It's
However, you can do this in patterns as well as terms. Becuase of this,
the splice is run by the *renamer* rather than the type checker.
+%************************************************************************
+%* *
+\subsubsection{Quasiquotation}
+%* *
+%************************************************************************
+
+See Note [Quasi-quote overview] in TcSplice.
+
\begin{code}
runQuasiQuote :: Outputable hs_syn
- => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
+ => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
-> Name -- Of type QuasiQuoter -> String -> Q th_syn
-> Name -- Name of th_syn type
-> MetaOps th_syn hs_syn
- -> TcM hs_syn
-runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector meta_ty meta_ops
- = do { -- Check that the quoter is not locally defined, otherwise the TH
+ -> RnM hs_syn
+runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
+ = do { quoter' <- lookupOccRn quoter
+ -- We use lookupOcc rather than lookupGlobalOcc because in the
+ -- erroneous case of \x -> [x| ...|] we get a better error message
+ -- (stage restriction rather than out of scope).
+
+ ; when (isUnboundName quoter') failM
+ -- If 'quoter' is not in scope, proceed no further
+ -- The error message was generated by lookupOccRn, but it then
+ -- succeeds with an "unbound name", which makes the subsequent
+ -- attempt to run the quote fail in a confusing way
+
+ -- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
- ; this_mod <- getModule
- ; let is_local = case nameModule_maybe quoter of
- Just mod | mod == this_mod -> True
- | otherwise -> False
- Nothing -> True
+ ; this_mod <- getModule
+ ; let is_local = nameIsLocalOrFrom this_mod quoter'
+ ; checkTc (not is_local) (quoteStageError quoter')
+
; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
- ; checkTc (not is_local) (quoteStageError quoter)
-- Build the expression
- ; let quoterExpr = L q_span $! HsVar $! quoter
+ ; let quoterExpr = L q_span $! HsVar $! quoter'
; let quoteExpr = L q_span $! HsLit $! HsString quote
; let expr = L q_span $
HsApp (L q_span $
; return result }
-runQuasiQuoteExpr quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps
-runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps
+runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName expQTyConName exprMetaOps
+runQuasiQuotePat qq = runQuasiQuote qq quotePatName patQTyConName patMetaOps
+runQuasiQuoteType qq = runQuasiQuote qq quoteTypeName typeQTyConName typeMetaOps
+runQuasiQuoteDecl qq = runQuasiQuote qq quoteDecName decsQTyConName declMetaOps
quoteStageError :: Name -> SDoc
quoteStageError quoter
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
+-- For GADTs etc, see Note [Reifying data constructors]
reifyDataCon tys dc
- | isVanillaDataCon dc
- = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
- ; let stricts = map reifyStrict (dataConStrictMarks dc)
- fields = dataConFieldLabels dc
- name = reifyName dc
- [a1,a2] = arg_tys
- [s1,s2] = stricts
- ; ASSERT( length arg_tys == length stricts )
- if not (null fields) then
- return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
- else
- if dataConIsInfix dc then
- ASSERT( length arg_tys == 2 )
- return (TH.InfixC (s1,a1) name (s2,a2))
- else
- return (TH.NormalC name (stricts `zip` arg_tys)) }
- | otherwise
- = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
- <+> quotes (ppr dc))
+ = do { let (tvs, theta, arg_tys, _) = dataConSig dc
+ subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs
+ (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
+ theta' = substTheta subst' theta
+ arg_tys' = substTys subst' arg_tys
+ stricts = map reifyStrict (dataConStrictMarks dc)
+ fields = dataConFieldLabels dc
+ name = reifyName dc
+
+ ; r_arg_tys <- reifyTypes arg_tys'
+
+ ; let main_con | not (null fields)
+ = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
+ | dataConIsInfix dc
+ = ASSERT( length arg_tys == 2 )
+ TH.InfixC (s1,r_a1) name (s2,r_a2)
+ | otherwise
+ = TH.NormalC name (stricts `zip` r_arg_tys)
+ [r_a1, r_a2] = r_arg_tys
+ [s1, s2] = stricts
+
+ ; ASSERT( length arg_tys == length stricts )
+ if null ex_tvs' && null theta then
+ return main_con
+ else do
+ { cxt <- reifyCxt theta'
+ ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
------------------------------
reifyClass :: Class -> TcM TH.Info
------------------------------
reifyType :: TypeRep.Type -> TcM TH.Type
+reifyType ty@(ForAllTy _ _) = reify_for_all ty
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
-reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
+reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
-reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
- ; tau' <- reifyType tau
- ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
- where
- (tvs, cxt, tau) = tcSplitSigmaTy ty
-reifyType (PredTy {}) = panic "reifyType PredTy"
+reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty)
+reify_for_all :: TypeRep.Type -> TcM TH.Type
+reify_for_all ty
+ = do { cxt' <- reifyCxt cxt;
+ ; tau' <- reifyType tau
+ ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
+ where
+ (tvs, cxt, tau) = tcSplitSigmaTy ty
+
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
kis_rep = map reifyKind kis
ki'_rep = reifyNonArrowKind ki'
in
- foldl TH.ArrowK ki'_rep kis_rep
+ foldr TH.ArrowK ki'_rep kis_rep
where
reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
| otherwise = pprPanic "Exotic form of kind"
kind = tyVarKind tv
name = reifyName tv
-reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
-reify_tc_app tc tys = do { tys' <- reifyTypes tys
- ; return (foldl TH.AppT (TH.ConT tc) tys') }
+reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
+reify_tc_app tc tys
+ = do { tys' <- reifyTypes tys
+ ; return (foldl TH.AppT r_tc tys') }
+ where
+ n_tys = length tys
+ r_tc | isTupleTyCon tc = TH.TupleT n_tys
+ | tc `hasKey` listTyConKey = TH.ListT
+ | otherwise = TH.ConT (reifyName tc)
reifyPred :: TypeRep.PredType -> TcM TH.Pred
reifyPred (ClassP cls tys)
= do { tys' <- reifyTypes tys
- ; return $ TH.ClassP (reifyName cls) tys'
- }
+ ; return $ TH.ClassP (reifyName cls) tys' }
+
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
reifyPred (EqPred ty1 ty2)
= do { ty1' <- reifyType ty1
conv_dir BasicTypes.InfixL = TH.InfixL
conv_dir BasicTypes.InfixN = TH.InfixN
-reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
-reifyStrict MarkedStrict = TH.IsStrict
-reifyStrict MarkedUnboxed = TH.IsStrict
-reifyStrict NotMarkedStrict = TH.NotStrict
+reifyStrict :: BasicTypes.HsBang -> TH.Strict
+reifyStrict bang | isBanged bang = TH.IsStrict
+ | otherwise = TH.NotStrict
------------------------------
noTH :: LitString -> SDoc -> TcM a
ptext (sLit "in Template Haskell:"),
nest 2 d])
\end{code}
+
+Note [Reifying data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Template Haskell syntax is rich enough to express even GADTs,
+provided we do so in the equality-predicate form. So a GADT
+like
+
+ data T a where
+ MkT1 :: a -> T [a]
+ MkT2 :: T Int
+
+will appear in TH syntax like this
+
+ data T a = forall b. (a ~ [b]) => MkT1 b
+ | (a ~ Int) => MkT2
+