[project @ 1996-04-25 16:31:20 by partain]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 98800bd..a30ed69 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -13,7 +13,7 @@ module TcEnv(
 
        tcExtendGlobalValEnv, tcExtendLocalValEnv,
        tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
-       tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc,
+       tcLookupGlobalValue, tcLookupGlobalValueByKey,
 
        newMonoIds, newLocalIds, newLocalId,
        tcGetGlobalTyVars
@@ -29,22 +29,21 @@ import TcKind       ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
 import TcType  ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
                  newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
                )
-import TyVar   ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
+import TyVar   ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
 import Type    ( tyVarsOfTypes )
 import TyCon   ( TyCon, Arity(..), tyConKind, synTyConArity )
-import Class   ( Class(..), GenClass, getClassSig )
+import Class   ( Class(..), GenClass, classSig )
 
 import TcMonad
 
-import Name            ( Name{-instance NamedThing-} )
-import Outputable      ( getOccName, getSrcLoc )
+import Name            ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
 import PprStyle
 import Pretty
 import RnHsSyn         ( RnName(..) )
 import Type            ( splitForAllTy )
-import Unique          ( Unique )
+import Unique          ( pprUnique10, pprUnique{-ToDo:rm-} )
 import UniqFM       
-import Util            ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
+import Util            ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic, pprTrace{-ToDo:rm-} )
 \end{code}
 
 Data type declarations
@@ -152,7 +151,7 @@ Looking up in the environments.
 \begin{code}
 tcLookupTyVar name
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
+    returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name)
 
 
 tcLookupTyCon (WiredInTyCon tc)                -- wired in tycons
@@ -160,26 +159,28 @@ tcLookupTyCon (WiredInTyCon tc)           -- wired in tycons
 
 tcLookupTyCon name
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name)
+    returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name)
 
 tcLookupTyConByKey uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let 
        (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce 
-                                       (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq)) 
+                                       (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) 
                                        uniq
     in
     returnNF_Tc tycon
 
 tcLookupClass name
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name)
+--  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $
+--  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $
+    returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name)
 
 tcLookupClassByKey uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let
        (kind, clas) = lookupWithDefaultUFM_Directly ce 
-                               (pprPanic "tcLookupClas:" (ppr PprDebug uniq))
+                               (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
                                uniq
     in
     returnNF_Tc clas
@@ -256,30 +257,13 @@ tcLookupGlobalValue name
     def = panic "tcLookupGlobalValue"
 #endif
 
--- A useful function that takes an occurrence of a global thing
--- and instantiates its type with fresh type variables
-tcGlobalOcc :: RnName 
-           -> NF_TcM s (Id,            -- The Id
-                         [TcType s],   -- Instance types
-                         TcType s)     -- Rest of its type
-
-tcGlobalOcc name
-  = tcLookupGlobalValue name   `thenNF_Tc` \ id ->
-    let
-      (tyvars, rho) = splitForAllTy (idType id)
-    in
-    tcInstTyVars tyvars                `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
-    tcInstType tenv rho                `thenNF_Tc` \ rho' ->
-    returnNF_Tc (id, arg_tys, rho')
-
-
 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 tcLookupGlobalValueByKey uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
   where
 #ifdef DEBUG
-    def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq)
+    def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
 #else
     def = panic "tcLookupGlobalValueByKey"
 #endif