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"
import Unique
import DynFlags
import PackageConfig
+import Maybe
import BasicTypes
import Panic
import FastString
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)
+
+* 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.
+
%************************************************************************
%* *
%* *
%************************************************************************
+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
getLIEVar `thenM` \ lie_var ->
setStage (Brack next_level pending_splices lie_var) (
- getLIE (tc_bracket brack)
+ getLIE (tc_bracket next_level brack)
) `thenM` \ (meta_ty, lie) ->
tcSimplifyBracket lie `thenM_`
returnM (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) }
+ 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
+tc_bracket use_lvl (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 use_lvl (TypBr typ)
+ = do { tcHsSigType ExprSigCtxt typ
+ ; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
-tc_bracket (DecBr decls)
+tc_bracket use_lvl (DecBr decls)
= do { tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
-- Result type is Q [Dec]
}
-tc_bracket (PatBr _)
+tc_bracket use_lvl (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}
-> TcM hs_syn -- Of type t
runMeta convert expr
= do { -- Desugar
- ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr)
-
+ ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
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
--
-- 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}
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) }
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