X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=9ec400d7226d7cc4e4c5d876a128b81be5961018;hp=cce4becd89bb0ff10ef942ea0e96fca25ee56d29;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index cce4bec..9ec400d 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1,77 +1,157 @@ % +% (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 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. + %************************************************************************ %* * @@ -83,6 +163,7 @@ import FastString ( mkFastString ) 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) @@ -96,8 +177,20 @@ 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 Id) +tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBracket brack res_ty = getStage `thenM` \ level -> case bracketOK level of { @@ -112,7 +205,7 @@ 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_` @@ -124,22 +217,34 @@ tcBracket brack res_ty 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 @@ -150,8 +255,12 @@ tc_bracket (DecBr decls) -- 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} @@ -368,22 +477,19 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> LHsExpr Id -- Of type X -> TcM hs_syn -- Of type t runMeta convert expr - = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv - ; this_mod <- getModule - ; let type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - + = 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 $ - HscMain.compileExpr - hsc_env this_mod - rdr_env type_env expr + 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 -- @@ -391,23 +497,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} @@ -498,8 +639,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) } @@ -568,9 +708,9 @@ reifyThing (AGlobal (ADataCon dc)) ; fix <- reifyFixity name ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) } -reifyThing (ATcId id _ _) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even - -- though it may be incomplete +reifyThing (ATcId {tct_id = id, tct_type = ty}) + = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even + -- though it may be incomplete ; ty2 <- reifyType ty1 ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } @@ -586,24 +726,26 @@ reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs - ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } + = do { let (tvs, rhs) = synTyConDefn tc + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ + TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } 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 @@ -629,7 +771,7 @@ reifyClass cls ; ops <- mapM reify_op op_stuff ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } where - (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls + (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds reify_op (op, _) = do { ty <- reifyType (idType op) ; return (TH.SigD (reifyName op) ty) }