[project @ 2003-02-22 04:51:50 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSplice.lhs

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index a5ebd6e..3278fd9 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -16,16 +16,17 @@ 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 TcHsSyn         ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
-import TcSimplify      ( tcSimplifyTop )
+import TcSimplify      ( tcSimplifyTop, tcSimplifyBracket )
+import TcUnify         ( unifyTauTy )
 import TcType          ( TcType, openTypeKind, mkAppTy )
-import TcEnv           ( spliceOK, tcMetaTy )
+import TcEnv           ( spliceOK, tcMetaTy, tcWithTempInstEnv, bracketOK )
 import TcRnTypes       ( TopEnv(..) )
 import TcMType         ( newTyVarTy, zapToType )
 import Name            ( Name )
@@ -63,20 +64,49 @@ 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) 
+tcBracket :: HsBracket Name -> 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_`  
+
+    unifyTauTy 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 (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_`
+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))
@@ -129,21 +159,10 @@ tcSpliceExpr name expr res_ty
 -- inner escape before dealing with the outer one
 
 tcTopSplice expr res_ty
-  = checkNoErrs (
-       -- checkNoErrs: must not try to run the thing
-       --              if the type checker fails!
-
-       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 ->
+  = tcMetaTy exprTyConName             `thenM` \ meta_exp_ty ->
 
-       -- Wrap the bindings around it and zonk
-       zonkTopExpr (mkHsLet const_binds 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_`
@@ -163,6 +182,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 (tcMonoExpr expr meta_ty)   `thenM` \ (expr', lie) ->
+
+       -- Solve the constraints
+    tcSimplifyTop lie                  `thenM` \ const_binds ->
+       
+       -- And zonk it
+    zonkTopExpr (mkHsLet const_binds expr')
 \end{code}
 
 
@@ -177,15 +215,10 @@ 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_`
@@ -361,6 +394,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