%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcSplice]{Template Haskell splices}
+
+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 HscMain ( compileExpr )
-import TcRnDriver ( tcTopSrcDecls )
+import HscMain
+import TcRnDriver
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
+import HsSyn
+import Convert
+import RnExpr
+import RnEnv
+import RdrName
+import RnTypes
+import TcExpr
+import TcHsSyn
+import TcSimplify
+import TcUnify
+import TcType
+import TcEnv
+import TcMType
+import TcHsType
+import TcIface
+import TypeRep
+import Name
+import NameEnv
+import HscTypes
+import OccName
+import Var
+import Module
+import TcRnMonad
+import IfaceEnv
+import Class
+import TyCon
+import DataCon
+import Id
+import IdInfo
+import TysWiredIn
+import DsMeta
+import DsExpr
+import DsMonad hiding (Splice)
+import ErrUtils
+import SrcLoc
+import Outputable
+import Unique
+import DynFlags
+import PackageConfig
+import Maybe
+import BasicTypes
+import Panic
+import FastString
+
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
-import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
- HsType, LHsType )
-import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName )
-import RnExpr ( rnLExpr )
-import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
-import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
-import RnTypes ( rnLHsType )
-import TcExpr ( tcMonoExpr )
-import TcHsSyn ( mkHsDictLet, zonkTopLExpr )
-import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify ( boxyUnify, unBox )
-import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
-import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
-import TcHsType ( tcHsSigType, kcHsType )
-import TcIface ( tcImportDecl )
-import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
-import PrelNames ( thFAKE )
-import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
- nameIsLocalOrFrom )
-import NameEnv ( lookupNameEnv )
-import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
-import OccName
-import Var ( Id, TyVar, idType )
-import Module ( moduleName, moduleNameString, modulePackageId )
-import TcRnMonad
-import IfaceEnv ( lookupOrig )
-import Class ( Class, classExtraBigSig )
-import TyCon ( TyCon, tyConTyVars, synTyConDefn,
- isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
- tyConArity, tyConStupidTheta, isUnLiftedTyCon )
-import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
- dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix,
- isVanillaDataCon )
-import Id ( idName, globalIdDetails )
-import IdInfo ( GlobalIdDetails(..) )
-import TysWiredIn ( mkListTy )
-import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
-import DsExpr ( dsLExpr )
-import DsMonad ( initDsTc )
-import ErrUtils ( Message )
-import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
-import Outputable
-import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-import PackageConfig ( packageIdString )
-import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
-import Panic ( showException )
-import FastString ( LitString )
-
-import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy
-import Monad ( liftM )
-
-#ifdef GHCI
-import FastString ( mkFastString )
-#endif
+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.
+
%************************************************************************
%* *
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
#ifndef GHCI
tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr 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
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}
runMeta convert expr
= do { -- Desugar
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
projects / ghc-hetmet.git / blobdiff