[project @ 2001-02-20 15:35:28 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 0dbc636..0192bba 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -16,18 +16,18 @@ module TcEnv(
        -- Global environment
        tcExtendGlobalEnv, tcExtendGlobalValEnv, 
        tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
-       tcLookupGlobal_maybe, tcLookupGlobal, 
+       tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
 
        -- Local environment
-       tcExtendKindEnv, 
+       tcExtendKindEnv,  tcLookupLocalIds,
        tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, 
-       tcExtendLocalValEnv, tcLookup,
+       tcExtendLocalValEnv, tcLookup, tcLookup_maybe, 
 
        -- Global type variables
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
 
        -- Random useful things
-       RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId,
+       RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, 
 
        -- New Ids
        newLocalId, newSpecPragmaId,
@@ -41,8 +41,8 @@ module TcEnv(
 
 import RnHsSyn         ( RenamedMonoBinds, RenamedSig )
 import TcMonad
-import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
-                         tcInstTyVars, zonkTcTyVars,
+import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, 
+                         zonkTcTyVarsAndFV
                        )
 import Id              ( idName, mkUserLocal, isDataConWrapId_maybe )
 import IdInfo          ( constantIdInfo )
@@ -51,13 +51,11 @@ import Var          ( TyVar, Id, idType, lazySetIdInfo, idInfo )
 import VarSet
 import Type            ( Type,
                          tyVarsOfTypes, splitDFunTy,
-                         splitForAllTys, splitRhoTy,
                          getDFunTyKey, tyConAppTyCon
                        )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
 import Class           ( Class, ClassOpItem, ClassContext )
-import Subst           ( substTy )
 import Name            ( Name, OccName, NamedThing(..), 
                          nameOccName, getSrcLoc, mkLocalName,
                          isLocalName, nameModule_maybe
@@ -70,6 +68,7 @@ import InstEnv                ( InstEnv, emptyInstEnv )
 import HscTypes                ( lookupType, TyThing(..) )
 import Util            ( zipEqual )
 import SrcLoc          ( SrcLoc )
+import qualified PrelNames 
 import Outputable
 
 import IOExts          ( newIORef )
@@ -87,6 +86,8 @@ type TcIdSet = IdSet
 
 data TcEnv
   = TcEnv {
+       tcSyntaxMap :: PrelNames.SyntaxMap,     -- The syntax map (usually the identity)
+
        tcGST    :: Name -> Maybe TyThing,      -- The type environment at the moment we began this compilation
 
        tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
@@ -140,10 +141,11 @@ data TcTyThing
 --     3. Then we zonk the kind variable.
 --     4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 
-initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
-initTcEnv hst pte 
+initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
+initTcEnv syntax_map hst pte 
   = do { gtv_var <- newIORef emptyVarSet ;
-        return (TcEnv { tcGST    = lookup,
+        return (TcEnv { tcSyntaxMap = syntax_map,
+                        tcGST    = lookup,
                         tcGEnv   = emptyNameEnv,
                         tcInsts  = emptyInstEnv,
                         tcLEnv   = emptyNameEnv,
@@ -223,33 +225,6 @@ tcLookupRecId env name = case lookup_global env name of
 
 %************************************************************************
 %*                                                                     *
-\subsection{Random useful functions}
-%*                                                                     *
-%************************************************************************
-
-
-\begin{code}
--- A useful function that takes an occurrence of a global thing
--- and instantiates its type with fresh type variables
-tcInstId :: Id
-        -> NF_TcM ([TcTyVar],  -- It's instantiated type
-                     TcThetaType,      --
-                     TcType)           --
-tcInstId id
-  = let
-      (tyvars, rho) = splitForAllTys (idType id)
-    in
-    tcInstTyVars tyvars                `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
-    let
-       rho'           = substTy tenv rho
-       (theta', tau') = splitRhoTy rho' 
-    in
-    returnNF_Tc (tyvars', theta', tau')
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
 \subsection{Making new Ids}
 %*                                                                     *
 %************************************************************************
@@ -339,8 +314,8 @@ tcLookupGlobalId :: Name -> NF_TcM Id
 tcLookupGlobalId name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_id ->
     case maybe_id of
-       Just (AnId clas) -> returnNF_Tc clas
-       other            -> notFound "tcLookupGlobalId" name
+       Just (AnId id) -> returnNF_Tc id
+       other          -> notFound "tcLookupGlobalId" name
        
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon con_name
@@ -363,6 +338,30 @@ tcLookupTyCon name
     case maybe_tc of
        Just (ATyCon tc) -> returnNF_Tc tc
        other            -> notFound "tcLookupTyCon" name
+
+tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
+tcLookupLocalIds ns
+  = tcGetEnv           `thenNF_Tc` \ env ->
+    returnNF_Tc (map (lookup (tcLEnv env)) ns)
+  where
+    lookup lenv name = case lookupNameEnv lenv name of
+                       Just (ATcId id) -> id
+                       other           -> pprPanic "tcLookupLocalIds" (ppr name)
+
+tcLookupSyntaxId :: Name -> NF_TcM Id
+-- Lookup a name like PrelNum.fromInt, and return the corresponding Id,
+-- after mapping through the SyntaxMap.  This may give us the Id for
+-- (say) MyPrelude.fromInt
+tcLookupSyntaxId name
+  = tcGetEnv           `thenNF_Tc` \ env ->
+    returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of
+                       Just (AnId id) -> id
+                       other          -> pprPanic "tcLookupSyntaxId" (ppr name))
+
+tcLookupSyntaxName :: Name -> NF_TcM Name
+tcLookupSyntaxName name
+  = tcGetEnv           `thenNF_Tc` \ env ->
+    returnNF_Tc (tcSyntaxMap env name)
 \end{code}
 
 
@@ -472,13 +471,10 @@ the environment.
 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
 tcGetGlobalTyVars
   = tcGetEnv                                   `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
-    tcReadMutVar gtv_var                       `thenNF_Tc` \ global_tvs ->
-    zonkTcTyVars (varSetElems global_tvs)      `thenNF_Tc` \ global_tys' ->
-    let
-       global_tvs' = (tyVarsOfTypes global_tys')
-    in
-    tcWriteMutVar gtv_var global_tvs'          `thenNF_Tc_` 
-    returnNF_Tc global_tvs'
+    tcReadMutVar gtv_var                       `thenNF_Tc` \ gbl_tvs ->
+    zonkTcTyVarsAndFV (varSetElems gbl_tvs)    `thenNF_Tc` \ gbl_tvs' ->
+    tcWriteMutVar gtv_var gbl_tvs'             `thenNF_Tc_` 
+    returnNF_Tc gbl_tvs'
 \end{code}