[project @ 2003-01-13 14:12:31 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 088c498..a5ebd6e 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -27,14 +27,17 @@ import TcSimplify   ( tcSimplifyTop )
 import TcType          ( TcType, openTypeKind, mkAppTy )
 import TcEnv           ( spliceOK, tcMetaTy )
 import TcRnTypes       ( TopEnv(..) )
-import TcMType         ( newTyVarTy )
+import TcMType         ( newTyVarTy, zapToType )
 import Name            ( Name )
 import TcRnMonad
 
 import TysWiredIn      ( mkListTy )
 import DsMeta          ( exprTyConName, declTyConName, 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}
 
 
@@ -99,11 +102,12 @@ 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!
 
+    zapToType res_ty                           `thenM_`
     tcMetaTy exprTyConName                     `thenM` \ meta_exp_ty ->
     setStage (Splice next_level) (
        setLIEVar lie_var          $
@@ -125,17 +129,21 @@ tcSpliceExpr name expr res_ty
 -- inner escape before dealing with the outer one
 
 tcTopSplice expr res_ty
-  = tcMetaTy exprTyConName             `thenM` \ meta_exp_ty ->
-    setStage topSpliceStage (
-       getLIE (tcMonoExpr expr meta_exp_ty)
-    )                                  `thenM` \ (expr', lie) ->
+  = 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 ->
-    let 
-       q_expr = mkHsLet const_binds expr'
-    in
-    zonkTopExpr q_expr                 `thenM` \ zonked_q_expr ->
+       tcSimplifyTop lie               `thenM` \ const_binds ->
+
+       -- Wrap the bindings around it and zonk
+       zonkTopExpr (mkHsLet const_binds expr')
+    )                                  `thenM` \ zonked_q_expr ->
 
        -- Run the expression
     traceTc (text "About to run" <+> ppr zonked_q_expr)        `thenM_`
@@ -182,15 +190,19 @@ tcSpliceDecls 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}
 
 
@@ -209,17 +221,14 @@ runMetaD :: TypecheckedHsExpr     -- Of type Q [Dec]
         -> TcM [Meta.Dec]      -- Of type [Dec]
 runMetaD e = runMeta e
 
-tcRunQ :: Meta.Q a -> TcM a
-tcRunQ thing = ioToTcRn (Meta.runQ 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
 
@@ -228,17 +237,23 @@ runMeta expr
 
        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
 \end{code}