[project @ 1997-09-05 16:23:41 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 3327ece..32fdf22 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,
-       tcAddImportedIdInfo,
+       tcAddImportedIdInfo, tcExplicitLookupGlobal,
        tcLookupGlobalValueByKeyMaybe, 
 
        newMonoIds, newLocalIds, newLocalId,
@@ -26,33 +26,31 @@ module TcEnv(
 IMP_Ubiq()
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
-#else
-import {-# SOURCE #-} TcType
 #endif
 
 import HsTypes ( HsTyVar(..) )
 import Id      ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo )
 import PragmaInfo ( PragmaInfo(..) )
-import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) )
 import TcKind  ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind, Kind )
-import TcType  ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
+import TcType  ( SYN_IE(TcIdBndr), TcIdOcc(..),
+                 SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
                  newTyVarTys, tcInstTyVars, zonkTcTyVars
                )
 import TyVar   ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) )
 import PprType ( GenTyVar )
 import Type    ( tyVarsOfTypes, splitForAllTy )
-import TyCon   ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )
-import Class   ( SYN_IE(Class), GenClass, classSig )
+import TyCon   ( TyCon, tyConKind, tyConArity, isSynTyCon, SYN_IE(Arity) )
+import Class   ( SYN_IE(Class), GenClass )
 
 import TcMonad
 
 import IdInfo          ( noIdInfo )
 import Name            ( Name, OccName(..), getSrcLoc, occNameString,
-                         maybeWiredInTyConName, maybeWiredInIdName,
+                         maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
                          NamedThing(..)
                        )
 import Pretty
-import Unique          ( pprUnique10{-, pprUnique ToDo:rm-}, Unique )
+import Unique          ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
 import UniqFM       
 import Util            ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
                          panic, pprPanic, pprTrace
@@ -143,21 +141,34 @@ tcLookupTyVar name
 
 
 tcLookupTyCon name
-  = case maybeWiredInTyConName name of
-       Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
-       Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-                  case lookupUFM tce name of
-                       Just stuff -> returnTc stuff
-                       Nothing    ->   -- Could be that he's using a class name as a type constructor
-                                     case lookupUFM ce name of
-                                       Just _  -> failTc (classAsTyConErr name)
-                                       Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
+  =    -- Try for a wired-in tycon
+    case maybeWiredInTyConName name of {
+       Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
+               | otherwise     -> returnTc (kind, Nothing,              tc)
+               where {
+                 kind = kindToTcKind (tyConKind tc) 
+               };
+
+       Nothing -> 
+
+           -- Try in the environment
+         tcGetEnv      `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+          case lookupUFM tce name of {
+             Just stuff -> returnTc stuff;
+
+             Nothing    ->
+
+               -- Could be that he's using a class name as a type constructor
+              case lookupUFM ce name of
+                Just _  -> failTc (classAsTyConErr name)
+                Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
+           } } 
 
 tcLookupTyConByKey uniq
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let 
        (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce 
-                                       (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) 
+                                       (pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq)) 
                                        uniq
     in
     returnNF_Tc tycon
@@ -255,7 +266,6 @@ tcLookupLocalValueOK err name
 
 
 tcLookupGlobalValue :: Name -> NF_TcM s Id
-
 tcLookupGlobalValue name
   = case maybeWiredInIdName name of
        Just id -> returnNF_Tc id
@@ -265,7 +275,6 @@ tcLookupGlobalValue name
     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)
@@ -289,18 +298,29 @@ tcLookupGlobalValueByKeyMaybe 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
-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
-    in
-    returnNF_Tc (id `replaceIdInfo` new_info)
-       -- The Id must be returned without a data dependency on maybe_id
 \end{code}