[project @ 1997-07-05 02:33:54 by sof]

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 4b45f0a..946eb8b 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -15,7 +15,7 @@ module TcEnv(
        tcExtendGlobalValEnv, tcExtendLocalValEnv,
        tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
        tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
        tcExtendGlobalValEnv, tcExtendLocalValEnv,
        tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
        tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,

-       tcAddImportedIdInfo,
+       tcAddImportedIdInfo, tcExplicitLookupGlobal,

        tcLookupGlobalValueByKeyMaybe, 
 
        newMonoIds, newLocalIds, newLocalId,
        tcLookupGlobalValueByKeyMaybe, 
 
        newMonoIds, newLocalIds, newLocalId,

@@ -26,8 +26,6 @@ module TcEnv(
 IMP_Ubiq()
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
 IMP_Ubiq()
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking

-#else
-import {-# SOURCE #-} TcType

 #endif
 
 import HsTypes ( HsTyVar(..) )
 #endif
 
 import HsTypes ( HsTyVar(..) )

@@ -42,13 +40,13 @@ import TyVar        ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) )
 import PprType ( GenTyVar )
 import Type    ( tyVarsOfTypes, splitForAllTy )
 import TyCon   ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )
 import PprType ( GenTyVar )
 import Type    ( tyVarsOfTypes, splitForAllTy )
 import TyCon   ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )

-import Class   ( SYN_IE(Class), GenClass, classSig )
+import Class   ( SYN_IE(Class), GenClass )

 
 import TcMonad
 
 import IdInfo          ( noIdInfo )
 import Name            ( Name, OccName(..), getSrcLoc, occNameString,
 
 import TcMonad
 
 import IdInfo          ( noIdInfo )
 import Name            ( Name, OccName(..), getSrcLoc, occNameString,

-                         maybeWiredInTyConName, maybeWiredInIdName,
+                         maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,

                          NamedThing(..)
                        )
 import Pretty
                          NamedThing(..)
                        )
 import Pretty

@@ -255,7 +253,6 @@ tcLookupLocalValueOK err name
 
 
 tcLookupGlobalValue :: Name -> NF_TcM s Id
 
 
 tcLookupGlobalValue :: Name -> NF_TcM s Id

-

 tcLookupGlobalValue name
   = case maybeWiredInIdName name of
        Just id -> returnNF_Tc id
 tcLookupGlobalValue name
   = case maybeWiredInIdName name of
        Just id -> returnNF_Tc id

@@ -265,7 +262,6 @@ tcLookupGlobalValue name
     def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
 
 tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
     def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
 
 tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)

-

 tcLookupGlobalValueMaybe name
   = case maybeWiredInIdName name of
        Just id -> returnNF_Tc (Just id)
 tcLookupGlobalValueMaybe name
   = case maybeWiredInIdName name of
        Just id -> returnNF_Tc (Just id)

@@ -289,18 +285,29 @@ tcLookupGlobalValueByKeyMaybe uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM_Directly gve uniq)
 
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM_Directly gve uniq)
 

+
+-- Non-monadic version, environment given explicitly
+tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
+tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
+  = case maybeWiredInIdName name of
+       Just id -> Just id
+       Nothing -> lookupUFM gve name
+

        -- Extract the IdInfo from an IfaceSig imported from an interface file
        -- Extract the IdInfo from an IfaceSig imported from an interface file

-tcAddImportedIdInfo :: Id -> NF_TcM s Id
-tcAddImportedIdInfo id
-  = tcLookupGlobalValueMaybe (getName id)      `thenNF_Tc` \ maybe_id ->
-    let 
-       new_info = case maybe_id of
+tcAddImportedIdInfo :: TcEnv s -> Id -> Id
+tcAddImportedIdInfo unf_env id
+  | isLocallyDefined id                -- Don't look up locally defined Ids, because they
+                               -- have explicit local definitions, so we get a black hole!
+  = id
+  | otherwise
+  = id `replaceIdInfo` new_info
+       -- The Id must be returned without a data dependency on maybe_id
+  where
+    new_info = -- pprTrace "tcAdd" (ppr PprDebug id) $
+              case tcExplicitLookupGlobal unf_env (getName id) of

                     Nothing          -> noIdInfo
                     Just imported_id -> getIdInfo imported_id
                -- ToDo: could check that types are the same
                     Nothing          -> noIdInfo
                     Just imported_id -> getIdInfo imported_id
                -- ToDo: could check that types are the same

-    in
-    returnNF_Tc (id `replaceIdInfo` new_info)
-       -- The Id must be returned without a data dependency on maybe_id

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index ad0fe55..48c62a0 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -44,7 +44,7 @@ import TcType         ( SYN_IE(TcType), TcMaybe(..),
                          newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
 import TcKind          ( TcKind )
 
                          newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
 import TcKind          ( TcKind )
 

-import Class           ( SYN_IE(Class), classSig )
+import Class           ( SYN_IE(Class) )

 import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType )
 import Id              ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
                          isRecordSelector,
 import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType )
 import Id              ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
                          isRecordSelector,

@@ -295,7 +295,7 @@ tcExpr (HsLet binds expr)
   where
     tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
                   returnTc ((expr',ty), lie)
   where
     tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
                   returnTc ((expr',ty), lie)

-    combiner bind (expr, ty) = (HsLet bind expr, ty)
+    combiner is_rec bind (expr, ty) = (HsLet (MonoBind bind [] is_rec) expr, ty)

 
 tcExpr in_expr@(HsCase expr matches src_loc)
   = tcAddSrcLoc src_loc        $
 
 tcExpr in_expr@(HsCase expr matches src_loc)
   = tcAddSrcLoc src_loc        $

@@ -885,7 +885,7 @@ tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
        binds
        do_next
      where
        binds
        do_next
      where

-       combine' binds' thing' = combine (LetStmt binds') Nothing thing'
+       combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index e2ea7eb..ef582ea 100644 (file)
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -76,6 +76,6 @@ tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
         )                      `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
     returnTc (grhss_and_binds', lie, result_ty)
   where
         )                      `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
     returnTc (grhss_and_binds', lie, result_ty)
   where

-    combiner binds1 (GRHSsAndBindsOut grhss binds2 ty) 
-       = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+    combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty) 
+       = GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty

 \end{code}
 \end{code}

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 47e540f..d317f10 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -37,6 +37,7 @@ import HsSyn          ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
 import RdrHsSyn                ( RdrName(..), varQual, varUnqual, mkOpApp,
                          SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
                        )
 import RdrHsSyn                ( RdrName(..), varQual, varUnqual, mkOpApp,
                          SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
                        )

+import BasicTypes      ( IfaceFlavour(..) )

 import Id              ( GenId, isNullaryDataCon, dataConTag,
                          dataConRawArgTys, fIRST_TAG,
                          isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
 import Id              ( GenId, isNullaryDataCon, dataConTag,
                          dataConRawArgTys, fIRST_TAG,
                          isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),

@@ -1051,7 +1052,7 @@ genOpApp e1 op e2 = mkOpApp e1 op e2
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
+qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }

 
 a_RDR          = varUnqual SLIT("a")
 b_RDR          = varUnqual SLIT("b")
 
 a_RDR          = varUnqual SLIT("a")
 b_RDR          = varUnqual SLIT("b")

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 880dc7a..4b9fc3c 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -29,7 +29,7 @@ module TcHsSyn (
        mkHsTyLam, mkHsDictLam,
        tcIdType, tcIdTyVars,
 
        mkHsTyLam, mkHsDictLam,
        tcIdType, tcIdTyVars,
 

-       zonkBinds, zonkMonoBinds
+       zonkTopBinds, zonkBinds, zonkMonoBinds

   ) where
 
 IMP_Ubiq(){-uitous-}
   ) where
 
 IMP_Ubiq(){-uitous-}

@@ -38,12 +38,13 @@ IMP_Ubiq(){-uitous-}
 import HsSyn   -- oodles of it
 import Id      ( GenId(..), IdDetails, -- Can meddle modestly with Ids
                  SYN_IE(DictVar), idType,
 import HsSyn   -- oodles of it
 import Id      ( GenId(..), IdDetails, -- Can meddle modestly with Ids
                  SYN_IE(DictVar), idType,

-                 SYN_IE(IdEnv), growIdEnvList, lookupIdEnv,

                  SYN_IE(Id)
                )
 
 -- others:
 import Name    ( Name{--O only-}, NamedThing(..) )
                  SYN_IE(Id)
                )
 
 -- others:
 import Name    ( Name{--O only-}, NamedThing(..) )

+import BasicTypes ( IfaceFlavour )
+import TcEnv   ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv )

 import TcMonad
 import TcType  ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
                  zonkTcTypeToType, zonkTcTyVarToTyVar
 import TcMonad
 import TcType  ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
                  zonkTcTypeToType, zonkTcTyVarToTyVar

@@ -59,10 +60,11 @@ import Util ( zipEqual, panic,
 import PprType  ( GenType, GenTyVar )  -- instances
 import Type    ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) )
 import TyVar   ( GenTyVar {- instances -}, SYN_IE(TyVar),
 import PprType  ( GenType, GenTyVar )  -- instances
 import Type    ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) )
 import TyVar   ( GenTyVar {- instances -}, SYN_IE(TyVar),

-                 SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
+                 SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet )

 import TysPrim ( voidTy )
 import CoreSyn  ( GenCoreExpr )
 import Unique  ( Unique )              -- instances
 import TysPrim ( voidTy )
 import CoreSyn  ( GenCoreExpr )
 import Unique  ( Unique )              -- instances

+import Bag

 import UniqFM
 import Outputable
 import Pretty
 import UniqFM
 import Outputable
 import Pretty

@@ -160,17 +162,25 @@ This zonking pass runs over the bindings
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
  b) convert unbound TcTyVar to Void
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
  b) convert unbound TcTyVar to Void

+ c) convert each TcIdBndr to an Id by zonking its type

 
 We pass an environment around so that
 
 We pass an environment around so that

+

  a) we know which TyVars are unbound
  b) we maintain sharing; eg an Id is zonked at its binding site and they
     all occurrences of that Id point to the common zonked copy
 
  a) we know which TyVars are unbound
  b) we maintain sharing; eg an Id is zonked at its binding site and they
     all occurrences of that Id point to the common zonked copy
 

+Actually, since this is all in the Tc monad, it's convenient to keep the
+mapping from TcIds to Ids in the GVE of the Tc monad.   (Those TcIds
+were previously in the LVE of the Tc monad.)
+

 It's all pretty boring stuff, because HsSyn is such a large type, and 
 the environment manipulation is tiresome.
 
 
 \begin{code}
 It's all pretty boring stuff, because HsSyn is such a large type, and 
 the environment manipulation is tiresome.
 
 
 \begin{code}

+extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
+

 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
 zonkIdBndr te (TcId (Id u n ty details prags info))
   = zonkTcTypeToType te ty     `thenNF_Tc` \ ty' ->
 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
 zonkIdBndr te (TcId (Id u n ty details prags info))
   = zonkTcTypeToType te ty     `thenNF_Tc` \ ty' ->

@@ -178,98 +188,118 @@ zonkIdBndr te (TcId (Id u n ty details prags info))
 
 zonkIdBndr te (RealId id) = returnNF_Tc id
 
 
 zonkIdBndr te (RealId id) = returnNF_Tc id
 

-zonkIdOcc :: IdEnv Id -> TcIdOcc s -> Id
-zonkIdOcc ve (RealId id) = id
-zonkIdOcc ve (TcId id)   = case (lookupIdEnv ve id) of
-                               Just id' -> id'
-                               Nothing  -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
-                                           Id u n voidTy details prags info
-                                        where
-                                           Id u n _ details prags info = id
-
-extend_ve ve ids    = growIdEnvList ve [(id,id) | id <- ids]
-extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
+zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
+zonkIdOcc (RealId id) = returnNF_Tc id
+zonkIdOcc (TcId id)   
+  = tcLookupGlobalValueMaybe (getName id)      `thenNF_Tc` \ maybe_id' ->
+    let
+       new_id = case maybe_id' of
+                   Just id' -> id'
+                   Nothing  -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
+                                   Id u n voidTy details prags info
+                               where
+                                   Id u n _ details prags info = id
+    in
+    returnNF_Tc new_id

 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}

-zonkBinds :: TyVarEnv Type -> IdEnv Id 
-         -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id)
-
-zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve)
-
-zonkBinds te ve (ThenBinds binds1 binds2)
-  = zonkBinds te ve binds1   `thenNF_Tc` \ (new_binds1, ve1) ->
-    zonkBinds te ve1 binds2  `thenNF_Tc` \ (new_binds2, ve2) ->
-    returnNF_Tc (ThenBinds new_binds1 new_binds2, ve2)
-
-zonkBinds te ve (MonoBind bind sigs is_rec)
-  = ASSERT( null sigs )
-    fixNF_Tc (\ ~(_,new_ve) ->
-       zonkMonoBinds te new_ve bind  `thenNF_Tc` \ (new_bind, new_ids) ->
-       returnNF_Tc (MonoBind new_bind [] is_rec, extend_ve ve new_ids)
-    )
+zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
+zonkTopBinds binds     -- Top level is implicitly recursive
+  = fixNF_Tc (\ ~(_, new_ids) ->
+       tcExtendGlobalValEnv (bagToList new_ids)        $
+       zonkMonoBinds nullTyVarEnv binds                `thenNF_Tc` \ (binds', new_ids) ->
+       tcGetEnv                                        `thenNF_Tc` \ env ->
+       returnNF_Tc ((binds', env), new_ids)
+    )                                  `thenNF_Tc` \ (stuff, _) ->
+    returnNF_Tc stuff
+
+
+zonkBinds :: TyVarEnv Type
+         -> TcHsBinds s 
+         -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
+
+zonkBinds te binds 
+  = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
+  where
+    -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s)) 
+    --                  -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
+    go (ThenBinds b1 b2) thing_inside = go b1  $ \ b1' -> 
+                                       go b2   $ \ b2' ->
+                                       thing_inside (b1' `ThenBinds` b2')
+
+    go EmptyBinds thing_inside = thing_inside EmptyBinds
+
+    go (MonoBind bind sigs is_rec) thing_inside
+         = ASSERT( null sigs )
+           fixNF_Tc (\ ~(_, new_ids) ->
+               tcExtendGlobalValEnv (bagToList new_ids)        $
+               zonkMonoBinds te bind                           `thenNF_Tc` \ (new_bind, new_ids) ->
+               thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
+               returnNF_Tc (stuff, new_ids)
+           )                                           `thenNF_Tc` \ (stuff, _) ->
+          returnNF_Tc stuff

 \end{code}
 
 \begin{code}
 -------------------------------------------------------------------------
 \end{code}
 
 \begin{code}
 -------------------------------------------------------------------------

-zonkMonoBinds :: TyVarEnv Type -> IdEnv Id 
-             -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id])
+zonkMonoBinds :: TyVarEnv Type
+             -> TcMonoBinds s 
+             -> NF_TcM s (TypecheckedMonoBinds, Bag Id)

 
 

-zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, [])
+zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)

 
 

-zonkMonoBinds te ve (AndMonoBinds mbinds1 mbinds2)
-  = zonkMonoBinds te ve mbinds1  `thenNF_Tc` \ (new_mbinds1, ids1) ->
-    zonkMonoBinds te ve mbinds2  `thenNF_Tc` \ (new_mbinds2, ids2) ->
-    returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2, ids1 ++ ids2)
+zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
+  = zonkMonoBinds te mbinds1           `thenNF_Tc` \ (b1', ids1) ->
+    zonkMonoBinds te mbinds2           `thenNF_Tc` \ (b2', ids2) ->
+    returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)

 
 

-zonkMonoBinds te ve (PatMonoBind pat grhss_w_binds locn)
-  = zonkPat te ve pat                          `thenNF_Tc` \ (new_pat, ids) ->
-    zonkGRHSsAndBinds te ve grhss_w_binds      `thenNF_Tc` \ new_grhss_w_binds ->
+zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
+  = zonkPat te pat                             `thenNF_Tc` \ (new_pat, ids) ->
+    zonkGRHSsAndBinds te grhss_w_binds         `thenNF_Tc` \ new_grhss_w_binds ->

     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
 
     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
 

-zonkMonoBinds te ve (VarMonoBind var expr)
+zonkMonoBinds te (VarMonoBind var expr)

   = zonkIdBndr te var          `thenNF_Tc` \ new_var ->
   = zonkIdBndr te var          `thenNF_Tc` \ new_var ->

-    zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (VarMonoBind new_var new_expr, [new_var])
+    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)

 
 

-zonkMonoBinds te ve (CoreMonoBind var core_expr)
+zonkMonoBinds te (CoreMonoBind var core_expr)

   = zonkIdBndr te var          `thenNF_Tc` \ new_var ->
   = zonkIdBndr te var          `thenNF_Tc` \ new_var ->

-    returnNF_Tc (CoreMonoBind new_var core_expr, [new_var])
+    returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)

 
 

-zonkMonoBinds te ve (FunMonoBind var inf ms locn)
+zonkMonoBinds te (FunMonoBind var inf ms locn)

   = zonkIdBndr te var                  `thenNF_Tc` \ new_var ->
   = zonkIdBndr te var                  `thenNF_Tc` \ new_var ->

-    mapNF_Tc (zonkMatch te ve) ms      `thenNF_Tc` \ new_ms ->
-    returnNF_Tc (FunMonoBind new_var inf new_ms locn, [new_var])
+    mapNF_Tc (zonkMatch te) ms         `thenNF_Tc` \ new_ms ->
+    returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)

 
 
 
 

-zonkMonoBinds te ve (AbsBinds tyvars dicts exports val_bind)
+zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)

   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
     let
        new_te = extend_te te new_tyvars
     in
     mapNF_Tc (zonkIdBndr new_te) dicts         `thenNF_Tc` \ new_dicts ->
 
   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
     let
        new_te = extend_te te new_tyvars
     in
     mapNF_Tc (zonkIdBndr new_te) dicts         `thenNF_Tc` \ new_dicts ->
 

-    let
-       ve1 = extend_ve ve new_dicts
-    in
-    fixNF_Tc (\ ~(_, _, ve2) ->
-       zonkMonoBinds new_te ve2 val_bind               `thenNF_Tc` \ (new_val_bind, new_ids) ->
-        mapNF_Tc (zonkExport new_te ve2) exports       `thenNF_Tc` \ new_exports ->
-       returnNF_Tc (new_val_bind, new_exports, extend_ve ve1 new_ids)
+    tcExtendGlobalValEnv new_dicts                     $
+    fixNF_Tc (\ ~(_, _, val_bind_ids) ->
+       tcExtendGlobalValEnv (bagToList val_bind_ids)           $
+       zonkMonoBinds new_te val_bind           `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
+        mapNF_Tc (zonkExport new_te) exports   `thenNF_Tc` \ new_exports ->
+       returnNF_Tc (new_val_bind, new_exports, val_bind_ids)

     )                                          `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
     )                                          `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->

-

     let
     let

-           new_globals = [global | (_, global, local) <- new_exports]
+           new_globals = listToBag [global | (_, global, local) <- new_exports]

     in
     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
                 new_globals)
     in
     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
                 new_globals)

-

   where
   where

-    zonkExport te ve (tyvars, global, local)
+    zonkExport te (tyvars, global, local)

        = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
          zonkIdBndr te global                  `thenNF_Tc` \ new_global ->
        = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
          zonkIdBndr te global                  `thenNF_Tc` \ new_global ->

-         returnNF_Tc (new_tyvars, new_global, zonkIdOcc ve local)
+         zonkIdOcc local                       `thenNF_Tc` \ new_local -> 
+         returnNF_Tc (new_tyvars, new_global, new_local)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -279,40 +309,40 @@ zonkMonoBinds te ve (AbsBinds tyvars dicts exports val_bind)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-zonkMatch :: TyVarEnv Type -> IdEnv Id 
+zonkMatch :: TyVarEnv Type

          -> TcMatch s -> NF_TcM s TypecheckedMatch
 
          -> TcMatch s -> NF_TcM s TypecheckedMatch
 

-zonkMatch te ve (PatMatch pat match)
-  = zonkPat te ve pat          `thenNF_Tc` \ (new_pat, ids) ->
-    let
-       new_ve = extend_ve ve ids
-    in
-    zonkMatch te new_ve match          `thenNF_Tc` \ new_match ->
+zonkMatch te (PatMatch pat match)
+  = zonkPat te pat             `thenNF_Tc` \ (new_pat, ids) ->
+    tcExtendGlobalValEnv (bagToList ids)       $
+    zonkMatch te match         `thenNF_Tc` \ new_match ->

     returnNF_Tc (PatMatch new_pat new_match)
 
     returnNF_Tc (PatMatch new_pat new_match)
 

-zonkMatch te ve (GRHSMatch grhss_w_binds)
-  = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+zonkMatch te (GRHSMatch grhss_w_binds)
+  = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->

     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 
     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 

-zonkMatch te ve (SimpleMatch expr)
-  = zonkExpr te ve expr   `thenNF_Tc` \ new_expr ->
+zonkMatch te (SimpleMatch expr)
+  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->

     returnNF_Tc (SimpleMatch new_expr)
 
 -------------------------------------------------------------------------
     returnNF_Tc (SimpleMatch new_expr)
 
 -------------------------------------------------------------------------

-zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id 
+zonkGRHSsAndBinds :: TyVarEnv Type

                  -> TcGRHSsAndBinds s
                  -> NF_TcM s TypecheckedGRHSsAndBinds
 
                  -> TcGRHSsAndBinds s
                  -> NF_TcM s TypecheckedGRHSsAndBinds
 

-zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
-  = zonkBinds te ve binds              `thenNF_Tc` \ (new_binds, new_ve) ->
+zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
+  = zonkBinds te binds                 `thenNF_Tc` \ (new_binds, new_env) ->
+    tcSetEnv new_env $

     let
        zonk_grhs (GRHS guard expr locn)
     let
        zonk_grhs (GRHS guard expr locn)

-         = zonkStmts te new_ve guard  `thenNF_Tc` \ (new_guard, new_ve2) ->
-           zonkExpr te new_ve2 expr   `thenNF_Tc` \ new_expr  ->
+         = zonkStmts te guard  `thenNF_Tc` \ (new_guard, new_env) ->
+           tcSetEnv new_env $
+           zonkExpr te expr    `thenNF_Tc` \ new_expr  ->

            returnNF_Tc (GRHS new_guard new_expr locn)
 
         zonk_grhs (OtherwiseGRHS expr locn)
            returnNF_Tc (GRHS new_guard new_expr locn)
 
         zonk_grhs (OtherwiseGRHS expr locn)

-          = zonkExpr te new_ve expr   `thenNF_Tc` \ new_expr  ->
+          = zonkExpr te expr   `thenNF_Tc` \ new_expr  ->

            returnNF_Tc (OtherwiseGRHS new_expr locn)
     in
     mapNF_Tc zonk_grhs grhss   `thenNF_Tc` \ new_grhss ->
            returnNF_Tc (OtherwiseGRHS new_expr locn)
     in
     mapNF_Tc zonk_grhs grhss   `thenNF_Tc` \ new_grhss ->

@@ -327,232 +357,229 @@ zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-{-
-zonkExpr :: TyVarEnv Type -> IdEnv Id 
+zonkExpr :: TyVarEnv Type

         -> TcExpr s -> NF_TcM s TypecheckedHsExpr
         -> TcExpr s -> NF_TcM s TypecheckedHsExpr

--}
-zonkExpr te ve (HsVar name)
-  = returnNF_Tc (HsVar (zonkIdOcc ve name))

 
 

-zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit"
+zonkExpr te (HsVar id)
+  = zonkIdOcc id       `thenNF_Tc` \ id' ->
+    returnNF_Tc (HsVar id')

 
 

-zonkExpr te ve (HsLitOut lit ty)
+zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
+
+zonkExpr te (HsLitOut lit ty)

   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
     returnNF_Tc (HsLitOut lit new_ty)
 
   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
     returnNF_Tc (HsLitOut lit new_ty)
 

-zonkExpr te ve (HsLam match)
-  = zonkMatch te ve match      `thenNF_Tc` \ new_match ->
+zonkExpr te (HsLam match)
+  = zonkMatch te match `thenNF_Tc` \ new_match ->

     returnNF_Tc (HsLam new_match)
 
     returnNF_Tc (HsLam new_match)
 

-zonkExpr te ve (HsApp e1 e2)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
+zonkExpr te (HsApp e1 e2)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->

     returnNF_Tc (HsApp new_e1 new_e2)
 
     returnNF_Tc (HsApp new_e1 new_e2)
 

-zonkExpr te ve (OpApp e1 op fixity e2)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve op  `thenNF_Tc` \ new_op ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
+zonkExpr te (OpApp e1 op fixity e2)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te op     `thenNF_Tc` \ new_op ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->

     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 
     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 

-zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
-zonkExpr te ve (HsPar _)    = panic "zonkExpr te ve:HsPar"
+zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
+zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"

 
 

-zonkExpr te ve (SectionL expr op)
-  = zonkExpr te ve expr        `thenNF_Tc` \ new_expr ->
-    zonkExpr te ve op          `thenNF_Tc` \ new_op ->
+zonkExpr te (SectionL expr op)
+  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
+    zonkExpr te op             `thenNF_Tc` \ new_op ->

     returnNF_Tc (SectionL new_expr new_op)
 
     returnNF_Tc (SectionL new_expr new_op)
 

-zonkExpr te ve (SectionR op expr)
-  = zonkExpr te ve op          `thenNF_Tc` \ new_op ->
-    zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
+zonkExpr te (SectionR op expr)
+  = zonkExpr te op             `thenNF_Tc` \ new_op ->
+    zonkExpr te expr           `thenNF_Tc` \ new_expr ->

     returnNF_Tc (SectionR new_op new_expr)
 
     returnNF_Tc (SectionR new_op new_expr)
 

-zonkExpr te ve (HsCase expr ms src_loc)
-  = zonkExpr te ve expr            `thenNF_Tc` \ new_expr ->
-    mapNF_Tc (zonkMatch te ve) ms   `thenNF_Tc` \ new_ms ->
+zonkExpr te (HsCase expr ms src_loc)
+  = zonkExpr te expr               `thenNF_Tc` \ new_expr ->
+    mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->

     returnNF_Tc (HsCase new_expr new_ms src_loc)
 
     returnNF_Tc (HsCase new_expr new_ms src_loc)
 

-zonkExpr te ve (HsIf e1 e2 e3 src_loc)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
-    zonkExpr te ve e3  `thenNF_Tc` \ new_e3 ->
+zonkExpr te (HsIf e1 e2 e3 src_loc)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
+    zonkExpr te e3     `thenNF_Tc` \ new_e3 ->

     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 
     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 

-zonkExpr te ve (HsLet binds expr)
-  = zonkBinds te ve binds      `thenNF_Tc` \ (new_binds, new_ve) ->
-    zonkExpr  te new_ve expr   `thenNF_Tc` \ new_expr ->
+zonkExpr te (HsLet binds expr)
+  = zonkBinds te binds         `thenNF_Tc` \ (new_binds, new_env) ->
+    tcSetEnv new_env           $
+    zonkExpr te expr           `thenNF_Tc` \ new_expr ->

     returnNF_Tc (HsLet new_binds new_expr)
 
     returnNF_Tc (HsLet new_binds new_expr)
 

-zonkExpr te ve (HsDo _ _ _) = panic "zonkExpr te ve:HsDo"
+zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"

 
 

-zonkExpr te ve (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
-  = zonkStmts te ve stmts      `thenNF_Tc` \ (new_stmts, _) ->
+zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+  = zonkStmts te stmts                 `thenNF_Tc` \ (new_stmts, _) ->

     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->
     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->

-    returnNF_Tc (HsDoOut do_or_lc new_stmts 
-                        (zonkIdOcc ve return_id)
-                        (zonkIdOcc ve then_id)
-                        (zonkIdOcc ve zero_id)
+    zonkIdOcc return_id                `thenNF_Tc` \ new_return_id ->
+    zonkIdOcc then_id          `thenNF_Tc` \ new_then_id ->
+    zonkIdOcc zero_id          `thenNF_Tc` \ new_zero_id ->
+    returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id

                         new_ty src_loc)
 
                         new_ty src_loc)
 

-zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList"
+zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"

 
 

-zonkExpr te ve (ExplicitListOut ty exprs)
+zonkExpr te (ExplicitListOut ty exprs)

   = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
   = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->

-    mapNF_Tc (zonkExpr te ve) exprs    `thenNF_Tc` \ new_exprs ->
+    mapNF_Tc (zonkExpr te) exprs       `thenNF_Tc` \ new_exprs ->

     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 
     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 

-zonkExpr te ve (ExplicitTuple exprs)
-  = mapNF_Tc (zonkExpr te ve) exprs  `thenNF_Tc` \ new_exprs ->
+zonkExpr te (ExplicitTuple exprs)
+  = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->

     returnNF_Tc (ExplicitTuple new_exprs)
 
     returnNF_Tc (ExplicitTuple new_exprs)
 

-zonkExpr te ve (RecordCon con rbinds)
-  = zonkExpr te ve con         `thenNF_Tc` \ new_con ->
-    zonkRbinds te ve rbinds    `thenNF_Tc` \ new_rbinds ->
+zonkExpr te (RecordCon con rbinds)
+  = zonkExpr te con            `thenNF_Tc` \ new_con ->
+    zonkRbinds te rbinds       `thenNF_Tc` \ new_rbinds ->

     returnNF_Tc (RecordCon new_con new_rbinds)
 
     returnNF_Tc (RecordCon new_con new_rbinds)
 

-zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd"
+zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"

 
 

-zonkExpr te ve (RecordUpdOut expr ty dicts rbinds)
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
+zonkExpr te (RecordUpdOut expr ty dicts rbinds)
+  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->

     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->

-    zonkRbinds te ve rbinds    `thenNF_Tc` \ new_rbinds ->
+    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
+    zonkRbinds te rbinds       `thenNF_Tc` \ new_rbinds ->

     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)

-  where
-    new_dicts = map (zonkIdOcc ve) dicts

 
 

-zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig"
-zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn"
+zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
+zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"

 
 

-zonkExpr te ve (ArithSeqOut expr info)
-  = zonkExpr te ve expr        `thenNF_Tc` \ new_expr ->
-    zonkArithSeq te ve info    `thenNF_Tc` \ new_info ->
+zonkExpr te (ArithSeqOut expr info)
+  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
+    zonkArithSeq te info       `thenNF_Tc` \ new_info ->

     returnNF_Tc (ArithSeqOut new_expr new_info)
 
     returnNF_Tc (ArithSeqOut new_expr new_info)
 

-zonkExpr te ve (CCall fun args may_gc is_casm result_ty)
-  = mapNF_Tc (zonkExpr te ve) args     `thenNF_Tc` \ new_args ->
+zonkExpr te (CCall fun args may_gc is_casm result_ty)
+  = mapNF_Tc (zonkExpr te) args        `thenNF_Tc` \ new_args ->

     zonkTcTypeToType te result_ty      `thenNF_Tc` \ new_result_ty ->
     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 
     zonkTcTypeToType te result_ty      `thenNF_Tc` \ new_result_ty ->
     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 

-zonkExpr te ve (HsSCC label expr)
-  = zonkExpr te ve expr        `thenNF_Tc` \ new_expr ->
+zonkExpr te (HsSCC label expr)
+  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->

     returnNF_Tc (HsSCC label new_expr)
 
     returnNF_Tc (HsSCC label new_expr)
 

-zonkExpr te ve (TyLam tyvars expr)
+zonkExpr te (TyLam tyvars expr)

   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
     let
        new_te = extend_te te new_tyvars
     in
   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
     let
        new_te = extend_te te new_tyvars
     in

-    zonkExpr new_te ve expr            `thenNF_Tc` \ new_expr ->
+    zonkExpr new_te expr               `thenNF_Tc` \ new_expr ->

     returnNF_Tc (TyLam new_tyvars new_expr)
 
     returnNF_Tc (TyLam new_tyvars new_expr)
 

-zonkExpr te ve (TyApp expr tys)
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
+zonkExpr te (TyApp expr tys)
+  = zonkExpr te expr                   `thenNF_Tc` \ new_expr ->

     mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
     returnNF_Tc (TyApp new_expr new_tys)
 
     mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
     returnNF_Tc (TyApp new_expr new_tys)
 

-zonkExpr te ve (DictLam dicts expr)
+zonkExpr te (DictLam dicts expr)

   = mapNF_Tc (zonkIdBndr te) dicts     `thenNF_Tc` \ new_dicts ->
   = mapNF_Tc (zonkIdBndr te) dicts     `thenNF_Tc` \ new_dicts ->

-    let
-       new_ve = extend_ve ve new_dicts
-    in
-    zonkExpr te new_ve expr                    `thenNF_Tc` \ new_expr ->
+    tcExtendGlobalValEnv new_dicts     $
+    zonkExpr te expr                   `thenNF_Tc` \ new_expr ->

     returnNF_Tc (DictLam new_dicts new_expr)
 
     returnNF_Tc (DictLam new_dicts new_expr)
 

-zonkExpr te ve (DictApp expr dicts)
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
+zonkExpr te (DictApp expr dicts)
+  = zonkExpr te expr                   `thenNF_Tc` \ new_expr ->
+    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->

     returnNF_Tc (DictApp new_expr new_dicts)
     returnNF_Tc (DictApp new_expr new_dicts)

-  where
-    new_dicts = map (zonkIdOcc ve) dicts

 
 

-zonkExpr te ve (ClassDictLam dicts methods expr)
-  = zonkExpr te ve expr            `thenNF_Tc` \ new_expr ->
+zonkExpr te (ClassDictLam dicts methods expr)
+  = zonkExpr te expr               `thenNF_Tc` \ new_expr ->
+    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
+    mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->

     returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
     returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)

-  where
-    new_dicts   = map (zonkIdOcc ve) dicts
-    new_methods = map (zonkIdOcc ve) methods
-    

 
 

-zonkExpr te ve (Dictionary dicts methods)
-  = returnNF_Tc (Dictionary new_dicts new_methods)
-  where
-    new_dicts   = map (zonkIdOcc ve) dicts
-    new_methods = map (zonkIdOcc ve) methods
+zonkExpr te (Dictionary dicts methods)
+  = mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
+    mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->
+    returnNF_Tc (Dictionary new_dicts new_methods)

 
 

-zonkExpr te ve (SingleDict name)
-  = returnNF_Tc (SingleDict (zonkIdOcc ve name))
+zonkExpr te (SingleDict name)
+  = zonkIdOcc name     `thenNF_Tc` \ name' ->
+    returnNF_Tc (SingleDict name')

 
 
 -------------------------------------------------------------------------
 
 
 -------------------------------------------------------------------------

-zonkArithSeq :: TyVarEnv Type -> IdEnv Id 
+zonkArithSeq :: TyVarEnv Type

             -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 
             -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 

-zonkArithSeq te ve (From e)
-  = zonkExpr te ve e           `thenNF_Tc` \ new_e ->
+zonkArithSeq te (From e)
+  = zonkExpr te e              `thenNF_Tc` \ new_e ->

     returnNF_Tc (From new_e)
 
     returnNF_Tc (From new_e)
 

-zonkArithSeq te ve (FromThen e1 e2)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
+zonkArithSeq te (FromThen e1 e2)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->

     returnNF_Tc (FromThen new_e1 new_e2)
 
     returnNF_Tc (FromThen new_e1 new_e2)
 

-zonkArithSeq te ve (FromTo e1 e2)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
+zonkArithSeq te (FromTo e1 e2)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->

     returnNF_Tc (FromTo new_e1 new_e2)
 
     returnNF_Tc (FromTo new_e1 new_e2)
 

-zonkArithSeq te ve (FromThenTo e1 e2 e3)
-  = zonkExpr te ve e1  `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2  `thenNF_Tc` \ new_e2 ->
-    zonkExpr te ve e3  `thenNF_Tc` \ new_e3 ->
+zonkArithSeq te (FromThenTo e1 e2 e3)
+  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
+    zonkExpr te e3     `thenNF_Tc` \ new_e3 ->

     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 
 -------------------------------------------------------------------------
     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 
 -------------------------------------------------------------------------

-zonkStmts :: TyVarEnv Type -> IdEnv Id 
-         -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], IdEnv Id)
+zonkStmts :: TyVarEnv Type
+         -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)

 
 

-zonkStmts te ve [] = returnNF_Tc ([], ve)
+zonkStmts te [] = tcGetEnv     `thenNF_Tc` \ env ->
+                 returnNF_Tc ([], env)

 
 

-zonkStmts te ve [ReturnStmt expr]
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    returnNF_Tc ([ReturnStmt new_expr], ve)
+zonkStmts te [ReturnStmt expr]
+  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    tcGetEnv                   `thenNF_Tc` \ env ->
+    returnNF_Tc ([ReturnStmt new_expr], env)

 
 

-zonkStmts te ve (ExprStmt expr locn : stmts)
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    zonkStmts te ve    stmts   `thenNF_Tc` \ (new_stmts, new_ve) ->
-    returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_ve)
+zonkStmts te (ExprStmt expr locn : stmts)
+  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    zonkStmts te       stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
+    returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)

 
 

-zonkStmts te ve (GuardStmt expr locn : stmts)
-  = zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    zonkStmts te ve    stmts   `thenNF_Tc` \ (new_stmts, new_ve) ->
-    returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_ve)
+zonkStmts te (GuardStmt expr locn : stmts)
+  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    zonkStmts te       stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
+    returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)

 
 

-zonkStmts te ve (LetStmt binds : stmts)
-  = zonkBinds te ve     binds  `thenNF_Tc` \ (new_binds, new_ve) ->
-    zonkStmts te new_ve stmts  `thenNF_Tc` \ (new_stmts, new_ve2) ->
-    returnNF_Tc (LetStmt new_binds : new_stmts, new_ve2)
+zonkStmts te (LetStmt binds : stmts)
+  = zonkBinds te     binds     `thenNF_Tc` \ (new_binds, new_env) ->
+    tcSetEnv new_env           $
+    zonkStmts te stmts         `thenNF_Tc` \ (new_stmts, new_env2) ->
+    returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)

 
 

-zonkStmts te ve (BindStmt pat expr locn : stmts)
-  = zonkPat te ve pat          `thenNF_Tc` \ (new_pat, ids) ->
-    zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    let
-       new_ve = extend_ve ve ids
-    in
-    zonkStmts te new_ve stmts  `thenNF_Tc` \ (new_stmts, new_ve2) ->
-    returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_ve2)
+zonkStmts te (BindStmt pat expr locn : stmts)
+  = zonkPat te pat             `thenNF_Tc` \ (new_pat, ids) ->
+    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    tcExtendGlobalValEnv (bagToList ids)       $ 
+    zonkStmts te stmts         `thenNF_Tc` \ (new_stmts, new_env) ->
+    returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)

 
 
 
 -------------------------------------------------------------------------
 
 
 
 -------------------------------------------------------------------------

-zonkRbinds :: TyVarEnv Type -> IdEnv Id 
+zonkRbinds :: TyVarEnv Type

           -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 
           -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 

-zonkRbinds te ve rbinds
+zonkRbinds te rbinds

   = mapNF_Tc zonk_rbind rbinds
   where
     zonk_rbind (field, expr, pun)
   = mapNF_Tc zonk_rbind rbinds
   where
     zonk_rbind (field, expr, pun)

-      = zonkExpr te ve expr    `thenNF_Tc` \ new_expr ->
-       returnNF_Tc (zonkIdOcc ve field, new_expr, pun)
+      = zonkExpr te expr       `thenNF_Tc` \ new_expr ->
+       zonkIdOcc field         `thenNF_Tc` \ new_field ->
+       returnNF_Tc (new_field, new_expr, pun)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -562,85 +589,84 @@ zonkRbinds te ve rbinds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-{-
-zonkPat :: TyVarEnv Type -> IdEnv Id 
-       -> TcPat s -> NF_TcM s (TypecheckedPat, [Id])
--}
-zonkPat te ve (WildPat ty)
+zonkPat :: TyVarEnv Type
+       -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
+
+zonkPat te (WildPat ty)

   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty ->
   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty ->

-    returnNF_Tc (WildPat new_ty, [])
+    returnNF_Tc (WildPat new_ty, emptyBag)

 
 

-zonkPat te ve (VarPat v)
+zonkPat te (VarPat v)

   = zonkIdBndr te v        `thenNF_Tc` \ new_v ->
   = zonkIdBndr te v        `thenNF_Tc` \ new_v ->

-    returnNF_Tc (VarPat new_v, [new_v])
+    returnNF_Tc (VarPat new_v, unitBag new_v)

 
 

-zonkPat te ve (LazyPat pat)
-  = zonkPat te ve pat      `thenNF_Tc` \ (new_pat, ids) ->
+zonkPat te (LazyPat pat)
+  = zonkPat te pat         `thenNF_Tc` \ (new_pat, ids) ->

     returnNF_Tc (LazyPat new_pat, ids)
 
     returnNF_Tc (LazyPat new_pat, ids)
 

-zonkPat te ve (AsPat n pat)
+zonkPat te (AsPat n pat)

   = zonkIdBndr te n        `thenNF_Tc` \ new_n ->
   = zonkIdBndr te n        `thenNF_Tc` \ new_n ->

-    zonkPat te ve pat      `thenNF_Tc` \ (new_pat, ids) ->
-    returnNF_Tc (AsPat new_n new_pat, new_n:ids)
+    zonkPat te pat         `thenNF_Tc` \ (new_pat, ids) ->
+    returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)

 
 

-zonkPat te ve (ConPat n ty pats)
+zonkPat te (ConPat n ty pats)

   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->

-    zonkPats te ve pats                `thenNF_Tc` \ (new_pats, ids) ->
+    zonkPats te pats           `thenNF_Tc` \ (new_pats, ids) ->

     returnNF_Tc (ConPat n new_ty new_pats, ids)
 
     returnNF_Tc (ConPat n new_ty new_pats, ids)
 

-zonkPat te ve (ConOpPat pat1 op pat2 ty)
-  = zonkPat te ve pat1     `thenNF_Tc` \ (new_pat1, ids1) ->
-    zonkPat te ve pat2     `thenNF_Tc` \ (new_pat2, ids2) ->
+zonkPat te (ConOpPat pat1 op pat2 ty)
+  = zonkPat te pat1        `thenNF_Tc` \ (new_pat1, ids1) ->
+    zonkPat te pat2        `thenNF_Tc` \ (new_pat2, ids2) ->

     zonkTcTypeToType te ty  `thenNF_Tc` \ new_ty ->
     zonkTcTypeToType te ty  `thenNF_Tc` \ new_ty ->

-    returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 ++ ids2)
+    returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)

 
 

-zonkPat te ve (ListPat ty pats)
+zonkPat te (ListPat ty pats)

   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->

-    zonkPats te ve pats                `thenNF_Tc` \ (new_pats, ids) ->
+    zonkPats te pats           `thenNF_Tc` \ (new_pats, ids) ->

     returnNF_Tc (ListPat new_ty new_pats, ids)
 
     returnNF_Tc (ListPat new_ty new_pats, ids)
 

-zonkPat te ve (TuplePat pats)
-  = zonkPats te ve pats                `thenNF_Tc` \ (new_pats, ids) ->
+zonkPat te (TuplePat pats)
+  = zonkPats te pats                   `thenNF_Tc` \ (new_pats, ids) ->

     returnNF_Tc (TuplePat new_pats, ids)
 
     returnNF_Tc (TuplePat new_pats, ids)
 

-zonkPat te ve (RecPat n ty rpats)
+zonkPat te (RecPat n ty rpats)

   = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
     mapAndUnzipNF_Tc zonk_rpat rpats   `thenNF_Tc` \ (new_rpats, ids_s) ->
   = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
     mapAndUnzipNF_Tc zonk_rpat rpats   `thenNF_Tc` \ (new_rpats, ids_s) ->

-    returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s)
+    returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)

   where
     zonk_rpat (f, pat, pun)
   where
     zonk_rpat (f, pat, pun)

-      = zonkPat te ve pat           `thenNF_Tc` \ (new_pat, ids) ->
+      = zonkPat te pat      `thenNF_Tc` \ (new_pat, ids) ->

        returnNF_Tc ((f, new_pat, pun), ids)
 
        returnNF_Tc ((f, new_pat, pun), ids)
 

-zonkPat te ve (LitPat lit ty)
+zonkPat te (LitPat lit ty)

   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
   = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->

-    returnNF_Tc (LitPat lit new_ty, [])
+    returnNF_Tc (LitPat lit new_ty, emptyBag)

 
 

-zonkPat te ve (NPat lit ty expr)
+zonkPat te (NPat lit ty expr)

   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->
   = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->

-    zonkExpr te ve expr                `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (NPat lit new_ty new_expr, [])
+    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
+    returnNF_Tc (NPat lit new_ty new_expr, emptyBag)

 
 

-zonkPat te ve (NPlusKPat n k ty e1 e2)
+zonkPat te (NPlusKPat n k ty e1 e2)

   = zonkIdBndr te n            `thenNF_Tc` \ new_n ->
     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
   = zonkIdBndr te n            `thenNF_Tc` \ new_n ->
     zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->

-    zonkExpr te ve e1          `thenNF_Tc` \ new_e1 ->
-    zonkExpr te ve e2          `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, [new_n])
+    zonkExpr te e1             `thenNF_Tc` \ new_e1 ->
+    zonkExpr te e2             `thenNF_Tc` \ new_e2 ->
+    returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)

 
 

-zonkPat te ve (DictPat ds ms)
+zonkPat te (DictPat ds ms)

   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
     mapNF_Tc (zonkIdBndr te) ms    `thenNF_Tc` \ new_ms ->
   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
     mapNF_Tc (zonkIdBndr te) ms    `thenNF_Tc` \ new_ms ->

-    returnNF_Tc (DictPat new_ds new_ms, new_ds ++ new_ms)
-
+    returnNF_Tc (DictPat new_ds new_ms, 
+                listToBag new_ds `unionBags` listToBag new_ms)

 
 

-zonkPats te ve [] 
-  = returnNF_Tc ([], [])
-zonkPats te ve (pat:pats) 
-  = zonkPat te ve pat  `thenNF_Tc` \ (pat', ids1) ->
-    zonkPats te ve pats        `thenNF_Tc` \ (pats', ids2) ->
-    returnNF_Tc (pat':pats', ids1 ++ ids2)

 
 

+zonkPats te [] 
+  = returnNF_Tc ([], emptyBag)
+zonkPats te (pat:pats) 
+  = zonkPat te pat     `thenNF_Tc` \ (pat', ids1) ->
+    zonkPats te pats   `thenNF_Tc` \ (pats', ids2) ->
+    returnNF_Tc (pat':pats', ids1 `unionBags` ids2)

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index a34a061..3cdf851 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -13,7 +13,8 @@ IMP_Ubiq()
 import TcMonad
 import TcMonoType      ( tcHsType, tcHsTypeKind )
 import TcEnv           ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
 import TcMonad
 import TcMonoType      ( tcHsType, tcHsTypeKind )
 import TcEnv           ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,

-                         tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
+                         tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue,
+                         tcExplicitLookupGlobal

                        )
 import TcKind          ( TcKind, kindToTcKind )
 
                        )
 import TcKind          ( TcKind, kindToTcKind )
 

@@ -21,7 +22,7 @@ import HsSyn          ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDe
                          Fake, InPat, HsType )
 import RnHsSyn         ( RenamedHsDecl(..) )
 import HsCore
                          Fake, InPat, HsType )
 import RnHsSyn         ( RenamedHsDecl(..) )
 import HsCore

-import HsDecls         ( HsIdInfo(..) )
+import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )

 import Literal         ( Literal(..) )
 import CoreSyn
 import CoreUtils       ( coreExprType )
 import Literal         ( Literal(..) )
 import CoreSyn
 import CoreUtils       ( coreExprType )

@@ -34,9 +35,9 @@ import PrimOp         ( PrimOp(..) )
 import Id              ( GenId, mkImported, mkUserId, addInlinePragma,
                          isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) )
 import Type            ( mkSynTy, getAppDataTyConExpandingDicts )
 import Id              ( GenId, mkImported, mkUserId, addInlinePragma,
                          isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) )
 import Type            ( mkSynTy, getAppDataTyConExpandingDicts )

-import TyVar           ( mkTyVar )
+import TyVar           ( mkSysTyVar )

 import Name            ( Name )
 import Name            ( Name )

-import Unique          ( rationalTyConKey )
+import Unique          ( rationalTyConKey, uniqueOf )

 import TysWiredIn      ( integerTy )
 import PragmaInfo      ( PragmaInfo(..) )
 import ErrUtils                ( pprBagOfErrors )
 import TysWiredIn      ( integerTy )
 import PragmaInfo      ( PragmaInfo(..) )
 import ErrUtils                ( pprBagOfErrors )

@@ -56,95 +57,91 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
 signatures.
 
 \begin{code}

-tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
-                  -- Ignore non-sig-decls in these decls
-
-tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
-  = tcAddSrcLoc src_loc $
-    tcAddErrCtxt (ifaceSigCtxt name) $
-    tcHsType ty                                        `thenTc` \ sigma_ty ->
-    tcIdInfo name sigma_ty noIdInfo id_infos   `thenTc` \ id_info' ->
-    let
-       imp_id = mkImported name sigma_ty id_info'
-       sig_id | any inline_please id_infos = addInlinePragma imp_id
-              | otherwise                  = imp_id
+tcInterfaceSigs :: TcEnv s             -- Envt to use when checking unfoldings
+               -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
+               -> TcM s [Id]
+               
+
+tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
+  = tcAddSrcLoc src_loc (
+    tcAddErrCtxt (ifaceSigCtxt name) (
+       tcHsType ty                                             `thenTc` \ sigma_ty ->
+       tcIdInfo unf_env name sigma_ty noIdInfo id_infos        `thenTc` \ id_info' ->
+       let
+           imp_id = mkImported name sigma_ty id_info'
+           sig_id | any inline_please id_infos = addInlinePragma imp_id
+                  | otherwise                  = imp_id

 
 

-       inline_please (HsUnfold inline _) = inline
-       inline_please other               = False
-    in
-    tcInterfaceSigs rest               `thenTc` \ sig_ids ->
+           inline_please (HsUnfold inline _) = inline
+           inline_please other           = False
+       in
+       returnTc sig_id
+    ))                                         `thenTc` \ sig_id ->
+    tcInterfaceSigs unf_env rest               `thenTc` \ sig_ids ->

     returnTc (sig_id : sig_ids)
 
     returnTc (sig_id : sig_ids)
 

-tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
+tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest

 
 

-tcInterfaceSigs [] = returnTc []
+tcInterfaceSigs unf_env [] = returnTc []

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-tcIdInfo name ty info [] = returnTc info
-
-tcIdInfo name ty info (HsArity arity : rest)
-  = tcIdInfo name ty (info `addArityInfo` arity) rest
-
-tcIdInfo name ty info (HsUpdate upd : rest)
-  = tcIdInfo name ty (info `addUpdateInfo` upd) rest
-
-tcIdInfo name ty info (HsFBType fb : rest)
-  = tcIdInfo name ty (info `addFBTypeInfo` fb) rest
-
-tcIdInfo name ty info (HsArgUsage au : rest)
-  = tcIdInfo name ty (info `addArgUsageInfo` au) rest
-
-tcIdInfo name ty info (HsDeforest df : rest)
-  = tcIdInfo name ty (info `addDeforestInfo` df) rest
-
-tcIdInfo name ty info (HsUnfold inline expr : rest)
-  = tcUnfolding name expr      `thenNF_Tc` \ unfold_info ->
-    tcIdInfo name ty (info `addUnfoldInfo` unfold_info) rest
-
-tcIdInfo name ty info (HsStrictness strict : rest)
-  = tcStrictness ty info strict        `thenTc` \ info' ->
-    tcIdInfo name ty info' rest
+tcIdInfo unf_env name ty info info_ins
+  = go noIdInfo info_ins
+  where
+    go info_so_far []             = returnTc info_so_far
+    go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
+    go info (HsUpdate upd : rest)  = go (info `addUpdateInfo` upd)  rest
+    go info (HsFBType fb : rest)   = go (info `addFBTypeInfo` fb)   rest
+    go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
+    go info (HsDeforest df : rest) = go (info `addDeforestInfo` df) rest
+
+    go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr      `thenNF_Tc` \ unfold_info ->
+                                           go (info `addUnfoldInfo` unfold_info) rest
+
+    go info (HsStrictness strict : rest)  = tcStrictness unf_env ty info strict        `thenTc` \ info' ->
+                                           go info' rest

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-tcStrictness ty info (StrictnessInfo demands maybe_worker)
-  = tcWorker maybe_worker                      `thenNF_Tc` \ maybe_worker_id ->
+tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
+  = tcWorker unf_env maybe_worker              `thenNF_Tc` \ maybe_worker_id ->

     uniqSMToTcM (mkWrapper ty demands)         `thenNF_Tc` \ wrap_fn ->
     let
        -- Watch out! We can't pull on maybe_worker_id too eagerly!
        info' = case maybe_worker_id of
     uniqSMToTcM (mkWrapper ty demands)         `thenNF_Tc` \ wrap_fn ->
     let
        -- Watch out! We can't pull on maybe_worker_id too eagerly!
        info' = case maybe_worker_id of

-                       Just (worker_id,_) -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
-                       Nothing            -> info
+                       Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
+                       Nothing        -> info
+       has_worker = maybeToBool maybe_worker_id

     in
     in

-    returnTc (info' `addStrictnessInfo` StrictnessInfo demands maybe_worker_id)
+    returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)

 
 -- Boring to write these out, but the result type differs from the arg type...
 
 -- Boring to write these out, but the result type differs from the arg type...

-tcStrictness ty info BottomGuaranteed
+tcStrictness unf_env ty info HsBottom

   = returnTc (info `addStrictnessInfo` BottomGuaranteed)
   = returnTc (info `addStrictnessInfo` BottomGuaranteed)

-tcStrictness ty info NoStrictnessInfo
-  = returnTc info

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-tcWorker Nothing = returnNF_Tc Nothing
+tcWorker unf_env Nothing = returnNF_Tc Nothing

 
 

-tcWorker (Just (worker_name,_))
-  = tcLookupGlobalValueMaybe worker_name       `thenNF_Tc` \ maybe_worker_id ->
-    returnNF_Tc (trace_maybe maybe_worker_id)
+tcWorker unf_env (Just (worker_name,_))
+  = returnNF_Tc (trace_maybe maybe_worker_id)

   where
   where

+    maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
+

        -- The trace is so we can see what's getting dropped
     trace_maybe Nothing  = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing
        -- The trace is so we can see what's getting dropped
     trace_maybe Nothing  = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing

-    trace_maybe (Just x) = Just (x, [])
+    trace_maybe (Just x) = Just x

 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
 an unfolding that isn't going to be looked at.
 
 \begin{code}
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
 an unfolding that isn't going to be looked at.
 
 \begin{code}

-tcUnfolding name core_expr
+tcUnfolding unf_env name core_expr

   = forkNF_Tc (
        recoverNF_Tc no_unfolding (
   = forkNF_Tc (
        recoverNF_Tc no_unfolding (

+               tcSetEnv unf_env $

                tcCoreExpr core_expr    `thenTc` \ core_expr' ->
                returnTc (mkUnfolding NoPragmaInfo core_expr')
     ))                 
                tcCoreExpr core_expr    `thenTc` \ core_expr' ->
                returnTc (mkUnfolding NoPragmaInfo core_expr')
     ))                 

@@ -261,7 +258,7 @@ tcCoreLamBndr (UfValBinder name ty) thing_inside
     
 tcCoreLamBndr (UfTyBinder name kind) thing_inside
   = let
     
 tcCoreLamBndr (UfTyBinder name kind) thing_inside
   = let

-       tyvar = mkTyVar name kind
+       tyvar = mkSysTyVar (uniqueOf name) kind

     in
     tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
     thing_inside (TyBinder tyvar)
     in
     tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
     thing_inside (TyBinder tyvar)

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 45ed913..59d6284 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -34,15 +34,16 @@ import TcHsSyn              ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds),
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 

-import TcBinds         ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..) )
+import TcBinds         ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars )

 import TcMonad
 import RnMonad         ( SYN_IE(RnNameSupply) )
 import Inst            ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
                          instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
 import TcMonad
 import RnMonad         ( SYN_IE(RnNameSupply) )
 import Inst            ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
                          instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )

-import TcBinds         ( tcPragmaSigs, checkSigTyVars )

 import PragmaInfo      ( PragmaInfo(..) )
 import TcDeriv         ( tcDeriving )
 import PragmaInfo      ( PragmaInfo(..) )
 import TcDeriv         ( tcDeriving )

-import TcEnv           ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars )
+import TcEnv           ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars,
+                         tcExtendGlobalValEnv, tcAddImportedIdInfo
+                       )

 import SpecEnv         ( SpecEnv )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import SpecEnv         ( SpecEnv )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )

@@ -61,23 +62,23 @@ import Bag          ( emptyBag, unitBag, unionBags, unionManyBags,
                          concatBag, foldBag, bagToList, listToBag,
                          Bag )
 import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingGhcInternals,
                          concatBag, foldBag, bagToList, listToBag,
                          Bag )
 import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingGhcInternals,

-                         opt_OmitDefaultInstanceMethods,
+                         opt_OmitDefaultInstanceMethods, opt_PprUserLength,

                          opt_SpecialiseOverloaded
                        )
                          opt_SpecialiseOverloaded
                        )

-import Class           ( GenClass, GenClassOp, 
-                         classBigSig, classOps, classOpLocalType,
+import Class           ( GenClass,
+                         classBigSig,

                          classDefaultMethodId, SYN_IE(Class)
                          )
                          classDefaultMethodId, SYN_IE(Class)
                          )

-import Id              ( GenId, idType, isDefaultMethodId_maybe, replacePragmaInfo,
+import Id              ( GenId, idType, replacePragmaInfo,

                          isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
 import ListSetOps      ( minusList )
                          isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
 import ListSetOps      ( minusList )

-import Maybes          ( maybeToBool, expectJust, seqMaybe )
-import Name            ( nameOccName, getOccString, occNameString, moduleString,
+import Maybes          ( maybeToBool, expectJust, seqMaybe, catMaybes )
+import Name            ( nameOccName, getOccString, occNameString, moduleString, getSrcLoc,

                          isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
                          NamedThing(..)
                        )
                          isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
                          NamedThing(..)
                        )

-import PrelVals                ( nO_EXPLICIT_METHOD_ERROR_ID )
-import PprType         ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
+import PrelVals                ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
+import PprType         ( GenType, GenTyVar, GenClass, TyCon,

                          pprParendGenType
                        )
 import Outputable
                          pprParendGenType
                        )
 import Outputable

@@ -94,7 +95,7 @@ import TyVar          ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
 import TysPrim         ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
 import TysPrim         ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )

-import Util            ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..),
+import Util            ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..)

 #if __GLASGOW_HASKELL__ < 202
                          , trace 
 #endif
 #if __GLASGOW_HASKELL__ < 202
                          , trace 
 #endif

@@ -175,16 +176,17 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 
 \begin{code}
 \end{enumerate}
 
 \begin{code}

-tcInstDecls1 :: [RenamedHsDecl]
+tcInstDecls1 :: TcEnv s                        -- Contains IdInfo for dfun ids
+            -> [RenamedHsDecl]

             -> Module                  -- module name for deriving
             -> RnNameSupply                    -- for renaming derivings
             -> TcM s (Bag InstInfo,
                       RenamedHsBinds,
                       PprStyle -> Doc)
 
             -> Module                  -- module name for deriving
             -> RnNameSupply                    -- for renaming derivings
             -> TcM s (Bag InstInfo,
                       RenamedHsBinds,
                       PprStyle -> Doc)
 

-tcInstDecls1 decls mod_name rn_name_supply
+tcInstDecls1 unf_env decls mod_name rn_name_supply

   =    -- Do the ordinary instance declarations
   =    -- Do the ordinary instance declarations

-    mapNF_Tc (tcInstDecl1 mod_name) 
+    mapNF_Tc (tcInstDecl1 unf_env mod_name) 

             [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
     let
        decl_inst_info = unionManyBags inst_info_bags
             [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
     let
        decl_inst_info = unionManyBags inst_info_bags

@@ -202,9 +204,9 @@ tcInstDecls1 decls mod_name rn_name_supply
     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 
 
     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 
 

-tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)

 
 

-tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
+tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)

   =    -- Prime error recovery, set source location
     recoverNF_Tc (returnNF_Tc emptyBag)        $
     tcAddSrcLoc src_loc                        $
   =    -- Prime error recovery, set source location
     recoverNF_Tc (returnNF_Tc emptyBag)        $
     tcAddSrcLoc src_loc                        $

@@ -225,12 +227,14 @@ tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
                                        `thenTc` \ (inst_tycon,arg_tys) ->
 
        -- Make the dfun id and constant-method ids
                                        `thenTc` \ (inst_tycon,arg_tys) ->
 
        -- Make the dfun id and constant-method ids

-    mkInstanceRelatedIds dfun_name
-                        clas inst_tyvars inst_tau inst_theta
-                                       `thenNF_Tc` \ (dfun_id, dfun_theta) ->
-
+    let
+       (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
+                                        clas inst_tyvars inst_tau inst_theta
+       -- Add info from interface file
+       final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
+    in

     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta   
     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta   

-                               dfun_theta dfun_id
+                       dfun_theta final_dfun_id

                                binds src_loc uprags))
   where
     (tyvar_names, context, dict_ty) = case poly_ty of
                                binds src_loc uprags))
   where
     (tyvar_names, context, dict_ty) = case poly_ty of

@@ -250,15 +254,15 @@ tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 
 \begin{code}
 tcInstDecls2 :: Bag InstInfo
 
 \begin{code}
 tcInstDecls2 :: Bag InstInfo

-            -> NF_TcM s (LIE s, TcHsBinds s)
+            -> NF_TcM s (LIE s, TcMonoBinds s)

 
 tcInstDecls2 inst_decls
 
 tcInstDecls2 inst_decls

-  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
+  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls

   where
     combine tc1 tc2 = tc1      `thenNF_Tc` \ (lie1, binds1) ->
                      tc2       `thenNF_Tc` \ (lie2, binds2) ->
                      returnNF_Tc (lie1 `plusLIE` lie2,
   where
     combine tc1 tc2 = tc1      `thenNF_Tc` \ (lie1, binds1) ->
                      tc2       `thenNF_Tc` \ (lie2, binds2) ->
                      returnNF_Tc (lie1 `plusLIE` lie2,

-                                  binds1 `ThenBinds` binds2)
+                                  binds1 `AndMonoBinds` binds2)

 \end{code}
 
 
 \end{code}
 
 

@@ -329,14 +333,14 @@ is the @dfun_theta@ below.
 First comes the easy case of a non-local instance decl.
 
 \begin{code}
 First comes the easy case of a non-local instance decl.
 
 \begin{code}

-tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcHsBinds s)
+tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)

 
 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
                      inst_decl_theta dfun_theta
                      dfun_id monobinds
                      locn uprags)
   | not (isLocallyDefined dfun_id)
 
 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
                      inst_decl_theta dfun_theta
                      dfun_id monobinds
                      locn uprags)
   | not (isLocallyDefined dfun_id)

-  = returnNF_Tc (emptyLIE, EmptyBinds)
+  = returnNF_Tc (emptyLIE, EmptyMonoBinds)

 
 {-
   -- I deleted this "optimisation" because when importing these
 
 {-
   -- I deleted this "optimisation" because when importing these

@@ -351,8 +355,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 
   | otherwise
   =     -- Prime error recovery
 
   | otherwise
   =     -- Prime error recovery

-    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds))  $
-    tcAddSrcLoc locn                                   $
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
+    tcAddSrcLoc locn                                      $

 
        -- Get the class signature
     tcInstSigTyVars inst_tyvars                `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 
        -- Get the class signature
     tcInstSigTyVars inst_tyvars                `thenNF_Tc` \ (inst_tyvars', _, tenv) ->

@@ -360,7 +364,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
        origin = InstanceDeclOrigin
         (class_tyvar,
         super_classes, sc_sel_ids,
        origin = InstanceDeclOrigin
         (class_tyvar,
         super_classes, sc_sel_ids,

-        class_ops, op_sel_ids, defm_ids) = classBigSig clas
+        op_sel_ids, defm_ids) = classBigSig clas

     in
     tcInstType tenv inst_ty            `thenNF_Tc` \ inst_ty' ->
     tcInstTheta tenv dfun_theta                `thenNF_Tc` \ dfun_theta' ->
     in
     tcInstType tenv inst_ty            `thenNF_Tc` \ inst_ty' ->
     tcInstTheta tenv dfun_theta                `thenNF_Tc` \ dfun_theta' ->

@@ -390,8 +394,10 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
     in
     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))     `thenTc_`
     tcExtendGlobalTyVars inst_tyvars_set' (
     in
     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))     `thenTc_`
     tcExtendGlobalTyVars inst_tyvars_set' (

-       mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' prag_fn monobinds) 
-                      (op_sel_ids `zip` [0..])
+        tcExtendGlobalValEnv (catMaybes defm_ids) $
+               -- Default-method Ids may be mentioned in synthesised RHSs 
+       mapAndUnzip3Tc (tcMethodBind clas inst_ty' monobinds) 
+                      (op_sel_ids `zip` defm_ids)

     )                                  `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 
        -- Check the overloading constraints of the methods and superclasses
     )                                  `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 
        -- Check the overloading constraints of the methods and superclasses

@@ -427,28 +433,16 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
        method_binds = andMonoBinds method_binds_s
 
        main_bind
        method_binds = andMonoBinds method_binds_s
 
        main_bind

-         = MonoBind (
-               AbsBinds
+         = AbsBinds

                 inst_tyvars'
                 dfun_arg_dicts_ids
                 [(inst_tyvars', RealId dfun_id, this_dict_id)] 
                 (super_binds   `AndMonoBinds` 
                  method_binds  `AndMonoBinds`
                 inst_tyvars'
                 dfun_arg_dicts_ids
                 [(inst_tyvars', RealId dfun_id, this_dict_id)] 
                 (super_binds   `AndMonoBinds` 
                  method_binds  `AndMonoBinds`

-                 dict_bind))
-               [] recursive            -- Recursive to play safe
+                 dict_bind)

     in
     returnTc (const_lie `plusLIE` spec_lie,
     in
     returnTc (const_lie `plusLIE` spec_lie,

-             main_bind `ThenBinds` spec_binds)
-\end{code}
-
-The next function looks for a method binding; if there isn't one it
-manufactures one that just calls the global default method.
-
-See the notes under default decls in TcClassDcl.lhs.
-
-\begin{code}
-getDefmRhs :: Class -> Int -> RenamedHsExpr
-getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx))
+             main_bind `AndMonoBinds` spec_binds)

 \end{code}
 
 
 \end{code}
 
 

@@ -460,32 +454,32 @@ getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx))
 
 \begin{code}
 tcMethodBind 
 
 \begin{code}
 tcMethodBind 

-       :: (Int -> RenamedHsExpr)                       -- Function mapping a tag to default RHS
+       :: Class

        -> TcType s                                     -- Instance type
        -> TcType s                                     -- Instance type

-       -> (Name -> PragmaInfo)

        -> RenamedMonoBinds                             -- Method binding
        -> RenamedMonoBinds                             -- Method binding

-       -> (Id, Int)                                    -- Selector ID (and its 0-indexed tag)
-                                                       --  for which binding is wanted
+       -> (Id, Maybe Id)                               -- Selector id and default-method id

        -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 
        -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 

-tcMethodBind deflt_fn inst_ty prag_fn meth_binds (sel_id, idx)
-  = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId meth_id) ->
-    tcInstSigTcType (idType meth_id)           `thenNF_Tc` \ (tyvars', rho_ty') ->
+tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
+  = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
+    tcInstSigTcType (idType local_meth_id)     `thenNF_Tc` \ (tyvars', rho_ty') ->

     let
     let

-       meth_name    = getName meth_id
-       default_bind = PatMonoBind (VarPatIn meth_name)
-                                  (GRHSsAndBindsIn [OtherwiseGRHS (deflt_fn idx) noSrcLoc] EmptyBinds)
-                                  noSrcLoc
+       meth_name    = getName local_meth_id

 
 

-        (op_name, op_bind) = case go (getOccName sel_id) meth_binds of
-                               Just stuff -> stuff
-                               Nothing    -> (meth_name, default_bind)
+       maybe_meth_bind      = go (getOccName sel_id) meth_binds 
+        (bndr_name, op_bind) = case maybe_meth_bind of
+                                 Just stuff -> stuff
+                                 Nothing    -> (meth_name, mk_default_bind meth_name)

 
        (theta', tau')  = splitRhoTy rho_ty'
 
        (theta', tau')  = splitRhoTy rho_ty'

-       meth_id_w_prags = replacePragmaInfo meth_id (prag_fn meth_name)
-       sig_info        = TySigInfo op_name meth_id_w_prags tyvars' theta' tau' noSrcLoc
+       sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc

     in
     in

-    tcBindWithSigs [op_name] op_bind [sig_info]
+
+       -- Warn if no method binding
+    warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id))        
+          (omittedMethodWarn sel_id clas)              `thenNF_Tc_`
+
+    tcBindWithSigs [bndr_name] op_bind [sig_info]

                   nonRecursive (\_ -> NoPragmaInfo)    `thenTc` \ (binds, insts, _) ->
 
     returnTc (binds, insts, meth)
                   nonRecursive (\_ -> NoPragmaInfo)    `thenTc` \ (binds, insts, _) ->
 
     returnTc (binds, insts, meth)

@@ -500,6 +494,23 @@ tcMethodBind deflt_fn inst_ty prag_fn meth_binds (sel_id, idx)
     go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
                                                     | otherwise                  = Nothing
     go occ other = panic "Urk! Bad instance method binding"
     go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
                                                     | otherwise                  = Nothing
     go occ other = panic "Urk! Bad instance method binding"

+
+
+    mk_default_bind local_meth_name
+      = PatMonoBind (VarPatIn local_meth_name)
+                   (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
+                   noSrcLoc
+
+    default_expr = case maybe_dm_id of
+                       Just dm_id -> HsVar (getName dm_id)     -- There's a default method
+                       Nothing    -> error_expr                -- No default method
+
+    error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID)) 
+                             (HsLit (HsString (_PK_ error_msg)))
+
+    error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|", 
+                           ppr (PprForUser opt_PprUserLength) sel_id
+               ])

 \end{code}
 
 
 \end{code}
 
 

@@ -730,7 +741,7 @@ instTypeErr ty sty
   = case ty of
       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
   = case ty of
       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]

-      other       -> hsep [ptext SLIT("The type"), ppr sty ty, rest_of_msg]
+      other       -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]

   where
     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 
   where
     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 

@@ -743,24 +754,14 @@ derivingWhenInstanceExistsErr clas tycon sty
                       ptext SLIT("type"), ppr sty tycon])
          4 (ptext SLIT("when an explicit instance exists"))
 
                       ptext SLIT("type"), ppr sty tycon])
          4 (ptext SLIT("when an explicit instance exists"))
 

-derivingWhenInstanceImportedErr inst_mod clas tycon sty
-  = hang (hsep [ptext SLIT("Deriving class"), 
-                      ppr sty clas, 
-                      ptext SLIT("type"), ppr sty tycon])
-         4 (hsep [ptext SLIT("when an instance declared in module"), 
-                      pp_mod, ptext SLIT("has been imported")])
-  where
-    pp_mod = hsep [ptext SLIT("module"), ptext inst_mod]
-

 nonBoxedPrimCCallErr clas inst_ty sty
   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
         4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
                        ppr sty inst_ty])
 
 nonBoxedPrimCCallErr clas inst_ty sty
   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
         4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
                        ppr sty inst_ty])
 

-omitDefaultMethodWarn clas_op clas_name inst_ty sty
-  = hsep [ptext SLIT("Warning: Omitted default method for"),
-          ppr sty clas_op, ptext SLIT("in instance"),
-          text clas_name, pprParendGenType sty inst_ty]
+omittedMethodWarn sel_id clas sty
+  = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id, 
+        ptext SLIT("in an instance declaration for") <+> ppr sty clas]

 
 instMethodNotInClassErr occ clas sty
   = hang (ptext SLIT("Instance mentions a method not in the class"))
 
 instMethodNotInClassErr occ clas sty
   = hang (ptext SLIT("Instance mentions a method not in the class"))

@@ -781,5 +782,4 @@ bindSigCtxt sty
 
 superClassSigCtxt sty
   = ptext SLIT("When checking superclass constraints of an instance declaration")
 
 superClassSigCtxt sty
   = ptext SLIT("When checking superclass constraints of an instance declaration")

-

 \end{code}
 \end{code}

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 991eb6a..0bebb37 100644 (file)
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -20,17 +20,15 @@ import HsSyn                ( MonoBinds, Fake, InPat, Sig )
 import RnHsSyn         ( SYN_IE(RenamedMonoBinds), RenamedSig(..), 
                          RenamedInstancePragmas(..) )
 
 import RnHsSyn         ( SYN_IE(RenamedMonoBinds), RenamedSig(..), 
                          RenamedInstancePragmas(..) )
 

-import TcEnv           ( tcAddImportedIdInfo )

 import TcMonad
 import Inst            ( SYN_IE(InstanceMapper) )
 
 import Bag             ( bagToList, Bag )
 import TcMonad
 import Inst            ( SYN_IE(InstanceMapper) )
 
 import Bag             ( bagToList, Bag )

-import Class           ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
-                         classBigSig, classOps, classOpLocalType,
-                         SYN_IE(ClassOp), SYN_IE(Class)
+import Class           ( GenClass, SYN_IE(ClassInstEnv),
+                         classBigSig, SYN_IE(Class)

                        )
 import CoreSyn         ( GenCoreExpr(..), mkValLam, mkTyApp )
                        )
 import CoreSyn         ( GenCoreExpr(..), mkValLam, mkTyApp )

-import Id              ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) )
+import Id              ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )

 import MatchEnv                ( nullMEnv, insertMEnv )
 import Maybes          ( MaybeErr(..), mkLookupFunDef )
 import Name            ( getSrcLoc, Name{--O only-} )
 import MatchEnv                ( nullMEnv, insertMEnv )
 import Maybes          ( MaybeErr(..), mkLookupFunDef )
 import Name            ( getSrcLoc, Name{--O only-} )

@@ -45,9 +43,7 @@ import TyVar          ( GenTyVar, SYN_IE(TyVar) )
 import Unique          ( Unique )
 import Util            ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
 
 import Unique          ( Unique )
 import Util            ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
 

-#if __GLASGOW_HASKELL__ >= 202

 import Outputable
 import Outputable

-#endif

 \end{code}
 
     instance c => k (t tvs) where b
 \end{code}
 
     instance c => k (t tvs) where b

@@ -82,13 +78,12 @@ mkInstanceRelatedIds :: Name                -- Name to use for the dict fun;
                     -> [TyVar]
                     -> Type
                     -> ThetaType
                     -> [TyVar]
                     -> Type
                     -> ThetaType

-                    -> NF_TcM s (Id, ThetaType)
+                    -> (Id, ThetaType)

 
 mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
 
 mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta

-  = tcAddImportedIdInfo dfun_id                        `thenNF_Tc` \ new_dfun_id ->
-    returnNF_Tc (new_dfun_id, dfun_theta)
+  = (dfun_id, dfun_theta)

   where
   where

-    (_, super_classes, _, _, _, _) = classBigSig clas
+    (_, super_classes, _, _, _) = classBigSig clas

     super_class_theta = super_classes `zip` repeat inst_ty
 
     dfun_theta = case inst_decl_theta of
     super_class_theta = super_classes `zip` repeat inst_ty
 
     dfun_theta = case inst_decl_theta of

@@ -126,24 +121,20 @@ buildInstanceEnvs info
     in
     mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
     let
     in
     mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
     let

-       class_lookup_fn = mkLookupFunDef (==) inst_env_entries 
-                                        (nullMEnv, \ o -> nullSpecEnv)
+       class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv

     in
     returnTc class_lookup_fn
 \end{code}
 
 \begin{code}
 buildInstanceEnv :: [InstInfo]         -- Non-empty, and all for same class
     in
     returnTc class_lookup_fn
 \end{code}
 
 \begin{code}
 buildInstanceEnv :: [InstInfo]         -- Non-empty, and all for same class

-                -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+                -> TcM s (Class, ClassInstEnv)

 
 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
   = foldlTc addClassInstance
 
 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
   = foldlTc addClassInstance

-           (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
-           inst_infos
-                                       `thenTc` \ (class_inst_env, op_inst_envs) ->
-    returnTc (clas, (class_inst_env,
-                    mkLookupFunDef (==) op_inst_envs
-                                   (panic "buildInstanceEnv")))
+           nullMEnv
+           inst_infos                          `thenTc` \ class_inst_env ->
+    returnTc (clas, class_inst_env)

 \end{code}
 
 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 \end{code}
 
 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@

@@ -152,34 +143,19 @@ about any overlap with an existing instance.
 
 \begin{code}
 addClassInstance
 
 \begin{code}
 addClassInstance

-    :: (ClassInstEnv, [(ClassOp,SpecEnv)])
+    :: ClassInstEnv

     -> InstInfo
     -> InstInfo

-    -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
+    -> TcM s ClassInstEnv

 
 

-addClassInstance
-    input_stuff@(class_inst_env, op_spec_envs)
+addClassInstance class_inst_env

     (InstInfo clas inst_tyvars inst_ty _ _ 
              dfun_id _ src_loc _)
     (InstInfo clas inst_tyvars inst_ty _ _ 
              dfun_id _ src_loc _)

-  = 
-
--- We only add specialised/overlapped instances
--- if we are specialising the overloading
--- ToDo ... This causes getConstMethodId errors!
---
---    if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
---    then
---     -- Drop this specialised/overlapped instance
---     returnTc (class_inst_env, op_spec_envs)
---    else     
-
-       -- Add the instance to the class's instance environment
-    case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
-       Failed (ty', dfun_id')    -> recoverTc (returnTc input_stuff) $
+  =    -- Add the instance to the class's instance environment
+    case insertMEnv matchTy class_inst_env inst_ty dfun_id of
+       Failed (ty', dfun_id')    -> recoverTc (returnTc class_inst_env) $

                                     dupInstFailure clas (inst_ty, src_loc) 
                                                         (ty', getSrcLoc dfun_id');
                                     dupInstFailure clas (inst_ty, src_loc) 
                                                         (ty', getSrcLoc dfun_id');

-       Succeeded class_inst_env' -> 
-
-           returnTc (class_inst_env', op_spec_envs)
+       Succeeded class_inst_env' -> returnTc class_inst_env'

 
 {-             OLD STUFF FOR CONSTANT METHODS 
 
 
 {-             OLD STUFF FOR CONSTANT METHODS 
 

@@ -224,7 +200,6 @@ addClassInstance
     returnTc (class_inst_env', op_spec_envs')
                END OF OLD STUFF -}
 
     returnTc (class_inst_env', op_spec_envs')
                END OF OLD STUFF -}
 

-    }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -233,8 +208,8 @@ dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
   = tcAddErrCtxt ctxt $
     failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
   where
   = tcAddErrCtxt ctxt $
     failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
   where

-    ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas,
-                         ptext SLIT("type"),  ppr sty ty1])
-                   4 (sep [hcat [ptext SLIT("at "), ppr sty locn1],
-                             hcat [ptext SLIT("and "), ppr sty locn2]])
+    ctxt sty = sep [hsep [ptext SLIT("for"), 
+                         pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty1],
+                   nest 4 (sep [ptext SLIT("at")  <+> ppr sty locn1,
+                                ptext SLIT("and") <+> ppr sty locn2])]

 \end{code}
 \end{code}

diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index 20b0ff1..bafa1fb 100644 (file)
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -24,9 +24,7 @@ import TcMonad
 import Unique  ( Unique, pprUnique10 )
 import Pretty
 import Util    ( nOfThem )
 import Unique  ( Unique, pprUnique10 )
 import Pretty
 import Util    ( nOfThem )

-#if __GLASGOW_HASKELL__ >= 202

 import Outputable
 import Outputable

-#endif

 \end{code}
 
 
 \end{code}
 
 

@@ -179,7 +177,7 @@ zonkTcKind kind@(TcVarKind uniq box)
 
 \begin{code}
 instance Outputable (TcKind s) where
 
 \begin{code}
 instance Outputable (TcKind s) where

-  ppr sty kind = ppr_kind sty kind
+  ppr sty kind = pprQuote sty $ \ sty -> ppr_kind sty kind

 
 ppr_kind sty TcTypeKind 
   = char '*'
 
 ppr_kind sty TcTypeKind 
   = char '*'

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index c168141..ee23bb1 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -9,26 +9,26 @@
 module TcModule (
        typecheckModule,
        SYN_IE(TcResults),
 module TcModule (
        typecheckModule,
        SYN_IE(TcResults),

-       SYN_IE(TcResultBinds),

        SYN_IE(TcSpecialiseRequests),
        SYN_IE(TcDDumpDeriv)
     ) where
 
 IMP_Ubiq(){-uitous-}
 
        SYN_IE(TcSpecialiseRequests),
        SYN_IE(TcDDumpDeriv)
     ) where
 
 IMP_Ubiq(){-uitous-}
 

-import HsSyn           ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds,
+import HsSyn           ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..),

                          TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
                          SpecInstSig, DefaultDecl, Sig, Fake, InPat,
                          TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
                          SpecInstSig, DefaultDecl, Sig, Fake, InPat,

-                         SYN_IE(RecFlag), nonRecursive,
+                         SYN_IE(RecFlag), nonRecursive,  GRHSsAndBinds, Match,

                          FixityDecl, IE, ImportDecl
                        )
 import RnHsSyn         ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
 import TcHsSyn         ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
                          FixityDecl, IE, ImportDecl
                        )
 import RnHsSyn         ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
 import TcHsSyn         ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),

-                         SYN_IE(TypecheckedDictBinds),
-                         TcIdOcc(..), zonkBinds )
+                         SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds),
+                         SYN_IE(TypecheckedMonoBinds),
+                         TcIdOcc(..), zonkTopBinds )

 
 import TcMonad
 
 import TcMonad

-import Inst            ( Inst, plusLIE )
+import Inst            ( Inst, emptyLIE, plusLIE )

 import TcBinds         ( tcBindsAndThen )
 import TcClassDcl      ( tcClassDecls2 )
 import TcDefaults      ( tcDefaults )
 import TcBinds         ( tcBindsAndThen )
 import TcClassDcl      ( tcClassDecls2 )
 import TcDefaults      ( tcDefaults )

@@ -55,7 +55,7 @@ import Maybes         ( catMaybes, MaybeErr )
 import Name            ( Name, isLocallyDefined, pprModule )
 import Pretty
 import TyCon           ( TyCon, isSynTyCon )
 import Name            ( Name, isLocallyDefined, pprModule )
 import Pretty
 import TyCon           ( TyCon, isSynTyCon )

-import Class           ( GenClass, SYN_IE(Class), classGlobalIds )
+import Class           ( GenClass, SYN_IE(Class), classSelIds )

 import Type            ( applyTyCon, mkSynTy, SYN_IE(Type) )
 import PprType         ( GenType, GenTyVar )
 import TysWiredIn      ( unitTy )
 import Type            ( applyTyCon, mkSynTy, SYN_IE(Type) )
 import PprType         ( GenType, GenTyVar )
 import TysWiredIn      ( unitTy )

@@ -79,24 +79,22 @@ tycon_specs = emptyFM
 
 Outside-world interface:
 \begin{code}
 
 Outside-world interface:
 \begin{code}

+--ToDo: put this in HsVersions
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
+

 -- Convenient type synonyms first:
 type TcResults
 -- Convenient type synonyms first:
 type TcResults

-  = (TcResultBinds,
+  = (TypecheckedMonoBinds,

      [TyCon], [Class],
      Bag InstInfo,             -- Instance declaration information
      TcSpecialiseRequests,
      TcDDumpDeriv)
 
      [TyCon], [Class],
      Bag InstInfo,             -- Instance declaration information
      TcSpecialiseRequests,
      TcDDumpDeriv)
 

-type TcResultBinds
-  = (TypecheckedHsBinds,       -- record selector binds
-     TypecheckedHsBinds,       -- binds from class decls; does NOT
-                               -- include default-methods bindings
-     TypecheckedHsBinds,       -- binds from instance decls; INCLUDES
-                               -- class default-methods binds
-     TypecheckedHsBinds,       -- binds from value decls
-
-     TypecheckedHsBinds)       -- constant instance binds
-

 type TcSpecialiseRequests
   = FiniteMap TyCon [(Bool, [Maybe Type])]
     -- source tycon specialisation requests
 type TcSpecialiseRequests
   = FiniteMap TyCon [(Bool, [Maybe Type])]
     -- source tycon specialisation requests

@@ -110,9 +108,9 @@ typecheckModule
        -> RnNameSupply
        -> RenamedHsModule
        -> MaybeErr
        -> RnNameSupply
        -> RenamedHsModule
        -> MaybeErr

-           (TcResults,         -- if all goes well...
-            Bag Warning)       -- (we can still get warnings)
-           (Bag Error,         -- if we had errors...
+           (TcResults,                 -- if all goes well...
+            Bag Warning)               -- (we can still get warnings)
+           (Bag Error,                 -- if we had errors...

             Bag Warning)
 
 typecheckModule us rn_name_supply mod
             Bag Warning)
 
 typecheckModule us rn_name_supply mod

@@ -129,133 +127,124 @@ tcModule rn_name_supply
        (HsModule mod_name verion exports imports fixities decls src_loc)
   = tcAddSrcLoc src_loc $      -- record where we're starting
 
        (HsModule mod_name verion exports imports fixities decls src_loc)
   = tcAddSrcLoc src_loc $      -- record where we're starting
 

-       -- Tie the knot for inteface-file value declaration signatures
-       -- This info is only used inside the knot for type-checking the
-       -- pragmas, which is done lazily [ie failure just drops the pragma
+    fixTc (\ ~(unf_env ,_) ->
+       -- unf_env is used for type-checking interface pragmas
+       -- which is done lazily [ie failure just drops the pragma

        -- without having any global-failure effect].
        -- without having any global-failure effect].

+       -- 
+       -- unf_env is also used to get the pragam info for dfuns.
+
+           -- The knot for instance information.  This isn't used at all
+           -- till we type-check value declarations
+       fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+    
+                -- Type-check the type and class decls
+               -- trace "tcTyAndClassDecls:"   $
+               tcTyAndClassDecls1 unf_env rec_inst_mapper decls        `thenTc` \ env ->
+    
+               -- trace "tc3" $
+                   -- Typecheck the instance decls, includes deriving
+               tcSetEnv env (
+               -- trace "tcInstDecls:" $
+               tcInstDecls1 unf_env decls mod_name rn_name_supply
+               )                                       `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+    
+               -- trace "tc4" $
+               buildInstanceEnvs inst_info     `thenTc` \ inst_mapper ->
+    
+               returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+    
+       -- End of inner fix loop
+       ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+    
+       -- trace "tc5" $
+       tcSetEnv env $
+       
+           -- Default declarations
+       tcDefaults decls                `thenTc` \ defaulting_tys ->
+       tcSetDefaultTys defaulting_tys  $
+       
+       -- Create any necessary record selector Ids and their bindings
+       -- "Necessary" includes data and newtype declarations
+       let
+           tycons   = getEnv_TyCons env
+           classes  = getEnv_Classes env
+       in
+       mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
+       
+       -- Extend the global value environment with 
+       --      (a) constructors
+       --      (b) record selectors
+       --      (c) class op selectors
+       --      (d) default-method ids
+       tcExtendGlobalValEnv data_ids                           $
+       tcExtendGlobalValEnv (concat (map classSelIds classes)) $

 
 

-    -- trace "tc1" $
-
-    fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
-
-       -- trace "tc2" $
-       tcExtendGlobalValEnv sig_ids (

 
 

-       -- The knot for instance information.  This isn't used at all
-       -- till we type-check value declarations
-       fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+           -- Interface type signatures
+           -- We tie a knot so that the Ids read out of interfaces are in scope
+           --   when we read their pragmas.
+           -- What we rely on is that pragmas are typechecked lazily; if
+           --   any type errors are found (ie there's an inconsistency)
+           --   we silently discard the pragma
+       tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
+       tcExtendGlobalValEnv sig_ids            $

 
 

-            -- Type-check the type and class decls
-           -- trace "tcTyAndClassDecls:"       $
-           tcTyAndClassDecls1 rec_inst_mapper decls    `thenTc` \ env ->

 
 

-           -- trace "tc3" $
-               -- Typecheck the instance decls, includes deriving
-           tcSetEnv env (
-           -- trace "tcInstDecls:"     $
-           tcInstDecls1 decls mod_name rn_name_supply
-           )                                   `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+       -- Value declarations next.
+       -- We also typecheck any extra binds that came out of the "deriving" process
+        -- trace "tcBinds:"                    $
+       tcBindsAndThen
+           (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
+           (get_val_decls decls `ThenBinds` deriv_binds)
+           (   tcGetEnv                `thenNF_Tc` \ env ->
+               returnTc ((EmptyMonoBinds, env), emptyLIE)
+           )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
+       tcSetEnv final_env $

 
 

-           -- trace "tc4" $
-           buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->

 
 

-           returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+               -- Second pass over class and instance declarations,
+               -- to compile the bindings themselves.
+       -- trace "tc8" $
+       tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+       tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->

 
 

-       ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->

 
 

-       -- trace "tc5" $
-       tcSetEnv env (

 
 

-           -- Default declarations
-       tcDefaults decls                `thenTc` \ defaulting_tys ->
-       tcSetDefaultTys defaulting_tys  ( -- for the iface sigs...
+       -- Check that "main" has the right signature
+       tcCheckMainSig mod_name         `thenTc_` 

 
 

-       -- Create any necessary record selector Ids and their bindings
-       -- "Necessary" includes data and newtype declarations
+            -- Deal with constant or ambiguous InstIds.  How could
+            -- there be ambiguous ones?  They can only arise if a
+            -- top-level decl falls under the monomorphism
+            -- restriction, and no subsequent decl instantiates its
+            -- type.  (Usually, ambiguous type variables are resolved
+            -- during the generalisation step.)
+       -- trace "tc9" $

        let
        let

-               tycons   = getEnv_TyCons env
-               classes  = getEnv_Classes env
+           lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls

        in
        in

-       mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
+       tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->

 
 

-       -- Extend the global value environment with 
-       --      a) constructors
-       --      b) record selectors
-       --      c) class op selectors
-       --      d) default-method ids
-       tcExtendGlobalValEnv data_ids                           $
-       tcExtendGlobalValEnv (concat (map classGlobalIds classes))      $

 
 

-           -- Interface type signatures
-           -- We tie a knot so that the Ids read out of interfaces are in scope
-           --   when we read their pragmas.
-           -- What we rely on is that pragmas are typechecked lazily; if
-           --   any type errors are found (ie there's an inconsistency)
-           --   we silently discard the pragma
-       tcInterfaceSigs decls           `thenTc` \ sig_ids ->
-       tcGetEnv                        `thenNF_Tc` \ env ->
-       -- trace "tc6" $
-
-       returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
-
-    )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+           -- Backsubstitution.    This must be done last.
+           -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
+       let
+           all_binds = data_binds              `AndMonoBinds` 
+                       val_binds               `AndMonoBinds`
+                       inst_binds              `AndMonoBinds`
+                       cls_binds               `AndMonoBinds`
+                       const_inst_binds
+       in
+       zonkTopBinds all_binds  `thenNF_Tc` \ (all_binds', really_final_env)  ->

 
 

-    -- trace "tc7" $
-    tcSetEnv env (                             -- to the end...
-    tcSetDefaultTys defaulting_tys (           -- ditto
+       returnTc (really_final_env, (all_binds', inst_info, ddump_deriv))

 
 

-       -- Value declarations next.
-       -- We also typecheck any extra binds that came out of the "deriving" process
-    -- trace "tcBinds:"                        $
-    tcBindsAndThen
-       (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
-       (get_val_decls decls `ThenBinds` deriv_binds)
-       (       -- Second pass over instance declarations,
-               -- to compile the bindings themselves.
-           -- trace "tc8" $
-           tcInstDecls2  inst_info     `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
-           tcClassDecls2 decls         `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
-           tcCheckMainSig mod_name     `thenTc_` 
-           tcGetEnv                    `thenNF_Tc` \ env ->
-           returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
-                      lie_instdecls `plusLIE` lie_clasdecls
-                    )
-       )
-
-       `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
-
-       -- Deal with constant or ambiguous InstIds.  How could
-       -- there be ambiguous ones?  They can only arise if a
-       -- top-level decl falls under the monomorphism
-       -- restriction, and no subsequent decl instantiates its
-       -- type.  (Usually, ambiguous type variables are resolved
-       -- during the generalisation step.)
-    -- trace "tc9" $
-    tcSimplifyTop lie_alldecls                 `thenTc` \ const_insts ->
-
-
-       -- Backsubstitution.  Monomorphic top-level decls may have
-       -- been instantiated by subsequent decls, and the final
-       -- simplification step may have instantiated some
-       -- ambiguous types.  So, sadly, we need to back-substitute
-       -- over the whole bunch of bindings.
-       -- 
-       -- More horrible still, we have to do it in a careful order, so that
-       -- all the TcIds are in scope when we come across them.
-       -- 
-       -- These bindings ought really to be bundled together in a huge
-       -- recursive group, but HsSyn doesn't have recursion among Binds, only
-       -- among MonoBinds.  Sigh again.
-    zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
-                                                       `thenNF_Tc` \ (const_insts', ve1) ->
-    zonkBinds nullTyVarEnv ve1 val_binds               `thenNF_Tc` \ (val_binds', ve2) ->
+    -- End of outer fix loop
+    ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) ->

 
 

-    zonkBinds nullTyVarEnv ve2 data_binds      `thenNF_Tc` \ (data_binds', _) ->
-    zonkBinds nullTyVarEnv ve2 inst_binds      `thenNF_Tc` \ (inst_binds', _) ->
-    zonkBinds nullTyVarEnv ve2 cls_binds       `thenNF_Tc` \ (cls_binds', _) ->

 
     let
 
     let

-        localids = getEnv_LocalIds final_env

        tycons   = getEnv_TyCons   final_env
        classes  = getEnv_Classes  final_env
 
        tycons   = getEnv_TyCons   final_env
        classes  = getEnv_Classes  final_env
 

@@ -264,12 +253,12 @@ tcModule rn_name_supply
     in
        -- FINISHED AT LAST
     returnTc (
     in
        -- FINISHED AT LAST
     returnTc (

-       (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
+       all_binds',

 
        local_tycons, local_classes, inst_info, tycon_specs,
 
        ddump_deriv
 
        local_tycons, local_classes, inst_info, tycon_specs,
 
        ddump_deriv

-    )))
+    )

 
 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 \end{code}
 
 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 \end{code}