basicTypes/Module.hs

    {-
    (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 Maps with Modules as
    the keys.
    -}

    {-# LANGUAGE DeriveDataTypeable #-}

    module Module
        (
            -- * The ModuleName type
            ModuleName,
            pprModuleName,
            moduleNameFS,
            moduleNameString,
            moduleNameSlashes, moduleNameColons,
            mkModuleName,
            mkModuleNameFS,
            stableModuleNameCmp,

            -- * The PackageKey type
            PackageKey,
            fsToPackageKey,
            packageKeyFS,
            stringToPackageKey,
            packageKeyString,
            stablePackageKeyCmp,

            -- * Wired-in PackageKeys
            -- $wired_in_packages
            primPackageKey,
            integerPackageKey,
            basePackageKey,
            rtsPackageKey,
            thPackageKey,
            dphSeqPackageKey,
            dphParPackageKey,
            mainPackageKey,
            thisGhcPackageKey,
            interactivePackageKey, isInteractiveModule,
            wiredInPackageKeys,

            -- * The Module type
            Module(Module),
            modulePackageKey, moduleName,
            pprModule,
            mkModule,
            stableModuleCmp,
            HasModule(..),
            ContainsModule(..),

            -- * 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,
            moduleEnvKeys, moduleEnvElts, moduleEnvToList,
            unitModuleEnv, isEmptyModuleEnv,
            foldModuleEnv, extendModuleEnvWith, filterModuleEnv,

            -- * ModuleName mappings
            ModuleNameEnv,

            -- * Sets of Modules
            ModuleSet,
            emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
        ) where

    import Config
    import Outputable
    import Unique
    import UniqFM
    import FastString
    import Binary
    import Util
    import {-# SOURCE #-} 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

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Module locations}
    *                                                                      *
    ************************************************************************
    -}

    -- | 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,
                    -- The source file, if we have one.  Package modules
                    -- probably don't have source files.

            ml_hi_file   :: FilePath,
                    -- Where the .hi file is, whether or not it exists
                    -- yet.  Always of form foo.hi, even if there is an
                    -- hi-boot file (we add the -boot suffix later)

            ml_obj_file  :: FilePath
                    -- Where the .o file is, whether or not it exists yet.
                    -- (might not exist either because the module hasn't
                    -- been compiled yet, or because it is part of a
                    -- package with a .a file)
      } deriving Show

    instance Outputable ModLocation where
       ppr = text . show

    {-
    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.
    -}

    addBootSuffix :: FilePath -> FilePath
    -- ^ 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)
             , ml_obj_file = addBootSuffix (ml_obj_file locn) }

    {-
    ************************************************************************
    *                                                                      *
    \subsection{The name of a module}
    *                                                                      *
    ************************************************************************
    -}

    -- | 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

    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 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
      -- 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 ->
        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

    -- |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)

    -- |Returns the string version of the module name, with dots replaced by underscores.
    --
    moduleNameColons :: ModuleName -> String
    moduleNameColons = dots_to_colons . moduleNameString
      where dots_to_colons = map (\c -> if c == '.' then ':' else c)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{A fully qualified module}
    *                                                                      *
    ************************************************************************
    -}

    -- | A Module is a pair of a 'PackageKey' and a 'ModuleName'.
    data Module = Module {
       modulePackageKey :: !PackageKey,  -- pkg-1.0
       moduleName      :: !ModuleName  -- A.B.C
      }
      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
      -- 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 `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 -- never qualify the main package in code
                    else ztext (zEncodeFS (packageKeyFS p)) <> char '_'
           | qualModule sty mod = ppr (modulePackageKey mod) <> char ':'
                    -- the PrintUnqualified tells us which modules have to
                    -- be qualified with package names
           | otherwise = empty

    class ContainsModule t where
        extractModule :: t -> Module

    class HasModule m where
        getModule :: m Module

    {-
    ************************************************************************
    *                                                                      *
    \subsection{PackageKey}
    *                                                                      *
    ************************************************************************
    -}

    -- | A string which uniquely identifies a package.  For wired-in packages,
    -- it is just the package name, but for user compiled packages, it is a hash.
    -- ToDo: when the key is a hash, we can do more clever things than store
    -- the hex representation and hash-cons those strings.
    newtype PackageKey = PId FastString deriving( Eq, Typeable )
        -- here to avoid module loops with PackageConfig

    instance Uniquable PackageKey where
     getUnique pid = getUnique (packageKeyFS pid)

    -- Note: *not* a stable lexicographic ordering, a faster unique-based
    -- ordering.
    instance Ord PackageKey where
      nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2

    instance Data PackageKey where
      -- don't traverse?
      toConstr _   = abstractConstr "PackageKey"
      gunfold _ _  = error "gunfold"
      dataTypeOf _ = mkNoRepType "PackageKey"

    stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
    -- ^ Compares package ids lexically, rather than by their 'Unique's
    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
               -- Don't bother qualifying if it's wired in!
               <> (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

    -- -----------------------------------------------------------------------------
    -- $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 'PackageKey' 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

    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")

    -- | 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.
    mainPackageKey      = fsToPackageKey (fsLit "main")

    isInteractiveModule :: Module -> Bool
    isInteractiveModule mod = modulePackageKey mod == interactivePackageKey

    wiredInPackageKeys :: [PackageKey]
    wiredInPackageKeys = [ primPackageKey,
                           integerPackageKey,
                           basePackageKey,
                           rtsPackageKey,
                           thPackageKey,
                           thisGhcPackageKey,
                           dphSeqPackageKey,
                           dphParPackageKey ]

    {-
    ************************************************************************
    *                                                                      *
    \subsection{@ModuleEnv@s}
    *                                                                      *
    ************************************************************************
    -}

    -- | 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
    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

    -- | 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    = Map.empty
    mkModuleSet ms    = Map.fromList [(m,()) | m <- ms ]
    extendModuleSet s m = Map.insert m () s
    moduleSetElts     = Map.keys
    elemModuleSet     = Map.member

    {-
    A ModuleName has a Unique, so we can build mappings of these using
    UniqFM.
    -}

    -- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
    type ModuleNameEnv elt = UniqFM elt