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 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}
= 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
+ ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
- ; decl_ty <- tcMetaTy decTyConName
- ; q_ty <- tcMetaTy qTyConName
- ; return (mkAppTy q_ty (mkListTy decl_ty))
- -- 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
; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; expr2 <- runMetaE convertToHsExpr zonked_q_expr
-
- ; traceTc (text "Got result" <+> ppr expr2)
-
+ ; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- ; (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
+ ; addErrCtxt (spliceResultDoc expr) $ do
+ { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
+
+ ; exp4 <- tcMonoExpr exp3 res_ty
+ ; return (unLoc exp4) } }
- ; exp4 <- tcMonoExpr exp3 res_ty
- ; return (unLoc exp4) }
+spliceResultDoc :: LHsExpr Name -> SDoc
+spliceResultDoc expr
+ = sep [ ptext (sLit "In the result of the splice:")
+ , nest 2 (char '$' <> pprParendExpr expr)
+ , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
-------------------
tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
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)
; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
-- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
-
- ; traceTc (text "Got result" <+> ppr hs_ty2)
-
+ ; hs_ty2 <- runMetaT zonked_q_expr
; showSplice "type" expr (ppr hs_ty2)
-
+
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+ ; addErrCtxt (spliceResultDoc expr) $ do
+ { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
-
; (ty4, kind) <- kcLHsType hs_ty3
- ; return (unLoc ty4, kind) }
+ ; return (unLoc ty4, kind) }}
\end{code}
%************************************************************************
-- 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
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; decls <- runMetaD convertToHsDecls zonked_q_expr
-
- ; traceTc (text "Got result" <+> vcat (map ppr decls))
- ; showSplice "declarations"
- expr
+ ; decls <- runMetaD zonked_q_expr
+ ; showSplice "declarations" expr
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
+
; return decls }
\end{code}
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
- -> String -- Documentation string only
-> Name -- Name of th_syn type
- -> (SrcSpan -> th_syn -> Either Message hs_syn)
- -> TcM hs_syn
-runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
- = do { -- Check that the quoter is not locally defined, otherwise the TH
+ -> MetaOps th_syn hs_syn
+ -> 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 $
; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; result <- runMetaQ convert zonked_q_expr
- ; traceTc (text "Got result" <+> ppr result)
- ; showSplice desc quoteExpr (ppr result)
- ; return result
- }
+ ; result <- runMetaQ meta_ops zonked_q_expr
+ ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
-runQuasiQuoteExpr quasiquote
- = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
+ ; return result }
-runQuasiQuotePat quasiquote
- = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
+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
%************************************************************************
\begin{code}
-runMetaAW :: (AnnotationWrapper -> output)
+data MetaOps th_syn hs_syn
+ = MT { mt_desc :: String -- Type of beast (expression, type etc)
+ , mt_show :: th_syn -> String -- How to show the th_syn thing
+ , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn
+ -- How to convert to hs_syn
+ }
+
+exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
+exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr }
+
+patMetaOps :: MetaOps TH.Pat (LPat RdrName)
+patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat }
+
+typeMetaOps :: MetaOps TH.Type (LHsType RdrName)
+typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType }
+
+declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName]
+declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls }
+
+----------------
+runMetaAW :: Outputable output
+ => (AnnotationWrapper -> output)
-> LHsExpr Id -- Of type AnnotationWrapper
-> TcM output
runMetaAW k = runMeta False (\_ -> return . Right . k)
-- We turn off showing the code in meta-level exceptions because doing so exposes
-- the toAnnotationWrapper function that we slap around the users code
-runQThen :: (SrcSpan -> input -> Either Message output)
- -> SrcSpan
- -> TH.Q input
- -> TcM (Either Message output)
-runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
-
-runMetaQ :: (SrcSpan -> input -> Either Message output)
+-----------------
+runMetaQ :: Outputable hs_syn
+ => MetaOps th_syn hs_syn
-> LHsExpr Id
- -> TcM output
-runMetaQ = runMeta True . runQThen
+ -> TcM hs_syn
+runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
+ = runMeta True run_and_cvt expr
+ where
+ run_and_cvt expr_span hval
+ = do { th_result <- TH.runQ hval
+ ; traceTc (text "Got TH result:" <+> text (show_th th_result))
+ ; return (cvt expr_span th_result) }
-runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
- -> LHsExpr Id -- Of type (Q Exp)
+runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
-runMetaE = runMetaQ
+runMetaE = runMetaQ exprMetaOps
-runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
- -> LHsExpr Id -- Of type (Q Pat)
- -> TcM (Pat RdrName)
-runMetaP = runMetaQ
-
-runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
- -> LHsExpr Id -- Of type (Q Type)
+runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
-runMetaT = runMetaQ
+runMetaT = runMetaQ typeMetaOps
-runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
- -> LHsExpr Id -- Of type Q [Dec]
+runMetaD :: LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
-runMetaD = runMetaQ
-
-runMeta :: Bool -- Whether code should be printed in the exception message
- -> (SrcSpan -> input -> TcM (Either Message output))
- -> LHsExpr Id -- Of type X
- -> TcM output -- Of type t
+runMetaD = runMetaQ declMetaOps
+
+---------------
+runMeta :: (Outputable hs_syn)
+ => Bool -- Whether code should be printed in the exception message
+ -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x
+ -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
+ -> TcM hs_syn -- Of type t
runMeta show_code run_and_convert expr
- = do { -- Desugar
- ds_expr <- initDsTc (dsLExpr expr)
+ = do { traceTc (text "About to run" <+> ppr expr)
+
+ -- Desugar
+ ; ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
; case mb_result of
Left err -> failWithTc err
- Right result -> return $! result }
+ Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result)
+ ; return $! result } }
; case either_tval of
Right v -> return v
- Left se ->
- case fromException se of
- Just IOEnvFailure ->
- failM -- Error already in Tc monad
- _ -> failWithTc (mk_msg "run" se) -- Exception
+ Left se -> case fromException se of
+ Just IOEnvFailure -> failM -- Error already in Tc monad
+ _ -> failWithTc (mk_msg "run" se) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
; fix <- reifyFixity (idName id)
; let v = reifyName id
; case idDetails id of
- ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
- _ -> return (TH.VarI v ty Nothing fix)
+ ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
+ _ -> return (TH.VarI v ty Nothing fix)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
------------------------------
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 (reifyName 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"
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
projects / ghc-hetmet.git / blobdiff