X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=17ca215064a50f918f0a8dc2c710cf2c477c8bb1;hb=3c85beaf1fd27f741f1511bc9dad3da1e41f8c0c;hp=2ae265c7dead0f362950307586b6d6c2503d4cb8;hpb=6942766ac64f71b57c85a4069900b383495e2bdb;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 2ae265c..17ca215 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -16,26 +16,30 @@ import TcRnDriver ( importSupportingDecls, tcTopSrcDecls ) import qualified Language.Haskell.THSyntax as Meta import HscTypes ( HscEnv(..), GhciMode(..), PersistentCompilerState(..), unQualInScope ) -import HsSyn ( HsBracket(..) ) +import HsSyn ( HsBracket(..), HsExpr(..) ) import Convert ( convertToHsExpr, convertToHsDecls ) import RnExpr ( rnExpr ) import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl ) import RnHsSyn ( RenamedHsExpr ) -import TcExpr ( tcMonoExpr ) +import TcExpr ( tcCheckRho, tcMonoExpr ) import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) -import TcSimplify ( tcSimplifyTop ) +import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) +import TcUnify ( Expected, unifyTauTy, zapExpectedTo, zapExpectedType ) import TcType ( TcType, openTypeKind, mkAppTy ) -import TcEnv ( spliceOK, tcMetaTy ) +import TcEnv ( spliceOK, tcMetaTy, tcWithTempInstEnv, bracketOK ) import TcRnTypes ( TopEnv(..) ) -import TcMType ( newTyVarTy ) +import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt) ) +import TcMonoType ( tcHsSigType ) import Name ( Name ) import TcRnMonad import TysWiredIn ( mkListTy ) -import DsMeta ( exprTyConName, declTyConName, decTyConName, qTyConName ) -import CmdLineOpts ( DynFlags(..), CoreToDo(..), SimplifierMode(..), SimplifierSwitch(..) ) +import DsMeta ( exprTyConName, declTyConName, typeTyConName, decTyConName, qTyConName ) +import ErrUtils (Message) import Outputable +import Panic ( showException ) import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy +import Monad (liftM) \end{code} @@ -50,7 +54,7 @@ tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl] tcSpliceExpr :: Name -> RenamedHsExpr - -> TcType + -> Expected TcType -> TcM TcExpr #ifndef GHCI @@ -61,20 +65,56 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ %* * -\subsection{Splicing an expression} +\subsection{Quoting an expression} %* * %************************************************************************ \begin{code} -tcBracket :: HsBracket Name -> TcM TcType -tcBracket (ExpBr expr) - = newTyVarTy openTypeKind `thenM` \ any_ty -> - tcMonoExpr expr any_ty `thenM_` +tcBracket :: HsBracket Name -> Expected TcType -> TcM TcExpr +tcBracket brack res_ty + = getStage `thenM` \ level -> + case bracketOK level of { + Nothing -> failWithTc (illegalBracket level) ; + Just next_level -> + + -- Typecheck expr to make sure it is valid, + -- but throw away the results. We'll type check + -- it again when we actually use it. + newMutVar [] `thenM` \ pending_splices -> + getLIEVar `thenM` \ lie_var -> + + setStage (Brack next_level pending_splices lie_var) ( + getLIE (tc_bracket brack) + ) `thenM` \ (meta_ty, lie) -> + tcSimplifyBracket lie `thenM_` + + -- Make the expected type have the right shape + zapExpectedTo res_ty meta_ty `thenM_` + + -- Return the original expression, not the type-decorated one + readMutVar pending_splices `thenM` \ pendings -> + returnM (HsBracketOut brack pendings) + } + +tc_bracket :: HsBracket Name -> TcM TcType +tc_bracket (ExpBr expr) + = newTyVarTy openTypeKind `thenM` \ any_ty -> + tcCheckRho expr any_ty `thenM_` tcMetaTy exprTyConName -- Result type is Expr (= Q Exp) -tcBracket (DecBr decls) - = tcTopSrcDecls decls `thenM_` +tc_bracket (TypBr typ) + = tcHsSigType ExprSigCtxt typ `thenM_` + tcMetaTy typeTyConName + -- Result type is Type (= Q Typ) + +tc_bracket (DecBr decls) + = tcWithTempInstEnv (tcTopSrcDecls decls) `thenM_` + -- Typecheck the declarations, dicarding any side effects + -- on the instance environment (which is in a mutable variable) + -- and the extended environment. We'll get all that stuff + -- later, when we splice it in + tcMetaTy decTyConName `thenM` \ decl_ty -> tcMetaTy qTyConName `thenM` \ q_ty -> returnM (mkAppTy q_ty (mkListTy decl_ty)) @@ -100,15 +140,16 @@ tcSpliceExpr name expr res_ty Brack _ ps_var lie_var -> -- A splice inside brackets - -- NB: ignore res_ty + -- NB: ignore res_ty, apart from zapping it to a mono-type -- e.g. [| reverse $(h 4) |] -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! + zapExpectedType res_ty `thenM_` tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> setStage (Splice next_level) ( setLIEVar lie_var $ - tcMonoExpr expr meta_exp_ty + tcCheckRho expr meta_exp_ty ) `thenM` \ expr' -> -- Write the pending splice into the bucket @@ -127,16 +168,9 @@ tcSpliceExpr name expr res_ty tcTopSplice expr res_ty = tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> - setStage topSpliceStage ( - getLIE (tcMonoExpr expr meta_exp_ty) - ) `thenM` \ (expr', lie) -> - -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> - let - q_expr = mkHsLet const_binds expr' - in - zonkTopExpr q_expr `thenM` \ zonked_q_expr -> + -- Typecheck the expression + tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr -> -- Run the expression traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` @@ -156,6 +190,25 @@ tcTopSplice expr res_ty importSupportingDecls fvs `thenM` \ env -> setGblEnv env (tcMonoExpr exp3 res_ty) + + +tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +tcTopSpliceExpr expr meta_ty + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + + setStage topSpliceStage $ + + -- Typecheck the expression + getLIE (tcCheckRho expr meta_ty) `thenM` \ (expr', lie) -> + + -- Solve the constraints + tcSimplifyTop lie `thenM` \ const_binds -> + + -- And zonk it + zonkTopExpr (mkHsLet const_binds expr') \end{code} @@ -170,28 +223,27 @@ tcTopSplice expr res_ty tcSpliceDecls expr = tcMetaTy decTyConName `thenM` \ meta_dec_ty -> tcMetaTy qTyConName `thenM` \ meta_q_ty -> - setStage topSpliceStage ( - getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty))) - ) `thenM` \ (expr', lie) -> - -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> - let - q_expr = mkHsLet const_binds expr' + let + list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty) in - zonkTopExpr q_expr `thenM` \ zonked_q_expr -> + tcTopSpliceExpr expr list_q `thenM` \ zonked_q_expr -> -- Run the expression traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` runMetaD zonked_q_expr `thenM` \ simple_expr -> - let - -- simple_expr :: [Meta.Dec] - decls :: [RdrNameHsDecl] - decls = convertToHsDecls simple_expr - in + -- simple_expr :: [Meta.Dec] + -- decls :: [RdrNameHsDecl] + handleErrors (convertToHsDecls simple_expr) `thenM` \ decls -> traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_` showSplice "declarations" zonked_q_expr (vcat (map ppr decls)) `thenM_` returnM decls + + where handleErrors :: [Either a Message] -> TcM [a] + handleErrors [] = return [] + handleErrors (Left x:xs) = liftM (x:) (handleErrors xs) + handleErrors (Right m:xs) = do addErrTc m + handleErrors xs \end{code} @@ -210,50 +262,40 @@ runMetaD :: TypecheckedHsExpr -- Of type Q [Dec] -> TcM [Meta.Dec] -- Of type [Dec] runMetaD e = runMeta e --- Warning: if Q is anything other than IO, we need to change this -tcRunQ :: Meta.Q a -> TcM a -tcRunQ thing = ioToTcRn thing - - runMeta :: TypecheckedHsExpr -- Of type X -> TcM t -- Of type t runMeta expr = getTopEnv `thenM` \ top_env -> + getGblEnv `thenM` \ tcg_env -> getEps `thenM` \ eps -> getNameCache `thenM` \ name_cache -> getModule `thenM` \ this_mod -> - getGlobalRdrEnv `thenM` \ rdr_env -> let ghci_mode = top_mode top_env - dflags = top_dflags top_env - -- Compile the Template Haskell stuff with low - -- optimisation even if the main compilation has - -- high optimisation. This is a bit of a hack. - th_dflags = dflags { coreToDo = thCoreToDo } - - hsc_env = HscEnv { hsc_mode = ghci_mode, - hsc_HPT = top_hpt top_env, - hsc_dflags = th_dflags } + hsc_env = HscEnv { hsc_mode = ghci_mode, hsc_HPT = top_hpt top_env, + hsc_dflags = top_dflags top_env } pcs = PCS { pcs_nc = name_cache, pcs_EPS = eps } - print_unqual = unQualInScope rdr_env + type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env in - ioToTcRn (HscMain.compileExpr hsc_env pcs this_mod - print_unqual expr) `thenM` \ hval -> - - tryM (tcRunQ (unsafeCoerce# hval)) `thenM` \ either_tval -> + -- Wrap the compile-and-run in an exception-catcher + -- Compiling might fail if linking fails + -- Running might fail if it throws an exception + tryM (ioToTcRn (do + hval <- HscMain.compileExpr + hsc_env pcs this_mod + rdr_env type_env expr + Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it + )) `thenM` \ either_tval -> case either_tval of - Left exn -> failWithTc (vcat [text "Exception when running compile-time code:", + Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:", nest 4 (vcat [text "Code:" <+> ppr expr, - text ("Exn: " ++ show exn)])]) + text ("Exn: " ++ Panic.showException exn)])]) Right v -> returnM v - - -thCoreToDo :: [CoreToDo] -thCoreToDo = [] -- CoreDoSimplify (SimplPhase 0) [MaxSimplifierIterations 3]] \end{code} @@ -360,6 +402,9 @@ showSplice what before after text "======>", nest 2 after])]) +illegalBracket level + = ptext SLIT("Illegal bracket at level") <+> ppr level + illegalSplice level = ptext SLIT("Illegal splice at level") <+> ppr level