Commit 61d2625a authored by Simon Marlow's avatar Simon Marlow

Generalise Package Support

This patch pushes through one fundamental change: a module is now
identified by the pair of its package and module name, whereas
previously it was identified by its module name alone.  This means
that now a program can contain multiple modules with the same name, as
long as they belong to different packages.

This is a language change - the Haskell report says nothing about
packages, but it is now necessary to understand packages in order to
understand GHC's module system.  For example, a type T from module M
in package P is different from a type T from module M in package Q.
Previously this wasn't an issue because there could only be a single
module M in the program.

The "module restriction" on combining packages has therefore been
lifted, and a program can contain multiple versions of the same
package.

Note that none of the proposed syntax changes have yet been
implemented, but the architecture is geared towards supporting import
declarations qualified by package name, and that is probably the next
step.

It is now necessary to specify the package name when compiling a
package, using the -package-name flag (which has been un-deprecated).
Fortunately Cabal still uses -package-name.

Certain packages are "wired in".  Currently the wired-in packages are:
base, haskell98, template-haskell and rts, and are always referred to
by these versionless names.  Other packages are referred to with full
package IDs (eg. "network-1.0").  This is because the compiler needs
to refer to entities in the wired-in packages, and we didn't want to
bake the version of these packages into the comiler.  It's conceivable
that someone might want to upgrade the base package independently of
GHC.

Internal changes:

  - There are two module-related types:

        ModuleName      just a FastString, the name of a module
        Module          a pair of a PackageId and ModuleName

    A mapping from ModuleName can be a UniqFM, but a mapping from Module
    must be a FiniteMap (we provide it as ModuleEnv).

  - The "HomeModules" type that was passed around the compiler is now
    gone, replaced in most cases by the current package name which is
    contained in DynFlags.  We can tell whether a Module comes from the
    current package by comparing its package name against the current
    package.

  - While I was here, I changed PrintUnqual to be a little more useful:
    it now returns the ModuleName that the identifier should be qualified
    with according to the current scope, rather than its original
    module.  Also, PrintUnqual tells whether to qualify module names with
    package names (currently unused).

Docs to follow.
parent b93eb0c2
......@@ -183,12 +183,16 @@ endif
#
ifneq "$(way)" "dll"
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
HS_PROG=$(odir)/ghc$(_way)-$(ProjectVersion)
GHC_PROG=$(odir)/ghc$(_way)-$(ProjectVersion)
else
HS_PROG=$(odir)/ghc$(_way)
GHC_PROG=$(odir)/ghc$(_way)
endif
else
HS_PROG=$(odir)/ghc-$(ProjectVersion)
GHC_PROG=$(odir)/ghc-$(ProjectVersion)
endif
ifneq "$(stage)" "2"
HS_PROG = $(GHC_PROG)
endif
# -----------------------------------------------------------------------------
......@@ -679,10 +683,10 @@ SRC_LD_OPTS += -no-link-chk
all :: $(odir)/ghc-inplace ghc-inplace
$(odir)/ghc-inplace : $(HS_PROG)
$(odir)/ghc-inplace : $(GHC_PROG)
@$(RM) $@
echo '#!/bin/sh' >>$@
echo exec $(GHC_COMPILER_DIR_ABS)/$(HS_PROG) '-B$(subst \,\\,$(FPTOOLS_TOP_ABS_PLATFORM))' '"$$@"' >>$@
echo exec $(GHC_COMPILER_DIR_ABS)/$(GHC_PROG) '-B$(subst \,\\,$(FPTOOLS_TOP_ABS_PLATFORM))' '"$$@"' >>$@
chmod 755 $@
ghc-inplace : stage1/ghc-inplace
......@@ -704,9 +708,9 @@ CLEAN_FILES += $(odir)/ghc-inplace
DESTDIR = $(INSTALL_LIBRARY_DIR_GHC)
ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
INSTALL_LIBEXECS += $(HS_PROG)
INSTALL_LIBEXECS += $(GHC_PROG)
else
INSTALL_PROGS += $(HS_PROG)
INSTALL_PROGS += $(GHC_PROG)
endif
# ----------------------------------------------------------------------------
......@@ -787,6 +791,19 @@ HS_IFACES = $(addsuffix .$(way_)hi,$(basename $(HS_OBJS)))
# Haddock can't handle recursive modules currently, so we disable it for now.
NO_HADDOCK_DOCS = YES
# Don't build the GHC binary as normal, because we need to link it
# against the GHC package. The GHC binary itself is built by
# compiling Main.o separately and linking it with -package ghc. This is
# done using a separate Makefile:
all :: $(GHC_PROG)
$(GHC_PROG) : libHS$(PACKAGE)$(_way).a main/Main.hs
$(MAKE) -f Makefile.ghcbin $(MFLAGS) HS_PROG=$(GHC_PROG) $@
docs runtests $(BOOT_TARGET) TAGS clean distclean mostlyclean maintainer-clean $(INSTALL_TARGET) $(INSTALL_DOCS_TARGET) html chm HxS ps dvi txt::
$(MAKE) -f Makefile.ghcbin $(MFLAGS) $@
endif
#-----------------------------------------------------------------------------
......
# This Makefile builds the GHC binary for stage2. In stage2, the GHC binary
# is built as a single Main module that links to the GHC package. It
# is easier to do this with a separate Makefile, because we don't want most
# of the options normally dumped into SRC_HC_OPTS by the main GHC Makefile.
# In particular, we don't want the .hi files picked up along the home package
# search path when compiling Main, we need the compiler to find them in
# the GHC package.
TOP = ..
include $(TOP)/mk/boilerplate.mk
stage=2
HC=$(GHC_STAGE1)
SRC_HC_OPTS += -package ghc
SRC_HC_OPTS += -DGHCI -DBREAKPOINT
SRC_HC_OPTS += -Istage$(stage)
SRC_HC_OPTS += \
-cpp -fglasgow-exts -fno-generics -Rghc-timing \
-I. -IcodeGen -InativeGen -Iparser
odir=stage$(stage)
HS_SRCS = main/Main.hs
HS_OBJS = $(patsubst %, $(odir)/%, $(addsuffix .$(way_)o,$(basename $(HS_SRCS))))
$(odir)/main/Main.o : libHSghc$(_way).a
include $(TOP)/mk/target.mk
-include .depend-$(stage)
......@@ -855,18 +855,18 @@ unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceI
nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId
lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId
errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID
recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError")
lazyIdName = mkWiredInIdName gHC_BASE FSLIT("lazy") lazyIdKey lazyId
errorName = mkWiredInIdName gHC_ERR FSLIT("error") errorIdKey eRROR_ID
recSelErrorName = mkWiredInIdName gHC_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
runtimeErrorName = mkWiredInIdName gHC_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
irrefutPatErrorName = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
recConErrorName = mkWiredInIdName gHC_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = mkWiredInIdName gHC_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName
= mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError")
= mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError")
nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
\end{code}
......
......@@ -11,36 +11,49 @@ the keys.
\begin{code}
module Module
(
Module -- Abstract, instance of Eq, Ord, Outputable
, pprModule -- :: Module -> SDoc
, ModLocation(..)
, addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn
, moduleString -- :: Module -> String
, moduleFS -- :: Module -> FastString
, mkModule -- :: String -> Module
, mkModuleFS -- :: FastString -> Module
, ModuleEnv
, elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, extendModuleEnv_C, filterModuleEnv
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
-- * The ModuleName type
ModuleName,
pprModuleName,
moduleNameFS,
moduleNameString,
mkModuleName,
mkModuleNameFS,
-- * The Module type
Module,
modulePackageId, moduleName,
pprModule,
mkModule,
-- * The ModuleLocation type
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
-- * Module mappings
ModuleEnv,
elemModuleEnv, extendModuleEnv, extendModuleEnvList,
extendModuleEnvList_C, plusModuleEnv_C,
delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv,
extendModuleEnv_C, filterModuleEnv,
-- * ModuleName mappings
ModuleNameEnv,
-- * Sets of modules
ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet,
elemModuleSet
) where
#include "HsVersions.h"
import Outputable
import Unique ( Uniquable(..) )
import FiniteMap
import UniqFM
import UniqSet
import Binary
import PackageConfig ( PackageId, packageIdFS, mainPackageId )
import FastString
import Binary
\end{code}
%************************************************************************
......@@ -105,49 +118,86 @@ addBootSuffixLocn locn
%************************************************************************
\begin{code}
newtype Module = Module FastString
-- Haskell module names can include the quote character ',
-- so the module names have the z-encoding applied to them
instance Binary Module where
put_ bh (Module m) = put_ bh m
get bh = do m <- get bh; return (Module m)
-- | A ModuleName is a simple string, eg. @Data.List@.
newtype ModuleName = ModuleName FastString
instance Uniquable Module where
getUnique (Module nm) = getUnique nm
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
instance Eq Module where
instance Eq ModuleName where
nm1 == nm2 = getUnique nm1 == getUnique nm2
-- Warning: gives an ordering relation based on the uniques of the
-- FastStrings which are the (encoded) module names. This is _not_
-- a lexicographical ordering.
instance Ord Module where
instance Ord ModuleName where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
instance Outputable Module where
ppr = pprModule
instance Outputable ModuleName where
ppr = pprModuleName
pprModule :: Module -> SDoc
pprModule (Module nm) =
instance Binary ModuleName where
put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs)
pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
getPprStyle $ \ sty ->
if codeStyle sty
then ftext (zEncodeFS nm)
else ftext nm
moduleFS :: Module -> FastString
moduleFS (Module mod) = mod
moduleNameFS :: ModuleName -> FastString
moduleNameFS (ModuleName mod) = mod
moduleString :: Module -> String
moduleString (Module mod) = unpackFS mod
moduleNameString :: ModuleName -> String
moduleNameString (ModuleName mod) = unpackFS mod
-- used to be called mkSrcModule
mkModule :: String -> Module
mkModule s = Module (mkFastString s)
mkModuleName :: String -> ModuleName
mkModuleName s = ModuleName (mkFastString s)
-- used to be called mkSrcModuleFS
mkModuleFS :: FastString -> Module
mkModuleFS s = Module s
mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s
\end{code}
%************************************************************************
%* *
\subsection{A fully qualified module}
%* *
%************************************************************************
\begin{code}
-- | A Module is a pair of a 'PackageId' and a 'ModuleName'.
data Module = Module {
modulePackageId :: !PackageId, -- pkg-1.0
moduleName :: !ModuleName -- A.B.C
}
deriving (Eq, Ord)
instance Outputable Module where
ppr = pprModule
instance Binary Module where
put_ bh (Module p n) = put_ bh p >> put_ bh n
get bh = do p <- get bh; n <- get bh; return (Module p n)
mkModule :: PackageId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
| codeStyle sty =
if p == mainPackageId
then empty -- never qualify the main package in code
else ftext (zEncodeFS (packageIdFS p)) <> char '_'
| Just pkg <- qualModule sty mod = ftext (packageIdFS pkg) <> char ':'
-- the PrintUnqualified tells us which modules have to
-- be qualified with package names
| otherwise = empty
\end{code}
%************************************************************************
......@@ -157,7 +207,7 @@ mkModuleFS s = Module s
%************************************************************************
\begin{code}
type ModuleEnv elt = UniqFM elt
type ModuleEnv elt = FiniteMap Module elt
emptyModuleEnv :: ModuleEnv a
mkModuleEnv :: [(Module, a)] -> ModuleEnv a
......@@ -166,6 +216,7 @@ extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
extendModuleEnvList_C :: (a->a->a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a
delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
......@@ -180,37 +231,45 @@ elemModuleEnv :: Module -> ModuleEnv a -> Bool
foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a
filterModuleEnv = filterUFM
elemModuleEnv = elemUFM
extendModuleEnv = addToUFM
extendModuleEnv_C = addToUFM_C
extendModuleEnvList = addListToUFM
plusModuleEnv_C = plusUFM_C
delModuleEnvList = delListFromUFM
delModuleEnv = delFromUFM
plusModuleEnv = plusUFM
lookupModuleEnv = lookupUFM
lookupWithDefaultModuleEnv = lookupWithDefaultUFM
mapModuleEnv = mapUFM
mkModuleEnv = listToUFM
emptyModuleEnv = emptyUFM
moduleEnvElts = eltsUFM
unitModuleEnv = unitUFM
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
filterModuleEnv f = filterFM (\_ v -> f v)
elemModuleEnv = elemFM
extendModuleEnv = addToFM
extendModuleEnv_C = addToFM_C
extendModuleEnvList = addListToFM
extendModuleEnvList_C = addListToFM_C
plusModuleEnv_C = plusFM_C
delModuleEnvList = delListFromFM
delModuleEnv = delFromFM
plusModuleEnv = plusFM
lookupModuleEnv = lookupFM
lookupWithDefaultModuleEnv = lookupWithDefaultFM
mapModuleEnv f = mapFM (\_ v -> f v)
mkModuleEnv = listToFM
emptyModuleEnv = emptyFM
moduleEnvElts = eltsFM
unitModuleEnv = unitFM
isEmptyModuleEnv = isEmptyFM
foldModuleEnv f = foldFM (\_ v -> f v)
\end{code}
\begin{code}
type ModuleSet = UniqSet Module
type ModuleSet = FiniteMap Module ()
mkModuleSet :: [Module] -> ModuleSet
extendModuleSet :: ModuleSet -> Module -> ModuleSet
emptyModuleSet :: ModuleSet
moduleSetElts :: ModuleSet -> [Module]
elemModuleSet :: Module -> ModuleSet -> Bool
emptyModuleSet = emptyUniqSet
mkModuleSet = mkUniqSet
extendModuleSet = addOneToUniqSet
moduleSetElts = uniqSetToList
elemModuleSet = elementOfUniqSet
emptyModuleSet = emptyFM
mkModuleSet ms = listToFM [(m,()) | m <- ms ]
extendModuleSet s m = addToFM s m ()
moduleSetElts = keysFM
elemModuleSet = elemFM
\end{code}
A ModuleName has a Unique, so we can build mappings of these using
UniqFM.
\begin{code}
type ModuleNameEnv elt = UniqFM elt
\end{code}
\begin{code}
module Module where
import PackageConfig (PackageId)
data Module
data ModuleName
moduleName :: Module -> ModuleName
modulePackageId :: Module -> PackageId
\end{code}
......@@ -38,7 +38,7 @@ module Name (
import {-# SOURCE #-} TypeRep( TyThing )
import OccName -- All of it
import Module ( Module, moduleFS )
import Module ( Module )
import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), getKey, pprUnique )
import Maybes ( orElse, isJust )
......@@ -56,7 +56,7 @@ import Outputable
data Name = Name {
n_sort :: NameSort, -- What sort of name it is
n_occ :: !OccName, -- Its occurrence name
n_uniq :: Unique,
n_uniq :: {-# UNPACK #-} !Unique,
n_loc :: !SrcLoc -- Definition site
}
......@@ -308,7 +308,7 @@ instance Outputable Name where
instance OutputableBndr Name where
pprBndr _ name = pprName name
pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
case sort of
WiredIn mod _ _ builtin -> pprExternal sty uniq mod occ True builtin
......@@ -317,18 +317,19 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
Internal -> pprInternal sty uniq occ
pprExternal sty uniq mod occ is_wired is_builtin
| codeStyle sty = ppr_z_module mod <> char '_' <> ppr_z_occ_name occ
| codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
-- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified
-- in code style, to reduce symbol table bloat?
| debugStyle sty = ppr mod <> dot <> ppr_occ_name occ
<> braces (hsep [if is_wired then ptext SLIT("(w)") else empty,
pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq])
| debugStyle sty = ppr mod <> dot <> ppr_occ_name occ
<> braces (hsep [if is_wired then ptext SLIT("(w)") else empty,
pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq])
| BuiltInSyntax <- is_builtin = ppr_occ_name occ
-- never qualify builtin syntax
| unqualStyle sty mod occ = ppr_occ_name occ
| otherwise = ppr mod <> dot <> ppr_occ_name occ
| Just mod <- qualName sty mod occ = ppr mod <> dot <> ppr_occ_name occ
-- the PrintUnqualified tells us how to qualify this Name, if at all
| otherwise = ppr_occ_name occ
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
......@@ -356,8 +357,6 @@ ppr_occ_name occ = ftext (occNameFS occ)
-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are
-- cached behind the scenes in the FastString implementation.
ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ))
ppr_z_module mod = ftext (zEncodeFS (moduleFS mod))
\end{code}
%************************************************************************
......
......@@ -15,8 +15,8 @@ module RdrName (
mkDerivedRdrName,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameSpace,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual,
rdrNameOcc, setRdrNameSpace,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
-- Printing; instance Outputable RdrName
......@@ -41,7 +41,7 @@ module RdrName (
#include "HsVersions.h"
import OccName
import Module ( Module, mkModuleFS )
import Module ( ModuleName, mkModuleNameFS, Module, moduleName )
import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe,
nameOccName, isExternalName, nameSrcLoc )
import Maybes ( mapCatMaybes )
......@@ -62,7 +62,7 @@ data RdrName
= Unqual OccName
-- Used for ordinary, unqualified occurrences
| Qual Module OccName
| Qual ModuleName OccName
-- A qualified name written by the user in
-- *source* code. The module isn't necessarily
-- the module where the thing is defined;
......@@ -92,12 +92,6 @@ data RdrName
%************************************************************************
\begin{code}
rdrNameModule :: RdrName -> Module
rdrNameModule (Qual m _) = m
rdrNameModule (Orig m _) = m
rdrNameModule (Exact n) = nameModule n
rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n)
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Qual _ occ) = occ
rdrNameOcc (Unqual occ) = occ
......@@ -125,7 +119,7 @@ setRdrNameSpace (Exact n) ns = Orig (nameModule n)
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = Unqual occ
mkRdrQual :: Module -> OccName -> RdrName
mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual mod occ = Qual mod occ
mkOrig :: Module -> OccName -> RdrName
......@@ -146,7 +140,7 @@ mkVarUnqual :: FastString -> RdrName
mkVarUnqual n = Unqual (mkVarOccFS n)
mkQual :: NameSpace -> (FastString, FastString) -> RdrName
mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccNameFS sp n)
mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)
getRdrName :: NamedThing thing => thing -> RdrName
getRdrName name = nameRdrName (getName name)
......@@ -178,6 +172,9 @@ isUnqual other = False
isQual (Qual _ _) = True
isQual _ = False
isQual_maybe (Qual m n) = Just (m,n)
isQual_maybe _ = Nothing
isOrig (Orig _ _) = True
isOrig _ = False
......@@ -372,24 +369,31 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
pickGREs rdr_name gres
= mapCatMaybes pick gres
where
is_unqual = isUnqual rdr_name
mod = rdrNameModule rdr_name
rdr_is_unqual = isUnqual rdr_name
rdr_is_qual = isQual_maybe rdr_name
pick :: GlobalRdrElt -> Maybe GlobalRdrElt
pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def
| is_unqual || nameModule n == mod = Just gre
| otherwise = Nothing
| rdr_is_unqual = Just gre
| Just (mod,_) <- rdr_is_qual,
mod == moduleName (nameModule n) = Just gre
| otherwise = Nothing
pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency)
| is_unqual = if not (is_qual (is_decl is)) then Just gre
else Nothing
| otherwise = if mod == is_as (is_decl is) then Just gre
else Nothing
| rdr_is_unqual,
not (is_qual (is_decl is)) = Just gre
| Just (mod,_) <- rdr_is_qual,
mod == is_as (is_decl is) = Just gre
| otherwise = Nothing
pick gre@(GRE {gre_prov = Imported is}) -- Multiple import
| null filtered_is = Nothing
| otherwise = Just (gre {gre_prov = Imported filtered_is})
where
filtered_is | is_unqual = filter (not . is_qual . is_decl) is
| otherwise = filter ((== mod) . is_as . is_decl) is
filtered_is | rdr_is_unqual
= filter (not . is_qual . is_decl) is
| Just (mod,_) <- rdr_is_qual
= filter ((== mod) . is_as . is_decl) is
| otherwise
= []
isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_prov = LocalDef}) = True
......@@ -449,10 +453,12 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
data ImpDeclSpec -- Describes a particular import declaration
-- Shared among all the Provenaces for that decl
= ImpDeclSpec {
is_mod :: Module, -- 'import Muggle'
is_mod :: ModuleName, -- 'import Muggle'
-- Note the Muggle may well not be
-- the defining module for this thing!
is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause)
-- TODO: either should be Module, or there
-- should be a Maybe PackageId here too.
is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause)
is_qual :: Bool, -- True <=> qualified (only)
is_dloc :: SrcSpan -- Location of import declaration
}
......@@ -476,7 +482,7 @@ importSpecLoc :: ImportSpec -> SrcSpan
importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
importSpecLoc (ImpSpec _ item) = is_iloc item
importSpecModule :: ImportSpec -> Module
importSpecModule :: ImportSpec -> ModuleName
importSpecModule is = is_mod (is_decl is)
-- Note [Comparing provenance]
......
......@@ -103,11 +103,11 @@ module CLabel (
#include "HsVersions.h"
import Packages ( HomeModules )
import StaticFlags ( opt_Static, opt_DoTickyProfiling )
import Packages ( isHomeModule, isDllName )
import Packages ( isDllName )
import DataCon ( ConTag )
import Module ( Module )
import PackageConfig ( PackageId )
import Module ( Module, modulePackageId )
import Name ( Name, isExternalName )
import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp )
......@@ -293,20 +293,20 @@ mkLocalInfoTableLabel name = IdLabel name InfoTable
mkLocalEntryLabel name = IdLabel name Entry
mkLocalClosureTableLabel name = IdLabel name ClosureTable
mkClosureLabel hmods name
| isDllName hmods name = DynIdLabel name Closure
mkClosureLabel this_pkg name
| isDllName this_pkg name = DynIdLabel name Closure
| otherwise = IdLabel name Closure
mkInfoTableLabel hmods name
| isDllName hmods name = DynIdLabel name InfoTable
mkInfoTableLabel this_pkg name
| isDllName this_pkg name = DynIdLabel name InfoTable
| otherwise = IdLabel name InfoTable
mkEntryLabel hmods name
| isDllName hmods name = DynIdLabel name Entry
mkEntryLabel this_pkg name
| isDllName this_pkg name = DynIdLabel name Entry
| otherwise = IdLabel name Entry
mkClosureTableLabel hmods name
| isDllName hmods name = DynIdLabel name ClosureTable
mkClosureTableLabel this_pkg name
| isDllName this_pkg name = DynIdLabel name ClosureTable
| otherwise = IdLabel name ClosureTable