[project @ 2003-10-29 18:10:14 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index ce66850..07a0a94 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -8,12 +8,12 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcCheckSigma, tcCheckRho )
 
 import CmdLineOpts     ( DynFlag(Opt_NoMonomorphismRestriction) )
 import HsSyn           ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), 
-                         Match(..), HsMatchContext(..), mkMonoBind,
+                         Match(..), mkMonoBind,
                          collectMonoBinders, andMonoBinds,
                          collectSigTysFromMonoBinds
                        )
@@ -26,7 +26,7 @@ import TcEnv          ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
 import TcUnify         ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
 import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, 
                          tcSimplifyToDicts, tcSimplifyIPs )
-import TcMonoType      ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), 
+import TcHsType                ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), 
                          tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
                        )
 import TcPat           ( tcPat, tcSubPat, tcMonoPatBndr )
@@ -121,7 +121,7 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
     tc_binds_and_then top_lvl combiner b2      $
     do_next
 
-tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next
+tc_binds_and_then top_lvl combiner (IPBinds binds) do_next
   = getLIE do_next                     `thenM` \ (result, expr_lie) ->
     mapAndUnzipM tc_ip_bind binds      `thenM` \ (avail_ips, binds') ->
 
@@ -129,7 +129,7 @@ tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next
        -- discharge any ?x constraints in expr_lie
     tcSimplifyIPs avail_ips expr_lie   `thenM` \ dict_binds ->
 
-    returnM (combiner (IPBinds binds' is_with) $
+    returnM (combiner (IPBinds binds') $
             combiner (mkMonoBind Recursive dict_binds) result)
   where
        -- I wonder if we should do these one at at time
@@ -221,12 +221,11 @@ so all the clever stuff is in here.
   as the Name in the tc_ty_sig
 
 \begin{code}
-tcBindWithSigs 
-       :: TopLevelFlag
-       -> RenamedMonoBinds
-       -> [RenamedSig]         -- Used solely to get INLINE, NOINLINE sigs
-       -> RecFlag
-       -> TcM (TcMonoBinds, [TcId])
+tcBindWithSigs :: TopLevelFlag
+               -> RenamedMonoBinds
+               -> [RenamedSig]
+               -> RecFlag
+               -> TcM (TcMonoBinds, [TcId])
 
 tcBindWithSigs top_lvl mbind sigs is_rec
   =    -- TYPECHECK THE SIGNATURES
@@ -253,6 +252,8 @@ tcBindWithSigs top_lvl mbind sigs is_rec
     )                                          $
 
        -- TYPECHECK THE BINDINGS
+    traceTc (ptext SLIT("--------------------------------------------------------"))   `thenM_`
+    traceTc (ptext SLIT("Bindings for") <+> ppr (collectMonoBinders mbind))            `thenM_`
     getLIE (tcMonoBinds mbind tc_ty_sigs is_rec)       `thenM` \ ((mbind', bndr_names_w_ids), lie_req) ->
     let
        (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids)
@@ -543,7 +544,7 @@ checkSigsTyVars qtvs sigs
   where
     check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
       = addSrcLoc src_loc                                              $
-       addErrCtxt (ptext SLIT("When checking the type signature for") 
+       addErrCtxt (ptext SLIT("In the type signature for") 
                      <+> quotes (ppr id))                              $
        addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau)           $
        checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
@@ -719,7 +720,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
        let
           complete_it = addSrcLoc locn                                 $
                         addErrCtxt (patMonoBindsCtxt bind)             $
-                        tcGRHSs PatBindRhs grhss (Check pat_ty)        `thenM` \ grhss' ->
+                        tcGRHSsPat grhss (Check pat_ty)        `thenM` \ grhss' ->
                         returnM (PatMonoBind pat' grhss' locn, ids)
        in
        returnM (complete_it, if isRec is_rec then ids else emptyBag)
@@ -820,7 +821,6 @@ tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
 tcSpecSigs []                = returnM EmptyMonoBinds
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection[TcBinds-errors]{Error contexts and messages}