[project @ 2000-05-25 12:41:14 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 8a27ea5..0fb4aba 100644 (file)
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -12,13 +12,14 @@ import {-# SOURCE #-}       TcExpr( tcExpr )
 
 import HsSyn           ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
                          MonoBinds(..), StmtCtxt(..), Stmt(..),
-                         pprMatch, getMatchLoc
+                         pprMatch, getMatchLoc, consLetStmt,
+                         mkMonoBind
                        )
 import RnHsSyn         ( RenamedMatch, RenamedGRHSs, RenamedStmt )
 import TcHsSyn         ( TcMatch, TcGRHSs, TcStmt )
 
 import TcMonad
-import TcMonoType      ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
+import TcMonoType      ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
 import Inst            ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
 import TcEnv           ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
 import TcPat           ( tcPat, tcPatBndr_NoSigs, polyPatSig )
@@ -149,7 +150,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- Check that the scoped type variables from the patterns
        -- have not been constrained
         tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids)          (
-               checkSigTyVars sig_tyvars
+               checkSigTyVars sig_tyvars emptyVarSet
        )                                                       `thenTc_`
 
        -- *Now* we're free to unify with expected_ty
@@ -174,7 +175,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- STEP 3: Unify with the rhs type signature if any
        (case maybe_rhs_sig of
            Nothing  -> returnTc ()
-           Just sig -> tcHsType sig    `thenTc` \ sig_ty ->
+           Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
 
                        -- Check that the signature isn't a polymorphic one, which
                        -- we don't permit (at present, anyway)
@@ -190,7 +191,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- STEP 5: Check for existentially bound type variables
        tcExtendGlobalTyVars (tyVarsOfType rhs_ty)      (
            tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids)       $
-           checkSigTyVars ex_tv_list                           `thenTc` \ zonked_ex_tvs ->
+           checkSigTyVars ex_tv_list emptyVarSet               `thenTc` \ zonked_ex_tvs ->
            tcSimplifyAndCheck 
                (text ("the existential context of a data constructor"))
                (mkVarSet zonked_ex_tvs)
@@ -212,7 +213,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- glue_on just avoids stupid dross
 glue_on _ EmptyMonoBinds grhss = grhss         -- The common case
 glue_on is_rec mbinds (GRHSs grhss binds ty)
-  = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
+  = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 
 tcGRHSs :: RenamedGRHSs
        -> TcType -> StmtCtxt
@@ -333,7 +334,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
     tcExtendGlobalTyVars (tyVarsOfType (m elt_ty))     $
     tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids)     $
 
-    checkSigTyVars pat_tv_list                         `thenTc` \ zonked_pat_tvs ->
+    checkSigTyVars pat_tv_list emptyVarSet             `thenTc` \ zonked_pat_tvs ->
 
     tcSimplifyAndCheck 
        (text ("the existential context of a data constructor"))
@@ -341,8 +342,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
        lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 
     returnTc (BindStmt pat' exp' src_loc : 
-               LetStmt (MonoBind dict_binds [] Recursive) :
-                 stmts',
+               consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
              lie_req `plusLIE` final_lie)
 
 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
@@ -351,7 +351,7 @@ tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
        binds
        (tcStmts do_or_lc m stmts elt_ty)
      where
-       combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+       combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
 
 
 isDoStmt DoStmt = True