X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=17ca215064a50f918f0a8dc2c710cf2c477c8bb1;hb=fe548aebdad3520e51d92fcda6bec9d26d69aa4a;hp=ba6891d17730858673960aac673bbfd1ea1a1792;hpb=0877011afd5886ee06df2e2723d631ff0686324f;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index ba6891d..17ca215 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -16,23 +16,25 @@ 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, zapToType )
+import TcMType		( newTyVarTy, UserTypeCtxt(ExprSigCtxt) )
+import TcMonoType	( tcHsSigType )
 import Name		( Name )
 import TcRnMonad
 
 import TysWiredIn	( mkListTy )
-import DsMeta		( exprTyConName, declTyConName, decTyConName, qTyConName )
+import DsMeta		( exprTyConName, declTyConName, typeTyConName, decTyConName, qTyConName )
 import ErrUtils (Message)
 import Outputable
 import Panic		( showException )
@@ -52,7 +54,7 @@ tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl]
 
 tcSpliceExpr :: Name 
 	     -> RenamedHsExpr
-	     -> TcType
+	     -> Expected TcType
 	     -> TcM TcExpr
 
 #ifndef GHCI
@@ -63,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))
@@ -107,11 +145,11 @@ tcSpliceExpr name expr res_ty
 	-- Here (h 4) :: Q Exp
 	-- but $(h 4) :: forall a.a 	i.e. anything!
 
-    zapToType res_ty				`thenM_`
+    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
@@ -155,6 +193,8 @@ tcTopSplice expr 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!
@@ -162,7 +202,7 @@ tcTopSpliceExpr expr meta_ty
     setStage topSpliceStage $
 
 	-- Typecheck the expression
-    getLIE (tcMonoExpr expr meta_ty)	`thenM` \ (expr', lie) ->
+    getLIE (tcCheckRho expr meta_ty)	`thenM` \ (expr', lie) ->
 
 	-- Solve the constraints
     tcSimplifyTop lie			`thenM` \ const_binds ->
@@ -362,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