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 [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
-> 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
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
projects / ghc-hetmet.git / blobdiff