[project @ 2004-09-15 17:48:08 by ross]

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

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index 5c8c3b5..8ea84ed 100644 (file)
--- a/ghc/compiler/typecheck/TcArrows.lhs
+++ b/ghc/compiler/typecheck/TcArrows.lhs
@@ -130,14 +130,12 @@ tc_cmd env (HsIf pred b1 b2) res_ty
 
 -------------------------------------------
 --             Arrow application
---                 (f -< a)   or   (f =< a)
+--                 (f -< a)   or   (f -<< a)
 
 tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)   $
     do  { arg_ty <- newTyVarTy openTypeKind
-       ; let fun_ty = mkCmdArrTy env arg_ty res_ty
-
-       ; checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
+       ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
 
        ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
 
@@ -148,7 +146,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
        -- Before type-checking f, remove the "arrow binders" from the 
        -- environment in the (-<) case.  
        -- Local bindings, inside the enclosing proc, are not in scope 
-       -- inside f.  In the higher-order case (--<), they are.
+       -- inside f.  In the higher-order case (-<<), they are.
     pop_arrow_binders tc = case ho_app of
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> popArrowBinders tc
@@ -234,7 +232,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
 
 tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)      
   = addErrCtxt (cmdCtxt cmd)   $
-    do { cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..])
+    do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
        ; w_tv       <- newSigTyVar liftedTypeKind
        ; let w_ty = mkTyVarTy w_tv
 
@@ -264,9 +262,9 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
   where
        -- Make the types       
        --      b, ((e,s1) .. sm), s
-    new_cmd_ty :: (LHsCmdTop Name, Int)
+    new_cmd_ty :: LHsCmdTop Name -> Int
               -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
-    new_cmd_ty (cmd,i)
+    new_cmd_ty cmd i
          = do  { b_ty   <- newTyVarTy arrowTyConKind
                ; tup_ty <- newTyVarTy liftedTypeKind
                        -- We actually make a type variable for the tuple