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

arrow notation: allow arrow applications (f -< a) to take a non-empty
command stack, as suggested by Sebastian Boldt <Sebastian.Boldt@arcor.de>.

diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs
index 6568eb1..8e9ce4c 100644 (file)
--- a/ghc/compiler/deSugar/DsArrows.lhs
+++ b/ghc/compiler/deSugar/DsArrows.lhs
@@ -289,12 +289,14 @@ dsCmd   :: DsCmdEnv               -- arrow combinators
        -> DsM (CoreExpr,       -- desugared expression
                IdSet)          -- set of local vars that occur free
 
---     A |- f :: a t t'
+--     A |- f :: a (t*ts) t'
 --     A, xs |- arg :: t
---     ---------------------------
---     A | xs |- f -< arg :: [] t'     ---> arr (\ (xs) -> arg) >>> f
+--     -----------------------------
+--     A | xs |- f -< arg :: [ts] t'
+--
+--             ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
 
-dsCmd ids local_vars env_ids [] res_ty
+dsCmd ids local_vars env_ids stack res_ty
        (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
   = let
        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -303,18 +305,26 @@ dsCmd ids local_vars env_ids [] res_ty
     in
     dsLExpr arrow                      `thenDs` \ core_arrow ->
     dsLExpr arg                                `thenDs` \ core_arg ->
-    matchEnvStack env_ids [] core_arg  `thenDs` \ core_make_arg ->
-    returnDs (do_map_arrow ids env_ty arg_ty res_ty
+    mappM newSysLocalDs stack          `thenDs` \ stack_ids ->
+    matchEnvStack env_ids stack_ids
+       (foldl mkCorePairExpr core_arg (map Var stack_ids))
+                                       `thenDs` \ core_make_arg ->
+    returnDs (do_map_arrow ids
+               (envStackType env_ids stack)
+               arg_ty
+               res_ty
                core_make_arg
                core_arrow,
              exprFreeVars core_arg `intersectVarSet` local_vars)
 
---     A, xs |- f :: a t t'
+--     A, xs |- f :: a (t*ts) t'
 --     A, xs |- arg :: t
---     ---------------------------
---     A | xs |- f -<< arg :: [] t'    ---> arr (\ (xs) -> (f,arg)) >>> app
+--     ------------------------------
+--     A | xs |- f -<< arg :: [ts] t'
+--
+--             ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
 
-dsCmd ids local_vars env_ids [] res_ty
+dsCmd ids local_vars env_ids stack res_ty
        (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
   = let
        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -323,9 +333,15 @@ dsCmd ids local_vars env_ids [] res_ty
     in
     dsLExpr arrow                      `thenDs` \ core_arrow ->
     dsLExpr arg                                `thenDs` \ core_arg ->
-    matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
+    mappM newSysLocalDs stack          `thenDs` \ stack_ids ->
+    matchEnvStack env_ids stack_ids
+       (mkCorePairExpr core_arrow
+               (foldl mkCorePairExpr core_arg (map Var stack_ids)))
                                        `thenDs` \ core_make_pair ->
-    returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
+    returnDs (do_map_arrow ids
+               (envStackType env_ids stack)
+               (mkCorePairTy arrow_ty arg_ty)
+               res_ty
                core_make_pair
                (do_app ids arg_ty res_ty),
              (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index 5a76356..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