[project @ 2000-04-21 15:59:13 by panne]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 586c5a5..8e546fe 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -13,7 +13,7 @@ module TcEnv(
 
        tcLookupTy,
        tcLookupTyCon, tcLookupTyConByKey, 
-       tcLookupClass, tcLookupClassByKey,
+       tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe,
 
        tcExtendGlobalValEnv, tcExtendLocalValEnv,
        tcGetValueEnv,        tcSetValueEnv, 
@@ -22,6 +22,7 @@ module TcEnv(
        tcLookupValue,      tcLookupValueMaybe, 
        tcLookupValueByKey, tcLookupValueByKeyMaybe,
        explicitLookupValueByKey, explicitLookupValue,
+       valueEnvIds,
 
        newLocalId, newSpecPragmaId,
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
@@ -32,7 +33,7 @@ module TcEnv(
 #include "HsVersions.h"
 
 import HsTypes ( HsTyVar, getTyVarName )
-import Id      ( mkUserLocal, isDataConId_maybe )
+import Id      ( mkUserLocal, isDataConWrapId_maybe )
 import MkId    ( mkSpecPragmaId )
 import Var     ( TyVar, Id, setVarName,
                  idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
@@ -88,7 +89,7 @@ type TcIdSet = IdSet
 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
 tcLookupDataCon con_name
   = tcLookupValue con_name             `thenNF_Tc` \ con_id ->
-    case isDataConId_maybe con_id of {
+    case isDataConWrapId_maybe con_id of {
        Nothing -> failWithTc (badCon con_id);
        Just data_con ->
 
@@ -152,6 +153,9 @@ type UsageEnv   = NameEnv UVar
 type TypeEnv   = NameEnv (TcKind, Maybe Arity, TcTyThing)
 type ValueEnv  = NameEnv Id    
 
+valueEnvIds :: ValueEnv -> [Id]
+valueEnvIds ve = eltsUFM ve
+
 data TcTyThing = ATyVar TcTyVar                -- Mutable only so that the kind can be mutable
                                        -- if the kind is mutable, the tyvar must be so that
                                        -- zonking works
@@ -328,6 +332,13 @@ tcLookupClassByKey key
        Just (_, _, AClass cl) -> returnNF_Tc cl
        other                  -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
 
+tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
+tcLookupClassByKey_maybe key
+  = tcGetEnv           `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+    case lookupUFM_Directly te key of
+       Just (_, _, AClass cl) -> returnNF_Tc (Just cl)
+       other                  -> returnNF_Tc Nothing
+
 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
 tcLookupTyConByKey key
   = tcGetEnv           `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->