[project @ 2003-10-10 07:34:34 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcArrows.lhs

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index 026c006..eda193a 100644 (file)
--- a/ghc/compiler/typecheck/TcArrows.lhs
+++ b/ghc/compiler/typecheck/TcArrows.lhs
@@ -11,13 +11,14 @@ module TcArrows ( tcProc ) where
 import {-# SOURCE #-}  TcExpr( tcCheckRho )
 
 import HsSyn
-import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet )
+import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet )
 
-import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts )
+import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
+                 TcMatchCtxt(..), tcMatchesCase )
 
 import TcType  ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
                  mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType )
-import TcMType ( newTyVar, newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
+import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
 import TcBinds ( tcBindsAndThen )
 import TcSimplify ( tcSimplifyCheck )
 import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
@@ -27,7 +28,7 @@ import TysWiredIn ( boolTy, pairTyCon )
 import VarSet 
 import Type    ( Kind,
                  mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
-import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmd, RenamedHsCmdTop )
+import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop )
 
 import Outputable
 import Util    ( lengthAtLeast )
@@ -99,6 +100,20 @@ tcCmd env (HsLet binds body) res_ty
   = tcBindsAndThen HsLet binds $
     tcCmd env body res_ty
 
+tcCmd env in_cmd@(HsCase scrut matches src_loc) (stk, res_ty)
+  = addSrcLoc src_loc                  $
+    addErrCtxt (cmdCtxt in_cmd)                $
+    tcMatchesCase match_ctxt matches (Check res_ty)
+                                       `thenM` \ (scrut_ty, matches') ->
+    addErrCtxt (caseScrutCtxt scrut)   (
+      tcCheckRho scrut scrut_ty
+    )                                  `thenM` \ scrut' ->
+    returnM (HsCase scrut' matches' src_loc)
+  where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = mc_body }
+    mc_body body (Check res_ty') = tcCmd env body (stk, res_ty')
+
 tcCmd env (HsIf pred b1 b2 src_loc) res_ty
   = addSrcLoc src_loc  $ 
     do         { pred' <- tcCheckRho pred boolTy
@@ -133,6 +148,18 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> popArrowBinders tc
 
+-------------------------------------------
+--             Command application
+
+tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)   $
+    do  { arg_ty <- newTyVarTy openTypeKind
+
+       ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
+
+       ; arg' <- tcCheckRho arg arg_ty
+
+       ; return (HsApp fun' arg') }
 
 -------------------------------------------
 --             Lambda
@@ -310,6 +337,9 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
 \begin{code}
 cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd
 
+caseScrutCtxt cmd
+  = hang (ptext SLIT("In the scrutinee of a case command:")) 4 (ppr cmd)
+
 nonEmptyCmdStkErr cmd
   = hang (ptext SLIT("Non-empty command stack at command:"))
         4 (ppr cmd)