[project @ 2000-02-10 18:39:51 by lewie]

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

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index db69565..484aa3c 100644 (file)
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -12,7 +12,8 @@ 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 )
@@ -20,9 +21,9 @@ import TcHsSyn                ( TcMatch, TcGRHSs, TcStmt )
 import TcMonad
 import TcMonoType      ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
 import Inst            ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
-import TcEnv           ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
+import TcEnv           ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
 import TcPat           ( tcPat, tcPatBndr_NoSigs, polyPatSig )
-import TcType          ( TcType, newTyVarTy, newTyVarTy_OpenKind )
+import TcType          ( TcType, newTyVarTy, newTyVarTy_OpenKind, zonkTcTyVars )
 import TcBinds         ( tcBindsAndThen )
 import TcSimplify      ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
 import TcUnify         ( unifyFunTy, unifyTauTy )
@@ -135,7 +136,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        returnTc match_and_lie
 
     else
-       -- If there are sig tve we must be careful *not* to use
+       -- If there are sig tvs we must be careful *not* to use
        -- expected_ty right away, else we'll unify with tyvars free
        -- in the envt.  So invent a fresh tyvar and use that instead
        newTyVarTy_OpenKind             `thenNF_Tc` \ tyvar_ty ->
@@ -158,7 +159,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        returnTc match_and_lie
 
   where
-    tc_match expexted_ty       -- Any sig tyvars are in scope by now
+    tc_match expected_ty       -- Any sig tyvars are in scope by now
       = -- STEP 1: Typecheck the patterns
        tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
         let
@@ -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
@@ -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
@@ -403,7 +403,7 @@ stmtCtxt do_or_lc stmt
   where
     what = case do_or_lc of
                ListComp -> ptext SLIT("a list-comprehension qualifier")
-               DoStmt   -> ptext SLIT("a do statement:")
+               DoStmt   -> ptext SLIT("a do statement")
                PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
                FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
                CaseAlt    -> thing <+> ptext SLIT("a case alternative")