[project @ 2005-07-22 13:58:17 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 8caa51d..d2bc11a 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -3,8 +3,8 @@ module TcEnv(
        TyThing(..), TcTyThing(..), TcId,
 
        -- Instance environment, and InstInfo type
-       InstInfo(..), pprInstInfo, pprInstInfoDetails,
-       simpleInstInfoTy, simpleInstInfoTyCon, 
+       InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
+       simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, 
        InstBindings(..),
 
        -- Global environment
@@ -16,7 +16,7 @@ module TcEnv(
        tcLookupLocatedClass, 
        
        -- Local environment
-       tcExtendKindEnv,
+       tcExtendKindEnv, tcExtendKindEnvTvs,
        tcExtendTyVarEnv, tcExtendTyVarEnv2, 
        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
        tcLookup, tcLookupLocated, tcLookupLocalIds,
@@ -42,13 +42,14 @@ module TcEnv(
 
 #include "HsVersions.h"
 
-import HsSyn           ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
+import HsSyn           ( LRuleDecl, LHsBinds, LSig, 
+                         LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
 import TcIface         ( tcImportDecl )
-import TcRnTypes       ( pprTcTyThingCategory )
+import IfaceEnv                ( newGlobalBinder )
 import TcRnMonad
 import TcMType         ( zonkTcType, zonkTcTyVarsAndFV )
 import TcType          ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
-                         tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
+                         tyVarsOfType, tyVarsOfTypes, mkGenTyConApp,
                          getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
                          tidyOpenType 
                        )
@@ -58,13 +59,14 @@ import Var          ( TyVar, Id, idType, tyVarName )
 import VarSet
 import VarEnv
 import RdrName         ( extendLocalRdrEnv )
+import InstEnv         ( Instance, DFunId, instanceDFunId, instanceHead )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
 import Class           ( Class )
-import Name            ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom )
+import Name            ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom )
 import NameEnv
 import OccName         ( mkDFunOcc, occNameString )
-import HscTypes                ( DFunId, extendTypeEnvList, lookupType,
+import HscTypes                ( extendTypeEnvList, lookupType,
                          TyThing(..), tyThingId, tyThingDataCon,
                          ExternalPackageState(..) )
 
@@ -105,9 +107,7 @@ tcLookupGlobal name
            Just thing -> return thing 
            Nothing    -> tcImportDecl name
     }}
-\end{code}
 
-\begin{code}
 tcLookupGlobalId :: Name -> TcM Id
 -- Never used for Haskell-source DataCons, hence no ADataCon case
 tcLookupGlobalId name
@@ -243,6 +243,14 @@ tcExtendKindEnv things thing_inside
     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 
+tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
+tcExtendKindEnvTvs bndrs thing_inside
+  = updLclEnv upd thing_inside
+  where
+    upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
+    extend env  = extendNameEnvList env pairs
+    pairs       = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
+
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
   = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
@@ -477,40 +485,6 @@ tcMetaTy tc_name
 
 %************************************************************************
 %*                                                                     *
-\subsection{Making new Ids}
-%*                                                                     *
-%************************************************************************
-
-Constructing new Ids
-
-\begin{code}
-newLocalName :: Name -> TcM Name
-newLocalName name      -- Make a clone
-  = newUnique          `thenM` \ uniq ->
-    returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
-\end{code}
-
-Make a name for the dict fun for an instance decl.  It's a *local*
-name for the moment.  The CoreTidy pass will externalise it.  Even in
---make and ghci stuff, we rebuild the instance environment each time,
-so the dfun id is internal to begin with, and external when compiling
-other modules
-
-\begin{code}
-newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
-newDFunName clas (ty:_) loc
-  = do { uniq <- newUnique
-       ; return (mkInternalName uniq (mkDFunOcc dfun_string) loc) }
-  where
-       -- Any string that is somewhat unique will do
-    dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
 \subsection{The InstInfo type}
 %*                                                                     *
 %************************************************************************
@@ -528,10 +502,13 @@ as well as explicit user written ones.
 \begin{code}
 data InstInfo
   = InstInfo {
-      iDFunId :: DFunId,               -- The dfun id.  Its forall'd type variables 
-      iBinds  :: InstBindings          -- scope over the stuff in InstBindings!
+      iSpec  :: Instance,              -- Includes the dfun id.  Its forall'd type 
+      iBinds :: InstBindings           -- variables scope over the stuff in InstBindings!
     }
 
+iDFunId :: InstInfo -> DFunId
+iDFunId info = instanceDFunId (iSpec info)
+
 data InstBindings
   = VanillaInst                -- The normal case
        (LHsBinds Name)         -- Bindings
@@ -551,9 +528,12 @@ pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
     details (VanillaInst b _)  = pprLHsBinds b
     details (NewTypeDerived _) = text "Derived from the representation type"
 
+simpleInstInfoClsTy :: InstInfo -> (Class, Type)
+simpleInstInfoClsTy info = case instanceHead (iSpec info) of
+                         (_, _, cls, [ty]) -> (cls, ty)
+
 simpleInstInfoTy :: InstInfo -> Type
-simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
-                         (_, _, _, [ty]) -> ty
+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
 
 simpleInstInfoTyCon :: InstInfo -> TyCon
   -- Gets the type constructor for a simple instance declaration,
@@ -561,6 +541,24 @@ simpleInstInfoTyCon :: InstInfo -> TyCon
 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 \end{code}
 
+Make a name for the dict fun for an instance decl.  It's an *external*
+name, like otber top-level names, and hence must be made with newGlobalBinder.
+
+\begin{code}
+newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
+newDFunName clas (ty:_) loc
+  = do { index   <- nextDFunIndex
+       ; is_boot <- tcIsHsBoot
+       ; mod     <- getModule
+       ; let info_string = occNameString (getOccName clas) ++ 
+                           occNameString (getDFunTyKey ty)
+             dfun_occ = mkDFunOcc info_string is_boot index
+
+       ; newGlobalBinder mod dfun_occ Nothing loc }
+
+newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *