From: ross <unknown>
Date: Wed, 15 Sep 2004 17:48:10 +0000 (+0000)
Subject: [project @ 2004-09-15 17:48:08 by ross]
X-Git-Tag: Initial_conversion_from_CVS_complete~1595
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=daf679859c603e550e1d232ddf7f7b28e8db4a8e;hp=346166a44c7989380e4b1ca096fb6afceda47df2;p=ghc-hetmet.git

[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
--- 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
--- 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