X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=11e45e401b2ceb0a321b144c57741814178361f3;hb=c8a60d43ddd698d673d80711d8e24b87c02cf856;hp=4e2ae695d90888804298f01c41ac285a0529a809;hpb=948af9452927becb494ac967fba813956b74a182;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 4e2ae69..11e45e4 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -6,6 +6,13 @@ TcSplice: Template Haskell splices \begin{code} +{-# OPTIONS -w #-} +-- 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 ) where #include "HsVersions.h" @@ -54,6 +61,7 @@ import Outputable import Unique import DynFlags import PackageConfig +import Maybe import BasicTypes import Panic import FastString @@ -64,8 +72,56 @@ import qualified Language.Haskell.TH.Syntax as TH import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) import Control.Monad ( liftM ) +import qualified Control.Exception as Exception( userErrors ) \end{code} +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Imported things are impLevel (= 0) +* 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 |] + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name is a bit like a quoted expression, except that we have no +cross-stage lifting (c.f. TcExpr.thBrackId). + +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 + + %************************************************************************ %* * @@ -132,18 +188,31 @@ tcBracket brack res_ty } tc_bracket :: HsBracket Name -> TcM TcType -tc_bracket (VarBr v) - = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) +tc_bracket (VarBr name) -- Note [Quoting names] + = do { thing <- tcLookup name + ; case thing of + AGlobal _ -> return () + ATcId { tct_level = bind_lvl } + | isExternalName name -- C.f isExternalName case of + -> keepAliveTc name -- TcExpr.thBrackId + | otherwise + -> do { use_stage <- getStage + ; checkTc (thLevel use_stage == bind_lvl) + (quotedNameStageErr name) } + other -> 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 + = 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 + = do { tcHsSigType ExprSigCtxt typ + ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) @@ -159,6 +228,10 @@ tc_bracket (DecBr decls) tc_bracket (PatBr _) = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")) + +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} @@ -376,11 +449,7 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> TcM hs_syn -- Of type t runMeta convert expr = do { -- Desugar -#if defined(GHCI) && defined(DEBUGGER) - ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr) -#else ds_expr <- initDsTc (dsLExpr expr) -#endif -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM @@ -391,6 +460,7 @@ runMeta convert expr 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 -- @@ -398,23 +468,58 @@ 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 + -- + -- See Note [Exceptions in TH] 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) } + Left err -> failWithTc err + Right hs_syn -> return hs_syn } ; 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 exn | Just s <- Exception.userErrors exn + , s == "IOEnv failure" + -> failM -- Error already in Tc monad + | otherwise -> failWithTc (mk_msg "run" exn) -- 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)] \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 a UserError, with the uninteresting string + "IOEnv failure" + + * So, when running a splice, we catch all exceptions; then for + - a UserError "IOEnv failure", 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} @@ -505,8 +610,7 @@ lookupThName th_name@(TH.Name occ flavour) Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig -> lookupImportedName rdr_name | otherwise -- Unqual, Qual - -> do { - mb_name <- lookupSrcOcc_maybe rdr_name + -> do { mb_name <- lookupSrcOcc_maybe rdr_name ; case mb_name of Just name -> return name Nothing -> failWithTc (notInScope th_name) }