Fix scoped type variables for expression type signatures

[ghc-hetmet.git] / compiler / iface / IfaceEnv.lhs

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 3c1db55..6175965 100644 (file)
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -6,7 +6,7 @@ module IfaceEnv (
        lookupIfaceTop, lookupIfaceExt,
        lookupOrig, lookupIfaceTc,
        newIfaceName, newIfaceNames,
-       extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
+       extendIfaceIdEnv, extendIfaceTyVarEnv, 
        tcIfaceLclId,     tcIfaceTyVar, 
 
        lookupAvail, ifaceExportNames,
@@ -22,27 +22,26 @@ import IfaceType    ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
 import TysWiredIn      ( tupleTyCon, tupleCon )
 import HscTypes                ( NameCache(..), HscEnv(..), GenAvailInfo(..), 
                          IfaceExport, OrigNameCache )
-import Type            ( mkOpenTvSubst, substTy )
 import TyCon           ( TyCon, tyConName )
-import Unify           ( TypeRefinement )
 import DataCon         ( dataConWorkId, dataConName )
-import Var             ( TyVar, Id, varName, setIdType, idType )
+import Var             ( TyVar, Id, varName )
 import Name            ( Name, nameUnique, nameModule, 
                          nameOccName, nameSrcLoc, 
                          getOccName, nameParent_maybe,
                          isWiredInName, mkIPName,
                          mkExternalName, mkInternalName )
 import NameSet         ( NameSet, emptyNameSet, addListToNameSet )
-import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv,
-                         lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
-import PrelNames       ( gHC_PRIM, pREL_TUP )
-import Module          ( Module, emptyModuleEnv, 
-                         lookupModuleEnv, extendModuleEnv_C )
+import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName, occNameFS,
+                         lookupOccEnv, unitOccEnv, extendOccEnv )
+import PrelNames       ( gHC_PRIM, dATA_TUP )
+import Module          ( Module, emptyModuleEnv, ModuleName, modulePackageId,
+                         lookupModuleEnv, extendModuleEnv_C, mkModule )
+import UniqFM           ( lookupUFM, addListToUFM )
+import FastString       ( FastString )
 import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
 import FiniteMap       ( emptyFM, lookupFM, addToFM )
 import BasicTypes      ( IPName(..), mapIPName )
 import SrcLoc          ( SrcLoc, noSrcLoc )
-import Maybes          ( orElse )
 
 import Outputable
 \end{code}
@@ -229,7 +228,7 @@ newIPName occ_name_ip
 \begin{code}
 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 lookupOrigNameCache nc mod occ
-  | mod == pREL_TUP || mod == gHC_PRIM,                -- Boxed tuples from one, 
+  | mod == dATA_TUP || mod == gHC_PRIM,                -- Boxed tuples from one, 
     Just tup_info <- isTupleOcc_maybe occ      -- unboxed from the other
   =    -- Special case for tuples; there are too many
        -- of them to pre-populate the original-name cache
@@ -285,34 +284,26 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 %************************************************************************
 
 \begin{code}
-tcIfaceLclId :: OccName -> IfL Id
+tcIfaceLclId :: FastString -> IfL Id
 tcIfaceLclId occ
   = do { lcl <- getLclEnv
-       ; case (lookupOccEnv (if_id_env lcl) occ) of
+       ; case (lookupUFM (if_id_env lcl) occ) of
             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
         }
 
-refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
-refineIfaceIdEnv (tv_subst, _) thing_inside
-  = do { env <- getLclEnv
-       ; let { id_env' = mapOccEnv refine_id (if_id_env env)
-             ; refine_id id = setIdType id (substTy subst (idType id))
-             ; subst = mkOpenTvSubst tv_subst }
-       ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
-       
 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 extendIfaceIdEnv ids thing_inside
   = do { env <- getLclEnv
-       ; let { id_env' = extendOccEnvList (if_id_env env) pairs
-             ; pairs   = [(getOccName id, id) | id <- ids] }
+       ; let { id_env' = addListToUFM (if_id_env env) pairs
+             ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 
 
-tcIfaceTyVar :: OccName -> IfL TyVar
+tcIfaceTyVar :: FastString -> IfL TyVar
 tcIfaceTyVar occ
   = do { lcl <- getLclEnv
-       ; case (lookupOccEnv (if_tv_env lcl) occ) of
+       ; case (lookupUFM (if_tv_env lcl) occ) of
             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
         }
@@ -320,8 +311,8 @@ tcIfaceTyVar occ
 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 extendIfaceTyVarEnv tyvars thing_inside
   = do { env <- getLclEnv
-       ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
-             ; pairs   = [(getOccName tv, tv) | tv <- tyvars] }
+       ; let { tv_env' = addListToUFM (if_tv_env env) pairs
+             ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 \end{code}
 
@@ -339,7 +330,7 @@ lookupIfaceTc other_tc          = return (ifaceTyConName other_tc)
 
 lookupIfaceExt :: IfaceExtName -> IfL Name
 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
-lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
+lookupIfaceExt (HomePkg mod occ _) = lookupHomePackage mod occ
 lookupIfaceExt (LocalTop occ)     = lookupIfaceTop occ
 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 
@@ -348,10 +339,16 @@ lookupIfaceTop :: OccName -> IfL Name
 lookupIfaceTop occ
   = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
 
+lookupHomePackage :: ModuleName -> OccName -> IfL Name
+lookupHomePackage mod_name occ
+  = do { env <- getLclEnv; 
+        ; let this_pkg = modulePackageId (if_mod env)
+        ; lookupOrig (mkModule this_pkg mod_name) occ }
+
 newIfaceName :: OccName -> IfL Name
 newIfaceName occ
   = do { uniq <- newUnique
-       ; return (mkInternalName uniq occ noSrcLoc) }
+       ; return $! mkInternalName uniq occ noSrcLoc }
 
 newIfaceNames :: [OccName] -> IfL [Name]
 newIfaceNames occs