%
% (c) The University of Glasgow, 20042006
%
Module
~~~~~~~~~~
Simply the name of a module, represented as a FastString.
These are Uniquable, hence we can build FiniteMaps with Modules as
the keys.
\begin{code}
module Module
(
ModuleName,
pprModuleName,
moduleNameFS,
moduleNameString,
moduleNameSlashes,
mkModuleName,
mkModuleNameFS,
stableModuleNameCmp,
PackageId,
fsToPackageId,
packageIdFS,
stringToPackageId,
packageIdString,
stablePackageIdCmp,
primPackageId,
integerPackageId,
basePackageId,
rtsPackageId,
haskell98PackageId,
thPackageId,
dphSeqPackageId,
dphParPackageId,
mainPackageId,
Module,
modulePackageId, moduleName,
pprModule,
mkModule,
stableModuleCmp,
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
ModuleEnv,
elemModuleEnv, extendModuleEnv, extendModuleEnvList,
extendModuleEnvList_C, plusModuleEnv_C,
delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
moduleEnvKeys, moduleEnvElts, moduleEnvToList,
unitModuleEnv, isEmptyModuleEnv,
foldModuleEnv, extendModuleEnv_C, filterModuleEnv,
ModuleNameEnv,
ModuleSet,
emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
) where
import Config
import Outputable
import qualified Pretty
import Unique
import FiniteMap
import LazyUniqFM
import FastString
import Binary
import Util
import System.FilePath
\end{code}
%************************************************************************
%* *
\subsection{Module locations}
%* *
%************************************************************************
\begin{code}
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
ml_hi_file :: FilePath,
ml_obj_file :: FilePath
} deriving Show
instance Outputable ModLocation where
ppr = text . show
\end{code}
For a module in another package, the hs_file and obj_file
components of ModLocation are undefined.
The locations specified by a ModLocation may or may not
correspond to actual files yet: for example, even if the object
file doesn't exist, the ModLocation still contains the path to
where the object file will reside if/when it is created.
\begin{code}
addBootSuffix :: FilePath -> FilePath
addBootSuffix path = path ++ "-boot"
addBootSuffix_maybe :: Bool -> FilePath -> FilePath
addBootSuffix_maybe is_boot path
| is_boot = addBootSuffix path
| otherwise = path
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
= locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
, ml_hi_file = addBootSuffix (ml_hi_file locn)
, ml_obj_file = addBootSuffix (ml_obj_file locn) }
\end{code}
%************************************************************************
%* *
\subsection{The name of a module}
%* *
%************************************************************************
\begin{code}
newtype ModuleName = ModuleName FastString
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
instance Eq ModuleName where
nm1 == nm2 = getUnique nm1 == getUnique nm2
instance Ord ModuleName where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
instance Outputable ModuleName where
ppr = pprModuleName
instance Binary ModuleName where
put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs)
stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
getPprStyle $ \ sty ->
if codeStyle sty
then ftext (zEncodeFS nm)
else ftext nm
moduleNameFS :: ModuleName -> FastString
moduleNameFS (ModuleName mod) = mod
moduleNameString :: ModuleName -> String
moduleNameString (ModuleName mod) = unpackFS mod
mkModuleName :: String -> ModuleName
mkModuleName s = ModuleName (mkFastString s)
mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s
moduleNameSlashes :: ModuleName -> String
moduleNameSlashes = dots_to_slashes . moduleNameString
where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
\end{code}
%************************************************************************
%* *
\subsection{A fully qualified module}
%* *
%************************************************************************
\begin{code}
data Module = Module {
modulePackageId :: !PackageId,
moduleName :: !ModuleName
}
deriving (Eq, Ord)
instance Uniquable Module where
getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n)
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)
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
| codeStyle sty =
if p == mainPackageId
then empty
else ftext (zEncodeFS (packageIdFS p)) <> char '_'
| qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':'
| otherwise = empty
\end{code}
%************************************************************************
%* *
\subsection{PackageId}
%* *
%************************************************************************
\begin{code}
newtype PackageId = PId FastString deriving( Eq )
instance Uniquable PackageId where
getUnique pid = getUnique (packageIdFS pid)
instance Ord PackageId where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
stablePackageIdCmp :: PackageId -> PackageId -> Ordering
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
integerPackageId, primPackageId,
basePackageId, rtsPackageId, haskell98PackageId,
thPackageId, dphSeqPackageId, dphParPackageId,
mainPackageId :: PackageId
primPackageId = fsToPackageId (fsLit "ghc-prim")
integerPackageId = fsToPackageId (fsLit cIntegerLibrary)
basePackageId = fsToPackageId (fsLit "base")
rtsPackageId = fsToPackageId (fsLit "rts")
haskell98PackageId = fsToPackageId (fsLit "haskell98")
thPackageId = fsToPackageId (fsLit "template-haskell")
dphSeqPackageId = fsToPackageId (fsLit "dph-seq")
dphParPackageId = fsToPackageId (fsLit "dph-par")
mainPackageId = fsToPackageId (fsLit "main")
\end{code}
%************************************************************************
%* *
\subsection{@ModuleEnv@s}
%* *
%************************************************************************
\begin{code}
newtype ModuleEnv elt = ModuleEnv (FiniteMap Module elt)
filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
filterModuleEnv f (ModuleEnv e) = ModuleEnv (filterFM f e)
elemModuleEnv :: Module -> ModuleEnv a -> Bool
elemModuleEnv m (ModuleEnv e) = elemFM m e
extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv (ModuleEnv e) m x = ModuleEnv (addToFM e m x)
extendModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv_C f (ModuleEnv e) m x = ModuleEnv (addToFM_C f e m x)
extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (addListToFM e xs)
extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
-> ModuleEnv a
extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (addListToFM_C f e xs)
plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM_C f e1 e2)
delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
delModuleEnvList (ModuleEnv e) ms = ModuleEnv (delListFromFM e ms)
delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
delModuleEnv (ModuleEnv e) m = ModuleEnv (delFromFM e m)
plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM e1 e2)
lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (ModuleEnv e) m = lookupFM e m
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
lookupWithDefaultModuleEnv (ModuleEnv e) x m = lookupWithDefaultFM e x m
mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
mapModuleEnv f (ModuleEnv e) = ModuleEnv (mapFM (\_ v -> f v) e)
mkModuleEnv :: [(Module, a)] -> ModuleEnv a
mkModuleEnv xs = ModuleEnv (listToFM xs)
emptyModuleEnv :: ModuleEnv a
emptyModuleEnv = ModuleEnv emptyFM
moduleEnvKeys :: ModuleEnv a -> [Module]
moduleEnvKeys (ModuleEnv e) = keysFM e
moduleEnvElts :: ModuleEnv a -> [a]
moduleEnvElts (ModuleEnv e) = eltsFM e
moduleEnvToList :: ModuleEnv a -> [(Module, a)]
moduleEnvToList (ModuleEnv e) = fmToList e
unitModuleEnv :: Module -> a -> ModuleEnv a
unitModuleEnv m x = ModuleEnv (unitFM m x)
isEmptyModuleEnv :: ModuleEnv a -> Bool
isEmptyModuleEnv (ModuleEnv e) = isEmptyFM e
foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
foldModuleEnv f x (ModuleEnv e) = foldFM (\_ v -> f v) x e
\end{code}
\begin{code}
type ModuleSet = FiniteMap 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
\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}