[project @ 2000-10-11 16:31:27 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 ab30217..b1fd639 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -26,6 +26,7 @@ module TcEnv(
        valueEnvIds,
 
        newLocalId, newSpecPragmaId,
+       newDefaultMethodName, newDFunName,
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
 
        InstEnv, emptyInstEnv, addToInstEnv, 
@@ -50,7 +51,7 @@ import VarSet
 import Type    ( Kind, Type, superKind,
                  tyVarsOfType, tyVarsOfTypes,
                  splitForAllTys, splitRhoTy, splitFunTys,
-                 splitAlgTyConApp_maybe, getTyVar
+                 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
                )
 import Subst   ( substTy )
 import UsageSPUtils ( unannotTy )
@@ -60,14 +61,15 @@ import Class        ( Class, ClassOpItem, ClassContext, classTyCon )
 
 import TcMonad
 
-import BasicTypes      ( Arity )
 import IdInfo          ( vanillaIdInfo )
-import Name            ( Name, OccName, nameOccName, getSrcLoc,
+import Name            ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), 
+                         nameOccName, nameModule, getSrcLoc, mkGlobalName,
                          maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
-                         NamedThing(..), 
                          NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, 
                                   extendNameEnv, extendNameEnvList
                        )
+import OccName         ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import Module          ( Module )
 import Unify           ( unifyTyListsX, matchTys )
 import Unique          ( pprUnique10, Unique, Uniquable(..) )
 import UniqFM
@@ -143,27 +145,37 @@ Data type declarations
 ~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-data TcEnv = TcEnv
-                  UsageEnv
-                 TypeEnv
-                 ValueEnv 
-                 InstEnv
-                 (TcTyVarSet,          -- The in-scope TyVars
-                  TcRef TcTyVarSet)    -- Free type variables of the value env
-                                       -- ...why mutable? see notes with tcGetGlobalTyVars
-                                       -- Includes the in-scope tyvars
+data TcEnv
+  = TcEnv {
+       tcGST    :: GlobalSymbolTable,  -- The symbol table at the moment we began this compilation
+
+       tcGEnv   :: NameEnv TyThing     -- The global type environment we've accumulated while
+                                       -- compiling this module:
+                                       --      types and classes (both imported and local)
+                                       --      imported Ids
+                                       -- (Ids defined in this module are in the local envt)
+               -- When type checking is over we'll augment the
+               -- global symbol table with everything in tcGEnv
+               
+       tcInst   :: InstEnv,            -- All instances (both imported and in this module)
+
+       tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
+                                       -- defined in this module
+
+       tcTyVars :: FreeTyVars          -- Type variables free in tcLST
+    }
 
-type UsageEnv   = NameEnv UVar
-type TypeEnv   = NameEnv TyThing
-type ValueEnv  = NameEnv Id    
+
+type InScopeTyVars = (TcTyVarSet,      -- The in-scope TyVars
+                     TcRef TcTyVarSet) -- Free type variables of the value env
+                                       -- ...why mutable? see notes with tcGetGlobalTyVars
 
 valueEnvIds :: ValueEnv -> [Id]
 valueEnvIds ve = nameEnvElts ve
 
-data TyThing = ATyVar TyVar
-            | ATyCon TyCon
-            | AClass Class
-            | AThing TcKind    -- Used temporarily, during kind checking
+data TcTyThing = ATyVar TyVar
+              | ATcId  TcId
+              | AThing TcKind  -- Used temporarily, during kind checking
 -- For example, when checking (forall a. T a Int):
 --     1. We first bind (a -> AThink kv), where kv is a kind variable. 
 --     2. Then we kind-check the (T a Int) part.
@@ -396,7 +408,10 @@ tcLookupValue name
        Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
                   returnNF_Tc (lookupWithDefaultUFM ve def name)
   where
-    def = pprPanic "tcLookupValue:" (ppr name)
+    wired_in = case maybeWiredInIdName name of
+       Just id -> True
+       Nothing -> False
+    def = pprPanic "tcLookupValue:" (ppr name <+> ppr wired_in)
 
 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
 tcLookupValueMaybe name
@@ -736,6 +751,27 @@ addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
        identical = ins_item_more_specific && cur_item_more_specific
 \end{code}
 
+Make a name for the dict fun for an instance decl
+
+\begin{code}
+newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM s Name
+newDFunName mod clas (ty:_) loc
+  = tcGetDFunUniq dfun_string  `thenNF_Tc` \ inst_uniq ->
+    tcGetUnique                        `thenNF_Tc` \ uniq ->
+    returnNF_Tc (mkGlobalName uniq mod
+                             (mkDFunOcc dfun_string inst_uniq) 
+                             (LocalDef loc Exported))
+  where
+       -- Any string that is somewhat unique will do
+    dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
+
+newDefaultMethodName :: Name -> SrcLoc -> NF_TcM s Name
+newDefaultMethodName op_name loc
+  = tcGetUnique                        `thenNF_Tc` \ uniq ->
+    returnNF_Tc (mkGlobalName uniq (nameModule op_name)
+                             (mkDefaultMethodOcc (getOccName op_name))
+                             (LocalDef loc Exported))
+\end{code}
 
 
 %************************************************************************