[project @ 2000-11-14 10:46:39 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 ea737a1..533058f 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,7 +4,7 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+module TcBinds ( tcBindsAndThen, tcTopBinds,
                 tcSpecSigs, tcBindWithSigs ) where
 
 #include "HsVersions.h"
@@ -25,7 +25,7 @@ import Inst           ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
                        )
 import TcEnv           ( tcExtendLocalValEnv,
                          newSpecPragmaId, newLocalId,
-                         tcLookupTyConByKey, 
+                         tcLookupTyCon, 
                          tcGetGlobalTyVars, tcExtendGlobalTyVars
                        )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
@@ -40,7 +40,8 @@ import TcType         ( TcThetaType, newTyVarTy, newTyVar,
                        )
 import TcUnify         ( unifyTauTy, unifyTauTyLists )
 
-import Id              ( mkVanillaId, setInlinePragma, idFreeTyVars )
+import CoreFVs         ( idFreeTyVars )
+import Id              ( mkVanillaId, setInlinePragma )
 import Var             ( idType, idName )
 import IdInfo          ( InlinePragInfo(..) )
 import Name            ( Name, getOccName, getSrcLoc )
@@ -58,7 +59,7 @@ import Util           ( isIn )
 import Maybes          ( maybeToBool )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
 import FiniteMap       ( listToFM, lookupFM )
-import PrelNames       ( ioTyConKey, mainKey, hasKey )
+import PrelNames       ( ioTyConName, mainKey, hasKey )
 import Outputable
 \end{code}
 
@@ -95,14 +96,22 @@ At the top-level the LIE is sure to contain nothing but constant
 dictionaries, which we resolve at the module level.
 
 \begin{code}
-tcTopBindsAndThen, tcBindsAndThen
+tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
+tcTopBinds binds
+  = tc_binds_and_then TopLevel glue binds      $
+    tcGetEnv                                   `thenNF_Tc` \ env ->
+    returnTc ((EmptyMonoBinds, env), emptyLIE)
+  where
+    glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
+
+
+tcBindsAndThen
        :: (RecFlag -> TcMonoBinds -> thing -> thing)           -- Combinator
        -> RenamedHsBinds
-       -> TcM s (thing, LIE)
-       -> TcM s (thing, LIE)
+       -> TcM (thing, LIE)
+       -> TcM (thing, LIE)
 
-tcTopBindsAndThen = tc_binds_and_then TopLevel
-tcBindsAndThen    = tc_binds_and_then NotTopLevel
+tcBindsAndThen = tc_binds_and_then NotTopLevel
 
 tc_binds_and_then top_lvl combiner EmptyBinds do_next
   = do_next
@@ -182,8 +191,8 @@ examples of this, which is why I thought it worth preserving! [SLPJ]
 \begin{pseudocode}
 % tcBindsAndThen
 %      :: RenamedHsBinds
-%      -> TcM s (thing, LIE, thing_ty))
-%      -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
+%      -> TcM (thing, LIE, thing_ty))
+%      -> TcM ((TcHsBinds, thing), LIE, thing_ty)
 % 
 % tcBindsAndThen EmptyBinds do_next
 %   = do_next          `thenTc` \ (thing, lie, thing_ty) ->
@@ -223,7 +232,7 @@ tcBindWithSigs
        -> [TcSigInfo]
        -> [RenamedSig]         -- Used solely to get INLINE, NOINLINE sigs
        -> RecFlag
-       -> TcM s (TcMonoBinds, LIE, [TcId])
+       -> TcM (TcMonoBinds, LIE, [TcId])
 
 tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
   = recoverTc (
@@ -601,7 +610,7 @@ The signatures have been dealt with already.
 tcMonoBinds :: RenamedMonoBinds 
            -> [TcSigInfo]
            -> RecFlag
-           -> TcM s (TcMonoBinds, 
+           -> TcM (TcMonoBinds, 
                      LIE,              -- LIE required
                      [Name],           -- Bound names
                      [TcId])   -- Corresponding monomorphic bound things
@@ -731,12 +740,12 @@ The error message here is somewhat unsatisfactory, but it'll do for
 now (ToDo).
 
 \begin{code}
-checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM s (Maybe (TcThetaType, LIE))
+checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM (Maybe (TcThetaType, LIE))
 checkSigMatch top_lvl binder_names mono_ids sigs
   | main_bound_here
   =    -- First unify the main_id with IO t, for any old t
     tcSetErrCtxt mainTyCheckCtxt (
-       tcLookupTyConByKey ioTyConKey           `thenTc`    \ ioTyCon ->
+       tcLookupTyCon ioTyConName               `thenTc`    \ ioTyCon ->
        newTyVarTy boxedTypeKind                `thenNF_Tc` \ t_tv ->
        unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
                   (idType main_mono_id)
@@ -750,8 +759,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs
        -- which is just waht check_one_sig looks for
     mapTc check_one_sig sigs                   `thenTc_`
     mapTc check_main_ctxt sigs                 `thenTc_` 
-
-           returnTc (Just ([], emptyLIE))
+    returnTc (Just ([], emptyLIE))
 
   | not (null sigs)
   = mapTc check_one_sig sigs                   `thenTc_`
@@ -857,7 +865,7 @@ a RULE now:
        {-# SPECIALISE (f::<type) = g #-}
 
 \begin{code}
-tcSpecSigs :: [RenamedSig] -> TcM s (TcMonoBinds, LIE)
+tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
   =    -- SPECIALISE f :: forall b. theta => tau  =  g
     tcAddSrcLoc src_loc                                $