X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGRHSs.lhs;h=77a0eab01d092b223d818023b924b225b56a583d;hb=fcc5fed0965ab75350748a14f05383821dbe601b;hp=7072a552ff103bb22aea75f2654635d70df0eb42;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index 7072a55..77a0eab 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -4,53 +4,47 @@
 \section[TcGRHSs]{Typecheck guarded right-hand-sides}
 
 \begin{code}
-#include "HsVersions.h"
-
 module TcGRHSs ( tcGRHSsAndBinds ) where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(TcLoop) -- for paranoia checking
+#include "HsVersions.h"
 
-import HsSyn		( GRHSsAndBinds(..), GRHS(..),
-			  HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
-import RnHsSyn		( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
-import TcHsSyn		( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
+import HsSyn		( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..) )
+import RnHsSyn		( RenamedGRHSsAndBinds, RenamedGRHS )
+import TcHsSyn		( TcGRHSsAndBinds, TcGRHS )
 
 import TcMonad
-import Inst		( Inst, SYN_IE(LIE), plusLIE )
+import Inst		( Inst, LIE, plusLIE )
 import TcBinds		( tcBindsAndThen )
-import TcExpr		( tcExpr )
-import TcType		( SYN_IE(TcType) ) 
-import Unify		( unifyTauTy )
+import TcExpr		( tcExpr, tcStmt )
+import TcType		( TcType, newTyVarTy ) 
+import TcEnv		( TcIdOcc(..) )
 
 import TysWiredIn	( boolTy )
 \end{code}
 
 \begin{code}
-tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
-
-tcGRHSs [grhs]
-  = tcGRHS grhs		`thenTc` \ (grhs', lie, ty) ->
-    returnTc ([grhs'], lie, ty)
+tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
 
-tcGRHSs (grhs:grhss)
-  = tcGRHS  grhs	`thenTc` \ (grhs',  lie1, ty1) ->
-    tcGRHSs grhss	`thenTc` \ (grhss', lie2, ty2) ->
-    unifyTauTy ty1 ty2	`thenTc_`
-    returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
+tcGRHSs expected_ty [grhs]
+  = tcGRHS expected_ty grhs		`thenTc` \ (grhs', lie) ->
+    returnTc ([grhs'], lie)
 
+tcGRHSs expected_ty (grhs:grhss)
+  = tcGRHS  expected_ty grhs	`thenTc` \ (grhs',  lie1) ->
+    tcGRHSs expected_ty grhss	`thenTc` \ (grhss', lie2) ->
+    returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
 
-tcGRHS (OtherwiseGRHS expr locn)
-  = tcAddSrcLoc locn	 $
-    tcExpr expr	`thenTc` \ (expr, lie, ty) ->
-    returnTc (OtherwiseGRHS expr locn, lie, ty)
-
-tcGRHS (GRHS guard expr locn)
+tcGRHS expected_ty (GRHS guard expr locn)
   = tcAddSrcLoc locn		$
-    tcExpr guard		`thenTc` \ (guard2, guard_lie, guard_ty) ->
-    unifyTauTy boolTy guard_ty	`thenTc_`
-    tcExpr expr			`thenTc` \ (expr2, expr_lie, expr_ty) ->
-    returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty)
+    tcStmts guard		`thenTc` \ ((guard', expr'), lie) ->
+    returnTc (GRHS guard' expr' locn, lie)
+  where
+    tcStmts []		 = tcExpr expr expected_ty	  `thenTc`    \ (expr2, expr_lie) ->
+	                   returnTc (([], expr2), expr_lie)
+    tcStmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $
+			   tcStmts stmts
+
+    combine stmt _ (stmts, expr) = (stmt:stmts, expr)
 \end{code}
 
 
@@ -58,16 +52,20 @@ tcGRHS (GRHS guard expr locn)
 pieces.
 
 \begin{code}
-tcGRHSsAndBinds :: RenamedGRHSsAndBinds
-		-> TcM s (TcGRHSsAndBinds s, LIE s, TcType s)
+tcGRHSsAndBinds :: TcType s			-- Expected type of RHSs
+		-> RenamedGRHSsAndBinds
+		-> TcM s (TcGRHSsAndBinds s, LIE s)
+
+-- Shortcut for common case
+tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)	
+  = tcGRHSs expected_ty grhss	       `thenTc` \ (grhss', lie) ->
+    returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
 
-tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
   = tcBindsAndThen
 	 combiner binds
-	 (tcGRHSs grhss		`thenTc` \ (grhss', lie, ty) ->
-	  returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty)
-	 )
+	 (tcGRHSs expected_ty grhss)
   where
-    combiner binds1 (GRHSsAndBindsOut grhss binds2 ty) 
- 	= GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+    combiner is_rec binds grhss
+ 	= GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
 \end{code}