From: simonpj@microsoft.com Date: Tue, 20 Oct 2009 07:44:35 +0000 (+0000) Subject: Tidy up TcSplice, especially runMeta and friends X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=da6b7fce09f98a0fbe66b6d218e6473c1845e354;p=ghc-hetmet.git Tidy up TcSplice, especially runMeta and friends I wanted to see the TH syntax produced by a splice, before its conversion back into HsSyn. Doing so involved some refactoring. This only affects deubbging code (-ddump-tc-trace). --- diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.lhs index 335ce31..d1b566b 100644 --- a/compiler/main/Annotations.lhs +++ b/compiler/main/Annotations.lhs @@ -62,6 +62,8 @@ instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) -- | A collection of annotations newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index f5c3ab8..10b9fb9 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -433,11 +433,7 @@ tcTopSplice expr res_ty ; 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 @@ -521,13 +517,9 @@ kcTopSpliceType expr ; 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 @@ -555,13 +547,10 @@ tcSpliceDecls expr ; 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} @@ -640,11 +629,10 @@ the splice is run by the *renamer* rather than the type checker. 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 @@ -667,18 +655,13 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ ; 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 @@ -694,51 +677,70 @@ 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 - -runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) - -> LHsExpr Id -- Of type (Q Pat) - -> TcM (Pat RdrName) -runMetaP = runMetaQ +runMetaE = runMetaQ exprMetaOps -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 @@ -766,15 +768,14 @@ runMeta show_code run_and_convert expr 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:",