[project @ 1997-07-26 03:26:10 by sof]

tcGRHS + tcGRHSsAndBinds carry extra expected type arg

diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index ef582ea..4bc3bf5 100644 (file)
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -16,48 +16,47 @@ IMPORT_DELOOPER(TcLoop) -- for paranoia checking
 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), TcIdOcc(..) )
+import TcHsSyn         ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS) )
 
 import TcMonad
 import Inst            ( Inst, SYN_IE(LIE), plusLIE )
+import Kind             ( mkTypeKind )
 import TcBinds         ( tcBindsAndThen )
 import TcExpr          ( tcExpr, tcStmt )
-import TcType          ( SYN_IE(TcType) ) 
-import Unify           ( unifyTauTy )
+import TcType          ( SYN_IE(TcType), TcIdOcc(..), newTyVarTy ) 
 
 import TysWiredIn      ( boolTy )
 \end{code}
 
 \begin{code}
-tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
+tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
 
-tcGRHSs [grhs]
-  = tcGRHS grhs                `thenTc` \ (grhs', lie, ty) ->
-    returnTc ([grhs'], lie, ty)
+tcGRHSs expected_ty [grhs]
+  = tcGRHS expected_ty grhs            `thenTc` \ (grhs', lie) ->
+    returnTc ([grhs'], lie)
 
-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: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)
+tcGRHS expected_ty (OtherwiseGRHS expr locn)
   = tcAddSrcLoc locn    $
-    tcExpr expr        `thenTc` \ (expr, lie, ty) ->
-    returnTc (OtherwiseGRHS expr locn, lie, ty)
+    tcExpr expr        expected_ty        `thenTc`    \ (expr, lie) ->
+    returnTc (OtherwiseGRHS expr locn, lie)
 
-tcGRHS (GRHS guard expr locn)
+tcGRHS expected_ty (GRHS guard expr locn)
   = tcAddSrcLoc locn           $
-    tc_stmts  guard    `thenTc` \ ((guard', expr', ty), lie) ->
-    returnTc (GRHS guard' expr' locn, lie, ty)
+    tc_stmts  guard    `thenTc` \ ((guard', expr'), lie) ->
+    returnTc (GRHS guard' expr' locn, lie)
   where
-    tc_stmts []                  = tcExpr expr         `thenTc` \ (expr2, expr_lie, expr_ty) ->
-                           returnTc (([], expr2, expr_ty), expr_lie)
+    tc_stmts []                  = tcExpr expr expected_ty       `thenTc`    \ (expr2, expr_lie) ->
+                           returnTc (([], expr2), expr_lie)
     tc_stmts (stmt:stmts) = tcStmt tcExpr ListComp (\x->x) combine stmt $
                            tc_stmts stmts
 
-    combine stmt _ (stmts, expr, ty) = (stmt:stmts, expr, ty)
+    combine stmt _ (stmts, expr) = (stmt:stmts, expr)
 \end{code}
 
 
@@ -65,17 +64,17 @@ 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)
 
-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)
-        )                      `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
-    returnTc (grhss_and_binds', lie, result_ty)
+        (tcGRHSs expected_ty grhss     `thenTc` \ (grhss', lie) ->
+         returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
+        )
   where
-    combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty) 
+    combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
        = GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
 \end{code}