diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index e88e4a1b026b7b9c8afe3e8d98482bf7950a173e..fbe86bdace2ee148eac84cf58272b16eac418afa 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -57,7 +57,7 @@ module Name ( isValName, isVarName, isWiredInName, isBuiltInSyntax, wiredInNameTyThing_maybe, - nameIsLocalOrFrom, + nameIsLocalOrFrom, stableNameCmp, -- * Class 'NamedThing' and overloaded friends NamedThing(..), @@ -341,6 +341,26 @@ hashName name = getKey (nameUnique name) + 1 cmpName :: Name -> Name -> Ordering cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) + +stableNameCmp :: Name -> Name -> Ordering +-- Compare lexicographically +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicogrpahic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT \end{code} %************************************************************************ diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 336030cf0dfc62f081e1072b6a74bbbe33e1aa01..94860f934b7ae2c6ed3fd24e1677f2e39ba57aa2 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -496,7 +496,7 @@ instance Binary Dependencies where return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, dep_finsts = fis }) -instance (Binary name) => Binary (GenAvailInfo name) where +instance Binary AvailInfo where put_ bh (Avail aa) = do putByte bh 0 put_ bh aa diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 36024ebb91e85d8804df4928088e9bab7454a19c..95f7a743ff45cd00f4fb0b27e856346bd6585c28 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -123,25 +123,7 @@ newImplicitBinder base_name mk_sys_occ loc = nameSrcSpan base_name ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] -ifaceExportNames exports = do - mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports - return (concat mod_avails) - --- Convert OccNames in GenAvailInfo to Names. -lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo -lookupAvail mod (Avail n) = do - n' <- lookupOrig mod n - return (Avail n') -lookupAvail mod (AvailTC p_occ occs) = do - p_name <- lookupOrig mod p_occ - let lookup_sub occ | occ == p_occ = return p_name - | otherwise = lookupOrig mod occ - subs <- mapM lookup_sub occs - return (AvailTC p_name subs) - -- Remember that 'occs' is all the exported things, including - -- the parent. It's possible to export just class ops without - -- the class, which shows up as C( op ) here. If the class was - -- exported too we'd have C( C, op ) +ifaceExportNames exports = return exports lookupOrig :: Module -> OccName -> TcRnIf a b Name lookupOrig mod occ diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 9b7a40fb3a8da43f8c1f4ecc560d6e7961546e4c..9d087c1808b6b86de9f877787696bc38afaaeb58 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -590,7 +590,7 @@ initExternalPackageState ghcPrimIface :: ModIface ghcPrimIface = (emptyModIface gHC_PRIM) { - mi_exports = [(gHC_PRIM, ghcPrimExports)], + mi_exports = ghcPrimExports, mi_decls = [], mi_fixities = fixities, mi_fix_fn = mkIfaceFixCache fixities @@ -657,7 +657,8 @@ pprModIface iface , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (ptext (sLit "where")) - , vcat (map pprExport (mi_exports iface)) + , ptext (sLit "exports:") + , nest 2 (vcat (map pprExport (mi_exports iface))) , pprDeps (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) @@ -684,16 +685,12 @@ When printing export lists, we print like this: \begin{code} pprExport :: IfaceExport -> SDoc -pprExport (mod, items) - = hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ] - where - pp_avail :: GenAvailInfo OccName -> SDoc - pp_avail (Avail occ) = ppr occ - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr n <> pp_export ns - | otherwise = ppr n <> char '|' <> pp_export (n':ns) - +pprExport (Avail n) = ppr n +pprExport (AvailTC _ []) = empty +pprExport (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + where pp_export [] = empty pp_export names = braces (hsep (map ppr names)) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 45a905543c967c340ebd954593ad39987bcd260e..3c333e653fa2fa02b9794f9ece7f3869b2e3cb85 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -977,54 +977,17 @@ mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = \end{code} \begin{code} -mkIfaceExports :: [AvailInfo] - -> [(Module, [GenAvailInfo OccName])] - -- Group by module and sort by occurrence +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical mkIfaceExports exports - = [ (mod, Map.elems avails) - | (mod, avails) <- sortBy (stableModuleCmp `on` fst) - (moduleEnvToList groupFM) - -- NB. the Map.toList is in a random order, - -- because Ord Module is not a predictable - -- ordering. Hence we perform a final sort - -- using the stable Module ordering. - ] + = sortBy stableAvailCmp (map sort_subs exports) where - -- Group by the module where the exported entities are defined - -- (which may not be the same for all Names in an Avail) - -- Deliberately use Map rather than UniqFM so we - -- get a canonical ordering - groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName)) - groupFM = foldl add emptyModuleEnv exports - - add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName)) - -> Module -> GenAvailInfo OccName - -> ModuleEnv (Map FastString (GenAvailInfo OccName)) - add_one env mod avail - -- XXX Is there a need to flip Map.union here? - = extendModuleEnvWith (flip Map.union) env mod - (Map.singleton (occNameFS (availName avail)) avail) - - -- NB: we should not get T(X) and T(Y) in the export list - -- else the Map.union will simply discard one! They - -- should have been combined by now. - add env (Avail n) - = ASSERT( isExternalName n ) - add_one env (nameModule n) (Avail (nameOccName n)) - - add env (AvailTC tc ns) - = ASSERT( all isExternalName ns ) - foldl add_for_mod env mods - where - tc_occ = nameOccName tc - mods = nub (map nameModule ns) - -- Usually just one, but see Note [Original module] - - add_for_mod env mod - = add_one env mod (AvailTC tc_occ (sort names_from_mod)) - -- NB. sort the children, we need a canonical order - where - names_from_mod = [nameOccName n | n <- ns, nameModule n == mod] + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | n==m = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) + -- Maintain the AvailTC Invariant \end{code} Note [Orignal module] diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d43105b02d6e10dfa7db23fc0905c96cdfa5fcca..59985df1a7f7760907fc0a488f7856ee9b8f89ab 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -71,8 +71,8 @@ module HscTypes ( Dependencies(..), noDependencies, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availsToNameEnv, availName, availNames, - GenAvailInfo(..), AvailInfo, RdrAvailInfo, - IfaceExport, + AvailInfo(..), + IfaceExport, stableAvailCmp, -- * Warnings Warnings(..), WarningTxt(..), plusWarns, @@ -149,6 +149,7 @@ import Fingerprint import MonadUtils import Bag import ErrUtils +import Util import System.FilePath import System.Time ( ClockTime ) @@ -1327,27 +1328,24 @@ plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) \begin{code} -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] --- | 'Name'd things that are available -type AvailInfo = GenAvailInfo Name --- | 'RdrName'd things that are available -type RdrAvailInfo = GenAvailInfo OccName -- | Records what things are "available", i.e. in scope -data GenAvailInfo name = Avail name -- ^ An ordinary identifier in scope - | AvailTC name - [name] -- ^ A type or class in scope. Parameters: - -- - -- 1) The name of the type or class - -- - -- 2) The available pieces of type or class. - -- NB: If the type or class is itself - -- to be in scope, it must be in this list. - -- Thus, typically: @AvailTC Eq [Eq, ==, \/=]@ - deriving( Eq ) +data AvailInfo = Avail Name -- ^ An ordinary identifier in scope + | AvailTC Name + [Name] -- ^ A type or class in scope. Parameters: + -- + -- 1) The name of the type or class + -- 2) The available pieces of type or class. + -- + -- The AvailTC Invariant: + -- * If the type or class is itself + -- to be in scope, it must be *first* in this list. + -- Thus, typically: @AvailTC Eq [Eq, ==, \/=]@ + deriving( Eq ) -- Equality used when deciding if the interface has changed -- | The original names declared of a certain module that are exported -type IfaceExport = (Module, [GenAvailInfo OccName]) +type IfaceExport = AvailInfo availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldr add emptyNameSet avails @@ -1360,21 +1358,29 @@ availsToNameEnv avails = foldr add emptyNameEnv avails -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'GenAvailInfo' -availName :: GenAvailInfo name -> name +availName :: AvailInfo -> Name availName (Avail n) = n availName (AvailTC n _) = n -- | All names made available by the availability information -availNames :: GenAvailInfo name -> [name] +availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC _ ns) = ns -instance Outputable n => Outputable (GenAvailInfo n) where +instance Outputable AvailInfo where ppr = pprAvail -pprAvail :: Outputable n => GenAvailInfo n -> SDoc +pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) + +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +-- Compare lexicographically +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) +stableAvailCmp (AvailTC {}) (Avail {}) = GT \end{code} \begin{code} diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 867e79d99acec2f61635cd8a0c089a95ecbf4e4b..f99f9ca2920ea63a393a555fac76af8d72ea718c 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -26,14 +26,13 @@ import PrelNames ( basicKnownKeyNames, hasKey, charDataConKey, intDataConKey, numericClassKeys, standardClassKeys ) import PrelRules -import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) +import PrimOp ( PrimOp, allThePrimOps, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) import Id ( Id, idName ) import MkId -- All of it, for re-export -import Name ( nameOccName ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), implicitTyThings, GenAvailInfo(..), RdrAvailInfo ) +import HscTypes ( TyThing(..), implicitTyThings, AvailInfo(..), IfaceExport ) import Class ( Class, classKey ) import Type ( funTyCon ) import TyCon ( tyConName ) @@ -82,7 +81,7 @@ wiredInThings , map AnId wiredInIds -- PrimOps - , map (AnId . mkPrimOpId) allThePrimOps + , map (AnId . primOpId) allThePrimOps ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) @@ -99,9 +98,10 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ \begin{code} -primOpIds :: Array Int Id -- Indexed by PrimOp tag +primOpIds :: Array Int Id +-- A cache of the PrimOp Ids, indexed by PrimOp tag primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps] + | op <- allThePrimOps ] primOpId :: PrimOp -> Id primOpId op = primOpIds ! primOpTag op @@ -118,13 +118,12 @@ GHC.Prim "exports" all the primops and primitive types, some wired-in Ids. \begin{code} -ghcPrimExports :: [RdrAvailInfo] +ghcPrimExports :: [IfaceExport] ghcPrimExports - = map (Avail . nameOccName . idName) ghcPrimIds ++ - map (Avail . primOpOcc) allThePrimOps ++ - [ AvailTC occ [occ] | - n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) - ] + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName . primOpId) allThePrimOps ++ + [ AvailTC n [n] + | tc <- funTyCon : primTyCons, let n = tyConName tc ] \end{code} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 9374b5ca173049a97efcc7f56dda1fdb58fa883b..e2f9805f97f58c4344687cfa59b7a96b54804fac 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -509,13 +509,11 @@ lookupQualifiedName rdr_name -- and respect hiddenness of modules/packages, hence loadSrcInterface. = loadSrcInterface doc mod False Nothing `thenM` \ iface -> - case [ (mod,occ) | - (mod,avails) <- mi_exports iface, - avail <- avails, - name <- availNames avail, - name == occ ] of - ((mod,occ):ns) -> ASSERT (null ns) - lookupOrig mod occ + case [ name + | avail <- mi_exports iface, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) return n _ -> unboundName WL_Any rdr_name | otherwise diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 1a70068210bcca4f63aacac45bcf19108dc492d0..892011ff94129909ba953310071dd0038d17dd2b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,7 +18,6 @@ import HsSyn import TcEnv ( isBrackStage ) import RnEnv import RnHsDoc ( rnHsDoc ) -import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad @@ -37,7 +36,7 @@ import ErrUtils import Util import FastString import ListSetOps -import Data.List ( partition, (\\), delete, find ) +import Data.List ( partition, (\\), find ) import qualified Data.Set as Set import System.IO import Control.Monad @@ -227,8 +226,17 @@ rnImportDecl this_mod implicit_prelude trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface - filtered_exports = filter not_this_mod (mi_exports iface) - not_this_mod (mod,_) = mod /= this_mod + qual_mod_name = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports iface imp_spec imp_details + + let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres) + from_this_mod gre = nameModule (gre_name gre) == this_mod -- If the module exports anything defined in this module, just -- ignore it. Reason: otherwise it looks as if there are two -- local definition sites for the thing, and an error gets @@ -237,7 +245,7 @@ rnImportDecl this_mod implicit_prelude -- itself, or another module that imported it. (Necessarily, -- this invoves a loop.) -- - -- Tiresome consequence: if you say + -- We do this *after* filterImports, so that if you say -- module A where -- import B( AType ) -- type AType = ... @@ -245,24 +253,9 @@ rnImportDecl this_mod implicit_prelude -- module B( AType ) where -- import {-# SOURCE #-} A( AType ) -- - -- then you'll get a 'B does not export AType' message. Oh well. + -- then you won't get a 'B does not export AType' message. - qual_mod_name = case as_mod of - Nothing -> imp_mod_name - Just another_name -> another_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } - -- Get the total exports from this module - total_avails <- ifaceExportNames filtered_exports - - -- filter the imports according to the import declaration - (new_imp_details, gbl_env) <- - filterImports iface imp_spec imp_details total_avails - - dflags <- getDOpts - - let -- Compute new transitive dependencies orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) @@ -546,7 +539,7 @@ getLocalNonValBinders group = do { gbl_env <- getGblEnv ; get_local_binders gbl_env group } -get_local_binders :: TcGblEnv -> HsGroup RdrName -> RnM [GenAvailInfo Name] +get_local_binders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, hs_tyclds = tycl_decls, hs_instds = inst_decls, @@ -581,7 +574,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] | otherwise = for_hs_bndrs - new_simple :: Located RdrName -> RnM (GenAvailInfo Name) + new_simple :: Located RdrName -> RnM AvailInfo new_simple rdr_name = do nm <- newTopSrcBinder rdr_name return (Avail nm) @@ -618,16 +611,15 @@ available, and filters it through the import spec (if any). filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl -> Maybe (Bool, [LIE RdrName]) -- Import spec; True => hiding - -> [AvailInfo] -- What's available -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names - GlobalRdrEnv) -- Same again, but in GRE form -filterImports _ decl_spec Nothing all_avails - = return (Nothing, mkGlobalRdrEnv (gresFromAvails prov all_avails)) + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports iface decl_spec Nothing + = return (Nothing, gresFromAvails prov (mi_exports iface)) where prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] -filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails +filterImports iface decl_spec (Just (want_hiding, import_items)) = do -- check for errors, convert RdrNames to Names opt_typeFamilies <- xoptM Opt_TypeFamilies items1 <- mapM (lookup_lie opt_typeFamilies) import_items @@ -645,8 +637,10 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails gres | want_hiding = gresFromAvails hiding_prov pruned_avails | otherwise = concatMap (gresFromIE decl_spec) items2 - return (Just (want_hiding, map fst items2), mkGlobalRdrEnv gres) + return (Just (want_hiding, map fst items2), gres) where + all_avails = mi_exports iface + -- This environment is how we map names mentioned in the import -- list to the actual Name they correspond to, and the name family -- that the Name belongs to (the AvailInfo). The situation is @@ -789,6 +783,27 @@ catMaybeErr ms = [ a | Succeeded a <- ms ] %* * %************************************************************************ +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (Trac #5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +becuase F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +So we compromise. When constructing exports with no export list, or +with module M( module M ), we add the parent to the exports as well. +But not when you see module M( f ), even if f is a class method with +a parent. Hence the include_parent flag to greExportAvail. + \begin{code} -- | make a 'GlobalRdrEnv' where all the elements point to the same -- import declaration (useful for "hiding" imports, or imports with @@ -804,17 +819,30 @@ gresFromAvail prov_fn avail gre_prov = prov_fn n} | n <- availNames avail ] -greAvail :: GlobalRdrElt -> AvailInfo -greAvail gre = mkUnitAvail (gre_name gre) (gre_par gre) - -mkUnitAvail :: Name -> Parent -> AvailInfo -mkUnitAvail me (ParentIs p) = AvailTC p [me] -mkUnitAvail me NoParent | isTyConName me = AvailTC me [me] - | otherwise = Avail me - -plusAvail :: GenAvailInfo Name -> GenAvailInfo Name -> GenAvailInfo Name -plusAvail (Avail n1) (Avail _) = Avail n1 -plusAvail (AvailTC _ ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2) +greExportAvail :: Bool -> GlobalRdrElt -> AvailInfo +-- For 'include_parent' see Note [Exports of data families] +greExportAvail include_parent gre + = case gre_par gre of + ParentIs p | include_parent -> AvailTC p [p,me] + | otherwise -> AvailTC p [me] + NoParent | isTyConName me -> AvailTC me [me] + | otherwise -> Avail me + where + me = gre_name gre + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 +plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) availParent :: Name -> AvailInfo -> Parent @@ -861,54 +889,16 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [Name] -> Name -> [Name] findChildren env n = lookupNameEnv env n `orElse` [] -\end{code} - ---------------------------------------- - AvailEnv and friends - -All this AvailEnv stuff is hardly used; only in a very small -part of RnNames. Todo: remove? ---------------------------------------- - -\begin{code} -type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it - -emptyAvailEnv :: AvailEnv -emptyAvailEnv = emptyNameEnv - -{- Dead code -unitAvailEnv :: AvailInfo -> AvailEnv -unitAvailEnv a = unitNameEnv (availName a) a - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts :: AvailEnv -> [AvailInfo] -availEnvElts = nameEnvElts --} -addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail - -mkAvailEnv :: [AvailInfo] -> AvailEnv +-- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index) -- We want to combine these; addAvail does that -mkAvailEnv avails = foldl addAvail emptyAvailEnv avails - --- After combining the avails, we need to ensure that the parent name is the --- first entry in the list of subnames, if it is included at all. (Subsequent --- functions rely on that.) -normaliseAvail :: AvailInfo -> AvailInfo -normaliseAvail avail@(Avail _) = avail -normaliseAvail (AvailTC name subs) = AvailTC name subs' - where - subs' = if name `elem` subs then name : (delete name subs) else subs - --- | combines 'AvailInfo's from the same family nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = map normaliseAvail . nameEnvElts . mkAvailEnv $ avails +nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail \end{code} @@ -996,8 +986,9 @@ exports_from_avail Nothing rdr_env _imports _this_mod = -- The same as (module M) where M is the current module name, -- so that's how we handle it. let - avails = [ greAvail gre | gre <- globalRdrEnvElts rdr_env, - isLocalGRE gre ] + avails = [ greExportAvail True gre + | gre <- globalRdrEnvElts rdr_env + , isLocalGRE gre ] in return (Nothing, avails) @@ -1051,7 +1042,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod -- several members of mod_avails with the same -- OccName. ; return (L loc (IEModuleContents mod) : ie_names, - occs', map greAvail gres ++ exports) } + occs', map (greExportAvail True) gres ++ exports) } exports_from_item acc@(lie_names, occs, exports) (L loc ie) | isDoc ie @@ -1072,7 +1063,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) lookup_ie (IEVar rdr) = do gre <- lookupGreRn rdr - return (IEVar (gre_name gre), greAvail gre) + return (IEVar (gre_name gre), greExportAvail False gre) lookup_ie (IEThingAbs rdr) = do gre <- lookupGreRn rdr @@ -1558,18 +1549,15 @@ printMinimalImports imports_w_usage to_ie _ (AvailTC n [m]) | n==m = [IEThingAbs n] to_ie iface (AvailTC n ns) - = case [xs | (m,as) <- mi_exports iface - , m == n_mod - , AvailTC x xs <- as - , x == nameOccName n + = case [xs | AvailTC x xs <- mi_exports iface + , x == n , x `elem` xs -- Note [Partial export] ] of [xs] | all_used xs -> [IEThingAll n] | otherwise -> [IEThingWith n (filter (/= n) ns)] - _other -> (map IEVar ns) + _other -> map IEVar ns where - all_used avail_occs = all (`elem` map nameOccName ns) avail_occs - n_mod = ASSERT( isExternalName n ) nameModule n + all_used avail_occs = all (`elem` ns) avail_occs \end{code} Note [Partial export] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 0ddfa0a2ae736e356a18f37285e0a8d967fe9cdc..8cd5d9dccf8b03f30e5a9a65f7ed5d4c5d944e77 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -30,7 +30,7 @@ import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( GenAvailInfo(..), availsToNameSet ) +import HscTypes ( AvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad