module Module
(
ModuleName,
pprModuleName,
moduleNameFS,
moduleNameString,
moduleNameSlashes, moduleNameColons,
mkModuleName,
mkModuleNameFS,
stableModuleNameCmp,
PackageKey,
fsToPackageKey,
packageKeyFS,
stringToPackageKey,
packageKeyString,
stablePackageKeyCmp,
primPackageKey,
integerPackageKey,
basePackageKey,
rtsPackageKey,
thPackageKey,
dphSeqPackageKey,
dphParPackageKey,
mainPackageKey,
thisGhcPackageKey,
interactivePackageKey, isInteractiveModule,
wiredInPackageKeys,
Module(Module),
modulePackageKey, moduleName,
pprModule,
mkModule,
stableModuleCmp,
HasModule(..),
ContainsModule(..),
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, extendModuleEnvWith, filterModuleEnv,
ModuleNameEnv,
ModuleSet,
emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
) where
import Config
import Outputable
import Unique
import UniqFM
import FastString
import Binary
import Util
import Packages
import GHC.PackageDb (BinaryStringRep(..))
import Data.Data
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
import System.FilePath
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
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) }
newtype ModuleName = ModuleName FastString
deriving Typeable
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)
instance BinaryStringRep ModuleName where
fromStringRep = mkModuleNameFS . mkFastStringByteString
toStringRep = fastStringToByteString . moduleNameFS
instance Data ModuleName where
toConstr _ = abstractConstr "ModuleName"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "ModuleName"
stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
getPprStyle $ \ sty ->
if codeStyle sty
then ztext (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)
moduleNameColons :: ModuleName -> String
moduleNameColons = dots_to_colons . moduleNameString
where dots_to_colons = map (\c -> if c == '.' then ':' else c)
data Module = Module {
modulePackageKey :: !PackageKey,
moduleName :: !ModuleName
}
deriving (Eq, Ord, Typeable)
instance Uniquable Module where
getUnique (Module p n) = getUnique (packageKeyFS 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)
instance Data Module where
toConstr _ = abstractConstr "Module"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Module"
stableModuleCmp :: Module -> Module -> Ordering
stableModuleCmp (Module p1 n1) (Module p2 n2)
= (p1 `stablePackageKeyCmp` p2) `thenCmp`
(n1 `stableModuleNameCmp` n2)
mkModule :: PackageKey -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) =
pprPackagePrefix p mod <> pprModuleName n
pprPackagePrefix :: PackageKey -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
| codeStyle sty =
if p == mainPackageKey
then empty
else ztext (zEncodeFS (packageKeyFS p)) <> char '_'
| qualModule sty mod = ppr (modulePackageKey mod) <> char ':'
| otherwise = empty
class ContainsModule t where
extractModule :: t -> Module
class HasModule m where
getModule :: m Module
newtype PackageKey = PId FastString deriving( Eq, Typeable )
instance Uniquable PackageKey where
getUnique pid = getUnique (packageKeyFS pid)
instance Ord PackageKey where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
instance Data PackageKey where
toConstr _ = abstractConstr "PackageKey"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "PackageKey"
stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2
instance Outputable PackageKey where
ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
case packageKeyPackageIdString dflags pk of
Nothing -> ftext (packageKeyFS pk)
Just pkg -> text pkg
<> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys)
then char '@' <> ftext (packageKeyFS pk)
else empty)
instance Binary PackageKey where
put_ bh pid = put_ bh (packageKeyFS pid)
get bh = do { fs <- get bh; return (fsToPackageKey fs) }
instance BinaryStringRep PackageKey where
fromStringRep = fsToPackageKey . mkFastStringByteString
toStringRep = fastStringToByteString . packageKeyFS
fsToPackageKey :: FastString -> PackageKey
fsToPackageKey = PId
packageKeyFS :: PackageKey -> FastString
packageKeyFS (PId fs) = fs
stringToPackageKey :: String -> PackageKey
stringToPackageKey = fsToPackageKey . mkFastString
packageKeyString :: PackageKey -> String
packageKeyString = unpackFS . packageKeyFS
integerPackageKey, primPackageKey,
basePackageKey, rtsPackageKey,
thPackageKey, dphSeqPackageKey, dphParPackageKey,
mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey
primPackageKey = fsToPackageKey (fsLit "ghc-prim")
integerPackageKey = fsToPackageKey (fsLit n)
where
n = case cIntegerLibraryType of
IntegerGMP -> "integer-gmp"
IntegerGMP2 -> "integer-gmp"
IntegerSimple -> "integer-simple"
basePackageKey = fsToPackageKey (fsLit "base")
rtsPackageKey = fsToPackageKey (fsLit "rts")
thPackageKey = fsToPackageKey (fsLit "template-haskell")
dphSeqPackageKey = fsToPackageKey (fsLit "dph-seq")
dphParPackageKey = fsToPackageKey (fsLit "dph-par")
thisGhcPackageKey = fsToPackageKey (fsLit "ghc")
interactivePackageKey = fsToPackageKey (fsLit "interactive")
mainPackageKey = fsToPackageKey (fsLit "main")
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = modulePackageKey mod == interactivePackageKey
wiredInPackageKeys :: [PackageKey]
wiredInPackageKeys = [ primPackageKey,
integerPackageKey,
basePackageKey,
rtsPackageKey,
thPackageKey,
thisGhcPackageKey,
dphSeqPackageKey,
dphParPackageKey ]
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
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
type ModuleSet = Map Module ()
mkModuleSet :: [Module] -> ModuleSet
extendModuleSet :: ModuleSet -> Module -> ModuleSet
emptyModuleSet :: ModuleSet
moduleSetElts :: ModuleSet -> [Module]
elemModuleSet :: Module -> ModuleSet -> Bool
emptyModuleSet = Map.empty
mkModuleSet ms = Map.fromList [(m,()) | m <- ms ]
extendModuleSet s m = Map.insert m () s
moduleSetElts = Map.keys
elemModuleSet = Map.member
type ModuleNameEnv elt = UniqFM elt