X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=94e9c0e2940c610bc42cc227dd838c52b59df7b6;hb=0df435464ff825eb66e409fb5668a53cd5362309;hp=e269f9f22a7b51b0a5ca2e365f14385e696beb4f;hpb=8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index e269f9f..94e9c0e 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -1,4 +1,4 @@
-%
+2%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcSplice]{Template Haskell splices}
@@ -24,7 +24,7 @@ import RnHsSyn		( RenamedHsExpr )
 import TcExpr		( tcMonoExpr )
 import TcHsSyn		( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
 import TcSimplify	( tcSimplifyTop )
-import TcType		( TcType, openTypeKind )
+import TcType		( TcType, openTypeKind, mkAppTy )
 import TcEnv		( spliceOK, tcMetaTy )
 import TcRnTypes	( TopEnv(..) )
 import TcMType		( newTyVarTy )
@@ -32,7 +32,7 @@ import Name		( Name )
 import TcRnMonad
 
 import TysWiredIn	( mkListTy )
-import DsMeta		( exprTyConName, declTyConName )
+import DsMeta		( exprTyConName, declTyConName, decTyConName, qTyConName )
 import Outputable
 import GHC.Base		( unsafeCoerce# )	-- Should have a better home in the module hierarchy
 \end{code}
@@ -70,13 +70,17 @@ tcBracket (ExpBr expr)
   = newTyVarTy openTypeKind		`thenM` \ any_ty ->
     tcMonoExpr expr any_ty		`thenM_`
     tcMetaTy exprTyConName
+	-- Result type is Expr (= Q Exp)
 
 tcBracket (DecBr decls)
   = tcTopSrcDecls decls			`thenM_`
-    tcMetaTy declTyConName		`thenM` \ decl_ty ->
-    returnM (mkListTy decl_ty)
+    tcMetaTy decTyConName		`thenM` \ decl_ty ->
+    tcMetaTy qTyConName			`thenM` \ q_ty ->
+    returnM (mkAppTy q_ty (mkListTy decl_ty))
+	-- Result type is Q [Dec]
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection{Splicing an expression}
@@ -144,6 +148,9 @@ tcTopSplice expr res_ty
 	expr2 = convertToHsExpr simple_expr 
     in
     traceTc (text "Got result" <+> ppr expr2) 	`thenM_`
+
+    showSplice "expression" 
+	       zonked_q_expr (ppr expr2)	`thenM_`
     initRn SourceMode (rnExpr expr2)		`thenM` \ (exp3, fvs) ->
     importSupportingDecls fvs			`thenM` \ env ->
 
@@ -160,9 +167,10 @@ tcTopSplice expr res_ty
 \begin{code}
 -- Always at top level
 tcSpliceDecls expr
-  = tcMetaTy declTyConName		`thenM` \ meta_dec_ty ->
+  = tcMetaTy decTyConName		`thenM` \ meta_dec_ty ->
+    tcMetaTy qTyConName    		`thenM` \ meta_q_ty ->
     setStage topSpliceStage (
-	getLIE (tcMonoExpr expr (mkListTy meta_dec_ty))
+	getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty)))
     )					`thenM` \ (expr', lie) ->
 	-- Solve the constraints
     tcSimplifyTop lie			`thenM` \ const_binds ->
@@ -180,6 +188,8 @@ tcSpliceDecls expr
 	decls = convertToHsDecls simple_expr 
     in
     traceTc (text "Got result" <+> vcat (map ppr decls))	`thenM_`
+    showSplice "declarations"
+	       zonked_q_expr (vcat (map ppr decls))		`thenM_`
     returnM decls
 \end{code}
 
@@ -193,29 +203,23 @@ tcSpliceDecls expr
 \begin{code}
 runMetaE :: TypecheckedHsExpr 	-- Of type (Q Exp)
 	 -> TcM Meta.Exp	-- Of type Exp
-runMetaE e = runMeta tcRunQ e
+runMetaE e = runMeta e
 
-runMetaD :: TypecheckedHsExpr 	-- Of type [Q Dec]
+runMetaD :: TypecheckedHsExpr 	-- Of type Q [Dec]
 	 -> TcM [Meta.Dec]	-- Of type [Dec]
-runMetaD e = runMeta run_decl e
-	   where
-	     run_decl :: [Meta.Decl] -> TcM [Meta.Dec]
-	     run_decl ds = mappM tcRunQ ds
+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
+tcRunQ thing = ioToTcRn (Meta.runQ thing)
 
-
-runMeta :: (x -> TcM t)		-- :: X -> IO t
-	-> TypecheckedHsExpr 	-- Of type X
+runMeta :: TypecheckedHsExpr 	-- Of type X
 	-> TcM t		-- Of type t
-runMeta run_it expr :: TcM 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
 
@@ -224,19 +228,14 @@ runMeta run_it expr :: TcM t
 
 	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
-    if (ghci_mode == OneShot) then
-	failWithTc (ptext SLIT("You must use --make or --interactive to run splice expressions"))
-	-- The reason for this is that the demand-linker doesn't have
-	-- enough information available to link all the things that
-	-- are needed when you try to run a splice
-    else
-
-    ioToTcRn (HscMain.compileExpr hsc_env pcs this_mod 
-				  print_unqual expr) `thenM` \ hval ->
+    ioToTcRn (HscMain.compileExpr 
+		hsc_env pcs this_mod 
+	        rdr_env type_env expr)	`thenM` \ hval ->
 
-    tryM (run_it (unsafeCoerce# hval))	`thenM` \ either_tval ->
+    tryM (tcRunQ (unsafeCoerce# hval))	`thenM` \ either_tval ->
 
     case either_tval of
 	  Left exn -> failWithTc (vcat [text "Exception when running compile-time code:", 
@@ -341,6 +340,14 @@ Two successive brackets aren't allowed
 %************************************************************************
 
 \begin{code}
+showSplice :: String -> TypecheckedHsExpr -> SDoc -> TcM ()
+showSplice what before after
+  = getSrcLocM		`thenM` \ loc ->
+    traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, 
+		       nest 2 (sep [nest 2 (ppr before),
+				    text "======>",
+				    nest 2 after])])
+
 illegalSplice level
   = ptext SLIT("Illegal splice at level") <+> ppr level