module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
-todoSession, todoTcM,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import System.IO.Error
-
-
---here for every bad reason :-)
-import InstEnv
-import FamInstEnv
---Session
-todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
-todoSession hsc_env name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env (hsc_IC hsc_env) $
- todoTcM name
-
-
-todoTcM :: Name -> TcM (LHsDecl RdrName)
-todoTcM name = do
- tcTyThing <- TcEnv.tcLookup name
- thInfo <- TcSplice.reifyThing tcTyThing
- let Just thDec = thGetDecFromInfo thInfo --BUG!
- let Right [hsdecl] = Convert.convertToHsDecls
- (error "srcspan of different package?")
- [thDec]
- return hsdecl
-
-thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
-thGetDecFromInfo (TH.ClassI dec) = Just dec
-thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
-thGetDecFromInfo (TH.TyConI dec) = Just dec
-thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
-thGetDecFromInfo (TH.DataConI {}) = error "datacon"
-thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
-thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
-thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
-
-setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext hsc_env icxt thing_inside
- = let -- Initialise the tcg_inst_env with instances from all home modules.
- -- This mimics the more selective call to hptInstances in tcRnModule.
- (home_insts, home_fam_insts) = hptInstances hsc_env (\_mod -> True)
- in
- updGblEnv (\env -> env {
- tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
- tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
- home_fam_insts
- }) $
-
- tcExtendGhciEnv (ic_tmp_ids icxt) $
- -- tcExtendGhciEnv does lots:
- -- - it extends the local type env (tcl_env) with the given Ids,
- -- - it extends the local rdr env (tcl_rdr) with the Names from
- -- the given Ids
- -- - it adds the free tyvars of the Ids to the tcl_tyvars
- -- set.
- --
- -- later ids in ic_tmp_ids must shadow earlier ones with the same
- -- OccName, and tcExtendIdEnv implements this behaviour.
-
- do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
- ; thing_inside }
\end{code}
Note [How top-level splices are handled]
; 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)
; 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}
%************************************************************************
; 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}
runQuasiQuote :: Outputable hs_syn
=> HsQuasiQuote Name -- 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)
+ -> MetaOps th_syn hs_syn
-> TcM hs_syn
-runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
+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
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
; 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 quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps
+runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps
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:",
; return (TH.mkNameU s i) }
qReport True msg = addErr (text msg)
- qReport False msg = addReport (text msg)
+ qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
; l <- getSrcSpanM
; 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