X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsArrows.lhs;h=111e0bccd04882dfddf0e3a054d2cd851d8b4213;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=4db17ea00f87678d8e99745ea879bd98f43cffd0;hpb=d7c402a3cedbe49345a34f2e58a3f3050638dcb4;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs
index 4db17ea..111e0bc 100644
--- a/ghc/compiler/deSugar/DsArrows.lhs
+++ b/ghc/compiler/deSugar/DsArrows.lhs
@@ -13,7 +13,7 @@ import DsUtils		( mkErrorAppDs,
 			  mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
 			  mkTupleCase, mkBigCoreTup, mkTupleType,
 			  mkTupleExpr, mkTupleSelector,
-			  dsReboundNames, lookupReboundName )
+			  dsSyntaxTable, lookupEvidence )
 import DsMonad
 
 import HsSyn
@@ -24,7 +24,7 @@ import TcHsSyn		( hsPatType )
 --     So WATCH OUT; check each use of split*Ty functions.
 -- Sigh.  This is a pain.
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
 
 import TcType		( Type, tcSplitAppTy, mkFunTy )
 import Type		( mkTyConApp, funArgTy )
@@ -48,7 +48,7 @@ import HsUtils		( collectPatBinders, collectPatsBinders )
 import VarSet		( IdSet, mkVarSet, varSetElems,
 			  intersectVarSet, minusVarSet, extendVarSetList, 
 			  unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc		( Located(..), unLoc, noLoc, getLoc )
+import SrcLoc		( Located(..), unLoc, noLoc )
 \end{code}
 
 \begin{code}
@@ -57,17 +57,17 @@ data DsCmdEnv = DsCmdEnv {
 	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
     }
 
-mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
+mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
 mkCmdEnv ids
-  = dsReboundNames ids			`thenDs` \ (meth_binds, ds_meths) ->
+  = dsSyntaxTable ids			`thenDs` \ (meth_binds, ds_meths) ->
     return $ DsCmdEnv {
 		meth_binds = meth_binds,
-		arr_id	   = lookupReboundName ds_meths arrAName,
-		compose_id = lookupReboundName ds_meths composeAName,
-		first_id   = lookupReboundName ds_meths firstAName,
-		app_id	   = lookupReboundName ds_meths appAName,
-		choice_id  = lookupReboundName ds_meths choiceAName,
-		loop_id	   = lookupReboundName ds_meths loopAName
+		arr_id	   = Var (lookupEvidence ds_meths arrAName),
+		compose_id = Var (lookupEvidence ds_meths composeAName),
+		first_id   = Var (lookupEvidence ds_meths firstAName),
+		app_id	   = Var (lookupEvidence ds_meths appAName),
+		choice_id  = Var (lookupEvidence ds_meths choiceAName),
+		loop_id	   = Var (lookupEvidence ds_meths loopAName)
 	    }
 
 bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
@@ -388,7 +388,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
 --		---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
 
 dsCmd ids local_vars env_ids stack res_ty
-    (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _))
+    (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
   = let
 	pat_vars = mkVarSet (collectPatsBinders pats)
 	local_vars' = local_vars `unionVarSet` pat_vars
@@ -555,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
 
 dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
   = let
-	defined_vars = mkVarSet (map unLoc (collectGroupBinders binds))
+	defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
 	local_vars' = local_vars `unionVarSet` defined_vars
     in
     dsfixCmd ids local_vars' stack res_ty body
 				`thenDs` \ (core_body, free_vars, env_ids') ->
     mappM newSysLocalDs stack		`thenDs` \ stack_ids ->
     -- build a new environment, plus the stack, using the let bindings
-    dsLet binds (buildEnvStack env_ids' stack_ids)
+    dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
 					`thenDs` \ core_binds ->
     -- match the old environment and stack against the input
     matchEnvStack env_ids stack_ids core_binds
@@ -575,8 +575,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
 			core_body,
 	exprFreeVars core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
-  = dsCmdDo ids local_vars env_ids res_ty stmts
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
+  = dsCmdDo ids local_vars env_ids res_ty stmts body
 
 --	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 --	A | xs |- ci :: [tsi] ti
@@ -650,7 +650,8 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 				-- This is typically fed back,
 				-- so don't pull on it too early
 	-> Type			-- return type of the statement
-	-> [LStmt Id]	-- statements to desugar
+	-> [LStmt Id]		-- statements to desugar
+	-> LHsExpr Id		-- body
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet)		-- set of local vars that occur free
 
@@ -658,16 +659,16 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 --	--------------------------
 --	A | xs |- do { c } :: [] t
 
-dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)]
-  = dsLCmd ids local_vars env_ids [] res_ty cmd
+dsCmdDo ids local_vars env_ids res_ty [] body
+  = dsLCmd ids local_vars env_ids [] res_ty body
 
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
   = let
 	bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
 	local_vars' = local_vars `unionVarSet` bound_vars
     in
     fixDs (\ ~(_,_,env_ids') ->
-	dsCmdDo ids local_vars' env_ids' res_ty stmts
+	dsCmdDo ids local_vars' env_ids' res_ty stmts body
 					`thenDs` \ (core_stmts, fv_stmts) ->
 	returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
 				`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
@@ -708,7 +709,7 @@ dsCmdStmt
 --		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 --			arr snd >>> ss
 
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
   = dsfixCmd ids local_vars [] c_ty cmd
 				`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
     matchEnvStack env_ids []
@@ -740,7 +741,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
 
-dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
   = dsfixCmd ids local_vars [] (hsPatType pat) cmd
 				`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
     let
@@ -797,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
 
 dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
     -- build a new environment using the let bindings
-  = dsLet binds (mkTupleExpr out_ids)	`thenDs` \ core_binds ->
+  = dsLocalBinds binds (mkTupleExpr out_ids)	`thenDs` \ core_binds ->
     -- match the old environment against the input
     matchEnvStack env_ids [] core_binds	`thenDs` \ core_map ->
     returnDs (do_arr ids
@@ -820,8 +821,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
 --			first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
 --			arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 
-dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
-  = let
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
+  = let		-- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
 	env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
 	env2_ids = varSetElems env2_id_set
 	env2_ty = mkTupleType env2_ids
@@ -885,7 +886,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
 
     -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
 
-    mappM dsLExpr rhss		`thenDs` \ core_rhss ->
+    mappM dsExpr rhss		`thenDs` \ core_rhss ->
     let
 	later_tuple = mkTupleExpr later_ids
 	later_ty = mkTupleType later_ids
@@ -1008,13 +1009,12 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
   = let
 	defined_vars = mkVarSet (collectPatsBinders pats)
 			`unionVarSet`
-		       mkVarSet (map unLoc (collectGroupBinders binds))
+		       mkVarSet (map unLoc (collectLocalBinders binds))
     in
     [(expr, 
-      mkVarSet (map unLoc (collectStmtsBinders stmts)) 
+      mkVarSet (map unLoc (collectLStmtsBinders stmts)) 
 	`unionVarSet` defined_vars) 
-    | L _ (GRHS stmts) <- grhss,
-      let L _ (ResultStmt expr) = last stmts]
+    | L _ (GRHS stmts expr) <- grhss]
 \end{code}
 
 Replace the leaf commands in a match
@@ -1037,8 +1037,8 @@ replaceLeavesGRHS
 	-> LGRHS Id	-- rhss of a case command
 	-> ([LHsExpr Id],-- remaining leaf expressions
 	    LGRHS Id)	-- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts))
-  = (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)])))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+  = (leaves, L loc (GRHS stmts leaf))
 \end{code}
 
 Balanced fold of a non-empty list.