From: simonpj <unknown>
Date: Mon, 4 Apr 2005 15:22:25 +0000 (+0000)
Subject: [project @ 2005-04-04 15:22:25 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~819
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=da5cbb6395529a8605ad317c4ca605ec02d35128;p=ghc-hetmet.git

[project @ 2005-04-04 15:22:25 by simonpj]
Further HsSyn wibbles
---

diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index 4294d31..d934b7c 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -55,8 +55,8 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id]	-- These are to build a MatchContext
 	-> Type					-- Type of RHS
 	-> DsM MatchResult
 
-dsGRHSs kind pats (GRHSs grhss binds) rhs_ty
-  = mappM (dsGRHS kind pats rhs_ty) grhss	`thenDs` \ match_results ->
+dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
+  = mappM (dsGRHS hs_ctx pats rhs_ty) grhss	`thenDs` \ match_results ->
     let 
 	match_result1 = foldr1 combineMatchResults match_results
 	match_result2 = adjustMatchResultDs (dsLet binds) match_result1
@@ -64,9 +64,8 @@ dsGRHSs kind pats (GRHSs grhss binds) rhs_ty
     in
     returnDs match_result2
 
-dsGRHS kind pats rhs_ty (L loc (GRHS guards rhs))
-  = matchGuard (map unLoc guards) (DsMatchContext kind pats loc)
-	       rhs rhs_ty
+dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
+  = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
 \end{code}
 
 
@@ -77,43 +76,43 @@ dsGRHS kind pats rhs_ty (L loc (GRHS guards rhs))
 %************************************************************************
 
 \begin{code}
-matchGuard :: [Stmt Id] 	-- Guard
-           -> DsMatchContext	-- Context
-	   -> LHsExpr Id	-- RHS
-	   -> Type		-- Type of RHS of guard
-	   -> DsM MatchResult
+matchGuards :: [Stmt Id] 		-- Guard
+            -> HsMatchContext Name	-- Context
+	    -> LHsExpr Id		-- RHS
+	    -> Type			-- Type of RHS of guard
+	    -> DsM MatchResult
 
 -- See comments with HsExpr.Stmt re what an ExprStmt means
 -- Here we must be in a guard context (not do-expression, nor list-comp)	
 
-matchGuard [] ctx rhs rhs_ty
+matchGuards [] ctx rhs rhs_ty
   = do	{ core_rhs <- dsLExpr rhs
 	; return (cantFailMatchResult core_rhs) }
 
 	-- ExprStmts must be guards
 	-- Turn an "otherwise" guard is a no-op
-matchGuard (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
+matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
   |  v `hasKey` otherwiseIdKey
   || v `hasKey` getUnique trueDataConId	
 	-- trueDataConId doesn't have the same 
 	-- unique as trueDataCon
-  = matchGuard stmts ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty
 
-matchGuard (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
-  = matchGuard stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
     dsLExpr expr			`thenDs` \ pred_expr ->
     returnDs (mkGuardedMatchResult pred_expr match_result)
 
-matchGuard (LetStmt binds : stmts) ctx rhs rhs_ty
-  = matchGuard stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
     returnDs (adjustMatchResultDs (dsLet binds) match_result)
 	-- NB the dsLet occurs inside the match_result
 	-- Reason: dsLet takes the body expression as its argument
 	--	   so we can't desugar the bindings without the
 	--	   body expression in hand
 
-matchGuard (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
-  = matchGuard stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
+matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
+  = matchGuards stmts ctx rhs rhs_ty	`thenDs` \ match_result ->
     dsLExpr bind_rhs			`thenDs` \ core_rhs ->
     matchSinglePat core_rhs ctx pat rhs_ty match_result
 \end{code}
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index cc87907..fe5b95b 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -113,9 +113,6 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
 	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 	       | otherwise                           = empty
 
-pp_context NoMatchContext msg rest_of_msg_fun
-  = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
-
 pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
   = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
 	        sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
diff --git a/ghc/compiler/typecheck/TcExpr.lhs-boot b/ghc/compiler/typecheck/TcExpr.lhs-boot
index ff93c46..8b1c06d 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs-boot
+++ b/ghc/compiler/typecheck/TcExpr.lhs-boot
@@ -1,6 +1,6 @@
 \begin{code}
 module TcExpr where
-import HsSyn	( LHsExpr )
+import HsSyn	( HsExpr, LHsExpr )
 import Name	( Name )
 import Var	( Id )
 import TcType	( TcType, Expected )