[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 8ca0034..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,20 +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(..), getNameShortName )
+import Name            ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
 import PprStyle
 import Pretty
-import Type    ( splitForAllTy )
-import Unique  ( Unique )
-import UniqFM
-import Util    ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
+import RnHsSyn         ( RnName(..) )
+import Type            ( splitForAllTy )
+import Unique          ( pprUnique10, pprUnique{-ToDo:rm-} )
+import UniqFM       
+import Util            ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic, pprTrace{-ToDo:rm-} )
 \end{code}
 
 Data type declarations
@@ -75,10 +76,10 @@ Making new TcTyVars, with knot tying!
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 tcTyVarScopeGivenKinds 
-       :: [Name]                       -- Names of some type variables
+       :: [Name]               -- Names of some type variables
        -> [TcKind s]
-       -> ([TyVar] -> TcM s a)         -- Thing to type check in their scope
-       -> TcM s a                      -- Result
+       -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+       -> TcM s a              -- Result
 
 tcTyVarScopeGivenKinds names kinds thing_inside
   = fixTc (\ ~(rec_tyvars, _) ->
@@ -97,7 +98,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside
                -- Construct the real TyVars
        let
          tyvars             = zipWithEqual mk_tyvar names kinds'
-         mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+         mk_tyvar name kind = mkTyVar name (uniqueOf name) kind
        in
        returnTc (tyvars, result)
     )                                  `thenTc` \ (_,result) ->
@@ -116,7 +117,8 @@ Extending the environments.  Notice the uses of @zipLazy@, which makes sure
 that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
 
 \begin{code}
-tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+
 tcExtendTyConEnv names_w_arities tycons scope
   = newKindVars (length names_w_arities)       `thenNF_Tc` \ kinds ->
     tcGetEnv                                   `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -131,7 +133,7 @@ tcExtendTyConEnv names_w_arities tycons scope
     returnTc result 
 
 
-tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
+tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r
 tcExtendClassEnv names classes scope
   = newKindVars (length names) `thenNF_Tc` \ kinds ->
     tcGetEnv                   `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -149,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
@@ -157,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
@@ -190,7 +194,7 @@ Extending and consulting the value environment
 tcExtendGlobalValEnv ids scope
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let
-       gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
+       gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
     in
     tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
 
@@ -222,7 +226,7 @@ tcGetGlobalTyVars
 \end{code}
 
 \begin{code}
-tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s))
 tcLookupLocalValue name
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM lve name)
@@ -232,15 +236,15 @@ tcLookupLocalValueByKey uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM_Directly lve uniq)
 
-tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s)
 tcLookupLocalValueOK err name
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 
 
-tcLookupGlobalValue :: Name -> NF_TcM s Id
+tcLookupGlobalValue :: RnName -> NF_TcM s Id
 
-tcLookupGlobalValue (WiredInVal id)    -- wired in ids
+tcLookupGlobalValue (WiredInId id)     -- wired in ids
   = returnNF_Tc id
 
 tcLookupGlobalValue name
@@ -253,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 :: Name 
-           -> 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
@@ -288,14 +275,19 @@ Constructing new Ids
 ~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+
 newMonoIds names kind m
   = newTyVarTys no_of_names kind       `thenNF_Tc` \ tys ->
     tcGetUniques no_of_names           `thenNF_Tc` \ uniqs ->
     let
-       new_ids            = zipWith3Equal mk_id names uniqs tys
-       mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
-                                        (getSrcLoc name)
+       new_ids = zipWith3Equal mk_id names uniqs tys
+
+       mk_id name uniq ty
+         = let
+               name_str = case (getOccName name) of { Unqual n -> n }
+           in
+           mkUserLocal name_str uniq ty (getSrcLoc name)
     in
     tcExtendLocalValEnv names new_ids (m new_ids)
   where