module Module
(
ModuleName,
pprModuleName,
moduleNameFS,
moduleNameString,
moduleNameSlashes, moduleNameColons,
moduleStableString,
mkModuleName,
mkModuleNameFS,
stableModuleNameCmp,
UnitId,
fsToUnitId,
unitIdFS,
stringToUnitId,
unitIdString,
stableUnitIdCmp,
primUnitId,
integerUnitId,
baseUnitId,
rtsUnitId,
thUnitId,
dphSeqUnitId,
dphParUnitId,
mainUnitId,
thisGhcUnitId,
holeUnitId, isHoleModule,
interactiveUnitId, isInteractiveModule,
wiredInUnitIds,
Module(Module),
moduleUnitId, 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
moduleStableString :: Module -> String
moduleStableString Module{..} =
"$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName
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 {
moduleUnitId :: !UnitId,
moduleName :: !ModuleName
}
deriving (Eq, Ord, Typeable)
instance Uniquable Module where
getUnique (Module p n) = getUnique (unitIdFS 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 `stableUnitIdCmp` p2) `thenCmp`
(n1 `stableModuleNameCmp` n2)
mkModule :: UnitId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) =
pprPackagePrefix p mod <> pprModuleName n
pprPackagePrefix :: UnitId -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
| codeStyle sty =
if p == mainUnitId
then empty
else ztext (zEncodeFS (unitIdFS p)) <> char '_'
| qualModule sty mod = ppr (moduleUnitId mod) <> char ':'
| otherwise = empty
class ContainsModule t where
extractModule :: t -> Module
class HasModule m where
getModule :: m Module
newtype UnitId = PId FastString deriving( Eq, Typeable )
instance Uniquable UnitId where
getUnique pid = getUnique (unitIdFS pid)
instance Ord UnitId where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
instance Data UnitId where
toConstr _ = abstractConstr "UnitId"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "UnitId"
stableUnitIdCmp :: UnitId -> UnitId -> Ordering
stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2
instance Outputable UnitId where
ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
case unitIdPackageIdString dflags pk of
Nothing -> ftext (unitIdFS pk)
Just pkg -> text pkg
<> (if qualPackage sty pk && not (pk `elem` wiredInUnitIds)
then char '@' <> ftext (unitIdFS pk)
else empty)
instance Binary UnitId where
put_ bh pid = put_ bh (unitIdFS pid)
get bh = do { fs <- get bh; return (fsToUnitId fs) }
instance BinaryStringRep UnitId where
fromStringRep = fsToUnitId . mkFastStringByteString
toStringRep = fastStringToByteString . unitIdFS
fsToUnitId :: FastString -> UnitId
fsToUnitId = PId
unitIdFS :: UnitId -> FastString
unitIdFS (PId fs) = fs
stringToUnitId :: String -> UnitId
stringToUnitId = fsToUnitId . mkFastString
unitIdString :: UnitId -> String
unitIdString = unpackFS . unitIdFS
integerUnitId, primUnitId,
baseUnitId, rtsUnitId,
thUnitId, dphSeqUnitId, dphParUnitId,
mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
primUnitId = fsToUnitId (fsLit "ghc-prim")
integerUnitId = fsToUnitId (fsLit n)
where
n = case cIntegerLibraryType of
IntegerGMP -> "integer-gmp"
IntegerSimple -> "integer-simple"
baseUnitId = fsToUnitId (fsLit "base")
rtsUnitId = fsToUnitId (fsLit "rts")
thUnitId = fsToUnitId (fsLit "template-haskell")
dphSeqUnitId = fsToUnitId (fsLit "dph-seq")
dphParUnitId = fsToUnitId (fsLit "dph-par")
thisGhcUnitId = fsToUnitId (fsLit "ghc")
interactiveUnitId = fsToUnitId (fsLit "interactive")
mainUnitId = fsToUnitId (fsLit "main")
holeUnitId :: UnitId
holeUnitId = fsToUnitId (fsLit "hole")
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = moduleUnitId mod == interactiveUnitId
isHoleModule :: Module -> Bool
isHoleModule mod = moduleUnitId mod == holeUnitId
wiredInUnitIds :: [UnitId]
wiredInUnitIds = [ primUnitId,
integerUnitId,
baseUnitId,
rtsUnitId,
thUnitId,
thisGhcUnitId,
dphSeqUnitId,
dphParUnitId ]
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