-- (c) The University of Glasgow, 2006

{-# LANGUAGE CPP, ScopedTypeVariables #-}

-- | Package manipulation
module Packages (
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
        PackageState(preloadPackages),
        initPackages,
        readPackageConfigs,
        getPackageConfRefs,
        resolvePackageConfig,
        readPackageConfig,

        -- * Querying the package config
        lookupPackage,
        resolveInstalledPackageId,
        searchPackageId,
        getPackageDetails,
        listVisibleModuleNames,
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
        LookupResult(..),
        ModuleSuggestion(..),
        ModuleOrigin(..),

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
        getPreloadPackagesAnd,

        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
        packageHsLibs,

        -- * Utils
        packageKeyPackageIdString,
        pprFlag,
        pprPackages,
        pprPackagesSimple,
        pprModuleMap,
        isDllName
    )
where

#include "HsVersions.h"

import GHC.PackageDb
import PackageConfig
import DynFlags
import Name             ( Name, nameModule_maybe )
import UniqFM
import Module
import Util
import Panic
import Outputable
import Maybes

import System.Environment ( getEnv )
import FastString
import ErrUtils         ( debugTraceMsg, MsgDoc )
import Exception
import Unique

import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.Char ( toUpper )
import Data.List as List
import Data.Map (Map)
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid hiding ((<>))
#endif
import qualified Data.Map as Map
import qualified FiniteMap as Map
import qualified Data.Set as Set

-- ---------------------------------------------------------------------------
-- The Package state

-- | Package state is all stored in 'DynFlags', including the details of
-- all packages, which packages are exposed, and which modules they
-- provide.
--
-- The package state is computed by 'initPackages', and kept in DynFlags.
-- It is influenced by various package flags:
--
--   * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
--     If @-hide-all-packages@ was not specified, these commands also cause
--      all other packages with the same name to become hidden.
--
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
--
--   * (there are a few more flags, check below for their semantics)
--
-- The package state has the following properties.
--
--   * Let @exposedPackages@ be the set of packages thus exposed.
--     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
--     their dependencies.
--
--   * When searching for a module from an preload import declaration,
--     only the exposed modules in @exposedPackages@ are valid.
--
--   * When searching for a module from an implicit import, all modules
--     from @depExposedPackages@ are valid.
--
--   * When linking in a compilation manager mode, we link in packages the
--     program depends on (the compiler knows this list by the
--     time it gets to the link step).  Also, we link in all packages
--     which were mentioned with preload @-package@ flags on the command-line,
--     or are a transitive dependency of same, or are \"base\"\/\"rts\".
--     The reason for this is that we might need packages which don't
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
-- When compiling module A, which imports module B, we need to
-- know whether B will be in the same DLL as A.
--      If it's in the same DLL, we refer to B_f_closure
--      If it isn't, we refer to _imp__B_f_closure
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

-- | Given a module name, there may be multiple ways it came into scope,
-- possibly simultaneously.  This data type tracks all the possible ways
-- it could have come into scope.  Warning: don't use the record functions,
-- they're partial!
data ModuleOrigin =
    -- | Module is hidden, and thus never will be available for import.
    -- (But maybe the user didn't realize), so we'll still keep track
    -- of these modules.)
    ModHidden
    -- | Module is public, and could have come from some places.
  | ModOrigin {
        -- | @Just False@ means that this module is in
        -- someone's @exported-modules@ list, but that package is hidden;
        -- @Just True@ means that it is available; @Nothing@ means neither
        -- applies.
        fromOrigPackage :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
      , fromExposedReexport :: [PackageConfig]
        -- | Is the module available from a reexport of a hidden package?
      , fromHiddenReexport :: [PackageConfig]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
    ppr ModHidden = text "hidden module"
    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
        (case e of
            Nothing -> []
            Just False -> [text "hidden package"]
            Just True -> [text "exposed package"]) ++
        (if null res
            then []
            else [text "reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if f then [text "package flag"] else [])
        ))

-- | Smart constructor for a module which is in @exposed-modules@.  Takes
-- as an argument whether or not the defining package is exposed.
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules e = ModOrigin (Just e) [] [] False

-- | Smart constructor for a module which is in @reexported-modules@.  Takes
-- as an argument whether or not the reexporting package is expsed, and
-- also its 'PackageConfig'.
fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False

-- | Smart constructor for a module which was bound by a package flag.
fromFlag :: ModuleOrigin
fromFlag = ModOrigin Nothing [] [] True

instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
    mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    mappend _ _ = panic "ModOrigin: hidden module redefined"

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f

-- | Are there actually no providers for this module?  This will never occur
-- except when we're filtering based on package imports.
originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False

-- | 'UniqFM' map from 'PackageKey'
type PackageKeyMap = UniqFM

-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
type PackageConfigMap = PackageKeyMap PackageConfig

-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
-- are exposed should be dumped into scope, (2) any custom renamings that
-- should also be apply, and (3) what package name is associated with the
-- key, if it might be hidden
type VisibilityMap =
    PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)

-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
-- (since this is the slow path, we'll just look it up again).
type ModuleToPkgConfAll =
    Map ModuleName (Map Module ModuleOrigin)

data PackageState = PackageState {
  -- | A mapping of 'PackageKey' to 'PackageConfig'.  This list is adjusted
  -- so that only valid packages are here.  Currently, we also flip the
  -- exposed/trusted bits based on package flags; however, the hope is to
  -- stop doing that.
  pkgIdMap              :: PackageConfigMap,

  -- | The packages we're going to link in eagerly.  This list
  -- should be in reverse dependency order; that is, a package
  -- is always mentioned before the packages it depends on.
  preloadPackages      :: [PackageKey],

  -- | This is a full map from 'ModuleName' to all modules which may possibly
  -- be providing it.  These providers may be hidden (but we'll still want
  -- to report them in error messages), or it may be an ambiguous import.
  moduleToPkgConfAll    :: ModuleToPkgConfAll,

  -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
  -- internally deals in package keys but the database may refer to installed
  -- package IDs.
  installedPackageIdMap :: InstalledPackageIdMap
  }

type InstalledPackageIdMap = Map InstalledPackageId PackageKey
type InstalledPackageIndex = Map InstalledPackageId PackageConfig

-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM

-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))

lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
lookupPackage' = lookupUFM

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
                               (listPackageConfigMap dflags)

-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap pkg_map new_pkgs
  = foldl add pkg_map new_pkgs
  where add pkg_map p = addToUFM pkg_map (packageConfigId p) p

-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

-- | Get a list of entries from the package database.  NB: be careful with
-- this function, it may not do what you expect it to.
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))

-- | Looks up a 'PackageKey' given an 'InstalledPackageId'
resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
resolveInstalledPackageId dflags ipid =
    expectJust "resolveInstalledPackageId"
        (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))

-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state

-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
-- database files, and sets up various internal tables of package
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
--
-- Returns a list of packages to link in if we're doing dynamic linking.
-- This list contains the packages that the user explicitly mentioned with
-- @-package@ flags.
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'pkgState' in 'DynFlags' and return a list of packages to
-- link in.
initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
initPackages dflags = do
  pkg_db <- case pkgDatabase dflags of
                Nothing -> readPackageConfigs dflags
                Just db -> return $ setBatchPackageFlags dflags db
  (pkg_state, preload, this_pkg)
        <- mkPackageState dflags pkg_db [] (thisPackage dflags)
  return (dflags{ pkgDatabase = Just pkg_db,
                  pkgState = pkg_state,
                  thisPackage = this_pkg },
          preload)

-- -----------------------------------------------------------------------------
-- Reading the package database(s)

readPackageConfigs :: DynFlags -> IO [PackageConfig]
readPackageConfigs dflags = do
  conf_refs <- getPackageConfRefs dflags
  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
  liftM concat $ mapM (readPackageConfig dflags) confs

getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
getPackageConfRefs dflags = do
  let system_conf_refs = [UserPkgConf, GlobalPkgConf]

  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
         | not (null path) && isSearchPathSeparator (last path)
         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
         | otherwise
         -> map PkgConfFile (splitSearchPath path)

  return $ reverse (extraPkgConfs dflags base_conf_refs)
  -- later packages shadow earlier ones.  extraPkgConfs
  -- is in the opposite order to the flags on the
  -- command line.

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
  dir <- versionedAppDir dflags
  let pkgconf = dir </> "package.conf.d"
  exist <- doesDirectoryExist pkgconf
  return $ if exist then Just pkgconf else Nothing
resolvePackageConfig _ (PkgConfFile name) = return $ Just name

readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
  isdir <- doesDirectoryExist conf_file

  proto_pkg_configs <-
    if isdir
       then do let filename = conf_file </> "package.cache"
               debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
               readPackageDbForGhc filename
       else do
            isfile <- doesFileExist conf_file
            if isfile
               then throwGhcExceptionIO $ InstallationError $
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file

  let
      top_dir = topDir dflags
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
  --
  return pkg_configs2

setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
  where
    maybeDistrustAll pkgs'
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
      | otherwise                           = pkgs'

    distrust pkg = pkg{ trusted = False }

-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
    pkg {
      importDirs  = munge_paths (importDirs pkg),
      includeDirs = munge_paths (includeDirs pkg),
      libraryDirs = munge_paths (libraryDirs pkg),
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
  where
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p

    munge_url p
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
                 ++ FilePath.Posix.joinPath
                        (r : -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             dropWhile (all isPathSeparator)
                                       (FilePath.splitDirectories p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix var path = case stripPrefix var path of
                              Just [] -> Just []
                              Just cs@(c : _) | isPathSeparator c -> Just cs
                              _ -> Nothing


-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).

applyPackageFlag
   :: DynFlags
   -> UnusablePackages
   -> ([PackageConfig], VisibilityMap)           -- Initial database
   -> PackageFlag               -- flag to apply
   -> IO ([PackageConfig], VisibilityMap)        -- new database

-- ToDo: Unfortunately, we still have to plumb the package config through,
-- because Safe Haskell trust is still implemented by modifying the database.
-- Eventually, track that separately and then axe @[PackageConfig]@ from
-- this fold entirely

applyPackageFlag dflags unusable (pkgs, vm) flag =
  case flag of
    ExposePackage arg (ModRenaming b rns) ->
       case selectPackages (matching arg) pkgs unusable of
         Left ps         -> packageFlagErr dflags flag ps
         Right (p:_,_) -> return (pkgs, vm')
          where
           n = fsPackageName p
           vm' = addToUFM_C edit vm_cleared (packageConfigId p)
                            (b, map convRn rns, n)
           edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
           convRn (a,b) = (mkModuleName a, mkModuleName b)
           -- ToDo: ATM, -hide-all-packages implicitly triggers change in
           -- behavior, maybe eventually make it toggleable with a separate
           -- flag
           vm_cleared | gopt Opt_HideAllPackages dflags = vm
                      | otherwise = filterUFM_Directly
                            (\k (_,_,n') -> k == getUnique (packageConfigId p)
                                                || n /= n') vm
         _ -> panic "applyPackageFlag"

    HidePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr dflags flag ps
         Right (ps,_) -> return (pkgs, vm')
          where vm' = delListFromUFM vm (map packageConfigId ps)

    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs, vm)
          where trust p = p {trusted=True}

    DistrustPackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs, vm)
          where distrust p = p {trusted=False}

    IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"

selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
  = let (ps,rest) = partition matches pkgs
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
        else Right (sortByVersion ps, rest)

-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
        =  str == sourcePackageIdString p
        || str == packageNameString p

matchingId :: String -> PackageConfig -> Bool
matchingId str p =  str == installedPackageIdString p

matchingKey :: String -> PackageConfig -> Bool
matchingKey str p = str == packageKeyString (packageConfigId p)

matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (PackageIdArg str) = matchingId str
matching (PackageKeyArg str) = matchingKey str

sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing f a b = f a `compare` f b

packageFlagErr :: DynFlags
               -> PackageFlag
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
  | is_dph_package pkg
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
  where dph_err = text "the " <> text pkg <> text " package is not installed."
                  $$ text "To install it: \"cabal install dph\"."
        is_dph_package pkg = "dph" `isPrefixOf` pkg

packageFlagErr dflags flag reasons
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
  where err = text "cannot satisfy " <> pprFlag flag <>
                (if null reasons then Outputable.empty else text ": ") $$
              nest 4 (ppr_reasons $$
                      -- ToDo: this admonition seems a bit dodgy
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
        ppr_reason (p, reason) =
            pprReason (ppr (installedPackageId p) <+> text "is") reason

pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    IgnorePackage p -> text "-ignore-package " <> text p
    HidePackage p   -> text "-hide-package " <> text p
    ExposePackage a rns -> ppr_arg a <> ppr_rns rns
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p
  where ppr_arg arg = case arg of
                     PackageArg    p -> text "-package " <> text p
                     PackageIdArg  p -> text "-package-id " <> text p
                     PackageKeyArg p -> text "-package-key " <> text p
        ppr_rns (ModRenaming True []) = Outputable.empty
        ppr_rns (ModRenaming b rns) =
            if b then text "with" else Outputable.empty <+>
            char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')'
        ppr_rn (orig, new) | orig == new = text orig
                           | otherwise = text orig <+> text "as" <+> text new

-- -----------------------------------------------------------------------------
-- Wired-in packages

wired_in_pkgids :: [String]
wired_in_pkgids = map packageKeyString wiredInPackageKeys

findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
   -> VisibilityMap             -- info on what packages are visible
   -> IO ([PackageConfig], VisibilityMap)

findWiredInPackages dflags pkgs vis_map = do
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
        matches :: PackageConfig -> String -> Bool
        pc `matches` pid = packageNameString pc == pid

        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
        -- update the package and any dependencies to point to the new
        -- one.
        --
        -- When choosing which package to map to a wired-in package
        -- name, we try to pick the latest version of exposed packages.
        -- However, if there are no exposed wired in packages available
        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
        -- to assign a package for the wired-in package: so we try again
        -- with hidden packages included to (and pick the latest
        -- version).
        --
        -- You can also override the default choice by using -ignore-package:
        -- this works even when there is no exposed wired in package
        -- available.
        --
        findWiredInPackage :: [PackageConfig] -> String
                           -> IO (Maybe PackageConfig)
        findWiredInPackage pkgs wired_pkg =
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
               all_exposed_ps =
                    [ p | p <- all_ps
                        , elemUFM (packageConfigId p) vis_map ] in
           case all_exposed_ps of
            [] -> case all_ps of
                       []   -> notfound
                       many -> pick (head (sortByVersion many))
            many -> pick (head (sortByVersion many))
          where
                notfound = do
                          debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " not found.")
                          return Nothing
                pick :: PackageConfig
                     -> IO (Maybe PackageConfig)
                pick pkg = do
                        debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " mapped to ")
                                 <> ppr (installedPackageId pkg)
                        return (Just pkg)


  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
  let
        wired_in_pkgs = catMaybes mb_wired_in_pkgs
        wired_in_ids = map installedPackageId wired_in_pkgs

        -- this is old: we used to assume that if there were
        -- multiple versions of wired-in packages installed that
        -- they were mutually exclusive.  Now we're assuming that
        -- you have one "main" version of each wired-in package
        -- (the latest version), and the others are backward-compat
        -- wrappers that depend on this one.  e.g. base-4.0 is the
        -- latest, base-3.0 is a compat wrapper depending on base-4.0.
        {-
        deleteOtherWiredInPackages pkgs = filterOut bad pkgs
          where bad p = any (p `matches`) wired_in_pkgids
                      && package p `notElem` map fst wired_in_ids
        -}

        updateWiredInDependencies pkgs = map upd_pkg pkgs
          where upd_pkg pkg
                  | installedPackageId pkg `elem` wired_in_ids
                  = pkg {
                      packageKey = stringToPackageKey (packageNameString pkg)
                    }
                  | otherwise
                  = pkg

        updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
          where f vm p = case lookupUFM vis_map (packageConfigId p) of
                            Nothing -> vm
                            Just r -> addToUFM vm (stringToPackageKey
                                                    (packageNameString p)) r


  return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map)

-- ----------------------------------------------------------------------------

data UnusablePackageReason
  = IgnoredWithFlag
  | MissingDependencies [InstalledPackageId]
  | ShadowedBy InstalledPackageId

type UnusablePackages = Map InstalledPackageId
                            (PackageConfig, UnusablePackageReason)

pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
  IgnoredWithFlag ->
      pref <+> ptext (sLit "ignored due to an -ignore-package flag")
  MissingDependencies deps ->
      pref <+>
      ptext (sLit "unusable due to missing or recursive dependencies:") $$
        nest 2 (hsep (map ppr deps))
  ShadowedBy ipid ->
      pref <+> ptext (sLit "shadowed by package ") <> ppr ipid

reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
  where
    report (ipid, (_, reason)) =
       debugTraceMsg dflags 2 $
         pprReason
           (ptext (sLit "package") <+>
            ppr ipid <+> text "is") reason

-- ----------------------------------------------------------------------------
--
-- Detect any packages that have missing dependencies, and also any
-- mutually-recursive groups of packages (loops in the package graph
-- are not allowed).  We do this by taking the least fixpoint of the
-- dependency graph, repeatedly adding packages whose dependencies are
-- satisfied until no more can be added.
--
findBroken :: [PackageConfig] -> UnusablePackages
findBroken pkgs = go [] Map.empty pkgs
 where
   go avail ipids not_avail =
     case partitionWith (depsAvailable ipids) not_avail of
        ([], not_avail) ->
            Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
                         | (p,deps) <- not_avail ]
        (new_avail, not_avail) ->
            go (new_avail ++ avail) new_ipids (map fst not_avail)
            where new_ipids = Map.insertList
                                [ (installedPackageId p, p) | p <- new_avail ]
                                ipids

   depsAvailable :: InstalledPackageIndex
                 -> PackageConfig
                 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
   depsAvailable ipids pkg
        | null dangling = Left pkg
        | otherwise     = Right (pkg, dangling)
        where dangling = filter (not . (`Map.member` ipids)) (depends pkg)

-- -----------------------------------------------------------------------------
-- Eliminate shadowed packages, giving the user some feedback

-- later packages in the list should shadow earlier ones with the same
-- package name/version.  Additionally, a package may be preferred if
-- it is in the transitive closure of packages selected using -package-id
-- flags.
type UnusablePackage = (PackageConfig, UnusablePackageReason)
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred
 = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
   in  Map.fromList shadowed
 where
 check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
       -> PackageConfig
       -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
 check (shadowed,pkgmap) pkg
      | Just oldpkg <- lookupUFM pkgmap pkgid
      , let
            ipid_new = installedPackageId pkg
            ipid_old = installedPackageId oldpkg
        --
      , ipid_old /= ipid_new
      = if ipid_old `elem` preferred
           then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
           else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
      | otherwise
      = (shadowed, pkgmap')
      where
        pkgid = packageKeyFS (packageKey pkg)
        pkgmap' = addToUFM pkgmap pkgid pkg

-- -----------------------------------------------------------------------------

ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
  where
  doit (IgnorePackage str) =
     case partition (matchingStr str) pkgs of
         (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
                    | p <- ps ]
        -- missing package is not an error for -ignore-package,
        -- because a common usage is to -ignore-package P as
        -- a preventative measure just in case P exists.
  doit _ = panic "ignorePackages"

-- -----------------------------------------------------------------------------

depClosure :: InstalledPackageIndex
           -> [InstalledPackageId]
           -> [InstalledPackageId]
depClosure index ipids = closure Map.empty ipids
  where
   closure set [] = Map.keys set
   closure set (ipid : ipids)
     | ipid `Map.member` set = closure set ipids
     | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
                                                 (depends p ++ ipids)
     | otherwise = closure set ipids

-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.

mkPackageState
    :: DynFlags
    -> [PackageConfig]          -- initial database
    -> [PackageKey]              -- preloaded packages
    -> PackageKey                -- this package
    -> IO (PackageState,
           [PackageKey],         -- new packages to preload
           PackageKey) -- this package, might be modified if the current
                      -- package is a wired-in package.

mkPackageState dflags0 pkgs0 preload0 this_package = do
  dflags <- interpretPackageEnv dflags0

{-
   Plan.

   1. P = transitive closure of packages selected by -package-id

   2. Apply shadowing.  When there are multiple packages with the same
      packageKey,
        * if one is in P, use that one
        * otherwise, use the one highest in the package stack
      [
       rationale: we cannot use two packages with the same packageKey
       in the same program, because packageKey is the symbol prefix.
       Hence we must select a consistent set of packages to use.  We have
       a default algorithm for doing this: packages higher in the stack
       shadow those lower down.  This default algorithm can be overriden
       by giving explicit -package-id flags; then we have to take these
       preferences into account when selecting which other packages are
       made available.

       Our simple algorithm throws away some solutions: there may be other
       consistent sets that would satisfy the -package flags, but it's
       not GHC's job to be doing constraint solving.
      ]

   3. remove packages selected by -ignore-package

   4. remove any packages with missing dependencies, or mutually recursive
      dependencies.

   5. report (with -v) any packages that were removed by steps 2-4

   6. apply flags to set exposed/hidden on the resulting packages
      - if any flag refers to a package which was removed by 2-4, then
        we can give an error message explaining why

   7. hide any packages which are superseded by later exposed packages
-}

  let
      flags = reverse (packageFlags dflags)

      -- pkgs0 with duplicate packages filtered out.  This is
      -- important: it is possible for a package in the global package
      -- DB to have the same IPID as a package in the user DB, and
      -- we want the latter to take precedence.  This is not the same
      -- as shadowing (below), since in this case the two packages
      -- have the same ABI and are interchangeable.
      --
      -- #4072: note that we must retain the ordering of the list here
      -- so that shadowing behaves as expected when we apply it later.
      pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
          where del p (s,ps)
                  | pid `Set.member` s = (s,ps)
                  | otherwise          = (Set.insert pid s, p:ps)
                  where pid = installedPackageId p
          -- XXX this is just a variant of nub

      ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]

      ipid_selected = depClosure ipid_map
                                 [ InstalledPackageId (mkFastString i)
                                 | ExposePackage (PackageIdArg i) _ <- flags ]

      (ignore_flags, other_flags) = partition is_ignore flags
      is_ignore IgnorePackage{} = True
      is_ignore _ = False

      shadowed = shadowPackages pkgs0_unique ipid_selected
      ignored  = ignorePackages ignore_flags pkgs0_unique

      isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
      pkgs0' = filter (not . isBroken) pkgs0_unique

      broken   = findBroken pkgs0'

      unusable = shadowed `Map.union` ignored `Map.union` broken
      pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'

  reportUnusable dflags unusable

  --
  -- Calculate the initial set of packages, prior to any package flags.
  -- This set contains the latest version of all valid (not unusable) packages,
  -- or is empty if we have -hide-all-packages
  --
  let preferLater pkg pkg' =
        case comparing packageVersion pkg pkg' of
            GT -> pkg
            _  -> pkg'
      calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
      initial = if gopt Opt_HideAllPackages dflags
                    then emptyUFM
                    else foldl' calcInitial emptyUFM pkgs1
      vis_map1 = foldUFM (\p vm ->
                            if exposed p
                               then addToUFM vm (packageConfigId p)
                                             (True, [], fsPackageName p)
                               else vm)
                         emptyUFM initial

  --
  -- Modify the package database according to the command-line flags
  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
  -- This needs to know about the unusable packages, since if a user tries
  -- to enable an unusable package, we should let them know.
  --
  (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
                            (pkgs1, vis_map1) other_flags

  --
  -- Sort out which packages are wired in. This has to be done last, since
  -- it modifies the package keys of wired in packages, but when we process
  -- package arguments we need to key against the old versions.  We also
  -- have to update the visibility map in the process.
  --
  (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2

  --
  -- Here we build up a set of the packages mentioned in -package
  -- flags on the command line; these are called the "preload"
  -- packages.  we link these packages in eagerly.  The preload set
  -- should contain at least rts & base, which is why we pretend that
  -- the command line contains -package rts & -package base.
  --
  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]

      get_exposed (ExposePackage a _) = take 1 . sortByVersion
                                      . filter (matching a)
                                      $ pkgs2
      get_exposed _                 = []

  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3

      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
                              | p <- pkgs3 ]

      lookupIPID ipid
         | Just pid <- Map.lookup ipid ipid_map = return pid
         | otherwise                            = missingPackageErr dflags ipid

  preload2 <- mapM lookupIPID preload1

  let
      -- add base & rts to the preload packages
      basicLinkedPackages
       | gopt Opt_AutoLinkPackages dflags
          = filter (flip elemUFM pkg_db)
                [basePackageKey, rtsPackageKey]
       | otherwise = []
      -- but in any case remove the current package from the set of
      -- preloaded packages so that base/rts does not end up in the
      -- set up preloaded package when we are just building it
      preload3 = nub $ filter (/= this_package)
                     $ (basicLinkedPackages ++ preload2)

  -- Close the preload packages with their dependencies
  dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
  let new_dep_preload = filter (`notElem` preload0) dep_preload

  let pstate = PackageState{
    preloadPackages     = dep_preload,
    pkgIdMap            = pkg_db,
    moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
    installedPackageIdMap = ipid_map
    }
  return (pstate, new_dep_preload, this_package)


-- -----------------------------------------------------------------------------
-- | Makes the mapping from module to package info

mkModuleToPkgConfAll
  :: DynFlags
  -> PackageConfigMap
  -> InstalledPackageIdMap
  -> VisibilityMap
  -> ModuleToPkgConfAll
mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
    foldl' extend_modmap emptyMap (eltsUFM pkg_db)
 where
  emptyMap = Map.empty
  sing pk m _ = Map.singleton (mkModule pk m)
  addListTo = foldl' merge
  merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
  setOrigins m os = fmap (const os) m
  extend_modmap modmap pkg = addListTo modmap theBindings
   where
    theBindings :: [(ModuleName, Map Module ModuleOrigin)]
    theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
                              = newBindings b rns
                | otherwise   = newBindings False []

    newBindings :: Bool
                -> [(ModuleName, ModuleName)]
                -> [(ModuleName, Map Module ModuleOrigin)]
    newBindings e rns  = es e ++ hiddens ++ map rnBinding rns

    rnBinding :: (ModuleName, ModuleName)
              -> (ModuleName, Map Module ModuleOrigin)
    rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
     where origEntry = case lookupUFM esmap orig of
            Just r -> r
            Nothing -> throwGhcException (CmdLineError (showSDoc dflags
                        (text "package flag: could not find module name" <+>
                            ppr orig <+> text "in package" <+> ppr pk)))

    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
    es e = do
     -- TODO: signature support
     ExposedModule m exposedReexport _exposedSignature <- exposed_mods
     let (pk', m', pkg', origin') =
          case exposedReexport of
           Nothing -> (pk, m, pkg, fromExposedModules e)
           Just (OriginalModule ipid' m') ->
            let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
                pkg' = pkg_lookup pk'
            in (pk', m', pkg', fromReexportedModules e pkg')
     return (m, sing pk' m' pkg' origin')

    esmap :: UniqFM (Map Module ModuleOrigin)
    esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
                                 -- be overwritten

    hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]

    pk = packageConfigId pkg
    pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db

    exposed_mods = exposedModules pkg
    hidden_mods = hiddenModules pkg

-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope

-- Many of these functions take a list of packages: in those cases,
-- the list is expected to contain the "dependent packages",
-- i.e. those packages that were found to be depended on by the
-- current module/program.  These can be auto or non-auto packages, it
-- doesn't really matter.  The list is always combined with the list
-- of preload (command-line) packages to determine which packages to
-- use.

-- | Find all the include directories in these and the preload packages
getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String]
getPackageIncludePath dflags pkgs =
  collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs

collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))

-- | Find all the library paths in these and the preload packages
getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String]
getPackageLibraryPath dflags pkgs =
  collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs

collectLibraryPaths :: [PackageConfig] -> [FilePath]
collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))

-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String])
getPackageLinkOpts dflags pkgs =
  collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs

collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
collectLinkOpts dflags ps =
    (
        concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
        concatMap (map ("-l" ++) . extraLibraries) ps,
        concatMap ldOptions ps
    )

packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
  where
        ways0 = ways dflags

        ways1 = filter (/= WayDyn) ways0
        -- the name of a shared library is libHSfoo-ghc<version>.so
        -- we leave out the _dyn, because it is superfluous

        -- debug RTS includes support for -eventlog
        ways2 | WayDebug `elem` ways1
              = filter (/= WayEventLog) ways1
              | otherwise
              = ways1

        tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
        rts_tag = mkBuildTag ways2

        mkDynName x
         | gopt Opt_Static dflags       = x
         | "HS" `isPrefixOf` x          =
              x ++ '-':programName dflags ++ projectVersion dflags
           -- For non-Haskell libraries, we use the name "Cfoo". The .a
           -- file is libCfoo.a, and the .so is libfoo.so. That way the
           -- linker knows what we mean for the vanilla (-lCfoo) and dyn
           -- (-lfoo) ways. We therefore need to strip the 'C' off here.
         | Just x' <- stripPrefix "C" x = x'
         | otherwise
            = panic ("Don't understand library name " ++ x)

        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
        addSuffix other_lib      = other_lib ++ (expandTag tag)

        expandTag t | null t = ""
                    | otherwise = '_':t

-- | Find all the C-compiler options in these and the preload packages
getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
  ps <- getPreloadPackagesAnd dflags pkgs
  return (concatMap ccOptions ps)

-- | Find all the package framework paths in these and the preload packages
getPackageFrameworkPath  :: DynFlags -> [PackageKey] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
  ps <- getPreloadPackagesAnd dflags pkgs
  return (nub (filter notNull (concatMap frameworkDirs ps)))

-- | Find all the package frameworks in these and the preload packages
getPackageFrameworks  :: DynFlags -> [PackageKey] -> IO [String]
getPackageFrameworks dflags pkgs = do
  ps <- getPreloadPackagesAnd dflags pkgs
  return (concatMap frameworks ps)

-- -----------------------------------------------------------------------------
-- Package Utils

-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllPackages :: DynFlags
                          -> ModuleName
                          -> [(Module, PackageConfig)]
lookupModuleInAllPackages dflags m
  = case lookupModuleWithSuggestions dflags m Nothing of
      LookupFound a b -> [(a,b)]
      LookupMultiple rs -> map f rs
        where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
                                                         (modulePackageKey m)))
      _ -> []

-- | The result of performing a lookup
data LookupResult =
    -- | Found the module uniquely, nothing else to do
    LookupFound Module PackageConfig
    -- | Multiple modules with the same name in scope
  | LookupMultiple [(Module, ModuleOrigin)]
    -- | No modules found, but there were some hidden ones with
    -- an exact name match.  First is due to package hidden, second
    -- is due to module being hidden
  | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
    -- | Nothing found, here are some suggested different names
  | LookupNotFound [ModuleSuggestion] -- suggestions

data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
                      | SuggestHidden ModuleName Module ModuleOrigin

lookupModuleWithSuggestions :: DynFlags
                            -> ModuleName
                            -> Maybe FastString
                            -> LookupResult
lookupModuleWithSuggestions dflags m mb_pn
  = case Map.lookup m (moduleToPkgConfAll pkg_state) of
        Nothing -> LookupNotFound suggestions
        Just xs ->
          case foldl' classify ([],[],[]) (Map.toList xs) of
            ([], [], []) -> LookupNotFound suggestions
            (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
            (_, _, exposed@(_:_))        -> LookupMultiple exposed
            (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
  where
    classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
      let origin = filterOrigin mb_pn (mod_pkg m) origin0
          x = (m, origin)
      in case origin of
          ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)
          _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)
            | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
            | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)

    pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
    pkg_state = pkgState dflags
    mod_pkg = pkg_lookup . modulePackageKey

    -- Filters out origins which are not associated with the given package
    -- qualifier.  No-op if there is no package qualifier.  Test if this
    -- excluded all origins with 'originEmpty'.
    filterOrigin :: Maybe FastString
                 -> PackageConfig
                 -> ModuleOrigin
                 -> ModuleOrigin
    filterOrigin Nothing _ o = o
    filterOrigin (Just pn) pkg o =
      case o of
          ModHidden -> if go pkg then ModHidden else mempty
          ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
                      fromHiddenReexport = rhs }
            -> ModOrigin {
                  fromOrigPackage = if go pkg then e else Nothing
                , fromExposedReexport = filter go res
                , fromHiddenReexport = filter go rhs
                , fromPackageFlag = False -- always excluded
                }
      where go pkg = pn == fsPackageName pkg

    suggestions
      | gopt Opt_HelpfulErrors dflags =
           fuzzyLookup (moduleNameString m) all_mods
      | otherwise = []

    all_mods :: [(String, ModuleSuggestion)]     -- All modules
    all_mods = sortBy (comparing fst) $
        [ (moduleNameString m, suggestion)
        | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
        , suggestion <- map (getSuggestion m) (Map.toList e)
        ]
    getSuggestion name (mod, origin) =
        (if originVisible origin then SuggestVisible else SuggestHidden)
            name mod origin

listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames dflags =
    map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
  where visible (_, ms) = any originVisible (Map.elems ms)

-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
  let
      state   = pkgState dflags
      pkg_map = pkgIdMap state
      ipid_map = installedPackageIdMap state
      preload = preloadPackages state
      pairs = zip pkgids (repeat Nothing)
  in do
  all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
  return (map (getPackageDetails dflags) all_pkgs)

-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
closeDeps :: DynFlags
          -> PackageConfigMap
          -> Map InstalledPackageId PackageKey
          -> [(PackageKey, Maybe PackageKey)]
          -> IO [PackageKey]
closeDeps dflags pkg_map ipid_map ps
    = throwErr dflags (closeDepsErr pkg_map ipid_map ps)

throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
              = case m of
                Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
                Succeeded r -> return r

closeDepsErr :: PackageConfigMap
             -> Map InstalledPackageId PackageKey
             -> [(PackageKey,Maybe PackageKey)]
             -> MaybeErr MsgDoc [PackageKey]
closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps

-- internal helper
add_package :: PackageConfigMap
            -> Map InstalledPackageId PackageKey
            -> [PackageKey]
            -> (PackageKey,Maybe PackageKey)
            -> MaybeErr MsgDoc [PackageKey]
add_package pkg_db ipid_map ps (p, mb_parent)
  | p `elem` ps = return ps     -- Check if we've already added this package
  | otherwise =
      case lookupPackage' pkg_db p of
        Nothing -> Failed (missingPackageMsg p <>
                           missingDependencyMsg mb_parent)
        Just pkg -> do
           -- Add the package's dependents also
           ps' <- foldM add_package_ipid ps (depends pkg)
           return (p : ps')
          where
            add_package_ipid ps ipid
              | Just pid <- Map.lookup ipid ipid_map
              = add_package pkg_db ipid_map ps (pid, Just p)
              | otherwise
              = Failed (missingPackageMsg ipid
                          <> missingDependencyMsg mb_parent)

missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a
missingPackageErr dflags p
    = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))

missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p

missingDependencyMsg :: Maybe PackageKey -> SDoc
missingDependencyMsg Nothing = Outputable.empty
missingDependencyMsg (Just parent)
  = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))

-- -----------------------------------------------------------------------------

packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String
packageKeyPackageIdString dflags pkg_key
    | pkg_key == mainPackageKey = Just "main"
    | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)

-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that
-- the synbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows
isDllName dflags _this_pkg this_mod name
  | gopt Opt_Static dflags = False
  | Just mod <- nameModule_maybe name
    -- Issue #8696 - when GHC is dynamically linked, it will attempt
    -- to load the dynamic dependencies of object files at compile
    -- time for things like QuasiQuotes or
    -- TemplateHaskell. Unfortunately, this interacts badly with
    -- intra-package linking, because we don't generate indirect
    -- (dynamic) symbols for intra-package calls. This means that if a
    -- module with an intra-package call is loaded without its
    -- dependencies, then GHC fails to link. This is the cause of #
    --
    -- In the mean time, always force dynamic indirections to be
    -- generated: when the module name isn't the module being
    -- compiled, references are dynamic.
    = if mod /= this_mod
      then True
      else case dllSplit dflags of
           Nothing -> False
           Just ss ->
               let findMod m = let modStr = moduleNameString (moduleName m)
                               in case find (modStr `Set.member`) ss of
                                  Just i -> i
                                  Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
               in findMod mod /= findMod this_mod

  | otherwise = False  -- no, it is not even an external name

-- -----------------------------------------------------------------------------
-- Displaying packages

-- | Show (very verbose) package info
pprPackages :: DynFlags -> SDoc
pprPackages = pprPackagesWith pprPackageConfig

pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
pprPackagesWith pprIPI dflags =
    vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))

-- | Show simplified package info.
--
-- The idea is to only print package id, and any information that might
-- be different from the package databases (exposure, trust)
pprPackagesSimple :: DynFlags -> SDoc
pprPackagesSimple = pprPackagesWith pprIPI
    where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi
                           e = if exposed ipi then text "E" else text " "
                           t = if trusted ipi then text "T" else text " "
                       in e <> t <> text "  " <> ftext i

-- | Show the mapping of modules to where they come from.
pprModuleMap :: DynFlags -> SDoc
pprModuleMap dflags =
  vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
    where
      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
      pprEntry m (m',o)
        | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o)
        | otherwise = ppr m' <+> parens (ppr o)

fsPackageName :: PackageConfig -> FastString
fsPackageName = mkFastString . packageNameString