[project @ 2005-06-21 10:44:37 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index 7ec59d8..b02eb2b 100644 (file)
--- a/ghc/compiler/typecheck/TcArrows.lhs
+++ b/ghc/compiler/typecheck/TcArrows.lhs
@@ -13,8 +13,8 @@ import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho )
 import HsSyn
 import TcHsSyn (  mkHsLet )
 
-import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
-                 TcMatchCtxt(..), tcMatchesCase )
+import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
+                  TcMatchCtxt(..), tcMatchesCase )
 
 import TcType  ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
                  mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType, 
@@ -50,13 +50,13 @@ tcProc :: InPat Name -> LHsCmdTop Name              -- proc pat -> expr
 
 tcProc pat cmd exp_ty
 -- gaw 2004 FIX?
- = do  { arr_ty <- newTyFlexiVarTy arrowTyConKind
+ = newArrowScope $ do
+       { arr_ty <- newTyFlexiVarTy arrowTyConKind
        ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind
        ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
 
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
-       ; ([pat'], cmd') <- incProcLevel $
-                           tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
+       ; ([pat'], cmd') <- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
                            tcCmdTop cmd_env cmd ([], res_ty)
                -- The False says don't do GADT type refinement
                -- This is a conservative choice, but I'm not sure of the consequences
@@ -74,7 +74,10 @@ tcProc pat cmd exp_ty
 
 \begin{code}
 type CmdStack = [TcTauType]
-data CmdEnv   = CmdEnv { cmd_arr   :: TcType }         -- The arrow type constructor, of kind *->*->*
+data CmdEnv
+  = CmdEnv {
+       cmd_arr         :: TcType -- arrow type constructor, of kind *->*->*
+    }
 
 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
@@ -142,19 +145,19 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
     do  { arg_ty <- newTyFlexiVarTy openTypeKind
        ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
 
-       ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
+       ; fun' <- select_arrow_scope (tcCheckRho fun fun_ty)
 
        ; arg' <- tcCheckRho arg arg_ty
 
        ; return (HsArrApp fun' arg' fun_ty ho_app lr) }
   where
-       -- Before type-checking f, remove the "arrow binders" from the 
-       -- environment in the (-<) case.  
+       -- Before type-checking f, use the environment of the enclosing
+       -- proc for the (-<) case.  
        -- Local bindings, inside the enclosing proc, are not in scope 
        -- inside f.  In the higher-order case (-<<), they are.
-    pop_arrow_binders tc = case ho_app of
+    select_arrow_scope tc = case ho_app of
        HsHigherOrderApp -> tc
-       HsFirstOrderApp  -> popArrowBinders tc
+       HsFirstOrderApp  -> escapeArrowScope tc
 
 -------------------------------------------
 --             Command application
@@ -195,39 +198,33 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g
     n_pats     = length pats
     stk'       = drop n_pats cmd_stk
     match_ctxt = LambdaExpr    -- Maybe KappaExpr?
+    pg_ctxt    = PatGuard match_ctxt
 
     tc_grhss (GRHSs grhss binds)
-       = tcBindsAndThen glueBindsOnGRHSs binds         $
+       = tcBindsAndThen glueBindsOnGRHSs binds $
          do { grhss' <- mappM (wrapLocM tc_grhs) grhss
             ; return (GRHSs grhss' []) }
 
-    stmt_ctxt = SC { sc_what = PatGuard match_ctxt, 
-                    sc_rhs  = tcInferRho, 
-                    sc_body = \ body -> tcCmd env body (stk', res_ty),
-                    sc_ty   = res_ty } -- ToDo: Is this right?
-    tc_grhs (GRHS guarded)
-       = do { guarded' <- tcStmts stmt_ctxt guarded    
-            ; return (GRHS guarded') }
+    tc_grhs (GRHS guards body)
+       = do { (guards', rhs') <- tcStmts pg_ctxt
+                                         (tcGuardStmt res_ty)
+                                         guards
+                                         (tcCmd env body (stk', res_ty))
+            ; return (GRHS guards' rhs') }
 
 -------------------------------------------
 --             Do notation
 
-tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
   = do         { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
-       ; stmts' <- tcStmts stmt_ctxt stmts 
-       ; return (HsDo do_or_lc stmts' [] res_ty) }
-       -- The 'methods' needed for the HsDo are in the enclosing HsCmd
-       -- hence the empty list here
+       ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts $
+                            tcCmd env body ([], res_ty)
+       ; return (HsDo do_or_lc stmts' body' res_ty) }
   where
-    stmt_ctxt = SC { sc_what = do_or_lc,
-                    sc_rhs  = tc_rhs,
-                    sc_body = tc_ret,
-                    sc_ty   = res_ty }
-
+    tc_stmt = tcMDoStmt res_ty tc_rhs
     tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind
                    ; rhs' <- tcCmd env rhs ([], ty)
                    ; return (rhs', ty) }
-    tc_ret body = tcCmd env body ([], res_ty)
 
 
 -----------------------------------------------------------------
@@ -256,7 +253,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                              e_res_ty
 
                -- Check expr
-       ; (expr', lie) <- popArrowBinders (getLIE (tcCheckRho expr e_ty))
+       ; (expr', lie) <- escapeArrowScope (getLIE (tcCheckRho expr e_ty))
        ; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie
 
                -- Check that the polymorphic variable hasn't been unified with anything
@@ -295,7 +292,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                      not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
                     (badFormFun i tup_ty')
 
-          ; tcCmdTop (CmdEnv { cmd_arr = b }) cmd (arg_tys, s) }
+          ; tcCmdTop (env { cmd_arr = b }) cmd (arg_tys, s) }
 
     unscramble :: TcType -> (TcType, [TcType])
     -- unscramble ((w,s1) .. sn)       =  (w, [s1..sn])