[project @ 2002-11-21 11:31:34 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 251c7ad..0ca5d60 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -315,7 +315,20 @@ zonkBinds env (MonoBind bind sigs is_rec)
        zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
        returnM (env1, new_bind, new_ids)
     )                          `thenM` \ (env1, new_bind, _) ->
-   returnM (env1, mkMonoBind new_bind [] is_rec)
+   returnM (env1, mkMonoBind is_rec new_bind)
+
+zonkBinds env (IPBinds binds is_with)
+  = mappM zonk_ip_bind binds   `thenM` \ new_binds ->
+    let
+       env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
+    in
+    returnM (env1, IPBinds new_binds is_with)
+  where
+    zonk_ip_bind (n, e)
+       = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
+         zonkExpr env e                        `thenM` \ e' ->
+         returnM (n', e')
+
 
 ---------------------------------------------
 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
@@ -413,7 +426,11 @@ zonkGRHSs env (GRHSs grhss binds ty)
 %************************************************************************
 
 \begin{code}
-zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
+zonkExpr  :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+
+zonkExprs env exprs = mappM (zonkExpr env) exprs
+
 
 zonkExpr env (HsVar id)
   = returnM (HsVar (zonkIdOcc env id))
@@ -450,8 +467,10 @@ zonkExpr env (HsBracketOut body bs)
     zonk_b (n,e) = zonkExpr env e      `thenM` \ e' ->
                   returnM (n,e')
 
-zonkExpr env (HsSplice n e) = WARN( True, ppr e )      -- Should not happen
-                             returnM (HsSplice n e)
+zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
+                                               -- level things can be reified (for now)
+zonkExpr env (HsSplice n e loc) = WARN( True, ppr e )  -- Should not happen
+                                 returnM (HsSplice n e loc)
 
 zonkExpr env (OpApp e1 op fixity e2)
   = zonkExpr env e1    `thenM` \ new_e1 ->
@@ -491,19 +510,6 @@ zonkExpr env (HsLet binds expr)
     zonkExpr new_env expr      `thenM` \ new_expr ->
     returnM (HsLet new_binds new_expr)
 
-zonkExpr env (HsWith expr binds is_with)
-  = mappM zonk_ip_bind binds   `thenM` \ new_binds ->
-    let
-       env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
-    in
-    zonkExpr env1 expr         `thenM` \ new_expr ->
-    returnM (HsWith new_expr new_binds is_with)
-    where
-       zonk_ip_bind (n, e)
-           = mapIPNameTc (zonkIdBndr env) n    `thenM` \ n' ->
-             zonkExpr env e                    `thenM` \ e' ->
-             returnM (n', e')
-
 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
   = zonkStmts env stmts        `thenM` \ new_stmts ->
     zonkTcTypeToType env ty    `thenM` \ new_ty   ->
@@ -513,16 +519,16 @@ zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
 
 zonkExpr env (ExplicitList ty exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
-    mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+    zonkExprs env exprs                `thenM` \ new_exprs ->
     returnM (ExplicitList new_ty new_exprs)
 
 zonkExpr env (ExplicitPArr ty exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
-    mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+    zonkExprs env exprs                `thenM` \ new_exprs ->
     returnM (ExplicitPArr new_ty new_exprs)
 
 zonkExpr env (ExplicitTuple exprs boxed)
-  = mappM (zonkExpr env) exprs         `thenM` \ new_exprs ->
+  = zonkExprs env exprs        `thenM` \ new_exprs ->
     returnM (ExplicitTuple new_exprs boxed)
 
 zonkExpr env (RecordConOut data_con con_expr rbinds)
@@ -554,7 +560,7 @@ zonkExpr env (PArrSeqOut expr info)
     returnM (PArrSeqOut new_expr new_info)
 
 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
-  = mappM (zonkExpr env) args          `thenM` \ new_args ->
+  = zonkExprs env args                 `thenM` \ new_args ->
     zonkTcTypeToType env result_ty     `thenM` \ new_result_ty ->
     returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
 
@@ -613,55 +619,63 @@ zonkArithSeq env (FromThenTo e1 e2 e3)
 
 
 -------------------------------------------------------------------------
-zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
+zonkStmts  :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
+
+zonkStmts env stmts = zonk_stmts env stmts     `thenM` \ (_, stmts) ->
+                     returnM stmts
 
-zonkStmts env [] = returnM []
+zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
 
-zonkStmts env (ParStmtOut bndrstmtss : stmts)
+zonk_stmts env [] = returnM (env, [])
+
+zonk_stmts env (ParStmtOut bndrstmtss : stmts)
   = mappM (mappM zonkId) bndrss                `thenM` \ new_bndrss ->
     mappM (zonkStmts env) stmtss       `thenM` \ new_stmtss ->
     let 
        new_binders = concat new_bndrss
        env1 = extendZonkEnv env new_binders
     in
-    zonkStmts env1 stmts               `thenM` \ new_stmts ->
-    returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+    zonk_stmts env1 stmts              `thenM` \ (env2, new_stmts) ->
+    returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
   where
     (bndrss, stmtss) = unzip bndrstmtss
 
-zonkStmts env (RecStmt vs segStmts : stmts)
+zonk_stmts env (RecStmt vs segStmts rets : stmts)
   = mappM zonkId vs            `thenM` \ new_vs ->
     let
        env1 = extendZonkEnv env new_vs
     in
-    zonkStmts env1 segStmts    `thenM` \ new_segStmts ->
-    zonkStmts env1 stmts       `thenM` \ new_stmts ->
-    returnM (RecStmt new_vs new_segStmts : new_stmts)
-
-zonkStmts env (ResultStmt expr locn : stmts)
-  = zonkExpr env expr  `thenM` \ new_expr ->
-    zonkStmts env stmts        `thenM` \ new_stmts ->
-    returnM (ResultStmt new_expr locn : new_stmts)
+    zonk_stmts env1 segStmts   `thenM` \ (env2, new_segStmts) ->
+       -- Zonk the ret-expressions in an envt that 
+       -- has the polymorphic bindings in the envt
+    zonkExprs env2 rets                `thenM` \ new_rets ->
+    zonk_stmts env1 stmts      `thenM` \ (env3, new_stmts) ->
+    returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
+
+zonk_stmts env (ResultStmt expr locn : stmts)
+  = ASSERT( null stmts )
+    zonkExpr env expr  `thenM` \ new_expr ->
+    returnM (env, [ResultStmt new_expr locn])
 
-zonkStmts env (ExprStmt expr ty locn : stmts)
+zonk_stmts env (ExprStmt expr ty locn : stmts)
   = zonkExpr env expr          `thenM` \ new_expr ->
     zonkTcTypeToType env ty    `thenM` \ new_ty ->
-    zonkStmts env stmts                `thenM` \ new_stmts ->
-    returnM (ExprStmt new_expr new_ty locn : new_stmts)
+    zonk_stmts env stmts       `thenM` \ (env1, new_stmts) ->
+    returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
 
-zonkStmts env (LetStmt binds : stmts)
-  = zonkBinds env binds                `thenM` \ (new_env, new_binds) ->
-    zonkStmts new_env stmts    `thenM` \ new_stmts ->
-    returnM (LetStmt new_binds : new_stmts)
+zonk_stmts env (LetStmt binds : stmts)
+  = zonkBinds env binds                `thenM` \ (env1, new_binds) ->
+    zonk_stmts env1 stmts      `thenM` \ (env2, new_stmts) ->
+    returnM (env2, LetStmt new_binds : new_stmts)
 
-zonkStmts env (BindStmt pat expr locn : stmts)
+zonk_stmts env (BindStmt pat expr locn : stmts)
   = zonkExpr env expr                  `thenM` \ new_expr ->
     zonkPat env pat                    `thenM` \ (new_pat, new_ids) ->
     let
        env1 = extendZonkEnv env (bagToList new_ids)
     in
-    zonkStmts env1 stmts               `thenM` \ new_stmts ->
-    returnM (BindStmt new_pat new_expr locn : new_stmts)
+    zonk_stmts env1 stmts              `thenM` \ (env2, new_stmts) ->
+    returnM (env2, BindStmt new_pat new_expr locn : new_stmts)