Commit fe44af73 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Change the representation of export lists in .hi files

Currently export list in .hi files are partitioned by module
  export M T(C1,C2)
         N f,g
In each list we only have OccNames, all assumed to come from
the parent module M or N resp.

This patch changes the representatation so that export lists
have full Names:
  export M.T(M.C1,M.C2), N.f, N.g

Numerous advatages
  * AvailInfo no longer needs to be parameterised; it always
    contains Names

  * Fixes Trac #5306.  This was the main provocation

  * Less to-and-fro conversion when reading interface files

It's all generally simpler.  Interface files should not get bigger,
becuase they have a nice compact representation for Names.
parent 428f8c3d
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -959,54 +959,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]
......
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......@@ -1560,18 +1551,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]
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment