%
-% (c) The University of Glasgow, 2004
+% (c) The University of Glasgow, 2004-2006
%
Module
~~~~~~~~~~
Simply the name of a module, represented as a FastString.
-These are Uniquable, hence we can build FiniteMaps with Modules as
+These are Uniquable, hence we can build Maps with Modules as
the keys.
\begin{code}
pprModuleName,
moduleNameFS,
moduleNameString,
+ moduleNameSlashes,
mkModuleName,
mkModuleNameFS,
+ stableModuleNameCmp,
+
+ -- * The PackageId type
+ PackageId,
+ fsToPackageId,
+ packageIdFS,
+ stringToPackageId,
+ packageIdString,
+ stablePackageIdCmp,
+
+ -- * Wired-in PackageIds
+ -- $wired_in_packages
+ primPackageId,
+ integerPackageId,
+ basePackageId,
+ rtsPackageId,
+ thPackageId,
+ dphSeqPackageId,
+ dphParPackageId,
+ mainPackageId,
-- * The Module type
Module,
modulePackageId, moduleName,
pprModule,
mkModule,
+ stableModuleCmp,
-- * The ModuleLocation type
ModLocation(..),
extendModuleEnvList_C, plusModuleEnv_C,
delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
- moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv,
- extendModuleEnv_C, filterModuleEnv,
+ moduleEnvKeys, moduleEnvElts, moduleEnvToList,
+ unitModuleEnv, isEmptyModuleEnv,
+ foldModuleEnv, extendModuleEnvWith, filterModuleEnv,
-- * ModuleName mappings
ModuleNameEnv,
- -- * Sets of modules
- ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet,
- elemModuleSet
+ -- * Sets of Modules
+ ModuleSet,
+ emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
) where
-#include "HsVersions.h"
+#include "Typeable.h"
+
+import Config
import Outputable
-import Unique ( Uniquable(..) )
-import FiniteMap
+import qualified Pretty
+import Unique
import UniqFM
-import PackageConfig ( PackageId, packageIdFS, mainPackageId )
import FastString
import Binary
+import Util
+
+import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+import System.FilePath
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+-- | Where a module lives on the file system: the actual locations
+-- of the .hs, .hi and .o files, if we have them
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
\begin{code}
addBootSuffix :: FilePath -> FilePath
--- Add the "-boot" suffix to .hs, .hi and .o files
+-- ^ Add the @-boot@ suffix to .hs, .hi and .o files
addBootSuffix path = path ++ "-boot"
addBootSuffix_maybe :: Bool -> FilePath -> FilePath
+-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@
addBootSuffix_maybe is_boot path
| is_boot = addBootSuffix path
| otherwise = path
addBootSuffixLocn :: ModLocation -> ModLocation
+-- ^ Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn locn
= locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
, ml_hi_file = addBootSuffix (ml_hi_file locn)
%************************************************************************
\begin{code}
--- | A ModuleName is a simple string, eg. @Data.List@.
+-- | A ModuleName is essentially a simple string, e.g. @Data.List@.
newtype ModuleName = ModuleName FastString
+ deriving Typeable
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs)
+instance Data ModuleName where
+ -- don't traverse?
+ toConstr _ = abstractConstr "ModuleName"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "ModuleName"
+
+stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
+-- ^ Compares module names lexically, rather than by their 'Unique's
+stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
+
pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
getPprStyle $ \ sty ->
mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s
+
+-- | Returns the string version of the module name, with dots replaced by slashes
+moduleNameSlashes :: ModuleName -> String
+moduleNameSlashes = dots_to_slashes . moduleNameString
+ where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
\end{code}
%************************************************************************
modulePackageId :: !PackageId, -- pkg-1.0
moduleName :: !ModuleName -- A.B.C
}
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Typeable)
+
+instance Uniquable Module where
+ getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n)
instance Outputable Module where
ppr = pprModule
put_ bh (Module p n) = put_ bh p >> put_ bh n
get bh = do p <- get bh; n <- get bh; return (Module p n)
+instance Data Module where
+ -- don't traverse?
+ toConstr _ = abstractConstr "Module"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Module"
+
+-- | This gives a stable ordering, as opposed to the Ord instance which
+-- gives an ordering based on the 'Unique's of the components, which may
+-- not be stable from run to run of the compiler.
+stableModuleCmp :: Module -> Module -> Ordering
+stableModuleCmp (Module p1 n1) (Module p2 n2)
+ = (p1 `stablePackageIdCmp` p2) `thenCmp`
+ (n1 `stableModuleNameCmp` n2)
+
mkModule :: PackageId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
+pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
pprPackagePrefix p mod = getPprStyle doc
where
doc 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 ':'
+ | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':'
-- the PrintUnqualified tells us which modules have to
-- be qualified with package names
| otherwise = empty
%************************************************************************
%* *
+\subsection{PackageId}
+%* *
+%************************************************************************
+
+\begin{code}
+-- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0
+newtype PackageId = PId FastString deriving( Eq, Typeable )
+ -- here to avoid module loops with PackageConfig
+
+instance Uniquable PackageId where
+ getUnique pid = getUnique (packageIdFS pid)
+
+-- Note: *not* a stable lexicographic ordering, a faster unique-based
+-- ordering.
+instance Ord PackageId where
+ nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+
+instance Data PackageId where
+ -- don't traverse?
+ toConstr _ = abstractConstr "PackageId"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "PackageId"
+
+stablePackageIdCmp :: PackageId -> PackageId -> Ordering
+-- ^ Compares package ids lexically, rather than by their 'Unique's
+stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2
+
+instance Outputable PackageId where
+ ppr pid = text (packageIdString pid)
+
+instance Binary PackageId where
+ put_ bh pid = put_ bh (packageIdFS pid)
+ get bh = do { fs <- get bh; return (fsToPackageId fs) }
+
+fsToPackageId :: FastString -> PackageId
+fsToPackageId = PId
+
+packageIdFS :: PackageId -> FastString
+packageIdFS (PId fs) = fs
+
+stringToPackageId :: String -> PackageId
+stringToPackageId = fsToPackageId . mkFastString
+
+packageIdString :: PackageId -> String
+packageIdString = unpackFS . packageIdFS
+
+
+-- -----------------------------------------------------------------------------
+-- $wired_in_packages
+-- Certain packages are known to the compiler, in that we know about certain
+-- entities that reside in these packages, and the compiler needs to
+-- declare static Modules and Names that refer to these packages. Hence
+-- the wired-in packages can't include version numbers, since we don't want
+-- to bake the version numbers of these packages into GHC.
+--
+-- So here's the plan. Wired-in packages are still versioned as
+-- normal in the packages database, and you can still have multiple
+-- versions of them installed. However, for each invocation of GHC,
+-- only a single instance of each wired-in package will be recognised
+-- (the desired one is selected via @-package@\/@-hide-package@), and GHC
+-- will use the unversioned 'PackageId' below when referring to it,
+-- including in .hi files and object file symbols. Unselected
+-- versions of wired-in packages will be ignored, as will any other
+-- package that depends directly or indirectly on it (much as if you
+-- had used @-ignore-package@).
+
+-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
+
+integerPackageId, primPackageId,
+ basePackageId, rtsPackageId,
+ thPackageId, dphSeqPackageId, dphParPackageId,
+ mainPackageId :: PackageId
+primPackageId = fsToPackageId (fsLit "ghc-prim")
+integerPackageId = fsToPackageId (fsLit cIntegerLibrary)
+basePackageId = fsToPackageId (fsLit "base")
+rtsPackageId = fsToPackageId (fsLit "rts")
+thPackageId = fsToPackageId (fsLit "template-haskell")
+dphSeqPackageId = fsToPackageId (fsLit "dph-seq")
+dphParPackageId = fsToPackageId (fsLit "dph-par")
+
+-- | This is the package Id for the current program. It is the default
+-- package Id if you don't specify a package name. We don't add this prefix
+-- to symbol names, since there can be only one main package per program.
+mainPackageId = fsToPackageId (fsLit "main")
+\end{code}
+
+%************************************************************************
+%* *
\subsection{@ModuleEnv@s}
%* *
%************************************************************************
\begin{code}
-type ModuleEnv elt = FiniteMap Module elt
-
-emptyModuleEnv :: ModuleEnv a
-mkModuleEnv :: [(Module, a)] -> ModuleEnv a
-unitModuleEnv :: Module -> a -> ModuleEnv a
-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
-plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
-mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
-moduleEnvElts :: ModuleEnv a -> [a]
-
-isEmptyModuleEnv :: ModuleEnv a -> Bool
-lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
+-- | A map keyed off of 'Module's
+newtype ModuleEnv elt = ModuleEnv (Map Module elt)
+
+filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
+filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e)
+
+elemModuleEnv :: Module -> ModuleEnv a -> Bool
+elemModuleEnv m (ModuleEnv e) = Map.member m e
+
+extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e)
+
+extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e)
+
+extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
+extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e)
+
+extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
+ -> ModuleEnv a
+extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e)
+
+plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2)
+
+delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
+delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e)
+
+delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e)
+
+plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
+
+lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
+lookupModuleEnv (ModuleEnv e) m = Map.lookup m e
+
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
-elemModuleEnv :: Module -> ModuleEnv a -> Bool
-foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
-filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a
-
-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)
+lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e
+
+mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
+
+mkModuleEnv :: [(Module, a)] -> ModuleEnv a
+mkModuleEnv xs = ModuleEnv (Map.fromList xs)
+
+emptyModuleEnv :: ModuleEnv a
+emptyModuleEnv = ModuleEnv Map.empty
+
+moduleEnvKeys :: ModuleEnv a -> [Module]
+moduleEnvKeys (ModuleEnv e) = Map.keys e
+
+moduleEnvElts :: ModuleEnv a -> [a]
+moduleEnvElts (ModuleEnv e) = Map.elems e
+
+moduleEnvToList :: ModuleEnv a -> [(Module, a)]
+moduleEnvToList (ModuleEnv e) = Map.toList e
+
+unitModuleEnv :: Module -> a -> ModuleEnv a
+unitModuleEnv m x = ModuleEnv (Map.singleton m x)
+
+isEmptyModuleEnv :: ModuleEnv a -> Bool
+isEmptyModuleEnv (ModuleEnv e) = Map.null e
+
+foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
+foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e
\end{code}
\begin{code}
-type ModuleSet = FiniteMap Module ()
+-- | A set of 'Module's
+type ModuleSet = Map Module ()
+
mkModuleSet :: [Module] -> ModuleSet
extendModuleSet :: ModuleSet -> Module -> ModuleSet
emptyModuleSet :: ModuleSet
moduleSetElts :: ModuleSet -> [Module]
elemModuleSet :: Module -> ModuleSet -> Bool
-emptyModuleSet = emptyFM
-mkModuleSet ms = listToFM [(m,()) | m <- ms ]
-extendModuleSet s m = addToFM s m ()
-moduleSetElts = keysFM
-elemModuleSet = elemFM
+emptyModuleSet = Map.empty
+mkModuleSet ms = Map.fromList [(m,()) | m <- ms ]
+extendModuleSet s m = Map.insert m () s
+moduleSetElts = Map.keys
+elemModuleSet = Map.member
\end{code}
A ModuleName has a Unique, so we can build mappings of these using
UniqFM.
\begin{code}
+-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
type ModuleNameEnv elt = UniqFM elt
\end{code}