X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=0ce334a5c67956e48349f4d108edcf2f4f7a3ba1;hp=3302b237378590cdc6dbc6e145081418bac3e006;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hpb=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 3302b23..0ce334a 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -6,7 +6,16 @@ TcSplice: Template Haskell splices \begin{code} -module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where +{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, + lookupThName_maybe, + runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where #include "HsVersions.h" @@ -33,13 +42,15 @@ import TcIface import TypeRep import Name import NameEnv +import PrelNames import HscTypes import OccName import Var import Module +import Annotations import TcRnMonad -import IfaceEnv import Class +import Inst import TyCon import DataCon import Id @@ -48,23 +59,107 @@ import TysWiredIn import DsMeta import DsExpr import DsMonad hiding (Splice) +import Serialized import ErrUtils import SrcLoc import Outputable import Unique -import PackageConfig +import Maybe import BasicTypes import Panic import FastString +import Exception import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH +#ifdef GHCI +-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler +import GHC.Desugar ( AnnotationWrapper(..) ) +#endif + import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) -import Control.Monad ( liftM ) +import System.IO.Error \end{code} +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Imported things are impLevel (= 0) + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at topLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +When a variable is used, we compare + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + +See Note [What is a top-level Id?] + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +See Note [What is a top-level Id?] in TcEnv. Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by + -- cross-stage lifting + + \y. [| \x. $(f 'y) |] -- Not ok (same reason) + + [| \x. $(f 'x) |] -- OK + + +Note [What is a top-level Id?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the level-control criteria above, we need to know what a "top level Id" is. +There are three kinds: + * Imported from another module (GlobalId, ExternalName) + * Bound at the top level of this module (ExternalName) + * In GHCi, bound by a previous stmt (GlobalId) +It's strange that there is no one criterion tht picks out all three, but that's +how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids +bound in an earlier Stmt, but what module would you choose? See +Note [Interactively-bound Ids in GHCi] in TcRnDriver.) + +The predicate we use is TcEnv.thTopLevelId. + %************************************************************************ %* * @@ -73,14 +168,29 @@ import Control.Monad ( liftM ) %************************************************************************ \begin{code} +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) -- 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) +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation + #ifndef GHCI -tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) +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) + +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) +runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) #else \end{code} @@ -90,50 +200,72 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %* * %************************************************************************ +Note [Handling brackets] +~~~~~~~~~~~~~~~~~~~~~~~~ +Source: f = [| Just $(g 3) |] + The [| |] part is a HsBracket + +Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression + The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression + +Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) -tcBracket brack res_ty - = getStage `thenM` \ level -> - case bracketOK level of { +tcBracket brack res_ty = do + level <- getStage + case bracketOK level of { Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> + Just next_level -> do -- Typecheck expr to make sure it is valid, -- but throw away the results. We'll type check -- it again when we actually use it. - recordThUse `thenM_` - newMutVar [] `thenM` \ pending_splices -> - getLIEVar `thenM` \ lie_var -> + recordThUse + pending_splices <- newMutVar [] + lie_var <- getLIEVar - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tc_bracket brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` + (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var) + (getLIE (tc_bracket next_level brack)) + tcSimplifyBracket lie -- Make the expected type have the right shape - boxyUnify meta_ty res_ty `thenM_` + boxyUnify meta_ty res_ty -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (noLoc (HsBracketOut brack pendings)) + pendings <- readMutVar pending_splices + return (noLoc (HsBracketOut brack pendings)) } -tc_bracket :: HsBracket Name -> TcM TcType -tc_bracket (VarBr v) - = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) +tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType +tc_bracket use_lvl (VarBr name) -- Note [Quoting names] + = do { thing <- tcLookup name + ; case thing of + AGlobal _ -> return () + ATcId { tct_level = bind_lvl, tct_id = id } + | thTopLevelId id -- C.f thTopLevelId case of + -> keepAliveTc id -- TcExpr.thBrackId + | otherwise + -> do { checkTc (use_lvl == bind_lvl) + (quotedNameStageErr name) } + _ -> pprPanic "th_bracket" (ppr name) + + ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) + } -tc_bracket (ExpBr expr) - = newFlexiTyVarTy liftedTypeKind `thenM` \ any_ty -> - tcMonoExpr expr any_ty `thenM_` - tcMetaTy expQTyConName +tc_bracket _ (ExpBr expr) + = do { any_ty <- newFlexiTyVarTy liftedTypeKind + ; tcMonoExpr expr any_ty + ; tcMetaTy expQTyConName } -- Result type is Expr (= Q Exp) -tc_bracket (TypBr typ) - = tcHsSigType ExprSigCtxt typ `thenM_` - tcMetaTy typeQTyConName +tc_bracket _ (TypBr typ) + = do { tcHsSigType ExprSigCtxt typ + ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) -tc_bracket (DecBr decls) +tc_bracket _ (DecBr decls) = do { tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -144,8 +276,13 @@ tc_bracket (DecBr decls) -- Result type is Q [Dec] } -tc_bracket (PatBr _) - = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")) +tc_bracket _ (PatBr _) + = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet")) + +quotedNameStageErr :: Name -> SDoc +quotedNameStageErr v + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v) + , ptext (sLit "must be used at the same stage at which is is bound")] \end{code} @@ -157,16 +294,16 @@ tc_bracket (PatBr _) \begin{code} tcSpliceExpr (HsSplice name expr) res_ty - = setSrcSpan (getLoc expr) $ - getStage `thenM` \ level -> + = setSrcSpan (getLoc expr) $ do + level <- getStage case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; Just next_level -> - case level of { - Comp -> do { e <- tcTopSplice expr res_ty - ; returnM (unLoc e) } ; - Brack _ ps_var lie_var -> + case level of { + Comp _ -> do { e <- tcTopSplice expr res_ty + ; return (unLoc e) } ; + Brack _ ps_var lie_var -> do -- A splice inside brackets -- NB: ignore res_ty, apart from zapping it to a mono-type @@ -174,19 +311,21 @@ tcSpliceExpr (HsSplice name expr) res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - unBox res_ty `thenM_` - tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> - setStage (Splice next_level) ( - setLIEVar lie_var $ - tcMonoExpr expr meta_exp_ty - ) `thenM` \ expr' -> + unBox res_ty + meta_exp_ty <- tcMetaTy expQTyConName + expr' <- setStage (Splice next_level) ( + setLIEVar lie_var $ + tcMonoExpr expr meta_exp_ty + ) -- Write the pending splice into the bucket - readMutVar ps_var `thenM` \ ps -> - writeMutVar ps_var ((name,expr') : ps) `thenM_` + ps <- readMutVar ps_var + writeMutVar ps_var ((name,expr') : ps) + + return (panic "tcSpliceExpr") -- The returned expression is ignored - returnM (panic "tcSpliceExpr") -- The returned expression is ignored - }} + ; Splice {} -> panic "tcSpliceExpr Splice" + }} -- tcTopSplice used to have this: -- Note that we do not decrement the level (to -1) before @@ -196,24 +335,24 @@ tcSpliceExpr (HsSplice name expr) res_ty -- inner escape before dealing with the outer one tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id) -tcTopSplice expr res_ty - = tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> +tcTopSplice expr res_ty = do + meta_exp_ty <- tcMetaTy expQTyConName - -- Typecheck the expression - tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr -> + -- Typecheck the expression + zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty - -- Run the expression - traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` - runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 -> - - traceTc (text "Got result" <+> ppr expr2) `thenM_` + -- Run the expression + traceTc (text "About to run" <+> ppr zonked_q_expr) + expr2 <- runMetaE convertToHsExpr zonked_q_expr + + traceTc (text "Got result" <+> ppr expr2) showSplice "expression" - zonked_q_expr (ppr expr2) `thenM_` + zonked_q_expr (ppr expr2) - -- Rename it, but bale out if there are errors - -- otherwise the type checker just gives more spurious errors - checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) -> + -- Rename it, but bale out if there are errors + -- otherwise the type checker just gives more spurious errors + (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) tcMonoExpr exp3 res_ty @@ -221,23 +360,149 @@ tcTopSplice expr res_ty tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id) -- Type check an expression that is the body of a top-level splice -- (the caller will compile and run it) -tcTopSpliceExpr expr meta_ty - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! +tcTopSpliceExpr expr meta_ty + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $ + (recordThUse >> tcMonoExpr expr meta_ty) + -- Zonk it and tie the knot of dictionary bindings + ; zonkTopLExpr (mkHsDictLet const_binds expr') } +\end{code} + + +%************************************************************************ +%* * + Annotations +%* * +%************************************************************************ - setStage topSpliceStage $ do +\begin{code} +runAnnotation target expr = do + expr_ty <- newFlexiTyVarTy liftedTypeKind + + -- Find the classes we want instances for in order to call toAnnotationWrapper + typeable_class <- tcLookupClass typeableClassName + data_class <- tcLookupClass dataClassName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do + expr' <- tcPolyExprNC expr expr_ty + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcSimplifyStagedExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + return (wrapper, expr') + + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + loc <- getSrcSpanM + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id)) + wrapped_expr' = mkHsDictLet const_binds $ + L loc (HsApp specialised_to_annotation_wrapper_expr expr') + + -- If we have type checking problems then potentially zonking + -- (and certainly compilation) may fail. Give up NOW! + failIfErrsM + + -- Zonk the type variables out of that raw expression. Note that + -- in particular we don't call recordThUse, since we don't + -- necessarily use any code or definitions from that package. + zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr' + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper -> + case annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` Annotation { + ann_target = target, + ann_value = serialized + } +\end{code} - - do { recordThUse -- Record that TH is used (for pkg depdendency) - -- Typecheck the expression - ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty) - - -- Solve the constraints - ; const_binds <- tcSimplifyTop lie - - -- And zonk it - ; zonkTopLExpr (mkHsDictLet const_binds expr') } +%************************************************************************ +%* * + Quasi-quoting +%* * +%************************************************************************ + +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GHC "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). + +Briefly, one writes + [: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 +a bit like a TH splice: + $(p "stuff") + +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. + +\begin{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) + -> 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 + -- 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 + ; 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 quoteExpr = L q_span $! HsLit $! HsString quote + ; let expr = L q_span $ + HsApp (L q_span $ + HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr + ; recordThUse + ; meta_exp_ty <- tcMetaTy meta_ty + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr 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 zonked_q_expr (ppr result) + ; return result + } + +runQuasiQuoteExpr quasiquote + = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr + +runQuasiQuotePat quasiquote + = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat + +quoteStageError :: Name -> SDoc +quoteStageError quoter + = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter, + nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))] \end{code} @@ -258,7 +523,7 @@ kcSpliceType (HsSplice name hs_expr) Just next_level -> do { case level of { - Comp -> do { (t,k) <- kcTopSpliceType hs_expr + Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr ; return (unLoc t, k) } ; Brack _ ps_var lie_var -> do @@ -276,8 +541,10 @@ kcSpliceType (HsSplice name hs_expr) -- Here (h 4) :: Q Type -- but $(h 4) :: forall a.a i.e. any kind ; kind <- newKindVar - ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored - }}}}} + ; return (panic "kcSpliceType", kind) -- The returned type is ignored + } + ; Splice {} -> panic "kcSpliceType Splice" + }}}} kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) kcTopSpliceType expr @@ -296,7 +563,7 @@ kcTopSpliceType expr -- 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 + ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) ; kcHsType hs_ty3 } @@ -326,13 +593,7 @@ tcSpliceDecls expr ; showSplice "declarations" zonked_q_expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) - ; returnM decls } - - where handleErrors :: [Either a Message] -> TcM [a] - handleErrors [] = return [] - handleErrors (Left x:xs) = liftM (x:) (handleErrors xs) - handleErrors (Right m:xs) = do addErrTc m - handleErrors xs + ; return decls } \end{code} @@ -343,38 +604,62 @@ tcSpliceDecls expr %************************************************************************ \begin{code} +runMetaAW :: (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) + -> LHsExpr Id + -> TcM output +runMetaQ = runMeta True . runQThen + runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) -> LHsExpr Id -- Of type (Q Exp) -> TcM (LHsExpr RdrName) -runMetaE = runMeta +runMetaE = runMetaQ + +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) -> TcM (LHsType RdrName) -runMetaT = runMeta +runMetaT = runMetaQ runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]) -> LHsExpr Id -- Of type Q [Dec] -> TcM [LHsDecl RdrName] -runMetaD = runMeta +runMetaD = runMetaQ -runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) +runMeta :: Bool -- Whether code should be printed in the exception message + -> (SrcSpan -> input -> TcM (Either Message output)) -> LHsExpr Id -- Of type X - -> TcM hs_syn -- Of type t -runMeta convert expr + -> TcM output -- Of type t +runMeta show_code run_and_convert expr = do { -- Desugar ds_expr <- initDsTc (dsLExpr expr) - -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM - ; either_hval <- tryM $ ioToTcRn $ + ; either_hval <- tryM $ liftIO $ HscMain.compileExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do { -- Coerce it to Q t, and run it + -- Running might fail if it throws an exception of any kind (hence tryAllM) -- including, say, a pattern-match exception in the code we are running -- @@ -382,23 +667,61 @@ runMeta convert expr -- exception-cacthing thing so that if there are any lurking -- exceptions in the data structure returned by hval, we'll -- encounter them inside the try - either_tval <- tryAllM $ do - { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert (getLoc expr) th_syn of - Left err -> do { addErrTc err; return Nothing } - Right hs_syn -> return (Just hs_syn) } + -- + -- See Note [Exceptions in TH] + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) + ; case mb_result of + Left err -> failWithTc err + Right result -> return $! result } ; case either_tval of - Right (Just v) -> return v - Right Nothing -> failM -- Error already in Tc monad - Left exn -> failWithTc (mk_msg "run" exn) -- Exception - }}} + Right v -> return v + 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:", nest 2 (text (Panic.showException exn)), - nest 2 (text "Code:" <+> ppr expr)] + if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] \end{code} +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Supppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see TcSplice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + + To call runQ in the Tc monad, we need to make TcM an instance of Quasi: \begin{code} @@ -410,10 +733,14 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qReport True msg = addErr (text msg) qReport False msg = addReport (text msg) - qCurrentModule = do { m <- getModule; - return (moduleNameString (moduleName m)) } - -- ToDo: is throwing away the package name ok here? - + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l) + , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } + qReify v = reify v -- For qRecover, discard error messages if @@ -426,7 +753,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where Nothing -> recover -- Discard all msgs } - qRunIO io = ioToTcRn io + qRunIO io = liftIO io \end{code} @@ -438,18 +765,20 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where \begin{code} showSplice :: String -> LHsExpr Id -> SDoc -> TcM () -showSplice what before after - = getSrcSpanM `thenM` \ loc -> +showSplice what before after = do + loc <- getSrcSpanM traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, nest 2 (sep [nest 2 (ppr before), text "======>", nest 2 after])]) +illegalBracket :: ThStage -> SDoc illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level + = ptext (sLit "Illegal bracket at level") <+> ppr level +illegalSplice :: ThStage -> SDoc illegalSplice level - = ptext SLIT("Illegal splice at level") <+> ppr level + = ptext (sLit "Illegal splice at level") <+> ppr level #endif /* GHCI */ \end{code} @@ -476,30 +805,32 @@ reify th_name ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" lookupThName :: TH.Name -> TcM Name -lookupThName th_name@(TH.Name occ flavour) - = do { let rdr_name = thRdrName guessed_ns occ_str flavour - - -- Repeat much of lookupOccRn, becase we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return name - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> lookupImportedName rdr_name - | otherwise -- Unqual, Qual - -> do { - mb_name <- lookupSrcOcc_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> failWithTc (notInScope th_name) } - } +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (listToMaybe names) } where - -- guessed_ns is the name space guessed from looking at the TH name - guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName - | otherwise = OccName.varName - occ_str = TH.occString occ + lookup rdr_name + = do { -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig + -> do { name <- lookupImportedName rdr_name + ; return (Just name) } + | otherwise -- Unqual, Qual + -> lookupSrcOcc_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that @@ -508,7 +839,7 @@ tcLookupTh :: Name -> TcM TcTyThing tcLookupTh name = do { (gbl_env, lcl_env) <- getEnvs ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> returnM thing; + Just thing -> return thing; Nothing -> do { if nameIsLocalOrFrom (tcg_mod gbl_env) name then -- It's defined in this module @@ -529,12 +860,12 @@ tcLookupTh name notInScope :: TH.Name -> SDoc notInScope th_name = quotes (text (TH.pprint th_name)) <+> - ptext SLIT("is not in scope at a reify") + ptext (sLit "is not in scope at a reify") -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> SDoc notInEnv name = quotes (ppr name) <+> - ptext SLIT("is not in the type environment at a reify") + ptext (sLit "is not in the type environment at a reify") ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info @@ -548,7 +879,7 @@ reifyThing (AGlobal (AnId id)) ; let v = reifyName id ; case globalIdDetails id of ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) - other -> return (TH.VarI v ty Nothing fix) + _ -> return (TH.VarI v ty Nothing fix) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -571,6 +902,8 @@ reifyThing (ATyVar tv ty) ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (AThing {}) = panic "reifyThing AThing" + ------------------------------ reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc @@ -584,18 +917,19 @@ reifyTyCon tc reifyTyCon tc = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; let tvs = tyConTyVars tc + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) ; let name = reifyName tc - tvs = reifyTyVars (tyConTyVars tc) + r_tvs = reifyTyVars tvs deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = TH.NewtypeD cxt name tvs (head cons) deriv - | otherwise = TH.DataD cxt name tvs cons deriv + decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv + | otherwise = TH.DataD cxt name r_tvs cons deriv ; return (TH.TyConI decl) } -reifyDataCon :: DataCon -> TcM TH.Con -reifyDataCon dc +reifyDataCon :: [Type] -> DataCon -> TcM TH.Con +reifyDataCon tys dc | isVanillaDataCon dc - = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) + = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys) ; let stricts = map reifyStrict (dataConStrictMarks dc) fields = dataConFieldLabels dc name = reifyName dc @@ -611,7 +945,7 @@ reifyDataCon dc else return (TH.NormalC name (stricts `zip` arg_tys)) } | otherwise - = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") + = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:") <+> quotes (ppr dc)) ------------------------------ @@ -630,7 +964,6 @@ reifyClass cls reifyType :: TypeRep.Type -> TcM TH.Type reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NoteTy _ ty) = reifyType ty 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; @@ -638,7 +971,11 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } where (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyType (PredTy {}) = panic "reifyType PredTy" + +reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType +reifyCxt :: [PredType] -> TcM [TH.Type] reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep @@ -653,7 +990,8 @@ reify_tc_app tc tys = do { tys' <- reifyTypes tys reifyPred :: TypeRep.PredType -> TcM TH.Type reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys -reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) +reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) +reifyPred (EqPred {}) = panic "reifyPred EqPred" ------------------------------ @@ -667,7 +1005,7 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = nameModule name + mod = ASSERT( isExternalName name ) nameModule name pkg_str = packageIdString (modulePackageId mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ @@ -695,7 +1033,7 @@ reifyStrict NotMarkedStrict = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+> - ptext SLIT("in Template Haskell:"), +noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> + ptext (sLit "in Template Haskell:"), nest 2 d]) \end{code}