X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGRHSs.lhs;h=0a0b58e47b15f4924e208dd578ead1cf00574f74;hb=b3912ef355dee6a459d2839e804a71632d52772c;hp=a66c33af732d2e6096c0ebd9457ccb0e13dd63e2;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index a66c33a..0a0b58e 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -4,54 +4,59 @@
 \section[TcGRHSs]{Typecheck guarded right-hand-sides}
 
 \begin{code}
-module TcGRHSs ( tcGRHSsAndBinds ) where
+#include "HsVersions.h"
 
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( boolTy )
-import E		( growE_LVE, E, LVE(..), TCE(..), UniqFM, CE(..) )
-			-- TCE and CE for pragmas only
-import Errors		( UnifyErrContext(..) )
-import LIE		( plusLIE, LIE )
-import TcBinds		( tcLocalBindsAndThen )
-import TcExpr		( tcExpr )
-import Unify		( unifyTauTy )
-import Util		-- pragmas only
-\end{code}
+module TcGRHSs ( tcGRHSsAndBinds ) where
 
-\begin{code}
-tcGRHSs :: E -> [RenamedGRHS] -> TcM ([TypecheckedGRHS], LIE, UniType)
+IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(TcLoop) -- for paranoia checking
+#endif
 
-tcGRHSs e [grhs]
-  = tcGRHS e grhs	`thenTc` \ (grhs', lie, ty) ->
-    returnTc ([grhs'], lie, ty)
+import HsSyn		( GRHSsAndBinds(..), GRHS(..), MonoBinds, Stmt, DoOrListComp(..),
+			  HsExpr, HsBinds(..), InPat, OutPat, Sig, Fake )
+import RnHsSyn		( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
+import TcHsSyn		( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS) )
 
-tcGRHSs e gs@(grhs:grhss)
-  = tcGRHS  e grhs	`thenTc` \ (grhs',  lie1, ty1) ->
-    tcGRHSs e grhss	`thenTc` \ (grhss', lie2, ty2) ->
+import TcMonad
+import Inst		( Inst, SYN_IE(LIE), plusLIE )
+import Kind             ( mkTypeKind )
+import TcBinds		( tcBindsAndThen )
+import TcExpr		( tcExpr, tcStmt )
+import TcType		( SYN_IE(TcType), TcIdOcc(..), newTyVarTy ) 
 
-    unifyTauTy ty1 ty2 (GRHSsBranchCtxt gs) `thenTc_`
+import TysWiredIn	( boolTy )
+\end{code}
 
-    returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
+\begin{code}
+tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
 
+tcGRHSs expected_ty [grhs]
+  = tcGRHS expected_ty grhs		`thenTc` \ (grhs', lie) ->
+    returnTc ([grhs'], lie)
 
-tcGRHS e (OtherwiseGRHS expr locn)
-  = addSrcLocTc locn	 (
-    tcExpr e expr	`thenTc` \ (expr, lie, ty) ->
-    returnTc (OtherwiseGRHS expr locn, lie, ty)
-    )
+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 e (GRHS guard expr locn)
-  = addSrcLocTc locn		 (
-    tcExpr e guard		`thenTc` \ (guard2, guard_lie, guard_ty) ->
 
-    unifyTauTy guard_ty boolTy (GRHSsGuardCtxt guard) `thenTc_`
+tcGRHS expected_ty (OtherwiseGRHS expr locn)
+  = tcAddSrcLoc locn	 $
+    tcExpr expr	expected_ty        `thenTc`    \ (expr, lie) ->
+    returnTc (OtherwiseGRHS expr locn, lie)
 
-    tcExpr e expr		`thenTc` \ (expr2, expr_lie, expr_ty) ->
+tcGRHS expected_ty (GRHS guard expr locn)
+  = tcAddSrcLoc locn		$
+    tc_stmts  guard	`thenTc` \ ((guard', expr'), lie) ->
+    returnTc (GRHS guard' expr' locn, lie)
+  where
+    tc_stmts []		  = tcExpr expr expected_ty	  `thenTc`    \ (expr2, expr_lie) ->
+			    returnTc (([], expr2), expr_lie)
+    tc_stmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $
+			    tc_stmts stmts
 
-    returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty)
-    )
+    combine stmt _ (stmts, expr) = (stmt:stmts, expr)
 \end{code}
 
 
@@ -59,18 +64,17 @@ tcGRHS e (GRHS guard expr locn)
 pieces.
 
 \begin{code}
-tcGRHSsAndBinds :: E 
+tcGRHSsAndBinds :: TcType s			-- Expected type of RHSs
 		-> RenamedGRHSsAndBinds
-		-> TcM (TypecheckedGRHSsAndBinds, LIE, UniType)
-
-tcGRHSsAndBinds e (GRHSsAndBindsIn grhss binds)
-  = tcLocalBindsAndThen e 
-	 combiner binds 
-	 (\e -> tcGRHSs e grhss		`thenTc` (\ (grhss', lie, ty) ->
-		returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty) 
-		)
+		-> TcM s (TcGRHSsAndBinds s, LIE s)
+
+tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
+  = tcBindsAndThen
+	 combiner binds
+	 (tcGRHSs expected_ty grhss	`thenTc` \ (grhss', lie) ->
+	  returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
 	 )
   where
-    combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
-	= GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+    combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
+ 	= GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
 \end{code}