[project @ 2000-10-13 14:14:31 by sewardj]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 61f1437..e106cba 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -12,7 +12,8 @@ module TcEnv(
 
        -- Global environment
        tcExtendGlobalEnv, tcExtendGlobalValEnv, 
-       tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
+       tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
+       tcLookupGlobal_maybe,
 
        -- Local environment
        tcExtendKindEnv, 
@@ -55,14 +56,15 @@ import Class        ( Class, ClassOpItem, ClassContext, classTyCon )
 import Subst   ( substTy )
 import Name    ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), 
                  nameOccName, nameModule, getSrcLoc, mkGlobalName,
-                 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
+                 isLocallyDefined,
                  NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, 
                  extendNameEnv, extendNameEnvList
                )
 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
 import Module  ( Module )
 import Unify   ( unifyTyListsX, matchTys )
-import HscTypes        ( ModDetails(..), lookupTypeEnv )
+import HscTypes        ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
+                 GlobalSymbolTable )
 import Unique  ( pprUnique10, Unique, Uniquable(..) )
 import UniqFM
 import Unique  ( Uniquable(..) )
@@ -71,6 +73,7 @@ import SrcLoc ( SrcLoc )
 import FastString      ( FastString )
 import Maybes
 import Outputable
+import IOExts  ( newIORef )
 \end{code}
 
 %************************************************************************
@@ -87,9 +90,9 @@ data TcEnv
   = TcEnv {
        tcGST    :: GlobalSymbolTable,  -- The symbol table at the moment we began this compilation
 
-       tcInst   :: InstEnv,            -- All instances (both imported and in this module)
+       tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
 
-       tcGEnv   :: NameEnv TyThing     -- The global type environment we've accumulated while
+       tcGEnv   :: NameEnv TyThing,    -- The global type environment we've accumulated while
                                        -- compiling this module:
                                        --      types and classes (both imported and local)
                                        --      imported Ids
@@ -140,11 +143,11 @@ data TcTyThing
 
 initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv
 initTcEnv gst inst_env
-  = do { gtv_var <- newIORef emptyVarSet
-        return (TcEnv { tcGST = gst,
-                        tcGEnv = emptyNameEnv, 
-                        tcInst = inst_env,
-                        tcLEnv = emptyNameEnv,
+  = do { gtv_var <- newIORef emptyVarSet ;
+        return (TcEnv { tcGST    = gst,
+                        tcGEnv   = emptyNameEnv,
+                        tcInsts  = inst_env,
+                        tcLEnv   = emptyNameEnv,
                         tcTyVars = gtv_var
         })}
 
@@ -172,17 +175,17 @@ data TyThingDetails = SynTyDetails Type
 lookup_global :: TcEnv -> Name -> Maybe TyThing
        -- Try the global envt and then the global symbol table
 lookup_global env name 
-  = case lookupNameEnv (tcGEnv env) name of {
-       Just thing -> Just thing ;
+  = case lookupNameEnv (tcGEnv env) name of
+       Just thing -> Just thing
        Nothing    -> lookupTypeEnv (tcGST env) name
 
 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
        -- Try the local envt and then try the global
 lookup_local env name
- = case lookupNameEnv (tcLEnv env) name of
-       Just thing -> Just thing ;
+  = case lookupNameEnv (tcLEnv env) name of
+       Just thing -> Just thing
        Nothing    -> case lookup_global env name of
-                       Just thing -> AGlobal thing
+                       Just thing -> Just (AGlobal thing)
                        Nothing    -> Nothing
 
 explicitLookupId :: TcEnv -> Name -> Maybe Id
@@ -308,6 +311,7 @@ A variety of global lookups, when we know what we are looking for.
 
 \begin{code}
 tcLookupGlobal :: Name -> NF_TcM TyThing
+tcLookupGlobal name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_thing ->
     case maybe_thing of
        Just thing -> returnNF_Tc thing
@@ -317,15 +321,15 @@ tcLookupGlobalId :: Name -> NF_TcM Id
 tcLookupGlobalId name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_id ->
     case maybe_id of
-       Just (AnId clas) -> returnNF_Tc id
+       Just (AnId clas) -> returnNF_Tc clas
        other            -> notFound "tcLookupGlobalId:" name
        
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon con_name
   = tcLookupGlobalId con_name          `thenNF_Tc` \ con_id ->
-    case isDataConWrapId_maybe con_id of {
+    case isDataConWrapId_maybe con_id of
        Just data_con -> returnTc data_con
-       Nothing       -> failWithTc (badCon con_id);
+       Nothing       -> failWithTc (badCon con_id)
 
 
 tcLookupClass :: Name -> NF_TcM Class
@@ -435,7 +439,7 @@ tcExtendLocalValEnv names_w_ids thing_inside
 tcExtendGlobalTyVars extra_global_tvs thing_inside
   = tcGetEnv                                           `thenNF_Tc` \ env ->
     tc_extend_gtvs (tcTyVars env) extra_global_tvs     `thenNF_Tc` \ gtvs' ->
-    tcSetEnv (env {tcTyVars = gtvs') thing_inside
+    tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
 
 tc_extend_gtvs gtvs extra_global_tvs
   = tcReadMutVar gtvs                  `thenNF_Tc` \ global_tvs ->
@@ -469,12 +473,12 @@ tcGetGlobalTyVars
 \begin{code}
 tcGetInstEnv :: NF_TcM InstEnv
 tcGetInstEnv = tcGetEnv        `thenNF_Tc` \ env -> 
-              returnNF_Tc (tcInst env)
+              returnNF_Tc (tcInsts env)
 
 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 tcSetInstEnv ie thing_inside
   = tcGetEnv   `thenNF_Tc` \ env ->
-    tcSetEnv (env {tcInst = ie}) thing_inside
+    tcSetEnv (env {tcInsts = ie}) thing_inside
 \end{code}    
 
 
@@ -487,6 +491,6 @@ tcSetInstEnv ie thing_inside
 \begin{code}
 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 
-notFound where name = failWithTc (text where <> colon <+> quotes (ppr name) <+> 
+notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> 
                                  ptext SLIT("is not in scope"))
 \end{code}