[project @ 2006-01-18 11:13:06 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index 08682ae..38ca1f6 100644 (file)
--- a/ghc/compiler/typecheck/TcArrows.lhs
+++ b/ghc/compiler/typecheck/TcArrows.lhs
@@ -11,7 +11,7 @@ module TcArrows ( tcProc ) where
 import {-# SOURCE #-}  TcExpr( tcCheckRho, tcInferRho )
 
 import HsSyn
-import TcHsSyn (  mkHsLet )
+import TcHsSyn (  mkHsDictLet )
 
 import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
                   TcMatchCtxt(..), tcMatchesCase )
@@ -20,7 +20,7 @@ import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
                  mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType, 
                  SkolemInfo(..) )
 import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType )
-import TcBinds ( tcBindsAndThen )
+import TcBinds ( tcLocalBinds )
 import TcSimplify ( tcSimplifyCheck )
 import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
 import TcRnMonad
@@ -50,12 +50,12 @@ 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])
 
-       ; proc_env <- getEnv
-       ; let cmd_env = CmdEnv { cmd_arr = arr_ty, cmd_proc_env = proc_env }
+       ; let cmd_env = CmdEnv { cmd_arr = arr_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
@@ -72,36 +72,16 @@ tcProc pat cmd exp_ty
 %*                                                                     *
 %************************************************************************
 
-In arrow notation, a variable bound by a proc (or enclosed let/kappa)
-is not in scope to the left of an arrow tail (-<) or the head of (|..|).
-For example
-
-       proc x -> (e1 -< e2)
-
-Here, x is not in scope in e1, but it is in scope in e2.  This can get 
-a bit complicated:
-
-       let x = 3 in
-       proc y -> (proc z -> e1) -< e2
-
-Here, x and z are in scope in e1, but y is not.  We implement this by
-recording the environment when passing a proc, and returning to that
-(using popArrowBinders) on the left of -< and the head of (|..|).
-
 \begin{code}
 type CmdStack = [TcTauType]
 data CmdEnv
   = CmdEnv {
-       cmd_arr         :: TcType, -- arrow type constructor, of kind *->*->*
-       cmd_proc_env    :: Env TcGblEnv TcLclEnv -- environment of the proc
+       cmd_arr         :: TcType -- arrow type constructor, of kind *->*->*
     }
 
 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
 
-popArrowBinders :: CmdEnv -> TcM a -> TcM a
-popArrowBinders env tc = setEnv (cmd_proc_env env) tc
-
 ---------------------------------------
 tcCmdTop :: CmdEnv 
          -> LHsCmdTop Name
@@ -131,11 +111,10 @@ tc_cmd env (HsPar cmd) res_ty
        ; return (HsPar cmd') }
 
 tc_cmd env (HsLet binds (L body_loc body)) res_ty
-  = tcBindsAndThen glue binds  $
-    setSrcSpan body_loc        $
-    tc_cmd env body res_ty
-  where
-    glue binds expr = HsLet [binds] (L body_loc expr)
+  = do { (binds', body') <- tcLocalBinds binds         $
+                            setSrcSpan body_loc        $
+                            tc_cmd env body res_ty
+       ; return (HsLet binds' (L body_loc body')) }
 
 tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd)                $
@@ -165,19 +144,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 env tc
+       HsFirstOrderApp  -> escapeArrowScope tc
 
 -------------------------------------------
 --             Command application
@@ -221,9 +200,9 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g
     pg_ctxt    = PatGuard match_ctxt
 
     tc_grhss (GRHSs grhss binds)
-       = tcBindsAndThen glueBindsOnGRHSs binds $
-         do { grhss' <- mappM (wrapLocM tc_grhs) grhss
-            ; return (GRHSs grhss' []) }
+       = do { (binds', grhss') <- tcLocalBinds binds $
+                                  mappM (wrapLocM tc_grhs) grhss
+            ; return (GRHSs grhss' binds') }
 
     tc_grhs (GRHS guards body)
        = do { (guards', rhs') <- tcStmts pg_ctxt
@@ -273,7 +252,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                              e_res_ty
 
                -- Check expr
-       ; (expr', lie) <- popArrowBinders env (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
@@ -284,7 +263,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                -- the s1..sm and check each cmd
        ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
 
-       ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsLet inst_binds expr')) fixity cmds')
+       ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsDictLet inst_binds expr')) fixity cmds')
        }
   where
        -- Make the types