-- (c) The University of Glasgow, 2006

{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}

-- | Package manipulation
module Packages (
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
        PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext),
        PackageConfigMap,
        emptyPackageState,
        initPackages,
        readPackageConfigs,
        getPackageConfRefs,
        resolvePackageConfig,
        readPackageConfig,
        listPackageConfigMap,

        -- * Querying the package config
        lookupPackage,
        lookupPackage',
        lookupInstalledPackage,
        lookupPackageName,
        improveUnitId,
        searchPackageId,
        getPackageDetails,
        getInstalledPackageDetails,
        componentIdString,
        displayInstalledUnitId,
        listVisibleModuleNames,
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
        lookupPluginModuleWithSuggestions,
        LookupResult(..),
        ModuleSuggestion(..),
        ModuleOrigin(..),
        UnusablePackageReason(..),
        pprReason,

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

        collectArchives,
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
        packageHsLibs, getLibs,

        -- * Utils
        unwireUnitId,
        pprFlag,
        pprPackages,
        pprPackagesSimple,
        pprModuleMap,
        isIndefinite,
        isDllName
    )
where

#include "HsVersions.h"

import GhcPrelude

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

import System.Environment ( getEnv )
import FastString
import ErrUtils         ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg,
                          withTiming )
import Exception

import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO.Error  ( isDoesNotExistError )
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
import Data.List as List
import Data.Map (Map)
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import qualified Data.Set as Set
import Data.Version

-- ---------------------------------------------------------------------------
-- 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 a 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 unavailable because the package is unusable.
  | ModUnusable UnusablePackageReason
    -- | 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.
        ModuleOrigin -> Maybe Bool
fromOrigPackage :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
      , ModuleOrigin -> [PackageConfig]
fromExposedReexport :: [PackageConfig]
        -- | Is the module available from a reexport of a hidden package?
      , ModuleOrigin -> [PackageConfig]
fromHiddenReexport :: [PackageConfig]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , ModuleOrigin -> Bool
fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
    ppr :: ModuleOrigin -> SDoc
ppr ModuleOrigin
ModHidden = String -> SDoc
text String
"hidden module"
    ppr (ModUnusable UnusablePackageReason
_) = String -> SDoc
text String
"unusable module"
    ppr (ModOrigin Maybe Bool
e [PackageConfig]
res [PackageConfig]
rhs Bool
f) = [SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (
        (case Maybe Bool
e of
            Maybe Bool
Nothing -> []
            Just Bool
False -> [String -> SDoc
text String
"hidden package"]
            Just Bool
True -> [String -> SDoc
text String
"exposed package"]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
        (if [PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
res
            then []
            else [String -> SDoc
text String
"reexport by" SDoc -> SDoc -> SDoc
<+>
                    [SDoc] -> SDoc
sep ((PackageConfig -> SDoc) -> [PackageConfig] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> SDoc)
-> (PackageConfig -> UnitId) -> PackageConfig -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> UnitId
packageConfigId) [PackageConfig]
res)]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
        (if [PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
rhs
            then []
            else [String -> SDoc
text String
"hidden reexport by" SDoc -> SDoc -> SDoc
<+>
                    [SDoc] -> SDoc
sep ((PackageConfig -> SDoc) -> [PackageConfig] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> SDoc)
-> (PackageConfig -> UnitId) -> PackageConfig -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> UnitId
packageConfigId) [PackageConfig]
res)]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
        (if Bool
f then [String -> SDoc
text String
"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 :: Bool -> ModuleOrigin
fromExposedModules Bool
e = Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
e) [] [] Bool
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 :: Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules Bool
True PackageConfig
pkg = Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [PackageConfig
pkg] [] Bool
False
fromReexportedModules Bool
False PackageConfig
pkg = Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [PackageConfig
pkg] Bool
False

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

instance Semigroup ModuleOrigin where
    ModOrigin Maybe Bool
e [PackageConfig]
res [PackageConfig]
rhs Bool
f <> :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
<> ModOrigin Maybe Bool
e' [PackageConfig]
res' [PackageConfig]
rhs' Bool
f' =
        Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin (Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
g Maybe Bool
e Maybe Bool
e') ([PackageConfig]
res [PackageConfig] -> [PackageConfig] -> [PackageConfig]
forall a. [a] -> [a] -> [a]
++ [PackageConfig]
res') ([PackageConfig]
rhs [PackageConfig] -> [PackageConfig] -> [PackageConfig]
forall a. [a] -> [a] -> [a]
++ [PackageConfig]
rhs') (Bool
f Bool -> Bool -> Bool
|| Bool
f')
      where g :: Maybe a -> Maybe a -> Maybe a
g (Just a
b) (Just a
b')
                | a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b'   = a -> Maybe a
forall a. a -> Maybe a
Just a
b
                | Bool
otherwise = String -> Maybe a
forall a. String -> a
panic String
"ModOrigin: package both exposed/hidden"
            g Maybe a
Nothing Maybe a
x = Maybe a
x
            g Maybe a
x Maybe a
Nothing = Maybe a
x
    ModuleOrigin
_x <> ModuleOrigin
_y = String -> ModuleOrigin
forall a. String -> a
panic String
"ModOrigin: hidden module redefined"

instance Monoid ModuleOrigin where
    mempty :: ModuleOrigin
mempty = Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [] Bool
False
    mappend :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
mappend = ModuleOrigin -> ModuleOrigin -> ModuleOrigin
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

-- | 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 :: ModuleOrigin -> Bool
originVisible ModuleOrigin
ModHidden = Bool
False
originVisible (ModUnusable UnusablePackageReason
_) = Bool
False
originVisible (ModOrigin Maybe Bool
b [PackageConfig]
res [PackageConfig]
_ Bool
f) = Maybe Bool
b Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Bool -> Bool -> Bool
|| Bool -> Bool
not ([PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
res) Bool -> Bool -> Bool
|| Bool
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 :: ModuleOrigin -> Bool
originEmpty (ModOrigin Maybe Bool
Nothing [] [] Bool
False) = Bool
True
originEmpty ModuleOrigin
_ = Bool
False

-- | 'UniqFM' map from 'InstalledUnitId'
type InstalledUnitIdMap = UniqDFM

-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
-- the transitive closure of preload packages.
data PackageConfigMap = PackageConfigMap {
        PackageConfigMap -> InstalledUnitIdMap PackageConfig
unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
        -- | The set of transitively reachable packages according
        -- to the explicitly provided command line arguments.
        -- See Note [UnitId to InstalledUnitId improvement]
        PackageConfigMap -> UniqSet InstalledUnitId
preloadClosure :: UniqSet InstalledUnitId
    }

-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
type VisibilityMap = Map UnitId UnitVisibility

-- | 'UnitVisibility' records the various aspects of visibility of a particular
-- 'UnitId'.
data UnitVisibility = UnitVisibility
    { UnitVisibility -> Bool
uv_expose_all :: Bool
      --  ^ Should all modules in exposed-modules should be dumped into scope?
    , UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings :: [(ModuleName, ModuleName)]
      -- ^ Any custom renamings that should bring extra 'ModuleName's into
      -- scope.
    , UnitVisibility -> First FastString
uv_package_name :: First FastString
      -- ^ The package name is associated with the 'UnitId'.  This is used
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
    , UnitVisibility -> Map ModuleName (Set IndefModule)
uv_requirements :: Map ModuleName (Set IndefModule)
      -- ^ The signatures which are contributed to the requirements context
      -- from this unit ID.
    , UnitVisibility -> Bool
uv_explicit :: Bool
      -- ^ Whether or not this unit was explicitly brought into scope,
      -- as opposed to implicitly via the 'exposed' fields in the
      -- package database (when @-hide-all-packages@ is not passed.)
    }

instance Outputable UnitVisibility where
    ppr :: UnitVisibility -> SDoc
ppr (UnitVisibility {
        uv_expose_all :: UnitVisibility -> Bool
uv_expose_all = Bool
b,
        uv_renamings :: UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns,
        uv_package_name :: UnitVisibility -> First FastString
uv_package_name = First Maybe FastString
mb_pn,
        uv_requirements :: UnitVisibility -> Map ModuleName (Set IndefModule)
uv_requirements = Map ModuleName (Set IndefModule)
reqs,
        uv_explicit :: UnitVisibility -> Bool
uv_explicit = Bool
explicit
    }) = (Bool, [(ModuleName, ModuleName)], Maybe FastString,
 Map ModuleName (Set IndefModule), Bool)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool
b, [(ModuleName, ModuleName)]
rns, Maybe FastString
mb_pn, Map ModuleName (Set IndefModule)
reqs, Bool
explicit)

instance Semigroup UnitVisibility where
    UnitVisibility
uv1 <> :: UnitVisibility -> UnitVisibility -> UnitVisibility
<> UnitVisibility
uv2
        = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set IndefModule)
-> Bool
-> UnitVisibility
UnitVisibility
          { uv_expose_all :: Bool
uv_expose_all = UnitVisibility -> Bool
uv_expose_all UnitVisibility
uv1 Bool -> Bool -> Bool
|| UnitVisibility -> Bool
uv_expose_all UnitVisibility
uv2
          , uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings UnitVisibility
uv1 [(ModuleName, ModuleName)]
-> [(ModuleName, ModuleName)] -> [(ModuleName, ModuleName)]
forall a. [a] -> [a] -> [a]
++ UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings UnitVisibility
uv2
          , uv_package_name :: First FastString
uv_package_name = First FastString -> First FastString -> First FastString
forall a. Monoid a => a -> a -> a
mappend (UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv1) (UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv2)
          , uv_requirements :: Map ModuleName (Set IndefModule)
uv_requirements = (Set IndefModule -> Set IndefModule -> Set IndefModule)
-> Map ModuleName (Set IndefModule)
-> Map ModuleName (Set IndefModule)
-> Map ModuleName (Set IndefModule)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set IndefModule -> Set IndefModule -> Set IndefModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UnitVisibility -> Map ModuleName (Set IndefModule)
uv_requirements UnitVisibility
uv1) (UnitVisibility -> Map ModuleName (Set IndefModule)
uv_requirements UnitVisibility
uv2)
          , uv_explicit :: Bool
uv_explicit = UnitVisibility -> Bool
uv_explicit UnitVisibility
uv1 Bool -> Bool -> Bool
|| UnitVisibility -> Bool
uv_explicit UnitVisibility
uv2
          }

instance Monoid UnitVisibility where
    mempty :: UnitVisibility
mempty = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set IndefModule)
-> Bool
-> UnitVisibility
UnitVisibility
             { uv_expose_all :: Bool
uv_expose_all = Bool
False
             , uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = []
             , uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First Maybe FastString
forall a. Maybe a
Nothing
             , uv_requirements :: Map ModuleName (Set IndefModule)
uv_requirements = Map ModuleName (Set IndefModule)
forall k a. Map k a
Map.empty
             , uv_explicit :: Bool
uv_explicit = Bool
False
             }
    mappend :: UnitVisibility -> UnitVisibility -> UnitVisibility
mappend = UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

type WiredUnitId = DefUnitId
type PreloadUnitId = InstalledUnitId

-- | 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 'UnitId' to 'PackageConfig'.  This list is adjusted
  -- so that only valid packages are here.  'PackageConfig' reflects
  -- what was stored *on disk*, except for the 'trusted' flag, which
  -- is adjusted at runtime.  (In particular, some packages in this map
  -- may have the 'exposed' flag be 'False'.)
  PackageState -> PackageConfigMap
pkgIdMap              :: PackageConfigMap,

  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when
  -- users refer to packages in Backpack includes.
  PackageState -> Map PackageName ComponentId
packageNameMap            :: Map PackageName ComponentId,

  -- | A mapping from wired in names to the original names from the
  -- package database.
  PackageState -> Map WiredUnitId WiredUnitId
unwireMap :: Map WiredUnitId WiredUnitId,

  -- | 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.
  PackageState -> [InstalledUnitId]
preloadPackages      :: [PreloadUnitId],

  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  PackageState -> [UnitId]
explicitPackages      :: [UnitId],

  -- | 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.
  PackageState -> ModuleToPkgConfAll
moduleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
  PackageState -> ModuleToPkgConfAll
pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | A map saying, for each requirement, what interfaces must be merged
  -- together when we use them.  For example, if our dependencies
  -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
  -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
  -- and @r[C=<A>]:C@.
  --
  -- There's an entry in this map for each hole in our home library.
  PackageState -> Map ModuleName [IndefModule]
requirementContext :: Map ModuleName [IndefModule]
  }

emptyPackageState :: PackageState
emptyPackageState :: PackageState
emptyPackageState = PackageState :: PackageConfigMap
-> Map PackageName ComponentId
-> Map WiredUnitId WiredUnitId
-> [InstalledUnitId]
-> [UnitId]
-> ModuleToPkgConfAll
-> ModuleToPkgConfAll
-> Map ModuleName [IndefModule]
-> PackageState
PackageState {
    pkgIdMap :: PackageConfigMap
pkgIdMap = PackageConfigMap
emptyPackageConfigMap,
    packageNameMap :: Map PackageName ComponentId
packageNameMap = Map PackageName ComponentId
forall k a. Map k a
Map.empty,
    unwireMap :: Map WiredUnitId WiredUnitId
unwireMap = Map WiredUnitId WiredUnitId
forall k a. Map k a
Map.empty,
    preloadPackages :: [InstalledUnitId]
preloadPackages = [],
    explicitPackages :: [UnitId]
explicitPackages = [],
    moduleToPkgConfAll :: ModuleToPkgConfAll
moduleToPkgConfAll = ModuleToPkgConfAll
forall k a. Map k a
Map.empty,
    pluginModuleToPkgConfAll :: ModuleToPkgConfAll
pluginModuleToPkgConfAll = ModuleToPkgConfAll
forall k a. Map k a
Map.empty,
    requirementContext :: Map ModuleName [IndefModule]
requirementContext = Map ModuleName [IndefModule]
forall k a. Map k a
Map.empty
    }

type InstalledPackageIndex = Map InstalledUnitId PackageConfig

-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = InstalledUnitIdMap PackageConfig
-> UniqSet InstalledUnitId -> PackageConfigMap
PackageConfigMap InstalledUnitIdMap PackageConfig
forall elt. UniqDFM elt
emptyUDFM UniqSet InstalledUnitId
forall a. UniqSet a
emptyUniqSet

-- | Find the package we know about with the given unit id, if any
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags = Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' (DynFlags -> Bool
isIndefinite DynFlags
dflags) (PackageState -> PackageConfigMap
pkgIdMap (DynFlags -> PackageState
pkgState DynFlags
dflags))

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
-- be used while we're initializing 'DynFlags'
lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' Bool
False (PackageConfigMap InstalledUnitIdMap PackageConfig
pkg_map UniqSet InstalledUnitId
_) UnitId
uid = InstalledUnitIdMap PackageConfig -> UnitId -> Maybe PackageConfig
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstalledUnitIdMap PackageConfig
pkg_map UnitId
uid
lookupPackage' Bool
True m :: PackageConfigMap
m@(PackageConfigMap InstalledUnitIdMap PackageConfig
pkg_map UniqSet InstalledUnitId
_) UnitId
uid =
    case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
        (InstalledUnitId
iuid, Just IndefUnitId
indef) ->
            (PackageConfig -> PackageConfig)
-> Maybe PackageConfig -> Maybe PackageConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageConfigMap
-> [(ModuleName, Module)] -> PackageConfig -> PackageConfig
renamePackage PackageConfigMap
m (IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef))
                 (InstalledUnitIdMap PackageConfig
-> InstalledUnitId -> Maybe PackageConfig
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstalledUnitIdMap PackageConfig
pkg_map InstalledUnitId
iuid)
        (InstalledUnitId
_, Maybe IndefUnitId
Nothing) -> InstalledUnitIdMap PackageConfig -> UnitId -> Maybe PackageConfig
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstalledUnitIdMap PackageConfig
pkg_map UnitId
uid

{-
-- | Find the indefinite package for a given 'ComponentId'.
-- The way this works is just by fiat'ing that every indefinite package's
-- unit key is precisely its component ID; and that they share uniques.
lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
  where
    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
-}

-- | Find the package we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName DynFlags
dflags PackageName
n = PackageName -> Map PackageName ComponentId -> Maybe ComponentId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
n (PackageState -> Map PackageName ComponentId
packageNameMap (DynFlags -> PackageState
pkgState DynFlags
dflags))

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
searchPackageId DynFlags
dflags SourcePackageId
pid = (PackageConfig -> Bool) -> [PackageConfig] -> [PackageConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter ((SourcePackageId
pid SourcePackageId -> SourcePackageId -> Bool
forall a. Eq a => a -> a -> Bool
==) (SourcePackageId -> Bool)
-> (PackageConfig -> SourcePackageId) -> PackageConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> SourcePackageId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgid
sourcePackageId)
                               (DynFlags -> [PackageConfig]
listPackageConfigMap DynFlags
dflags)

-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap (PackageConfigMap InstalledUnitIdMap PackageConfig
pkg_map UniqSet InstalledUnitId
closure) [PackageConfig]
new_pkgs
  = InstalledUnitIdMap PackageConfig
-> UniqSet InstalledUnitId -> PackageConfigMap
PackageConfigMap ((InstalledUnitIdMap PackageConfig
 -> PackageConfig -> InstalledUnitIdMap PackageConfig)
-> InstalledUnitIdMap PackageConfig
-> [PackageConfig]
-> InstalledUnitIdMap PackageConfig
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstalledUnitIdMap PackageConfig
-> PackageConfig -> InstalledUnitIdMap PackageConfig
add InstalledUnitIdMap PackageConfig
pkg_map [PackageConfig]
new_pkgs) UniqSet InstalledUnitId
closure
    -- We also add the expanded version of the packageConfigId, so that
    -- 'improveUnitId' can find it.
  where add :: InstalledUnitIdMap PackageConfig
-> PackageConfig -> InstalledUnitIdMap PackageConfig
add InstalledUnitIdMap PackageConfig
pkg_map PackageConfig
p = InstalledUnitIdMap PackageConfig
-> InstalledUnitId
-> PackageConfig
-> InstalledUnitIdMap PackageConfig
forall key elt.
Uniquable key =>
UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM (InstalledUnitIdMap PackageConfig
-> UnitId -> PackageConfig -> InstalledUnitIdMap PackageConfig
forall key elt.
Uniquable key =>
UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM InstalledUnitIdMap PackageConfig
pkg_map (PackageConfig -> UnitId
expandedPackageConfigId PackageConfig
p) PackageConfig
p)
                                  (PackageConfig -> InstalledUnitId
installedPackageConfigId PackageConfig
p) PackageConfig
p

-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags UnitId
pid =
    String -> Maybe PackageConfig -> PackageConfig
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"getPackageDetails" (DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags UnitId
pid)

lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags InstalledUnitId
uid = PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' (PackageState -> PackageConfigMap
pkgIdMap (DynFlags -> PackageState
pkgState DynFlags
dflags)) InstalledUnitId
uid

lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' (PackageConfigMap InstalledUnitIdMap PackageConfig
db UniqSet InstalledUnitId
_) InstalledUnitId
uid = InstalledUnitIdMap PackageConfig
-> InstalledUnitId -> Maybe PackageConfig
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstalledUnitIdMap PackageConfig
db InstalledUnitId
uid

getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails DynFlags
dflags InstalledUnitId
uid =
    String -> Maybe PackageConfig -> PackageConfig
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"getInstalledPackageDetails" (Maybe PackageConfig -> PackageConfig)
-> Maybe PackageConfig -> PackageConfig
forall a b. (a -> b) -> a -> b
$
        DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags InstalledUnitId
uid

-- | Get a list of entries from the package database.  NB: be careful with
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap DynFlags
dflags = InstalledUnitIdMap PackageConfig -> [PackageConfig]
forall elt. UniqDFM elt -> [elt]
eltsUDFM InstalledUnitIdMap PackageConfig
pkg_map
  where
    PackageConfigMap InstalledUnitIdMap PackageConfig
pkg_map UniqSet InstalledUnitId
_ = PackageState -> PackageConfigMap
pkgIdMap (DynFlags -> PackageState
pkgState DynFlags
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, [PreloadUnitId])
initPackages :: DynFlags -> IO (DynFlags, [InstalledUnitId])
initPackages DynFlags
dflags0 = DynFlags
-> SDoc
-> ((DynFlags, [InstalledUnitId]) -> ())
-> IO (DynFlags, [InstalledUnitId])
-> IO (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags0
                                  (String -> SDoc
text String
"initializing package database")
                                  (DynFlags, [InstalledUnitId]) -> ()
forall b. (DynFlags, b) -> ()
forcePkgDb (IO (DynFlags, [InstalledUnitId])
 -> IO (DynFlags, [InstalledUnitId]))
-> IO (DynFlags, [InstalledUnitId])
-> IO (DynFlags, [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- DynFlags -> IO DynFlags
interpretPackageEnv DynFlags
dflags0
  [(String, [PackageConfig])]
pkg_db <-
    case DynFlags -> Maybe [(String, [PackageConfig])]
pkgDatabase DynFlags
dflags of
        Maybe [(String, [PackageConfig])]
Nothing -> DynFlags -> IO [(String, [PackageConfig])]
readPackageConfigs DynFlags
dflags
        Just [(String, [PackageConfig])]
db -> [(String, [PackageConfig])] -> IO [(String, [PackageConfig])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [PackageConfig])] -> IO [(String, [PackageConfig])])
-> [(String, [PackageConfig])] -> IO [(String, [PackageConfig])]
forall a b. (a -> b) -> a -> b
$ ((String, [PackageConfig]) -> (String, [PackageConfig]))
-> [(String, [PackageConfig])] -> [(String, [PackageConfig])]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
p, [PackageConfig]
pkgs)
                                    -> (String
p, DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags DynFlags
dflags [PackageConfig]
pkgs)) [(String, [PackageConfig])]
db
  (PackageState
pkg_state, [InstalledUnitId]
preload, Maybe [(ModuleName, Module)]
insts)
        <- DynFlags
-> [(String, [PackageConfig])]
-> [InstalledUnitId]
-> IO
     (PackageState, [InstalledUnitId], Maybe [(ModuleName, Module)])
mkPackageState DynFlags
dflags [(String, [PackageConfig])]
pkg_db []
  (DynFlags, [InstalledUnitId]) -> IO (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags{ pkgDatabase :: Maybe [(String, [PackageConfig])]
pkgDatabase = [(String, [PackageConfig])] -> Maybe [(String, [PackageConfig])]
forall a. a -> Maybe a
Just [(String, [PackageConfig])]
pkg_db,
                  pkgState :: PackageState
pkgState = PackageState
pkg_state,
                  thisUnitIdInsts_ :: Maybe [(ModuleName, Module)]
thisUnitIdInsts_ = Maybe [(ModuleName, Module)]
insts },
          [InstalledUnitId]
preload)
  where
    forcePkgDb :: (DynFlags, b) -> ()
forcePkgDb (DynFlags
dflags, b
_) = PackageState -> PackageConfigMap
pkgIdMap (DynFlags -> PackageState
pkgState DynFlags
dflags) PackageConfigMap -> () -> ()
`seq` ()

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

readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
readPackageConfigs :: DynFlags -> IO [(String, [PackageConfig])]
readPackageConfigs DynFlags
dflags = do
  [PkgConfRef]
conf_refs <- DynFlags -> IO [PkgConfRef]
getPackageConfRefs DynFlags
dflags
  [String]
confs     <- ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (PkgConfRef -> IO (Maybe String))
-> [PkgConfRef] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> PkgConfRef -> IO (Maybe String)
resolvePackageConfig DynFlags
dflags) [PkgConfRef]
conf_refs
  (String -> IO (String, [PackageConfig]))
-> [String] -> IO [(String, [PackageConfig])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> String -> IO (String, [PackageConfig])
readPackageConfig DynFlags
dflags) [String]
confs


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

  Either IOException String
e_pkg_path <- IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IO String
getEnv (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (DynFlags -> String
programName DynFlags
dflags) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_PACKAGE_PATH")
  let base_conf_refs :: [PkgConfRef]
base_conf_refs = case Either IOException String
e_pkg_path of
        Left IOException
_ -> [PkgConfRef]
system_conf_refs
        Right String
path
         | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path) Bool -> Bool -> Bool
&& Char -> Bool
isSearchPathSeparator (String -> Char
forall a. [a] -> a
last String
path)
         -> (String -> PkgConfRef) -> [String] -> [PkgConfRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgConfRef
PkgConfFile (String -> [String]
splitSearchPath (String -> String
forall a. [a] -> [a]
init String
path)) [PkgConfRef] -> [PkgConfRef] -> [PkgConfRef]
forall a. [a] -> [a] -> [a]
++ [PkgConfRef]
system_conf_refs
         | Bool
otherwise
         -> (String -> PkgConfRef) -> [String] -> [PkgConfRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgConfRef
PkgConfFile (String -> [String]
splitSearchPath String
path)

  -- Apply the package DB-related flags from the command line to get the
  -- final list of package DBs.
  --
  -- Notes on ordering:
  --  * The list of flags is reversed (later ones first)
  --  * We work with the package DB list in "left shadows right" order
  --  * and finally reverse it at the end, to get "right shadows left"
  --
  [PkgConfRef] -> IO [PkgConfRef]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PkgConfRef] -> IO [PkgConfRef])
-> [PkgConfRef] -> IO [PkgConfRef]
forall a b. (a -> b) -> a -> b
$ [PkgConfRef] -> [PkgConfRef]
forall a. [a] -> [a]
reverse ((PackageDBFlag -> [PkgConfRef] -> [PkgConfRef])
-> [PkgConfRef] -> [PackageDBFlag] -> [PkgConfRef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PackageDBFlag -> [PkgConfRef] -> [PkgConfRef]
doFlag [PkgConfRef]
base_conf_refs (DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
dflags))
 where
  doFlag :: PackageDBFlag -> [PkgConfRef] -> [PkgConfRef]
doFlag (PackageDB PkgConfRef
p) [PkgConfRef]
dbs = PkgConfRef
p PkgConfRef -> [PkgConfRef] -> [PkgConfRef]
forall a. a -> [a] -> [a]
: [PkgConfRef]
dbs
  doFlag PackageDBFlag
NoUserPackageDB [PkgConfRef]
dbs = (PkgConfRef -> Bool) -> [PkgConfRef] -> [PkgConfRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgConfRef -> Bool
isNotUser [PkgConfRef]
dbs
  doFlag PackageDBFlag
NoGlobalPackageDB [PkgConfRef]
dbs = (PkgConfRef -> Bool) -> [PkgConfRef] -> [PkgConfRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgConfRef -> Bool
isNotGlobal [PkgConfRef]
dbs
  doFlag PackageDBFlag
ClearPackageDBs [PkgConfRef]
_ = []

  isNotUser :: PkgConfRef -> Bool
isNotUser PkgConfRef
UserPkgConf = Bool
False
  isNotUser PkgConfRef
_ = Bool
True

  isNotGlobal :: PkgConfRef -> Bool
isNotGlobal PkgConfRef
GlobalPkgConf = Bool
False
  isNotGlobal PkgConfRef
_ = Bool
True

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe String)
resolvePackageConfig DynFlags
dflags PkgConfRef
GlobalPkgConf = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (DynFlags -> String
systemPackageConfig DynFlags
dflags)
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal.  (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
resolvePackageConfig DynFlags
dflags PkgConfRef
UserPkgConf = MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
  String
dir <- DynFlags -> MaybeT IO String
versionedAppDir DynFlags
dflags
  let pkgconf :: String
pkgconf = String
dir String -> String -> String
</> String
"package.conf.d"
  Bool
exist <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
tryMaybeT (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
pkgconf
  if Bool
exist then String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
pkgconf else MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
resolvePackageConfig DynFlags
_ (PkgConfFile String
name) = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
name

readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
readPackageConfig :: DynFlags -> String -> IO (String, [PackageConfig])
readPackageConfig DynFlags
dflags String
conf_file = do
  Bool
isdir <- String -> IO Bool
doesDirectoryExist String
conf_file

  [PackageConfig]
proto_pkg_configs <-
    if Bool
isdir
       then String -> IO [PackageConfig]
forall b c f a d e g.
(BinaryStringRep b, BinaryStringRep c, BinaryStringRep f,
 BinaryStringRep a, BinaryStringRep d,
 DbUnitIdModuleRep d a e f g) =>
String -> IO [InstalledPackageInfo a b c d e f g]
readDirStylePackageConfig String
conf_file
       else do
            Bool
isfile <- String -> IO Bool
doesFileExist String
conf_file
            if Bool
isfile
               then do
                 Maybe [PackageConfig]
mpkgs <- IO (Maybe [PackageConfig])
tryReadOldFileStylePackageConfig
                 case Maybe [PackageConfig]
mpkgs of
                   Just [PackageConfig]
pkgs -> [PackageConfig] -> IO [PackageConfig]
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageConfig]
pkgs
                   Maybe [PackageConfig]
Nothing   -> GhcException -> IO [PackageConfig]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [PackageConfig])
-> GhcException -> IO [PackageConfig]
forall a b. (a -> b) -> a -> b
$ String -> GhcException
InstallationError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
                      String
"ghc no longer supports single-file style package " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"databases (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_file String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
") use 'ghc-pkg init' to create the database with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"the correct format."
               else GhcException -> IO [PackageConfig]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [PackageConfig])
-> GhcException -> IO [PackageConfig]
forall a b. (a -> b) -> a -> b
$ String -> GhcException
InstallationError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
                      String
"can't find a package database at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_file

  let
      -- Fix #16360: remove trailing slash from conf_file before calculting pkgroot
      conf_file' :: String
conf_file' = String -> String
dropTrailingPathSeparator String
conf_file
      top_dir :: String
top_dir = DynFlags -> String
topDir DynFlags
dflags
      pkgroot :: String
pkgroot = String -> String
takeDirectory String
conf_file'
      pkg_configs1 :: [PackageConfig]
pkg_configs1 = (PackageConfig -> PackageConfig)
-> [PackageConfig] -> [PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> PackageConfig -> PackageConfig
mungePackageConfig String
top_dir String
pkgroot)
                         [PackageConfig]
proto_pkg_configs
      pkg_configs2 :: [PackageConfig]
pkg_configs2 = DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags DynFlags
dflags [PackageConfig]
pkg_configs1
  --
  (String, [PackageConfig]) -> IO (String, [PackageConfig])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
conf_file', [PackageConfig]
pkg_configs2)
  where
    readDirStylePackageConfig :: String -> IO [InstalledPackageInfo a b c d e f g]
readDirStylePackageConfig String
conf_dir = do
      let filename :: String
filename = String
conf_dir String -> String -> String
</> String
"package.cache"
      Bool
cache_exists <- String -> IO Bool
doesFileExist String
filename
      if Bool
cache_exists
        then do
          DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Using binary package database:"
                                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
filename
          String -> IO [InstalledPackageInfo a b c d e f g]
forall a b c d e f g.
RepInstalledPackageInfo a b c d e f g =>
String -> IO [InstalledPackageInfo a b c d e f g]
readPackageDbForGhc String
filename
        else do
          -- If there is no package.cache file, we check if the database is not
          -- empty by inspecting if the directory contains any .conf file. If it
          -- does, something is wrong and we fail. Otherwise we assume that the
          -- database is empty.
          DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"There is no package.cache in"
                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir
                                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", checking if the database is empty"
          Bool
db_empty <- (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".conf")
                   ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
conf_dir
          if Bool
db_empty
            then do
              DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"There are no .conf files in"
                                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", treating"
                                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"package database as empty"
              [InstalledPackageInfo a b c d e f g]
-> IO [InstalledPackageInfo a b c d e f g]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do
              GhcException -> IO [InstalledPackageInfo a b c d e f g]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [InstalledPackageInfo a b c d e f g])
-> GhcException -> IO [InstalledPackageInfo a b c d e f g]
forall a b. (a -> b) -> a -> b
$ String -> GhcException
InstallationError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
                String
"there is no package.cache in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
" even though package database is not empty"


    -- Single-file style package dbs have been deprecated for some time, but
    -- it turns out that Cabal was using them in one place. So this is a
    -- workaround to allow older Cabal versions to use this newer ghc.
    -- We check if the file db contains just "[]" and if so, we look for a new
    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    -- We cannot just replace the file with a new dir style since Cabal still
    -- assumes it's a file and tries to overwrite with 'writeFile'.
    -- ghc-pkg also cooperates with this workaround.
    tryReadOldFileStylePackageConfig :: IO (Maybe [PackageConfig])
tryReadOldFileStylePackageConfig = do
      String
content <- String -> IO String
readFile String
conf_file IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
      if Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 String
content String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]"
        then do
          let conf_dir :: String
conf_dir = String
conf_file String -> String -> String
<.> String
"d"
          Bool
direxists <- String -> IO Bool
doesDirectoryExist String
conf_dir
          if Bool
direxists
             then do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (String -> SDoc
text String
"Ignoring old file-style db and trying:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir)
                     ([PackageConfig] -> Maybe [PackageConfig])
-> IO [PackageConfig] -> IO (Maybe [PackageConfig])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [PackageConfig] -> Maybe [PackageConfig]
forall a. a -> Maybe a
Just (String -> IO [PackageConfig]
forall b c f a d e g.
(BinaryStringRep b, BinaryStringRep c, BinaryStringRep f,
 BinaryStringRep a, BinaryStringRep d,
 DbUnitIdModuleRep d a e f g) =>
String -> IO [InstalledPackageInfo a b c d e f g]
readDirStylePackageConfig String
conf_dir)
             else Maybe [PackageConfig] -> IO (Maybe [PackageConfig])
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageConfig] -> Maybe [PackageConfig]
forall a. a -> Maybe a
Just []) -- ghc-pkg will create it when it's updated
        else Maybe [PackageConfig] -> IO (Maybe [PackageConfig])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [PackageConfig]
forall a. Maybe a
Nothing

setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags DynFlags
dflags [PackageConfig]
pkgs = [PackageConfig] -> [PackageConfig]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
[InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod]
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname instunitid unitid modulename mod]
maybeDistrustAll [PackageConfig]
pkgs
  where
    maybeDistrustAll :: [InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod]
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname instunitid unitid modulename mod]
maybeDistrustAll [InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod]
pkgs'
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DistrustAllPackages DynFlags
dflags = (InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod
 -> InstalledPackageInfo
      compid srcpkgid srcpkgname instunitid unitid modulename mod)
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname instunitid unitid modulename mod]
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname instunitid unitid modulename mod]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
forall compid srcpkgid srcpkgname instunitid unitid modulename mod
       unitid.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
distrust [InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod]
pkgs'
      | Bool
otherwise                           = [InstalledPackageInfo
   compid srcpkgid srcpkgname instunitid unitid modulename mod]
pkgs'

    distrust :: InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
distrust InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
pkg = InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
pkg{ trusted :: Bool
trusted = Bool
False }

mungePackageConfig :: FilePath -> FilePath
                   -> PackageConfig -> PackageConfig
mungePackageConfig :: String -> String -> PackageConfig -> PackageConfig
mungePackageConfig String
top_dir String
pkgroot =
    PackageConfig -> PackageConfig
mungeDynLibFields
  (PackageConfig -> PackageConfig)
-> (PackageConfig -> PackageConfig)
-> PackageConfig
-> PackageConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> PackageConfig -> PackageConfig
mungePackagePaths String
top_dir String
pkgroot

mungeDynLibFields :: PackageConfig -> PackageConfig
mungeDynLibFields :: PackageConfig -> PackageConfig
mungeDynLibFields PackageConfig
pkg =
    PackageConfig
pkg {
      libraryDynDirs :: [String]
libraryDynDirs     = PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDynDirs PackageConfig
pkg
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
`orIfNull` PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDirs PackageConfig
pkg
    }
  where
    orIfNull :: [a] -> [a] -> [a]
orIfNull [] [a]
flags = [a]
flags
    orIfNull [a]
flags [a]
_  = [a]
flags

-- 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 :: String -> String -> PackageConfig -> PackageConfig
mungePackagePaths String
top_dir String
pkgroot PackageConfig
pkg =
    PackageConfig
pkg {
      importDirs :: [String]
importDirs  = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
importDirs PackageConfig
pkg),
      includeDirs :: [String]
includeDirs = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
includeDirs PackageConfig
pkg),
      libraryDirs :: [String]
libraryDirs = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDirs PackageConfig
pkg),
      libraryDynDirs :: [String]
libraryDynDirs = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDynDirs PackageConfig
pkg),
      frameworkDirs :: [String]
frameworkDirs = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
frameworkDirs PackageConfig
pkg),
      haddockInterfaces :: [String]
haddockInterfaces = [String] -> [String]
munge_paths (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
haddockInterfaces PackageConfig
pkg),
      haddockHTMLs :: [String]
haddockHTMLs = [String] -> [String]
munge_urls (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
haddockHTMLs PackageConfig
pkg)
    }
  where
    munge_paths :: [String] -> [String]
munge_paths = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
munge_path
    munge_urls :: [String] -> [String]
munge_urls  = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
munge_url

    munge_path :: String -> String
munge_path String
p
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"${pkgroot}" String
p = String
pkgroot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p'
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"$topdir"    String
p = String
top_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p'
      | Bool
otherwise                                = String
p

    munge_url :: String -> String
munge_url String
p
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"${pkgrooturl}" String
p = String -> String -> String
toUrlPath String
pkgroot String
p'
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"$httptopdir"   String
p = String -> String -> String
toUrlPath String
top_dir String
p'
      | Bool
otherwise                                   = String
p

    toUrlPath :: String -> String -> String
toUrlPath String
r String
p = String
"file:///"
                 -- URLs always use posix style '/' separators:
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
FilePath.Posix.joinPath
                        (String
r String -> [String] -> [String]
forall a. a -> [a] -> [a]
: -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator)
                                       (String -> [String]
FilePath.splitDirectories String
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 :: String -> String -> Maybe String
stripVarPrefix String
var String
path = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
var String
path of
                              Just [] -> String -> Maybe String
forall a. a -> Maybe a
Just []
                              Just cs :: String
cs@(Char
c : String
_) | Char -> Bool
isPathSeparator Char
c -> String -> Maybe String
forall a. a -> Maybe a
Just String
cs
                              Maybe String
_ -> Maybe String
forall a. Maybe a
Nothing


-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
   -> PackagePrecedenceIndex
   -> UnusablePackages
   -> [PackageConfig]
   -> TrustFlag
   -> IO [PackageConfig]
applyTrustFlag :: DynFlags
-> PackagePrecedenceIndex
-> UnusablePackages
-> [PackageConfig]
-> TrustFlag
-> IO [PackageConfig]
applyTrustFlag DynFlags
dflags PackagePrecedenceIndex
prec_map UnusablePackages
unusable [PackageConfig]
pkgs TrustFlag
flag =
  case TrustFlag
flag of
    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage String
str ->
       case PackagePrecedenceIndex
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either
     [(PackageConfig, UnusablePackageReason)]
     ([PackageConfig], [PackageConfig])
selectPackages PackagePrecedenceIndex
prec_map (String -> PackageArg
PackageArg String
str) [PackageConfig]
pkgs UnusablePackages
unusable of
         Left [(PackageConfig, UnusablePackageReason)]
ps       -> DynFlags
-> TrustFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO [PackageConfig]
forall a.
DynFlags
-> TrustFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
trustFlagErr DynFlags
dflags TrustFlag
flag [(PackageConfig, UnusablePackageReason)]
ps
         Right ([PackageConfig]
ps,[PackageConfig]
qs) -> [PackageConfig] -> IO [PackageConfig]
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageConfig -> PackageConfig)
-> [PackageConfig] -> [PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> PackageConfig
forall compid srcpkgid srcpkgname instunitid unitid modulename mod
       unitid.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
trust [PackageConfig]
ps [PackageConfig] -> [PackageConfig] -> [PackageConfig]
forall a. [a] -> [a] -> [a]
++ [PackageConfig]
qs)
          where trust :: InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
trust InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
p = InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
p {trusted :: Bool
trusted=Bool
True}

    DistrustPackage String
str ->
       case PackagePrecedenceIndex
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either
     [(PackageConfig, UnusablePackageReason)]
     ([PackageConfig], [PackageConfig])
selectPackages PackagePrecedenceIndex
prec_map (String -> PackageArg
PackageArg String
str) [PackageConfig]
pkgs UnusablePackages
unusable of
         Left [(PackageConfig, UnusablePackageReason)]
ps       -> DynFlags
-> TrustFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO [PackageConfig]
forall a.
DynFlags
-> TrustFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
trustFlagErr DynFlags
dflags TrustFlag
flag [(PackageConfig, UnusablePackageReason)]
ps
         Right ([PackageConfig]
ps,[PackageConfig]
qs) -> [PackageConfig] -> IO [PackageConfig]
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageConfig -> PackageConfig)
-> [PackageConfig] -> [PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> PackageConfig
forall compid srcpkgid srcpkgname instunitid unitid modulename mod
       unitid.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
distrust [PackageConfig]
ps [PackageConfig] -> [PackageConfig] -> [PackageConfig]
forall a. [a] -> [a] -> [a]
++ [PackageConfig]
qs)
          where distrust :: InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
distrust InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
p = InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
p {trusted :: Bool
trusted=Bool
False}

-- | A little utility to tell if the 'thisPackage' is indefinite
-- (if it is not, we should never use on-the-fly renaming.)
isIndefinite :: DynFlags -> Bool
isIndefinite :: DynFlags -> Bool
isIndefinite DynFlags
dflags = Bool -> Bool
not (UnitId -> Bool
unitIdIsDefinite (DynFlags -> UnitId
thisPackage DynFlags
dflags))

applyPackageFlag
   :: DynFlags
   -> PackagePrecedenceIndex
   -> PackageConfigMap
   -> UnusablePackages
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
   -> PackageFlag               -- flag to apply
   -> IO VisibilityMap        -- Now exposed

applyPackageFlag :: DynFlags
-> PackagePrecedenceIndex
-> PackageConfigMap
-> UnusablePackages
-> Bool
-> [PackageConfig]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag DynFlags
dflags PackagePrecedenceIndex
prec_map PackageConfigMap
pkg_db UnusablePackages
unusable Bool
no_hide_others [PackageConfig]
pkgs VisibilityMap
vm PackageFlag
flag =
  case PackageFlag
flag of
    ExposePackage String
_ PackageArg
arg (ModRenaming Bool
b [(ModuleName, ModuleName)]
rns) ->
       case PackagePrecedenceIndex
-> PackageConfigMap
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
findPackages PackagePrecedenceIndex
prec_map PackageConfigMap
pkg_db PackageArg
arg [PackageConfig]
pkgs UnusablePackages
unusable of
         Left [(PackageConfig, UnusablePackageReason)]
ps         -> DynFlags
-> PackageFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO VisibilityMap
forall a.
DynFlags
-> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr DynFlags
dflags PackageFlag
flag [(PackageConfig, UnusablePackageReason)]
ps
         Right (PackageConfig
p:[PackageConfig]
_) -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
          where
           n :: FastString
n = PackageConfig -> FastString
fsPackageName PackageConfig
p

           -- If a user says @-unit-id p[A=<A>]@, this imposes
           -- a requirement on us: whatever our signature A is,
           -- it must fulfill all of p[A=<A>]:A's requirements.
           -- This method is responsible for computing what our
           -- inherited requirements are.
           reqs :: Map ModuleName (Set IndefModule)
reqs | UnitIdArg UnitId
orig_uid <- PackageArg
arg = UnitId -> Map ModuleName (Set IndefModule)
collectHoles UnitId
orig_uid
                | Bool
otherwise                 = Map ModuleName (Set IndefModule)
forall k a. Map k a
Map.empty

           collectHoles :: UnitId -> Map ModuleName (Set IndefModule)
collectHoles UnitId
uid = case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
                (InstalledUnitId
_, Just IndefUnitId
indef) ->
                  let local :: [Map ModuleName (Set IndefModule)]
local = [ ModuleName -> Set IndefModule -> Map ModuleName (Set IndefModule)
forall k a. k -> a -> Map k a
Map.singleton
                                  (Module -> ModuleName
moduleName Module
mod)
                                  (IndefModule -> Set IndefModule
forall a. a -> Set a
Set.singleton (IndefModule -> Set IndefModule) -> IndefModule -> Set IndefModule
forall a b. (a -> b) -> a -> b
$ IndefUnitId -> ModuleName -> IndefModule
IndefModule IndefUnitId
indef ModuleName
mod_name)
                              | (ModuleName
mod_name, Module
mod) <- IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef
                              , Module -> Bool
isHoleModule Module
mod ]
                      recurse :: [Map ModuleName (Set IndefModule)]
recurse = [ UnitId -> Map ModuleName (Set IndefModule)
collectHoles (Module -> UnitId
moduleUnitId Module
mod)
                                | (ModuleName
_, Module
mod) <- IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef ]
                  in (Set IndefModule -> Set IndefModule -> Set IndefModule)
-> [Map ModuleName (Set IndefModule)]
-> Map ModuleName (Set IndefModule)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set IndefModule -> Set IndefModule -> Set IndefModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Map ModuleName (Set IndefModule)]
 -> Map ModuleName (Set IndefModule))
-> [Map ModuleName (Set IndefModule)]
-> Map ModuleName (Set IndefModule)
forall a b. (a -> b) -> a -> b
$ [Map ModuleName (Set IndefModule)]
local [Map ModuleName (Set IndefModule)]
-> [Map ModuleName (Set IndefModule)]
-> [Map ModuleName (Set IndefModule)]
forall a. [a] -> [a] -> [a]
++ [Map ModuleName (Set IndefModule)]
recurse
                -- Other types of unit identities don't have holes
                (InstalledUnitId
_, Maybe IndefUnitId
Nothing) -> Map ModuleName (Set IndefModule)
forall k a. Map k a
Map.empty


           uv :: UnitVisibility
uv = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set IndefModule)
-> Bool
-> UnitVisibility
UnitVisibility
                { uv_expose_all :: Bool
uv_expose_all = Bool
b
                , uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns
                , uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
n)
                , uv_requirements :: Map ModuleName (Set IndefModule)
uv_requirements = Map ModuleName (Set IndefModule)
reqs
                , uv_explicit :: Bool
uv_explicit = Bool
True
                }
           vm' :: VisibilityMap
vm' = (UnitVisibility -> UnitVisibility -> UnitVisibility)
-> UnitId -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Monoid a => a -> a -> a
mappend (PackageConfig -> UnitId
packageConfigId PackageConfig
p) UnitVisibility
uv VisibilityMap
vm_cleared
           -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
           -- (or if p-0.1 was registered in the pkgdb as exposed: True),
           -- the second package flag would override the first one and you
           -- would only see p-0.2 in exposed modules.  This is good for
           -- usability.
           --
           -- However, with thinning and renaming (or Backpack), there might be
           -- situations where you legitimately want to see two versions of a
           -- package at the same time, and this behavior would make it
           -- impossible to do so.  So we decided that if you pass
           -- -hide-all-packages, this should turn OFF the overriding behavior
           -- where an exposed package hides all other packages with the same
           -- name.  This should not affect Cabal at all, which only ever
           -- exposes one package at a time.
           --
           -- NB: Why a variable no_hide_others?  We have to apply this logic to
           -- -plugin-package too, and it's more consistent if the switch in
           -- behavior is based off of
           -- -hide-all-packages/-hide-all-plugin-packages depending on what
           -- flag is in question.
           vm_cleared :: VisibilityMap
vm_cleared | Bool
no_hide_others = VisibilityMap
vm
                      -- NB: renamings never clear
                      | ((ModuleName, ModuleName)
_:[(ModuleName, ModuleName)]
_) <- [(ModuleName, ModuleName)]
rns = VisibilityMap
vm
                      | Bool
otherwise = (UnitId -> UnitVisibility -> Bool)
-> VisibilityMap -> VisibilityMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                            (\UnitId
k UnitVisibility
uv -> UnitId
k UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> UnitId
packageConfigId PackageConfig
p
                                   Bool -> Bool -> Bool
|| Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
n) First FastString -> First FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv) VisibilityMap
vm
         Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
_ -> String -> IO VisibilityMap
forall a. String -> a
panic String
"applyPackageFlag"

    HidePackage String
str ->
       case PackagePrecedenceIndex
-> PackageConfigMap
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
findPackages PackagePrecedenceIndex
prec_map PackageConfigMap
pkg_db (String -> PackageArg
PackageArg String
str) [PackageConfig]
pkgs UnusablePackages
unusable of
         Left [(PackageConfig, UnusablePackageReason)]
ps  -> DynFlags
-> PackageFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO VisibilityMap
forall a.
DynFlags
-> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr DynFlags
dflags PackageFlag
flag [(PackageConfig, UnusablePackageReason)]
ps
         Right [PackageConfig]
ps -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
          where vm' :: VisibilityMap
vm' = (VisibilityMap -> UnitId -> VisibilityMap)
-> VisibilityMap -> [UnitId] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((UnitId -> VisibilityMap -> VisibilityMap)
-> VisibilityMap -> UnitId -> VisibilityMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) VisibilityMap
vm ((PackageConfig -> UnitId) -> [PackageConfig] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> UnitId
packageConfigId [PackageConfig]
ps)

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
findPackages :: PackagePrecedenceIndex
             -> PackageConfigMap -> PackageArg -> [PackageConfig]
             -> UnusablePackages
             -> Either [(PackageConfig, UnusablePackageReason)]
                [PackageConfig]
findPackages :: PackagePrecedenceIndex
-> PackageConfigMap
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
findPackages PackagePrecedenceIndex
prec_map PackageConfigMap
pkg_db PackageArg
arg [PackageConfig]
pkgs UnusablePackages
unusable
  = let ps :: [PackageConfig]
ps = (PackageConfig -> Maybe PackageConfig)
-> [PackageConfig] -> [PackageConfig]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageArg -> PackageConfig -> Maybe PackageConfig
finder PackageArg
arg) [PackageConfig]
pkgs
    in if [PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
ps
        then [(PackageConfig, UnusablePackageReason)]
-> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
forall a b. a -> Either a b
Left (((PackageConfig, UnusablePackageReason)
 -> Maybe (PackageConfig, UnusablePackageReason))
-> [(PackageConfig, UnusablePackageReason)]
-> [(PackageConfig, UnusablePackageReason)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PackageConfig
x,UnusablePackageReason
y) -> PackageArg -> PackageConfig -> Maybe PackageConfig
finder PackageArg
arg PackageConfig
x Maybe PackageConfig
-> (PackageConfig -> Maybe (PackageConfig, UnusablePackageReason))
-> Maybe (PackageConfig, UnusablePackageReason)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PackageConfig
x' -> (PackageConfig, UnusablePackageReason)
-> Maybe (PackageConfig, UnusablePackageReason)
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageConfig
x',UnusablePackageReason
y))
                            (UnusablePackages -> [(PackageConfig, UnusablePackageReason)]
forall k a. Map k a -> [a]
Map.elems UnusablePackages
unusable))
        else [PackageConfig]
-> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig]
forall a b. b -> Either a b
Right (PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference PackagePrecedenceIndex
prec_map [PackageConfig]
ps)
  where
    finder :: PackageArg -> PackageConfig -> Maybe PackageConfig
finder (PackageArg String
str) PackageConfig
p
      = if String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
sourcePackageIdString PackageConfig
p Bool -> Bool -> Bool
|| String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
packageNameString PackageConfig
p
          then PackageConfig -> Maybe PackageConfig
forall a. a -> Maybe a
Just PackageConfig
p
          else Maybe PackageConfig
forall a. Maybe a
Nothing
    finder (UnitIdArg UnitId
uid) PackageConfig
p
      = let (InstalledUnitId
iuid, Maybe IndefUnitId
mb_indef) = UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid
        in if InstalledUnitId
iuid InstalledUnitId -> InstalledUnitId -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> InstalledUnitId
installedPackageConfigId PackageConfig
p
              then PackageConfig -> Maybe PackageConfig
forall a. a -> Maybe a
Just (case Maybe IndefUnitId
mb_indef of
                            Maybe IndefUnitId
Nothing    -> PackageConfig
p
                            Just IndefUnitId
indef -> PackageConfigMap
-> [(ModuleName, Module)] -> PackageConfig -> PackageConfig
renamePackage PackageConfigMap
pkg_db (IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef) PackageConfig
p)
              else Maybe PackageConfig
forall a. Maybe a
Nothing

selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages :: PackagePrecedenceIndex
-> PackageArg
-> [PackageConfig]
-> UnusablePackages
-> Either
     [(PackageConfig, UnusablePackageReason)]
     ([PackageConfig], [PackageConfig])
selectPackages PackagePrecedenceIndex
prec_map PackageArg
arg [PackageConfig]
pkgs UnusablePackages
unusable
  = let matches :: PackageConfig -> Bool
matches = PackageArg -> PackageConfig -> Bool
matching PackageArg
arg
        ([PackageConfig]
ps,[PackageConfig]
rest) = (PackageConfig -> Bool)
-> [PackageConfig] -> ([PackageConfig], [PackageConfig])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition PackageConfig -> Bool
matches [PackageConfig]
pkgs
    in if [PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
ps
        then [(PackageConfig, UnusablePackageReason)]
-> Either
     [(PackageConfig, UnusablePackageReason)]
     ([PackageConfig], [PackageConfig])
forall a b. a -> Either a b
Left (((PackageConfig, UnusablePackageReason) -> Bool)
-> [(PackageConfig, UnusablePackageReason)]
-> [(PackageConfig, UnusablePackageReason)]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageConfig -> Bool
matches(PackageConfig -> Bool)
-> ((PackageConfig, UnusablePackageReason) -> PackageConfig)
-> (PackageConfig, UnusablePackageReason)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PackageConfig, UnusablePackageReason) -> PackageConfig
forall a b. (a, b) -> a
fst) (UnusablePackages -> [(PackageConfig, UnusablePackageReason)]
forall k a. Map k a -> [a]
Map.elems UnusablePackages
unusable))
        else ([PackageConfig], [PackageConfig])
-> Either
     [(PackageConfig, UnusablePackageReason)]
     ([PackageConfig], [PackageConfig])
forall a b. b -> Either a b
Right (PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference PackagePrecedenceIndex
prec_map [PackageConfig]
ps, [PackageConfig]
rest)

-- | Rename a 'PackageConfig' according to some module instantiation.
renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
              -> PackageConfig -> PackageConfig
renamePackage :: PackageConfigMap
-> [(ModuleName, Module)] -> PackageConfig -> PackageConfig
renamePackage PackageConfigMap
pkg_map [(ModuleName, Module)]
insts PackageConfig
conf =
    let hsubst :: UniqFM Module
hsubst = [(ModuleName, Module)] -> UniqFM Module
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [(ModuleName, Module)]
insts
        smod :: Module -> Module
smod  = PackageConfigMap -> UniqFM Module -> Module -> Module
renameHoleModule' PackageConfigMap
pkg_map UniqFM Module
hsubst
        new_insts :: [(ModuleName, Module)]
new_insts = ((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
k,Module
v) -> (ModuleName
k,Module -> Module
smod Module
v)) (PackageConfig -> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, mod)]
instantiatedWith PackageConfig
conf)
    in PackageConfig
conf {
        instantiatedWith :: [(ModuleName, Module)]
instantiatedWith = [(ModuleName, Module)]
new_insts,
        exposedModules :: [(ModuleName, Maybe Module)]
exposedModules = ((ModuleName, Maybe Module) -> (ModuleName, Maybe Module))
-> [(ModuleName, Maybe Module)] -> [(ModuleName, Maybe Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
mod_name, Maybe Module
mb_mod) -> (ModuleName
mod_name, (Module -> Module) -> Maybe Module -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Module
smod Maybe Module
mb_mod))
                             (PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
conf)
    }


-- 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 :: String -> PackageConfig -> Bool
matchingStr String
str PackageConfig
p
        =  String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
sourcePackageIdString PackageConfig
p
        Bool -> Bool -> Bool
|| String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
packageNameString PackageConfig
p

matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId InstalledUnitId
uid PackageConfig
p = InstalledUnitId
uid InstalledUnitId -> InstalledUnitId -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> InstalledUnitId
installedPackageConfigId PackageConfig
p

matching :: PackageArg -> PackageConfig -> Bool
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg String
str) = String -> PackageConfig -> Bool
matchingStr String
str
matching (UnitIdArg (DefiniteUnitId (DefUnitId InstalledUnitId
uid)))  = InstalledUnitId -> PackageConfig -> Bool
matchingId InstalledUnitId
uid
matching (UnitIdArg UnitId
_)  = \PackageConfig
_ -> Bool
False -- TODO: warn in this case

-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference PackagePrecedenceIndex
prec_map = (PackageConfig -> PackageConfig -> Ordering)
-> [PackageConfig] -> [PackageConfig]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((PackageConfig -> PackageConfig -> Ordering)
-> PackageConfig -> PackageConfig -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackagePrecedenceIndex
-> PackageConfig -> PackageConfig -> Ordering
compareByPreference PackagePrecedenceIndex
prec_map))

-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
-- which should be "active".  Here is the order of preference:
--
--      1. First, prefer the latest version
--      2. If the versions are the same, prefer the package that
--      came in the latest package database.
--
-- Pursuant to #12518, we could change this policy to, for example, remove
-- the version preference, meaning that we would always prefer the packages
-- in later package database.
--
-- Instead, we use that preference based policy only when one of the packages
-- is integer-gmp and the other is integer-simple.
-- This currently only happens when we're looking up which concrete
-- package to use in place of @integer-wired-in@ and that two different
-- package databases supply a different integer library. For more about
-- the fake @integer-wired-in@ package, see Note [The integer library]
-- in the @PrelNames@ module.
compareByPreference
    :: PackagePrecedenceIndex
    -> PackageConfig
    -> PackageConfig
    -> Ordering
compareByPreference :: PackagePrecedenceIndex
-> PackageConfig -> PackageConfig -> Ordering
compareByPreference PackagePrecedenceIndex
prec_map PackageConfig
pkg PackageConfig
pkg'
  | Just Int
prec  <- InstalledUnitId -> PackagePrecedenceIndex -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg)  PackagePrecedenceIndex
prec_map
  , Just Int
prec' <- InstalledUnitId -> PackagePrecedenceIndex -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg') PackagePrecedenceIndex
prec_map
  , PackageConfig -> PackageConfig -> Bool
differentIntegerPkgs PackageConfig
pkg PackageConfig
pkg'
  = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
prec Int
prec'

  | Bool
otherwise
  = case (PackageConfig -> Version)
-> PackageConfig -> PackageConfig -> Ordering
forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
packageVersion PackageConfig
pkg PackageConfig
pkg' of
        Ordering
GT -> Ordering
GT
        Ordering
EQ | Just Int
prec  <- InstalledUnitId -> PackagePrecedenceIndex -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg)  PackagePrecedenceIndex
prec_map
           , Just Int
prec' <- InstalledUnitId -> PackagePrecedenceIndex -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg') PackagePrecedenceIndex
prec_map
           -- Prefer the package from the later DB flag (i.e., higher
           -- precedence)
           -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
prec Int
prec'
           | Bool
otherwise
           -> Ordering
EQ
        Ordering
LT -> Ordering
LT

  where isIntegerPkg :: PackageConfig -> Bool
isIntegerPkg PackageConfig
p = PackageConfig -> String
packageNameString PackageConfig
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
          [String
"integer-simple", String
"integer-gmp"]
        differentIntegerPkgs :: PackageConfig -> PackageConfig -> Bool
differentIntegerPkgs PackageConfig
p PackageConfig
p' =
          PackageConfig -> Bool
isIntegerPkg PackageConfig
p Bool -> Bool -> Bool
&& PackageConfig -> Bool
isIntegerPkg PackageConfig
p' Bool -> Bool -> Bool
&&
          (PackageConfig -> PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
packageName PackageConfig
p PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageConfig -> PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
packageName PackageConfig
p')

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

packageFlagErr :: DynFlags
               -> PackageFlag
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
packageFlagErr :: DynFlags
-> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr DynFlags
dflags PackageFlag
flag [(PackageConfig, UnusablePackageReason)]
reasons
  = DynFlags
-> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a
forall a.
DynFlags
-> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr' DynFlags
dflags (PackageFlag -> SDoc
pprFlag PackageFlag
flag) [(PackageConfig, UnusablePackageReason)]
reasons

trustFlagErr :: DynFlags
             -> TrustFlag
             -> [(PackageConfig, UnusablePackageReason)]
             -> IO a
trustFlagErr :: DynFlags
-> TrustFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a
trustFlagErr DynFlags
dflags TrustFlag
flag [(PackageConfig, UnusablePackageReason)]
reasons
  = DynFlags
-> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a
forall a.
DynFlags
-> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr' DynFlags
dflags (TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag) [(PackageConfig, UnusablePackageReason)]
reasons

packageFlagErr' :: DynFlags
               -> SDoc
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
packageFlagErr' :: DynFlags
-> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a
packageFlagErr' DynFlags
dflags SDoc
flag_doc [(PackageConfig, UnusablePackageReason)]
reasons
  = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
CmdLineError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ SDoc
err))
  where err :: SDoc
err = String -> SDoc
text String
"cannot satisfy " SDoc -> SDoc -> SDoc
<> SDoc
flag_doc SDoc -> SDoc -> SDoc
<>
                (if [(PackageConfig, UnusablePackageReason)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageConfig, UnusablePackageReason)]
reasons then SDoc
Outputable.empty else String -> SDoc
text String
": ") SDoc -> SDoc -> SDoc
$$
              Int -> SDoc -> SDoc
nest Int
4 (SDoc
ppr_reasons SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"(use -v for more information)")
        ppr_reasons :: SDoc
ppr_reasons = [SDoc] -> SDoc
vcat (((PackageConfig, UnusablePackageReason) -> SDoc)
-> [(PackageConfig, UnusablePackageReason)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageConfig, UnusablePackageReason) -> SDoc
forall a compid srcpkgid srcpkgname unitid modulename mod.
Outputable a =>
(InstalledPackageInfo
   compid srcpkgid srcpkgname a unitid modulename mod,
 UnusablePackageReason)
-> SDoc
ppr_reason [(PackageConfig, UnusablePackageReason)]
reasons)
        ppr_reason :: (InstalledPackageInfo
   compid srcpkgid srcpkgname a unitid modulename mod,
 UnusablePackageReason)
-> SDoc
ppr_reason (InstalledPackageInfo
  compid srcpkgid srcpkgname a unitid modulename mod
p, UnusablePackageReason
reason) =
            SDoc -> UnusablePackageReason -> SDoc
pprReason (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InstalledPackageInfo
  compid srcpkgid srcpkgname a unitid modulename mod
-> a
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  compid srcpkgid srcpkgname a unitid modulename mod
p) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is") UnusablePackageReason
reason

pprFlag :: PackageFlag -> SDoc
pprFlag :: PackageFlag -> SDoc
pprFlag PackageFlag
flag = case PackageFlag
flag of
    HidePackage String
p   -> String -> SDoc
text String
"-hide-package " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p
    ExposePackage String
doc PackageArg
_ ModRenaming
_ -> String -> SDoc
text String
doc

pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag = case TrustFlag
flag of
    TrustPackage String
p    -> String -> SDoc
text String
"-trust " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p
    DistrustPackage String
p -> String -> SDoc
text String
"-distrust " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p

-- -----------------------------------------------------------------------------
-- Wired-in packages
--
-- See Note [Wired-in packages] in Module

type WiredInUnitId = String
type WiredPackagesMap = Map WiredUnitId WiredUnitId

wired_in_pkgids :: [WiredInUnitId]
wired_in_pkgids :: [String]
wired_in_pkgids = (UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
unitIdString [UnitId]
wiredInUnitIds

findWiredInPackages
   :: DynFlags
   -> PackagePrecedenceIndex
   -> [PackageConfig]           -- database
   -> VisibilityMap             -- info on what packages are visible
                                -- for wired in selection
   -> IO ([PackageConfig],  -- package database updated for wired in
          WiredPackagesMap) -- map from unit id to wired identity

findWiredInPackages :: DynFlags
-> PackagePrecedenceIndex
-> [PackageConfig]
-> VisibilityMap
-> IO ([PackageConfig], Map WiredUnitId WiredUnitId)
findWiredInPackages DynFlags
dflags PackagePrecedenceIndex
prec_map [PackageConfig]
pkgs VisibilityMap
vis_map = do
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base), as described
  -- in Note [Wired-in packages] in Module
  let
        matches :: PackageConfig -> WiredInUnitId -> Bool
        PackageConfig
pc matches :: PackageConfig -> String -> Bool
`matches` String
pid
            -- See Note [The integer library] in PrelNames
            | String
pid String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId -> String
unitIdString UnitId
integerUnitId
            = PackageConfig -> String
packageNameString PackageConfig
pc String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"integer-gmp", String
"integer-simple"]
        PackageConfig
pc `matches` String
pid = PackageConfig -> String
packageNameString PackageConfig
pc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
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] -> WiredInUnitId
                           -> IO (Maybe (WiredInUnitId, PackageConfig))
        findWiredInPackage :: [PackageConfig] -> String -> IO (Maybe (String, PackageConfig))
findWiredInPackage [PackageConfig]
pkgs String
wired_pkg =
           let all_ps :: [PackageConfig]
all_ps = [ PackageConfig
p | PackageConfig
p <- [PackageConfig]
pkgs, PackageConfig
p PackageConfig -> String -> Bool
`matches` String
wired_pkg ]
               all_exposed_ps :: [PackageConfig]
all_exposed_ps =
                    [ PackageConfig
p | PackageConfig
p <- [PackageConfig]
all_ps
                        , UnitId -> VisibilityMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (PackageConfig -> UnitId
packageConfigId PackageConfig
p) VisibilityMap
vis_map ] in
           case [PackageConfig]
all_exposed_ps of
            [] -> case [PackageConfig]
all_ps of
                       []   -> IO (Maybe (String, PackageConfig))
forall a. IO (Maybe a)
notfound
                       [PackageConfig]
many -> PackageConfig -> IO (Maybe (String, PackageConfig))
pick ([PackageConfig] -> PackageConfig
forall a. [a] -> a
head (PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference PackagePrecedenceIndex
prec_map [PackageConfig]
many))
            [PackageConfig]
many -> PackageConfig -> IO (Maybe (String, PackageConfig))
pick ([PackageConfig] -> PackageConfig
forall a. [a] -> a
head (PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference PackagePrecedenceIndex
prec_map [PackageConfig]
many))
          where
                notfound :: IO (Maybe a)
notfound = do
                          DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
text String
"wired-in package "
                                 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
wired_pkg
                                 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" not found."
                          Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                pick :: PackageConfig
                     -> IO (Maybe (WiredInUnitId, PackageConfig))
                pick :: PackageConfig -> IO (Maybe (String, PackageConfig))
pick PackageConfig
pkg = do
                        DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
text String
"wired-in package "
                                 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
wired_pkg
                                 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" mapped to "
                                 SDoc -> SDoc -> SDoc
<> InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg)
                        Maybe (String, PackageConfig) -> IO (Maybe (String, PackageConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, PackageConfig) -> Maybe (String, PackageConfig)
forall a. a -> Maybe a
Just (String
wired_pkg, PackageConfig
pkg))


  [Maybe (String, PackageConfig)]
mb_wired_in_pkgs <- (String -> IO (Maybe (String, PackageConfig)))
-> [String] -> IO [Maybe (String, PackageConfig)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([PackageConfig] -> String -> IO (Maybe (String, PackageConfig))
findWiredInPackage [PackageConfig]
pkgs) [String]
wired_in_pkgids
  let
        wired_in_pkgs :: [(String, PackageConfig)]
wired_in_pkgs = [Maybe (String, PackageConfig)] -> [(String, PackageConfig)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (String, PackageConfig)]
mb_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
        -}

        wiredInMap :: Map WiredUnitId WiredUnitId
        wiredInMap :: Map WiredUnitId WiredUnitId
wiredInMap = [(WiredUnitId, WiredUnitId)] -> Map WiredUnitId WiredUnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (WiredUnitId
key, InstalledUnitId -> WiredUnitId
DefUnitId (String -> InstalledUnitId
stringToInstalledUnitId String
wiredInUnitId))
          | (String
wiredInUnitId, PackageConfig
pkg) <- [(String, PackageConfig)]
wired_in_pkgs
          , Just WiredUnitId
key <- Maybe WiredUnitId -> [Maybe WiredUnitId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe WiredUnitId -> [Maybe WiredUnitId])
-> Maybe WiredUnitId -> [Maybe WiredUnitId]
forall a b. (a -> b) -> a -> b
$ PackageConfig -> Maybe WiredUnitId
definitePackageConfigId PackageConfig
pkg
          ]

        updateWiredInDependencies :: [PackageConfig]
-> [InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      unitid
      ModuleName
      Module]
updateWiredInDependencies [PackageConfig]
pkgs = (PackageConfig
 -> InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      unitid
      ModuleName
      Module)
-> [PackageConfig]
-> [InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      unitid
      ModuleName
      Module]
forall a b. (a -> b) -> [a] -> [b]
map (PackageConfig
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     unitid
     ModuleName
     Module
forall compid srcpkgid srcpkgname unitid a unitid.
InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
-> InstalledPackageInfo
     compid srcpkgid srcpkgname InstalledUnitId unitid a Module
upd_deps (PackageConfig
 -> InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      unitid
      ModuleName
      Module)
-> (PackageConfig -> PackageConfig)
-> PackageConfig
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     unitid
     ModuleName
     Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> PackageConfig
upd_pkg) [PackageConfig]
pkgs
          where upd_pkg :: PackageConfig -> PackageConfig
upd_pkg PackageConfig
pkg
                  | Just WiredUnitId
def_uid <- PackageConfig -> Maybe WiredUnitId
definitePackageConfigId PackageConfig
pkg
                  , Just WiredUnitId
wiredInUnitId <- WiredUnitId -> Map WiredUnitId WiredUnitId -> Maybe WiredUnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WiredUnitId
def_uid Map WiredUnitId WiredUnitId
wiredInMap
                  = let fs :: FastString
fs = InstalledUnitId -> FastString
installedUnitIdFS (WiredUnitId -> InstalledUnitId
unDefUnitId WiredUnitId
wiredInUnitId)
                    in PackageConfig
pkg {
                      unitId :: InstalledUnitId
unitId = FastString -> InstalledUnitId
fsToInstalledUnitId FastString
fs,
                      componentId :: ComponentId
componentId = FastString -> ComponentId
ComponentId FastString
fs
                    }
                  | Bool
otherwise
                  = PackageConfig
pkg
                upd_deps :: InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
-> InstalledPackageInfo
     compid srcpkgid srcpkgname InstalledUnitId unitid a Module
upd_deps InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
pkg = InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
pkg {
                      -- temporary harmless DefUnitId invariant violation
                      depends :: [InstalledUnitId]
depends = (InstalledUnitId -> InstalledUnitId)
-> [InstalledUnitId] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (WiredUnitId -> InstalledUnitId
unDefUnitId (WiredUnitId -> InstalledUnitId)
-> (InstalledUnitId -> WiredUnitId)
-> InstalledUnitId
-> InstalledUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map WiredUnitId WiredUnitId -> WiredUnitId -> WiredUnitId
upd_wired_in Map WiredUnitId WiredUnitId
wiredInMap (WiredUnitId -> WiredUnitId)
-> (InstalledUnitId -> WiredUnitId)
-> InstalledUnitId
-> WiredUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledUnitId -> WiredUnitId
DefUnitId) (InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
-> [InstalledUnitId]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
pkg),
                      exposedModules :: [(a, Maybe Module)]
exposedModules
                        = ((a, Maybe Module) -> (a, Maybe Module))
-> [(a, Maybe Module)] -> [(a, Maybe Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
k,Maybe Module
v) -> (a
k, (Module -> Module) -> Maybe Module -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map WiredUnitId WiredUnitId -> Module -> Module
upd_wired_in_mod Map WiredUnitId WiredUnitId
wiredInMap) Maybe Module
v))
                              (InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
-> [(a, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid a Module
pkg)
                    }


  ([PackageConfig], Map WiredUnitId WiredUnitId)
-> IO ([PackageConfig], Map WiredUnitId WiredUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageConfig] -> [PackageConfig]
forall unitid.
[PackageConfig]
-> [InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      unitid
      ModuleName
      Module]
updateWiredInDependencies [PackageConfig]
pkgs, Map WiredUnitId WiredUnitId
wiredInMap)

-- Helper functions for rewiring Module and UnitId.  These
-- rewrite UnitIds of modules in wired-in packages to the form known to the
-- compiler, as described in Note [Wired-in packages] in Module.
--
-- For instance, base-4.9.0.0 will be rewritten to just base, to match
-- what appears in PrelNames.

upd_wired_in_mod :: WiredPackagesMap -> Module -> Module
upd_wired_in_mod :: Map WiredUnitId WiredUnitId -> Module -> Module
upd_wired_in_mod Map WiredUnitId WiredUnitId
wiredInMap (Module UnitId
uid ModuleName
m) = UnitId -> ModuleName -> Module
Module (Map WiredUnitId WiredUnitId -> UnitId -> UnitId
upd_wired_in_uid Map WiredUnitId WiredUnitId
wiredInMap UnitId
uid) ModuleName
m

upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId
upd_wired_in_uid :: Map WiredUnitId WiredUnitId -> UnitId -> UnitId
upd_wired_in_uid Map WiredUnitId WiredUnitId
wiredInMap (DefiniteUnitId WiredUnitId
def_uid) =
    WiredUnitId -> UnitId
DefiniteUnitId (Map WiredUnitId WiredUnitId -> WiredUnitId -> WiredUnitId
upd_wired_in Map WiredUnitId WiredUnitId
wiredInMap WiredUnitId
def_uid)
upd_wired_in_uid Map WiredUnitId WiredUnitId
wiredInMap (IndefiniteUnitId IndefUnitId
indef_uid) =
    IndefUnitId -> UnitId
IndefiniteUnitId (IndefUnitId -> UnitId) -> IndefUnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId
        (IndefUnitId -> ComponentId
indefUnitIdComponentId IndefUnitId
indef_uid)
        (((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
x,Module
y) -> (ModuleName
x,Map WiredUnitId WiredUnitId -> Module -> Module
upd_wired_in_mod Map WiredUnitId WiredUnitId
wiredInMap Module
y)) (IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef_uid))

upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId
upd_wired_in :: Map WiredUnitId WiredUnitId -> WiredUnitId -> WiredUnitId
upd_wired_in Map WiredUnitId WiredUnitId
wiredInMap WiredUnitId
key
    | Just WiredUnitId
key' <- WiredUnitId -> Map WiredUnitId WiredUnitId -> Maybe WiredUnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WiredUnitId
key Map WiredUnitId WiredUnitId
wiredInMap = WiredUnitId
key'
    | Bool
otherwise = WiredUnitId
key

updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap :: Map WiredUnitId WiredUnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map WiredUnitId WiredUnitId
wiredInMap VisibilityMap
vis_map = (VisibilityMap -> (WiredUnitId, WiredUnitId) -> VisibilityMap)
-> VisibilityMap -> [(WiredUnitId, WiredUnitId)] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> (WiredUnitId, WiredUnitId) -> VisibilityMap
f VisibilityMap
vis_map (Map WiredUnitId WiredUnitId -> [(WiredUnitId, WiredUnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map WiredUnitId WiredUnitId
wiredInMap)
  where f :: VisibilityMap -> (WiredUnitId, WiredUnitId) -> VisibilityMap
f VisibilityMap
vm (WiredUnitId
from, WiredUnitId
to) = case UnitId -> VisibilityMap -> Maybe UnitVisibility
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (WiredUnitId -> UnitId
DefiniteUnitId WiredUnitId
from) VisibilityMap
vis_map of
                    Maybe UnitVisibility
Nothing -> VisibilityMap
vm
                    Just UnitVisibility
r -> UnitId -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (WiredUnitId -> UnitId
DefiniteUnitId WiredUnitId
to) UnitVisibility
r
                                (UnitId -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (WiredUnitId -> UnitId
DefiniteUnitId WiredUnitId
from) VisibilityMap
vm)


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

-- | The reason why a package is unusable.
data UnusablePackageReason
  = -- | We ignored it explicitly using @-ignore-package@.
    IgnoredWithFlag
    -- | This package transitively depends on a package that was never present
    -- in any of the provided databases.
  | BrokenDependencies   [InstalledUnitId]
    -- | This package transitively depends on a package involved in a cycle.
    -- Note that the list of 'InstalledUnitId' reports the direct dependencies
    -- of this package that (transitively) depended on the cycle, and not
    -- the actual cycle itself (which we report separately at high verbosity.)
  | CyclicDependencies   [InstalledUnitId]
    -- | This package transitively depends on a package which was ignored.
  | IgnoredDependencies  [InstalledUnitId]
    -- | This package transitively depends on a package which was
    -- shadowed by an ABI-incompatible package.
  | ShadowedDependencies [InstalledUnitId]

instance Outputable UnusablePackageReason where
    ppr :: UnusablePackageReason -> SDoc
ppr UnusablePackageReason
IgnoredWithFlag = String -> SDoc
text String
"[ignored with flag]"
    ppr (BrokenDependencies [InstalledUnitId]
uids)   = SDoc -> SDoc
brackets (String -> SDoc
text String
"broken" SDoc -> SDoc -> SDoc
<+> [InstalledUnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
uids)
    ppr (CyclicDependencies [InstalledUnitId]
uids)   = SDoc -> SDoc
brackets (String -> SDoc
text String
"cyclic" SDoc -> SDoc -> SDoc
<+> [InstalledUnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
uids)
    ppr (IgnoredDependencies [InstalledUnitId]
uids)  = SDoc -> SDoc
brackets (String -> SDoc
text String
"ignored" SDoc -> SDoc -> SDoc
<+> [InstalledUnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
uids)
    ppr (ShadowedDependencies [InstalledUnitId]
uids) = SDoc -> SDoc
brackets (String -> SDoc
text String
"shadowed" SDoc -> SDoc -> SDoc
<+> [InstalledUnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
uids)

type UnusablePackages = Map InstalledUnitId
                            (PackageConfig, UnusablePackageReason)

pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason SDoc
pref UnusablePackageReason
reason = case UnusablePackageReason
reason of
  UnusablePackageReason
IgnoredWithFlag ->
      SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"ignored due to an -ignore-package flag"
  BrokenDependencies [InstalledUnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"unusable due to missing dependencies:" SDoc -> SDoc -> SDoc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((InstalledUnitId -> SDoc) -> [InstalledUnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
deps))
  CyclicDependencies [InstalledUnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"unusable due to cyclic dependencies:" SDoc -> SDoc -> SDoc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((InstalledUnitId -> SDoc) -> [InstalledUnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
deps))
  IgnoredDependencies [InstalledUnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (String
"unusable because the -ignore-package flag was used to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
"ignore at least one of its dependencies:") SDoc -> SDoc -> SDoc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((InstalledUnitId -> SDoc) -> [InstalledUnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
deps))
  ShadowedDependencies [InstalledUnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"unusable due to shadowed dependencies:" SDoc -> SDoc -> SDoc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((InstalledUnitId -> SDoc) -> [InstalledUnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstalledUnitId]
deps))

reportCycles :: DynFlags -> [SCC PackageConfig] -> IO ()
reportCycles :: DynFlags -> [SCC PackageConfig] -> IO ()
reportCycles DynFlags
dflags [SCC PackageConfig]
sccs = (SCC PackageConfig -> IO ()) -> [SCC PackageConfig] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SCC PackageConfig -> IO ()
forall a compid srcpkgid srcpkgname unitid modulename mod.
Outputable a =>
SCC
  (InstalledPackageInfo
     compid srcpkgid srcpkgname a unitid modulename mod)
-> IO ()
report [SCC PackageConfig]
sccs
  where
    report :: SCC
  (InstalledPackageInfo
     compid srcpkgid srcpkgname a unitid modulename mod)
-> IO ()
report (AcyclicSCC InstalledPackageInfo
  compid srcpkgid srcpkgname a unitid modulename mod
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    report (CyclicSCC [InstalledPackageInfo
   compid srcpkgid srcpkgname a unitid modulename mod]
vs) =
        DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"these packages are involved in a cycle:" SDoc -> SDoc -> SDoc
$$
            Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((InstalledPackageInfo
   compid srcpkgid srcpkgname a unitid modulename mod
 -> SDoc)
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname a unitid modulename mod]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> SDoc)
-> (InstalledPackageInfo
      compid srcpkgid srcpkgname a unitid modulename mod
    -> a)
-> InstalledPackageInfo
     compid srcpkgid srcpkgname a unitid modulename mod
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo
  compid srcpkgid srcpkgname a unitid modulename mod
-> a
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId) [InstalledPackageInfo
   compid srcpkgid srcpkgname a unitid modulename mod]
vs))

reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable DynFlags
dflags UnusablePackages
pkgs = ((InstalledUnitId, (PackageConfig, UnusablePackageReason))
 -> IO ())
-> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (InstalledUnitId, (PackageConfig, UnusablePackageReason)) -> IO ()
forall a a.
Outputable a =>
(a, (a, UnusablePackageReason)) -> IO ()
report (UnusablePackages
-> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
forall k a. Map k a -> [(k, a)]
Map.toList UnusablePackages
pkgs)
  where
    report :: (a, (a, UnusablePackageReason)) -> IO ()
report (a
ipid, (a
_, UnusablePackageReason
reason)) =
       DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> UnusablePackageReason -> SDoc
pprReason
           (String -> SDoc
text String
"package" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ipid SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is") UnusablePackageReason
reason

-- ----------------------------------------------------------------------------
--
-- Utilities on the database
--

-- | A reverse dependency index, mapping an 'InstalledUnitId' to
-- the 'InstalledUnitId's which have a dependency on it.
type RevIndex = Map InstalledUnitId [InstalledUnitId]

-- | Compute the reverse dependency index of a package database.
reverseDeps :: InstalledPackageIndex -> RevIndex
reverseDeps :: InstalledPackageIndex -> RevIndex
reverseDeps InstalledPackageIndex
db = (RevIndex -> PackageConfig -> RevIndex)
-> RevIndex -> InstalledPackageIndex -> RevIndex
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' RevIndex -> PackageConfig -> RevIndex
forall k compid srcpkgid srcpkgname unitid modulename mod.
Ord k =>
Map k [k]
-> InstalledPackageInfo
     compid srcpkgid srcpkgname k unitid modulename mod
-> Map k [k]
go RevIndex
forall k a. Map k a
Map.empty InstalledPackageIndex
db
  where
    go :: Map k [k]
-> InstalledPackageInfo
     compid srcpkgid srcpkgname k unitid modulename mod
-> Map k [k]
go Map k [k]
r InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg = (Map k [k] -> k -> Map k [k]) -> Map k [k] -> [k] -> Map k [k]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (k -> Map k [k] -> k -> Map k [k]
forall k a. Ord k => a -> Map k [a] -> k -> Map k [a]
go' (InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
-> k
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg)) Map k [k]
r (InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
-> [k]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg)
    go' :: a -> Map k [a] -> k -> Map k [a]
go' a
from Map k [a]
r k
to = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) k
to [a
from] Map k [a]
r

-- | Given a list of 'InstalledUnitId's to remove, a database,
-- and a reverse dependency index (as computed by 'reverseDeps'),
-- remove those packages, plus any packages which depend on them.
-- Returns the pruned database, as well as a list of 'PackageConfig's
-- that was removed.
removePackages :: [InstalledUnitId] -> RevIndex
               -> InstalledPackageIndex
               -> (InstalledPackageIndex, [PackageConfig])
removePackages :: [InstalledUnitId]
-> RevIndex
-> InstalledPackageIndex
-> (InstalledPackageIndex, [PackageConfig])
removePackages [InstalledUnitId]
uids RevIndex
index InstalledPackageIndex
m = [InstalledUnitId]
-> (InstalledPackageIndex, [PackageConfig])
-> (InstalledPackageIndex, [PackageConfig])
forall a.
[InstalledUnitId]
-> (Map InstalledUnitId a, [a]) -> (Map InstalledUnitId a, [a])
go [InstalledUnitId]
uids (InstalledPackageIndex
m,[])
  where
    go :: [InstalledUnitId]
-> (Map InstalledUnitId a, [a]) -> (Map InstalledUnitId a, [a])
go [] (Map InstalledUnitId a
m,[a]
pkgs) = (Map InstalledUnitId a
m,[a]
pkgs)
    go (InstalledUnitId
uid:[InstalledUnitId]
uids) (Map InstalledUnitId a
m,[a]
pkgs)
        | Just a
pkg <- InstalledUnitId -> Map InstalledUnitId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup InstalledUnitId
uid Map InstalledUnitId a
m
        = case InstalledUnitId -> RevIndex -> Maybe [InstalledUnitId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup InstalledUnitId
uid RevIndex
index of
            Maybe [InstalledUnitId]
Nothing    -> [InstalledUnitId]
-> (Map InstalledUnitId a, [a]) -> (Map InstalledUnitId a, [a])
go [InstalledUnitId]
uids (InstalledUnitId -> Map InstalledUnitId a -> Map InstalledUnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete InstalledUnitId
uid Map InstalledUnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
            Just [InstalledUnitId]
rdeps -> [InstalledUnitId]
-> (Map InstalledUnitId a, [a]) -> (Map InstalledUnitId a, [a])
go ([InstalledUnitId]
rdeps [InstalledUnitId] -> [InstalledUnitId] -> [InstalledUnitId]
forall a. [a] -> [a] -> [a]
++ [InstalledUnitId]
uids) (InstalledUnitId -> Map InstalledUnitId a -> Map InstalledUnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete InstalledUnitId
uid Map InstalledUnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
        | Bool
otherwise
        = [InstalledUnitId]
-> (Map InstalledUnitId a, [a]) -> (Map InstalledUnitId a, [a])
go [InstalledUnitId]
uids (Map InstalledUnitId a
m,[a]
pkgs)

-- | Given a 'PackageConfig' from some 'InstalledPackageIndex',
-- return all entries in 'depends' which correspond to packages
-- that do not exist in the index.
depsNotAvailable :: InstalledPackageIndex
                 -> PackageConfig
                 -> [InstalledUnitId]
depsNotAvailable :: InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsNotAvailable InstalledPackageIndex
pkg_map PackageConfig
pkg = (InstalledUnitId -> Bool) -> [InstalledUnitId] -> [InstalledUnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InstalledUnitId -> Bool) -> InstalledUnitId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId -> InstalledPackageIndex -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` InstalledPackageIndex
pkg_map)) (PackageConfig -> [InstalledUnitId]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends PackageConfig
pkg)

-- | Given a 'PackageConfig' from some 'InstalledPackageIndex'
-- return all entries in 'abiDepends' which correspond to packages
-- that do not exist, OR have mismatching ABIs.
depsAbiMismatch :: InstalledPackageIndex
                -> PackageConfig
                -> [InstalledUnitId]
depsAbiMismatch :: InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsAbiMismatch InstalledPackageIndex
pkg_map PackageConfig
pkg = ((InstalledUnitId, String) -> InstalledUnitId)
-> [(InstalledUnitId, String)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, String) -> InstalledUnitId
forall a b. (a, b) -> a
fst ([(InstalledUnitId, String)] -> [InstalledUnitId])
-> ([(InstalledUnitId, String)] -> [(InstalledUnitId, String)])
-> [(InstalledUnitId, String)]
-> [InstalledUnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstalledUnitId, String) -> Bool)
-> [(InstalledUnitId, String)] -> [(InstalledUnitId, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((InstalledUnitId, String) -> Bool)
-> (InstalledUnitId, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId, String) -> Bool
abiMatch) ([(InstalledUnitId, String)] -> [InstalledUnitId])
-> [(InstalledUnitId, String)] -> [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ PackageConfig -> [(InstalledUnitId, String)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(instunitid, String)]
abiDepends PackageConfig
pkg
  where
    abiMatch :: (InstalledUnitId, String) -> Bool
abiMatch (InstalledUnitId
dep_uid, String
abi)
        | Just PackageConfig
dep_pkg <- InstalledUnitId -> InstalledPackageIndex -> Maybe PackageConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup InstalledUnitId
dep_uid InstalledPackageIndex
pkg_map
        = PackageConfig -> String
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> String
abiHash PackageConfig
dep_pkg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
abi
        | Bool
otherwise
        = Bool
False

-- -----------------------------------------------------------------------------
-- Ignore packages

ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages [IgnorePackageFlag]
flags [PackageConfig]
pkgs = [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
-> UnusablePackages
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((IgnorePackageFlag
 -> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))])
-> [IgnorePackageFlag]
-> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IgnorePackageFlag
-> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
doit [IgnorePackageFlag]
flags)
  where
  doit :: IgnorePackageFlag
-> [(InstalledUnitId, (PackageConfig, UnusablePackageReason))]
doit (IgnorePackage String
str) =
     case (PackageConfig -> Bool)
-> [PackageConfig] -> ([PackageConfig], [PackageConfig])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> PackageConfig -> Bool
matchingStr String
str) [PackageConfig]
pkgs of
         ([PackageConfig]
ps, [PackageConfig]
_) -> [ (PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
p, (PackageConfig
p, UnusablePackageReason
IgnoredWithFlag))
                    | PackageConfig
p <- [PackageConfig]
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.

-- ----------------------------------------------------------------------------
--
-- Merging databases
--

-- | For each package, a mapping from uid -> i indicates that this
-- package was brought into GHC by the ith @-package-db@ flag on
-- the command line.  We use this mapping to make sure we prefer
-- packages that were defined later on the command line, if there
-- is an ambiguity.
type PackagePrecedenceIndex = Map InstalledUnitId Int

-- | Given a list of databases, merge them together, where
-- packages with the same unit id in later databases override
-- earlier ones.  This does NOT check if the resulting database
-- makes sense (that's done by 'validateDatabase').
mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])]
               -> IO (InstalledPackageIndex, PackagePrecedenceIndex)
mergeDatabases :: DynFlags
-> [(String, [PackageConfig])]
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
mergeDatabases DynFlags
dflags = ((InstalledPackageIndex, PackagePrecedenceIndex)
 -> (Int, (String, [PackageConfig]))
 -> IO (InstalledPackageIndex, PackagePrecedenceIndex))
-> (InstalledPackageIndex, PackagePrecedenceIndex)
-> [(Int, (String, [PackageConfig]))]
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (InstalledPackageIndex, PackagePrecedenceIndex)
-> (Int, (String, [PackageConfig]))
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
merge (InstalledPackageIndex
forall k a. Map k a
Map.empty, PackagePrecedenceIndex
forall k a. Map k a
Map.empty) ([(Int, (String, [PackageConfig]))]
 -> IO (InstalledPackageIndex, PackagePrecedenceIndex))
-> ([(String, [PackageConfig])]
    -> [(Int, (String, [PackageConfig]))])
-> [(String, [PackageConfig])]
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int]
-> [(String, [PackageConfig])]
-> [(Int, (String, [PackageConfig]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
  where
    merge :: (InstalledPackageIndex, PackagePrecedenceIndex)
-> (Int, (String, [PackageConfig]))
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
merge (InstalledPackageIndex
pkg_map, PackagePrecedenceIndex
prec_map) (Int
i, (String
db_path, [PackageConfig]
db)) = do
      DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"loading package database" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
db_path
      [InstalledUnitId] -> (InstalledUnitId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set InstalledUnitId -> [InstalledUnitId]
forall a. Set a -> [a]
Set.toList Set InstalledUnitId
override_set) ((InstalledUnitId -> IO ()) -> IO ())
-> (InstalledUnitId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledUnitId
pkg ->
          DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> SDoc
text String
"package" SDoc -> SDoc -> SDoc
<+> InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledUnitId
pkg SDoc -> SDoc -> SDoc
<+>
              String -> SDoc
text String
"overrides a previously defined package"
      (InstalledPackageIndex, PackagePrecedenceIndex)
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex
pkg_map', PackagePrecedenceIndex
prec_map')
     where
      db_map :: InstalledPackageIndex
db_map = [PackageConfig] -> InstalledPackageIndex
forall compid srcpkgid srcpkgname unitid modulename mod.
[InstalledPackageInfo
   compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod]
-> Map
     InstalledUnitId
     (InstalledPackageInfo
        compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)
mk_pkg_map [PackageConfig]
db
      mk_pkg_map :: [InstalledPackageInfo
   compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod]
-> Map
     InstalledUnitId
     (InstalledPackageInfo
        compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)
mk_pkg_map = [(InstalledUnitId,
  InstalledPackageInfo
    compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)]
-> Map
     InstalledUnitId
     (InstalledPackageInfo
        compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(InstalledUnitId,
   InstalledPackageInfo
     compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)]
 -> Map
      InstalledUnitId
      (InstalledPackageInfo
         compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod))
-> ([InstalledPackageInfo
       compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod]
    -> [(InstalledUnitId,
         InstalledPackageInfo
           compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)])
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod]
-> Map
     InstalledUnitId
     (InstalledPackageInfo
        compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo
   compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
 -> (InstalledUnitId,
     InstalledPackageInfo
       compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod))
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod]
-> [(InstalledUnitId,
     InstalledPackageInfo
       compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod)]
forall a b. (a -> b) -> [a] -> [b]
map (\InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
p -> (InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
p, InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
p))

      -- The set of UnitIds which appear in both db and pkgs.  These are the
      -- ones that get overridden.  Compute this just to give some
      -- helpful debug messages at -v2
      override_set :: Set InstalledUnitId
      override_set :: Set InstalledUnitId
override_set = Set InstalledUnitId -> Set InstalledUnitId -> Set InstalledUnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (InstalledPackageIndex -> Set InstalledUnitId
forall k a. Map k a -> Set k
Map.keysSet InstalledPackageIndex
db_map)
                                      (InstalledPackageIndex -> Set InstalledUnitId
forall k a. Map k a -> Set k
Map.keysSet InstalledPackageIndex
pkg_map)

      -- Now merge the sets together (NB: in case of duplicate,
      -- first argument preferred)
      pkg_map' :: InstalledPackageIndex
      pkg_map' :: InstalledPackageIndex
pkg_map' = InstalledPackageIndex
-> InstalledPackageIndex -> InstalledPackageIndex
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union InstalledPackageIndex
db_map InstalledPackageIndex
pkg_map

      prec_map' :: PackagePrecedenceIndex
      prec_map' :: PackagePrecedenceIndex
prec_map' = PackagePrecedenceIndex
-> PackagePrecedenceIndex -> PackagePrecedenceIndex
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((PackageConfig -> Int)
-> InstalledPackageIndex -> PackagePrecedenceIndex
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int -> PackageConfig -> Int
forall a b. a -> b -> a
const Int
i) InstalledPackageIndex
db_map) PackagePrecedenceIndex
prec_map

-- | Validates a database, removing unusable packages from it
-- (this includes removing packages that the user has explicitly
-- ignored.)  Our general strategy:
--
-- 1. Remove all broken packages (dangling dependencies)
-- 2. Remove all packages that are cyclic
-- 3. Apply ignore flags
-- 4. Remove all packages which have deps with mismatching ABIs
--
validateDatabase :: DynFlags -> InstalledPackageIndex
                 -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])
validateDatabase :: DynFlags
-> InstalledPackageIndex
-> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])
validateDatabase DynFlags
dflags InstalledPackageIndex
pkg_map1 =
    (InstalledPackageIndex
pkg_map5, UnusablePackages
unusable, [SCC PackageConfig]
sccs)
  where
    ignore_flags :: [IgnorePackageFlag]
ignore_flags = [IgnorePackageFlag] -> [IgnorePackageFlag]
forall a. [a] -> [a]
reverse (DynFlags -> [IgnorePackageFlag]
ignorePackageFlags DynFlags
dflags)

    -- Compute the reverse dependency index
    index :: RevIndex
index = InstalledPackageIndex -> RevIndex
reverseDeps InstalledPackageIndex
pkg_map1

    -- Helper function
    mk_unusable :: (t -> b)
-> (t
    -> InstalledPackageInfo
         compid srcpkgid srcpkgname k unitid modulename mod
    -> t)
-> t
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname k unitid modulename mod]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
mk_unusable t -> b
mk_err t
-> InstalledPackageInfo
     compid srcpkgid srcpkgname k unitid modulename mod
-> t
dep_matcher t
m [InstalledPackageInfo
   compid srcpkgid srcpkgname k unitid modulename mod]
uids =
      [(k,
  (InstalledPackageInfo
     compid srcpkgid srcpkgname k unitid modulename mod,
   b))]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
-> k
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg, (InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg, t -> b
mk_err (t
-> InstalledPackageInfo
     compid srcpkgid srcpkgname k unitid modulename mod
-> t
dep_matcher t
m InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg)))
                   | InstalledPackageInfo
  compid srcpkgid srcpkgname k unitid modulename mod
pkg <- [InstalledPackageInfo
   compid srcpkgid srcpkgname k unitid modulename mod]
uids ]

    -- Find broken packages
    directly_broken :: [PackageConfig]
directly_broken = (PackageConfig -> Bool) -> [PackageConfig] -> [PackageConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PackageConfig -> Bool) -> PackageConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledUnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([InstalledUnitId] -> Bool)
-> (PackageConfig -> [InstalledUnitId]) -> PackageConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsNotAvailable InstalledPackageIndex
pkg_map1)
                             (InstalledPackageIndex -> [PackageConfig]
forall k a. Map k a -> [a]
Map.elems InstalledPackageIndex
pkg_map1)
    (InstalledPackageIndex
pkg_map2, [PackageConfig]
broken) = [InstalledUnitId]
-> RevIndex
-> InstalledPackageIndex
-> (InstalledPackageIndex, [PackageConfig])
removePackages ((PackageConfig -> InstalledUnitId)
-> [PackageConfig] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId [PackageConfig]
directly_broken) RevIndex
index InstalledPackageIndex
pkg_map1
    unusable_broken :: UnusablePackages
unusable_broken = ([InstalledUnitId] -> UnusablePackageReason)
-> (InstalledPackageIndex -> PackageConfig -> [InstalledUnitId])
-> InstalledPackageIndex
-> [PackageConfig]
-> UnusablePackages
forall k t b t compid srcpkgid srcpkgname unitid modulename mod.
Ord k =>
(t -> b)
-> (t
    -> InstalledPackageInfo
         compid srcpkgid srcpkgname k unitid modulename mod
    -> t)
-> t
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname k unitid modulename mod]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
mk_unusable [InstalledUnitId] -> UnusablePackageReason
BrokenDependencies InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsNotAvailable InstalledPackageIndex
pkg_map2 [PackageConfig]
broken

    -- Find recursive packages
    sccs :: [SCC PackageConfig]
sccs = [(PackageConfig, InstalledUnitId, [InstalledUnitId])]
-> [SCC PackageConfig]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [ (PackageConfig
pkg, PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId PackageConfig
pkg, PackageConfig -> [InstalledUnitId]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends PackageConfig
pkg)
                            | PackageConfig
pkg <- InstalledPackageIndex -> [PackageConfig]
forall k a. Map k a -> [a]
Map.elems InstalledPackageIndex
pkg_map2 ]
    getCyclicSCC :: SCC
  (InstalledPackageInfo
     compid srcpkgid srcpkgname b unitid modulename mod)
-> [b]
getCyclicSCC (CyclicSCC [InstalledPackageInfo
   compid srcpkgid srcpkgname b unitid modulename mod]
vs) = (InstalledPackageInfo
   compid srcpkgid srcpkgname b unitid modulename mod
 -> b)
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname b unitid modulename mod]
-> [b]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo
  compid srcpkgid srcpkgname b unitid modulename mod
-> b
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId [InstalledPackageInfo
   compid srcpkgid srcpkgname b unitid modulename mod]
vs
    getCyclicSCC (AcyclicSCC InstalledPackageInfo
  compid srcpkgid srcpkgname b unitid modulename mod
_) = []
    (InstalledPackageIndex
pkg_map3, [PackageConfig]
cyclic) = [InstalledUnitId]
-> RevIndex
-> InstalledPackageIndex
-> (InstalledPackageIndex, [PackageConfig])
removePackages ((SCC PackageConfig -> [InstalledUnitId])
-> [SCC PackageConfig] -> [InstalledUnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC PackageConfig -> [InstalledUnitId]
forall compid srcpkgid srcpkgname b unitid modulename mod.
SCC
  (InstalledPackageInfo
     compid srcpkgid srcpkgname b unitid modulename mod)
-> [b]
getCyclicSCC [SCC PackageConfig]
sccs) RevIndex
index InstalledPackageIndex
pkg_map2
    unusable_cyclic :: UnusablePackages
unusable_cyclic = ([InstalledUnitId] -> UnusablePackageReason)
-> (InstalledPackageIndex -> PackageConfig -> [InstalledUnitId])
-> InstalledPackageIndex
-> [PackageConfig]
-> UnusablePackages
forall k t b t compid srcpkgid srcpkgname unitid modulename mod.
Ord k =>
(t -> b)
-> (t
    -> InstalledPackageInfo
         compid srcpkgid srcpkgname k unitid modulename mod
    -> t)
-> t
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname k unitid modulename mod]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
mk_unusable [InstalledUnitId] -> UnusablePackageReason
CyclicDependencies InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsNotAvailable InstalledPackageIndex
pkg_map3 [PackageConfig]
cyclic

    -- Apply ignore flags
    directly_ignored :: UnusablePackages
directly_ignored = [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages [IgnorePackageFlag]
ignore_flags (InstalledPackageIndex -> [PackageConfig]
forall k a. Map k a -> [a]
Map.elems InstalledPackageIndex
pkg_map3)
    (InstalledPackageIndex
pkg_map4, [PackageConfig]
ignored) = [InstalledUnitId]
-> RevIndex
-> InstalledPackageIndex
-> (InstalledPackageIndex, [PackageConfig])
removePackages (UnusablePackages -> [InstalledUnitId]
forall k a. Map k a -> [k]
Map.keys UnusablePackages
directly_ignored) RevIndex
index InstalledPackageIndex
pkg_map3
    unusable_ignored :: UnusablePackages
unusable_ignored = ([InstalledUnitId] -> UnusablePackageReason)
-> (InstalledPackageIndex -> PackageConfig -> [InstalledUnitId])
-> InstalledPackageIndex
-> [PackageConfig]
-> UnusablePackages
forall k t b t compid srcpkgid srcpkgname unitid modulename mod.
Ord k =>
(t -> b)
-> (t
    -> InstalledPackageInfo
         compid srcpkgid srcpkgname k unitid modulename mod
    -> t)
-> t
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname k unitid modulename mod]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
mk_unusable [InstalledUnitId] -> UnusablePackageReason
IgnoredDependencies InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsNotAvailable InstalledPackageIndex
pkg_map4 [PackageConfig]
ignored

    -- Knock out packages whose dependencies don't agree with ABI
    -- (i.e., got invalidated due to shadowing)
    directly_shadowed :: [PackageConfig]
directly_shadowed = (PackageConfig -> Bool) -> [PackageConfig] -> [PackageConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PackageConfig -> Bool) -> PackageConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledUnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([InstalledUnitId] -> Bool)
-> (PackageConfig -> [InstalledUnitId]) -> PackageConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsAbiMismatch InstalledPackageIndex
pkg_map4)
                               (InstalledPackageIndex -> [PackageConfig]
forall k a. Map k a -> [a]
Map.elems InstalledPackageIndex
pkg_map4)
    (InstalledPackageIndex
pkg_map5, [PackageConfig]
shadowed) = [InstalledUnitId]
-> RevIndex
-> InstalledPackageIndex
-> (InstalledPackageIndex, [PackageConfig])
removePackages ((PackageConfig -> InstalledUnitId)
-> [PackageConfig] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId [PackageConfig]
directly_shadowed) RevIndex
index InstalledPackageIndex
pkg_map4
    unusable_shadowed :: UnusablePackages
unusable_shadowed = ([InstalledUnitId] -> UnusablePackageReason)
-> (InstalledPackageIndex -> PackageConfig -> [InstalledUnitId])
-> InstalledPackageIndex
-> [PackageConfig]
-> UnusablePackages
forall k t b t compid srcpkgid srcpkgname unitid modulename mod.
Ord k =>
(t -> b)
-> (t
    -> InstalledPackageInfo
         compid srcpkgid srcpkgname k unitid modulename mod
    -> t)
-> t
-> [InstalledPackageInfo
      compid srcpkgid srcpkgname k unitid modulename mod]
-> Map
     k
     (InstalledPackageInfo
        compid srcpkgid srcpkgname k unitid modulename mod,
      b)
mk_unusable [InstalledUnitId] -> UnusablePackageReason
ShadowedDependencies InstalledPackageIndex -> PackageConfig -> [InstalledUnitId]
depsAbiMismatch InstalledPackageIndex
pkg_map5 [PackageConfig]
shadowed

    unusable :: UnusablePackages
unusable = UnusablePackages
directly_ignored UnusablePackages -> UnusablePackages -> UnusablePackages
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusablePackages
unusable_ignored
                                UnusablePackages -> UnusablePackages -> UnusablePackages
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusablePackages
unusable_broken
                                UnusablePackages -> UnusablePackages -> UnusablePackages
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusablePackages
unusable_cyclic
                                UnusablePackages -> UnusablePackages -> UnusablePackages
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusablePackages
unusable_shadowed

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

mkPackageState
    :: DynFlags
    -- initial databases, in the order they were specified on
    -- the command line (later databases shadow earlier ones)
    -> [(FilePath, [PackageConfig])]
    -> [PreloadUnitId]              -- preloaded packages
    -> IO (PackageState,
           [PreloadUnitId],         -- new packages to preload
           Maybe [(ModuleName, Module)])

mkPackageState :: DynFlags
-> [(String, [PackageConfig])]
-> [InstalledUnitId]
-> IO
     (PackageState, [InstalledUnitId], Maybe [(ModuleName, Module)])
mkPackageState DynFlags
dflags [(String, [PackageConfig])]
dbs [InstalledUnitId]
preload0 = do
{-
   Plan.

   There are two main steps for making the package state:

    1. We want to build a single, unified package database based
       on all of the input databases, which upholds the invariant that
       there is only one package per any UnitId and there are no
       dangling dependencies.  We'll do this by merging, and
       then successively filtering out bad dependencies.

       a) Merge all the databases together.
          If an input database defines unit ID that is already in
          the unified database, that package SHADOWS the existing
          package in the current unified database.  Note that
          order is important: packages defined later in the list of
          command line arguments shadow those defined earlier.

       b) Remove all packages with missing dependencies, or
          mutually recursive dependencies.

       b) Remove packages selected by -ignore-package from input database

       c) Remove all packages which depended on packages that are now
          shadowed by an ABI-incompatible package

       d) report (with -v) any packages that were removed by steps 1-3

    2. We want to look at the flags controlling package visibility,
       and build a mapping of what module names are in scope and
       where they live.

       a) on the final, unified database, we apply -trust/-distrust
          flags directly, modifying the database so that the 'trusted'
          field has the correct value.

       b) we use the -package/-hide-package flags to compute a
          visibility map, stating what packages are "exposed" for
          the purposes of computing the module map.
          * if any flag refers to a package which was removed by 1-5, then
            we can give an error message explaining why
          * if -hide-all-packages what not specified, this step also
            hides packages which are superseded by later exposed packages
          * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
            are used

       c) based on the visibility map, we pick wired packages and rewrite
          them to have the expected unitId.

       d) finally, using the visibility map and the package database,
          we build a mapping saying what every in scope module name points to.
-}

  -- This, and the other reverse's that you will see, are due to the face that
  -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
  -- than they are on the command line.
  let other_flags :: [PackageFlag]
other_flags = [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags)
  DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"package flags" SDoc -> SDoc -> SDoc
<+> [PackageFlag] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PackageFlag]
other_flags

  -- Merge databases together, without checking validity
  (InstalledPackageIndex
pkg_map1, PackagePrecedenceIndex
prec_map) <- DynFlags
-> [(String, [PackageConfig])]
-> IO (InstalledPackageIndex, PackagePrecedenceIndex)
mergeDatabases DynFlags
dflags [(String, [PackageConfig])]
dbs

  -- Now that we've merged everything together, prune out unusable
  -- packages.
  let (InstalledPackageIndex
pkg_map2, UnusablePackages
unusable, [SCC PackageConfig]
sccs) = DynFlags
-> InstalledPackageIndex
-> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])
validateDatabase DynFlags
dflags InstalledPackageIndex
pkg_map1

  DynFlags -> [SCC PackageConfig] -> IO ()
reportCycles DynFlags
dflags [SCC PackageConfig]
sccs
  DynFlags -> UnusablePackages -> IO ()
reportUnusable DynFlags
dflags UnusablePackages
unusable

  -- Apply trust flags (these flags apply regardless of whether
  -- or not packages are visible or not)
  [PackageConfig]
pkgs1 <- ([PackageConfig] -> TrustFlag -> IO [PackageConfig])
-> [PackageConfig] -> [TrustFlag] -> IO [PackageConfig]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> PackagePrecedenceIndex
-> UnusablePackages
-> [PackageConfig]
-> TrustFlag
-> IO [PackageConfig]
applyTrustFlag DynFlags
dflags PackagePrecedenceIndex
prec_map UnusablePackages
unusable)
                 (InstalledPackageIndex -> [PackageConfig]
forall k a. Map k a -> [a]
Map.elems InstalledPackageIndex
pkg_map2) ([TrustFlag] -> [TrustFlag]
forall a. [a] -> [a]
reverse (DynFlags -> [TrustFlag]
trustFlags DynFlags
dflags))
  let prelim_pkg_db :: PackageConfigMap
prelim_pkg_db = PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap PackageConfigMap
emptyPackageConfigMap [PackageConfig]
pkgs1

  --
  -- Calculate the initial set of units from package databases, prior to any package flags.
  --
  -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
  -- (not units). This is empty if we have -hide-all-packages.
  --
  -- Then we create an initial visibility map with default visibilities for all
  -- exposed, definite units which belong to the latest valid packages.
  --
  let preferLater :: PackageConfig -> PackageConfig -> PackageConfig
preferLater PackageConfig
unit PackageConfig
unit' =
        case PackagePrecedenceIndex
-> PackageConfig -> PackageConfig -> Ordering
compareByPreference PackagePrecedenceIndex
prec_map PackageConfig
unit PackageConfig
unit' of
            Ordering
GT -> PackageConfig
unit
            Ordering
_  -> PackageConfig
unit'
      addIfMorePreferable :: InstalledUnitIdMap PackageConfig
-> PackageConfig -> InstalledUnitIdMap PackageConfig
addIfMorePreferable InstalledUnitIdMap PackageConfig
m PackageConfig
unit = (PackageConfig -> PackageConfig -> PackageConfig)
-> InstalledUnitIdMap PackageConfig
-> FastString
-> PackageConfig
-> InstalledUnitIdMap PackageConfig
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM_C PackageConfig -> PackageConfig -> PackageConfig
preferLater InstalledUnitIdMap PackageConfig
m (PackageConfig -> FastString
fsPackageName PackageConfig
unit) PackageConfig
unit
      -- This is the set of maximally preferable packages. In fact, it is a set of
      -- most preferable *units* keyed by package name, which act as stand-ins in
      -- for "a package in a database". We use units here because we don't have
      -- "a package in a database" as a type currently.
      mostPreferablePackageReps :: InstalledUnitIdMap PackageConfig
mostPreferablePackageReps = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags
                    then InstalledUnitIdMap PackageConfig
forall elt. UniqDFM elt
emptyUDFM
                    else (InstalledUnitIdMap PackageConfig
 -> PackageConfig -> InstalledUnitIdMap PackageConfig)
-> InstalledUnitIdMap PackageConfig
-> [PackageConfig]
-> InstalledUnitIdMap PackageConfig
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstalledUnitIdMap PackageConfig
-> PackageConfig -> InstalledUnitIdMap PackageConfig
addIfMorePreferable InstalledUnitIdMap PackageConfig
forall elt. UniqDFM elt
emptyUDFM [PackageConfig]
pkgs1
      -- When exposing units, we want to consider all of those in the most preferable
      -- packages. We can implement that by looking for units that are equi-preferable
      -- with the most preferable unit for package. Being equi-preferable means that
      -- they must be in the same database, with the same version, and the same pacakge name.
      --
      -- We must take care to consider all these units and not just the most
      -- preferable one, otherwise we can end up with problems like #16228.
      mostPreferable :: PackageConfig -> Bool
mostPreferable PackageConfig
u =
        case InstalledUnitIdMap PackageConfig
-> FastString -> Maybe PackageConfig
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstalledUnitIdMap PackageConfig
mostPreferablePackageReps (PackageConfig -> FastString
fsPackageName PackageConfig
u) of
          Maybe PackageConfig
Nothing -> Bool
False
          Just PackageConfig
u' -> PackagePrecedenceIndex
-> PackageConfig -> PackageConfig -> Ordering
compareByPreference PackagePrecedenceIndex
prec_map PackageConfig
u PackageConfig
u' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
      vis_map1 :: VisibilityMap
vis_map1 = (VisibilityMap -> PackageConfig -> VisibilityMap)
-> VisibilityMap -> [PackageConfig] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\VisibilityMap
vm PackageConfig
p ->
                            -- Note: we NEVER expose indefinite packages by
                            -- default, because it's almost assuredly not
                            -- what you want (no mix-in linking has occurred).
                            if PackageConfig -> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
exposed PackageConfig
p Bool -> Bool -> Bool
&& UnitId -> Bool
unitIdIsDefinite (PackageConfig -> UnitId
packageConfigId PackageConfig
p) Bool -> Bool -> Bool
&& PackageConfig -> Bool
mostPreferable PackageConfig
p
                               then UnitId -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PackageConfig -> UnitId
packageConfigId PackageConfig
p)
                                               UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set IndefModule)
-> Bool
-> UnitVisibility
UnitVisibility {
                                                 uv_expose_all :: Bool
uv_expose_all = Bool
True,
                                                 uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = [],
                                                 uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (PackageConfig -> FastString
fsPackageName PackageConfig
p)),
                                                 uv_requirements :: Map ModuleName (Set IndefModule)
uv_requirements = Map ModuleName (Set IndefModule)
forall k a. Map k a
Map.empty,
                                                 uv_explicit :: Bool
uv_explicit = Bool
False
                                               }
                                               VisibilityMap
vm
                               else VisibilityMap
vm)
                         VisibilityMap
forall k a. Map k a
Map.empty [PackageConfig]
pkgs1

  --
  -- Compute a visibility map according to the command-line flags (-package,
  -- -hide-package).  This needs to know about the unusable packages, since if a
  -- user tries to enable an unusable package, we should let them know.
  --
  VisibilityMap
vis_map2 <- (VisibilityMap -> PackageFlag -> IO VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> IO VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> PackagePrecedenceIndex
-> PackageConfigMap
-> UnusablePackages
-> Bool
-> [PackageConfig]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag DynFlags
dflags PackagePrecedenceIndex
prec_map PackageConfigMap
prelim_pkg_db UnusablePackages
unusable
                        (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags) [PackageConfig]
pkgs1)
                            VisibilityMap
vis_map1 [PackageFlag]
other_flags

  --
  -- Sort out which packages are wired in. This has to be done last, since
  -- it modifies the unit ids of wired in packages, but when we process
  -- package arguments we need to key against the old versions.
  --
  ([PackageConfig]
pkgs2, Map WiredUnitId WiredUnitId
wired_map) <- DynFlags
-> PackagePrecedenceIndex
-> [PackageConfig]
-> VisibilityMap
-> IO ([PackageConfig], Map WiredUnitId WiredUnitId)
findWiredInPackages DynFlags
dflags PackagePrecedenceIndex
prec_map [PackageConfig]
pkgs1 VisibilityMap
vis_map2
  let pkg_db :: PackageConfigMap
pkg_db = PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap PackageConfigMap
emptyPackageConfigMap [PackageConfig]
pkgs2

  -- Update the visibility map, so we treat wired packages as visible.
  let vis_map :: VisibilityMap
vis_map = Map WiredUnitId WiredUnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map WiredUnitId WiredUnitId
wired_map VisibilityMap
vis_map2

  let hide_plugin_pkgs :: Bool
hide_plugin_pkgs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPluginPackages DynFlags
dflags
  VisibilityMap
plugin_vis_map <-
    case DynFlags -> [PackageFlag]
pluginPackageFlags DynFlags
dflags of
        -- common case; try to share the old vis_map
        [] | Bool -> Bool
not Bool
hide_plugin_pkgs -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vis_map
           | Bool
otherwise -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
forall k a. Map k a
Map.empty
        [PackageFlag]
_ -> do let plugin_vis_map1 :: VisibilityMap
plugin_vis_map1
                        | Bool
hide_plugin_pkgs = VisibilityMap
forall k a. Map k a
Map.empty
                        -- Use the vis_map PRIOR to wired in,
                        -- because otherwise applyPackageFlag
                        -- won't work.
                        | Bool
otherwise = VisibilityMap
vis_map2
                VisibilityMap
plugin_vis_map2
                    <- (VisibilityMap -> PackageFlag -> IO VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> IO VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> PackagePrecedenceIndex
-> PackageConfigMap
-> UnusablePackages
-> Bool
-> [PackageConfig]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag DynFlags
dflags PackagePrecedenceIndex
prec_map PackageConfigMap
prelim_pkg_db UnusablePackages
unusable
                                (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPluginPackages DynFlags
dflags) [PackageConfig]
pkgs1)
                             VisibilityMap
plugin_vis_map1
                             ([PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (DynFlags -> [PackageFlag]
pluginPackageFlags DynFlags
dflags))
                -- Updating based on wired in packages is mostly
                -- good hygiene, because it won't matter: no wired in
                -- package has a compiler plugin.
                -- TODO: If a wired in package had a compiler plugin,
                -- and you tried to pick different wired in packages
                -- with the plugin flags and the normal flags... what
                -- would happen?  I don't know!  But this doesn't seem
                -- likely to actually happen.
                VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WiredUnitId WiredUnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map WiredUnitId WiredUnitId
wired_map VisibilityMap
plugin_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.
  --
  -- NB: preload IS important even for type-checking, because we
  -- need the correct include path to be set.
  --
  let preload1 :: [UnitId]
preload1 = VisibilityMap -> [UnitId]
forall k a. Map k a -> [k]
Map.keys ((UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter UnitVisibility -> Bool
uv_explicit VisibilityMap
vis_map)

  let pkgname_map :: Map PackageName ComponentId
pkgname_map = (Map PackageName ComponentId
 -> PackageConfig -> Map PackageName ComponentId)
-> Map PackageName ComponentId
-> [PackageConfig]
-> Map PackageName ComponentId
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PackageName ComponentId
-> PackageConfig -> Map PackageName ComponentId
forall srcpkgname a srcpkgid instunitid unitid modulename mod.
Ord srcpkgname =>
Map srcpkgname a
-> InstalledPackageInfo
     a srcpkgid srcpkgname instunitid unitid modulename mod
-> Map srcpkgname a
add Map PackageName ComponentId
forall k a. Map k a
Map.empty [PackageConfig]
pkgs2
        where add :: Map srcpkgname a
-> InstalledPackageInfo
     a srcpkgid srcpkgname instunitid unitid modulename mod
-> Map srcpkgname a
add Map srcpkgname a
pn_map InstalledPackageInfo
  a srcpkgid srcpkgname instunitid unitid modulename mod
p
                = srcpkgname -> a -> Map srcpkgname a -> Map srcpkgname a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (InstalledPackageInfo
  a srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
packageName InstalledPackageInfo
  a srcpkgid srcpkgname instunitid unitid modulename mod
p) (InstalledPackageInfo
  a srcpkgid srcpkgname instunitid unitid modulename mod
-> a
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> compid
componentId InstalledPackageInfo
  a srcpkgid srcpkgname instunitid unitid modulename mod
p) Map srcpkgname a
pn_map

  -- The explicitPackages accurately reflects the set of packages we have turned
  -- on; as such, it also is the only way one can come up with requirements.
  -- The requirement context is directly based off of this: we simply
  -- look for nested unit IDs that are directly fed holes: the requirements
  -- of those units are precisely the ones we need to track
  let explicit_pkgs :: [UnitId]
explicit_pkgs = VisibilityMap -> [UnitId]
forall k a. Map k a -> [k]
Map.keys VisibilityMap
vis_map
      req_ctx :: Map ModuleName [IndefModule]
req_ctx = (Set IndefModule -> [IndefModule])
-> Map ModuleName (Set IndefModule) -> Map ModuleName [IndefModule]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Set IndefModule -> [IndefModule]
forall a. Set a -> [a]
Set.toList)
              (Map ModuleName (Set IndefModule) -> Map ModuleName [IndefModule])
-> Map ModuleName (Set IndefModule) -> Map ModuleName [IndefModule]
forall a b. (a -> b) -> a -> b
$ (Set IndefModule -> Set IndefModule -> Set IndefModule)
-> [Map ModuleName (Set IndefModule)]
-> Map ModuleName (Set IndefModule)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set IndefModule -> Set IndefModule -> Set IndefModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((UnitVisibility -> Map ModuleName (Set IndefModule))
-> [UnitVisibility] -> [Map ModuleName (Set IndefModule)]
forall a b. (a -> b) -> [a] -> [b]
map UnitVisibility -> Map ModuleName (Set IndefModule)
uv_requirements (VisibilityMap -> [UnitVisibility]
forall k a. Map k a -> [a]
Map.elems VisibilityMap
vis_map))


  let preload2 :: [UnitId]
preload2 = [UnitId]
preload1

  let
      -- add base & rts to the preload packages
      basicLinkedPackages :: [UnitId]
basicLinkedPackages
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoLinkPackages DynFlags
dflags
          = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> InstalledUnitIdMap PackageConfig -> Bool)
-> InstalledUnitIdMap PackageConfig -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> InstalledUnitIdMap PackageConfig -> Bool
forall key elt. Uniquable key => key -> UniqDFM elt -> Bool
elemUDFM (PackageConfigMap -> InstalledUnitIdMap PackageConfig
unPackageConfigMap PackageConfigMap
pkg_db))
                [UnitId
baseUnitId, UnitId
rtsUnitId]
       | Bool
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
      -- (NB: since this is only relevant for base/rts it doesn't matter
      -- that thisUnitIdInsts_ is not wired yet)
      --
      preload3 :: [UnitId]
preload3 = [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
ordNub ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
thisPackage DynFlags
dflags)
                        ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ([UnitId]
basicLinkedPackages [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
preload2)

  -- Close the preload packages with their dependencies
  [InstalledUnitId]
dep_preload <- DynFlags
-> PackageConfigMap
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> IO [InstalledUnitId]
closeDeps DynFlags
dflags PackageConfigMap
pkg_db ([InstalledUnitId]
-> [Maybe InstalledUnitId]
-> [(InstalledUnitId, Maybe InstalledUnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((UnitId -> InstalledUnitId) -> [UnitId] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> InstalledUnitId
toInstalledUnitId [UnitId]
preload3) (Maybe InstalledUnitId -> [Maybe InstalledUnitId]
forall a. a -> [a]
repeat Maybe InstalledUnitId
forall a. Maybe a
Nothing))
  let new_dep_preload :: [InstalledUnitId]
new_dep_preload = (InstalledUnitId -> Bool) -> [InstalledUnitId] -> [InstalledUnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstalledUnitId -> [InstalledUnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InstalledUnitId]
preload0) [InstalledUnitId]
dep_preload

  let mod_map1 :: ModuleToPkgConfAll
mod_map1 = DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll
mkModuleToPkgConfAll DynFlags
dflags PackageConfigMap
pkg_db VisibilityMap
vis_map
      mod_map2 :: ModuleToPkgConfAll
mod_map2 = UnusablePackages -> ModuleToPkgConfAll
mkUnusableModuleToPkgConfAll UnusablePackages
unusable
      mod_map :: ModuleToPkgConfAll
mod_map = ModuleToPkgConfAll -> ModuleToPkgConfAll -> ModuleToPkgConfAll
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ModuleToPkgConfAll
mod_map1 ModuleToPkgConfAll
mod_map2

  DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn (DynFlags
dflags { pprCols :: Int
pprCols = Int
200 }) DumpFlag
Opt_D_dump_mod_map String
"Mod Map"
    (ModuleToPkgConfAll -> SDoc
pprModuleMap ModuleToPkgConfAll
mod_map)

  -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
  let !pstate :: PackageState
pstate = PackageState :: PackageConfigMap
-> Map PackageName ComponentId
-> Map WiredUnitId WiredUnitId
-> [InstalledUnitId]
-> [UnitId]
-> ModuleToPkgConfAll
-> ModuleToPkgConfAll
-> Map ModuleName [IndefModule]
-> PackageState
PackageState{
    preloadPackages :: [InstalledUnitId]
preloadPackages     = [InstalledUnitId]
dep_preload,
    explicitPackages :: [UnitId]
explicitPackages    = [UnitId]
explicit_pkgs,
    pkgIdMap :: PackageConfigMap
pkgIdMap            = PackageConfigMap
pkg_db,
    moduleToPkgConfAll :: ModuleToPkgConfAll
moduleToPkgConfAll  = ModuleToPkgConfAll
mod_map,
    pluginModuleToPkgConfAll :: ModuleToPkgConfAll
pluginModuleToPkgConfAll = DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll
mkModuleToPkgConfAll DynFlags
dflags PackageConfigMap
pkg_db VisibilityMap
plugin_vis_map,
    packageNameMap :: Map PackageName ComponentId
packageNameMap          = Map PackageName ComponentId
pkgname_map,
    unwireMap :: Map WiredUnitId WiredUnitId
unwireMap = [(WiredUnitId, WiredUnitId)] -> Map WiredUnitId WiredUnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (WiredUnitId
v,WiredUnitId
k) | (WiredUnitId
k,WiredUnitId
v) <- Map WiredUnitId WiredUnitId -> [(WiredUnitId, WiredUnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map WiredUnitId WiredUnitId
wired_map ],
    requirementContext :: Map ModuleName [IndefModule]
requirementContext = Map ModuleName [IndefModule]
req_ctx
    }
  let new_insts :: Maybe [(ModuleName, Module)]
new_insts = ([(ModuleName, Module)] -> [(ModuleName, Module)])
-> Maybe [(ModuleName, Module)] -> Maybe [(ModuleName, Module)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map ((Module -> Module) -> (ModuleName, Module) -> (ModuleName, Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map WiredUnitId WiredUnitId -> Module -> Module
upd_wired_in_mod Map WiredUnitId WiredUnitId
wired_map))) (DynFlags -> Maybe [(ModuleName, Module)]
thisUnitIdInsts_ DynFlags
dflags)
  (PackageState, [InstalledUnitId], Maybe [(ModuleName, Module)])
-> IO
     (PackageState, [InstalledUnitId], Maybe [(ModuleName, Module)])
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageState
pstate, [InstalledUnitId]
new_dep_preload, Maybe [(ModuleName, Module)]
new_insts)

-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
-- that it was recorded as in the package database.
unwireUnitId :: DynFlags -> UnitId -> UnitId
unwireUnitId :: DynFlags -> UnitId -> UnitId
unwireUnitId DynFlags
dflags uid :: UnitId
uid@(DefiniteUnitId WiredUnitId
def_uid) =
    UnitId -> (WiredUnitId -> UnitId) -> Maybe WiredUnitId -> UnitId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UnitId
uid WiredUnitId -> UnitId
DefiniteUnitId (WiredUnitId -> Map WiredUnitId WiredUnitId -> Maybe WiredUnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WiredUnitId
def_uid (PackageState -> Map WiredUnitId WiredUnitId
unwireMap (DynFlags -> PackageState
pkgState DynFlags
dflags)))
unwireUnitId DynFlags
_ UnitId
uid = UnitId
uid

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

-- Slight irritation: we proceed by leafing through everything
-- in the installed package database, which makes handling indefinite
-- packages a bit bothersome.

mkModuleToPkgConfAll
  :: DynFlags
  -> PackageConfigMap
  -> VisibilityMap
  -> ModuleToPkgConfAll
mkModuleToPkgConfAll :: DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll
mkModuleToPkgConfAll DynFlags
dflags PackageConfigMap
pkg_db VisibilityMap
vis_map =
    -- What should we fold on?  Both situations are awkward:
    --
    --    * Folding on the visibility map means that we won't create
    --      entries for packages that aren't mentioned in vis_map
    --      (e.g., hidden packages, causing #14717)
    --
    --    * Folding on pkg_db is awkward because if we have an
    --      Backpack instantiation, we need to possibly add a
    --      package from pkg_db multiple times to the actual
    --      ModuleToPkgConfAll.  Also, we don't really want
    --      definite package instantiations to show up in the
    --      list of possibilities.
    --
    -- So what will we do instead?  We'll extend vis_map with
    -- entries for every definite (for non-Backpack) and
    -- indefinite (for Backpack) package, so that we get the
    -- hidden entries we need.
    (ModuleToPkgConfAll
 -> UnitId -> UnitVisibility -> ModuleToPkgConfAll)
-> ModuleToPkgConfAll -> VisibilityMap -> ModuleToPkgConfAll
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey ModuleToPkgConfAll
-> UnitId -> UnitVisibility -> ModuleToPkgConfAll
extend_modmap ModuleToPkgConfAll
forall k a. Map k a
emptyMap VisibilityMap
vis_map_extended
 where
  vis_map_extended :: VisibilityMap
vis_map_extended = VisibilityMap -> VisibilityMap -> VisibilityMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union VisibilityMap
vis_map {- preferred -} VisibilityMap
default_vis

  default_vis :: VisibilityMap
default_vis = [(UnitId, UnitVisibility)] -> VisibilityMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (PackageConfig -> UnitId
packageConfigId PackageConfig
pkg, UnitVisibility
forall a. Monoid a => a
mempty)
                  | PackageConfig
pkg <- InstalledUnitIdMap PackageConfig -> [PackageConfig]
forall elt. UniqDFM elt -> [elt]
eltsUDFM (PackageConfigMap -> InstalledUnitIdMap PackageConfig
unPackageConfigMap PackageConfigMap
pkg_db)
                  -- Exclude specific instantiations of an indefinite
                  -- package
                  , PackageConfig -> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
indefinite PackageConfig
pkg Bool -> Bool -> Bool
|| [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageConfig -> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, mod)]
instantiatedWith PackageConfig
pkg)
                  ]

  emptyMap :: Map k a
emptyMap = Map k a
forall k a. Map k a
Map.empty
  setOrigins :: f b -> b -> f b
setOrigins f b
m b
os = (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b -> b
forall a b. a -> b -> a
const b
os) f b
m
  extend_modmap :: ModuleToPkgConfAll
-> UnitId -> UnitVisibility -> ModuleToPkgConfAll
extend_modmap ModuleToPkgConfAll
modmap UnitId
uid
    UnitVisibility { uv_expose_all :: UnitVisibility -> Bool
uv_expose_all = Bool
b, uv_renamings :: UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns }
    = ModuleToPkgConfAll
-> [(ModuleName, Map Module ModuleOrigin)] -> ModuleToPkgConfAll
forall a k1 k2.
(Monoid a, Ord k1, Ord k2) =>
Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo ModuleToPkgConfAll
modmap [(ModuleName, Map Module ModuleOrigin)]
theBindings
   where
    pkg :: PackageConfig
pkg = UnitId -> PackageConfig
pkg_lookup UnitId
uid

    theBindings :: [(ModuleName, Map Module ModuleOrigin)]
    theBindings :: [(ModuleName, Map Module ModuleOrigin)]
theBindings = Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
newBindings Bool
b [(ModuleName, ModuleName)]
rns

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

    rnBinding :: (ModuleName, ModuleName)
              -> (ModuleName, Map Module ModuleOrigin)
    rnBinding :: (ModuleName, ModuleName) -> (ModuleName, Map Module ModuleOrigin)
rnBinding (ModuleName
orig, ModuleName
new) = (ModuleName
new, Map Module ModuleOrigin -> ModuleOrigin -> Map Module ModuleOrigin
forall (f :: * -> *) b b. Functor f => f b -> b -> f b
setOrigins Map Module ModuleOrigin
origEntry ModuleOrigin
fromFlag)
     where origEntry :: Map Module ModuleOrigin
origEntry = case UniqFM (Map Module ModuleOrigin)
-> ModuleName -> Maybe (Map Module ModuleOrigin)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Map Module ModuleOrigin)
esmap ModuleName
orig of
            Just Map Module ModuleOrigin
r -> Map Module ModuleOrigin
r
            Maybe (Map Module ModuleOrigin)
Nothing -> GhcException -> Map Module ModuleOrigin
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
                        (String -> SDoc
text String
"package flag: could not find module name" SDoc -> SDoc -> SDoc
<+>
                            ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
orig SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in package" SDoc -> SDoc -> SDoc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pk)))

    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
es Bool
e = do
     (ModuleName
m, Maybe Module
exposedReexport) <- [(ModuleName, Maybe Module)]
exposed_mods
     let (UnitId
pk', ModuleName
m', ModuleOrigin
origin') =
          case Maybe Module
exposedReexport of
           Maybe Module
Nothing -> (UnitId
pk, ModuleName
m, Bool -> ModuleOrigin
fromExposedModules Bool
e)
           Just (Module UnitId
pk' ModuleName
m') ->
            let pkg' :: PackageConfig
pkg' = UnitId -> PackageConfig
pkg_lookup UnitId
pk'
            in (UnitId
pk', ModuleName
m', Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules Bool
e PackageConfig
pkg')
     (ModuleName, Map Module ModuleOrigin)
-> [(ModuleName, Map Module ModuleOrigin)]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m, UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap UnitId
pk' ModuleName
m' ModuleOrigin
origin')

    esmap :: UniqFM (Map Module ModuleOrigin)
    esmap :: UniqFM (Map Module ModuleOrigin)
esmap = [(ModuleName, Map Module ModuleOrigin)]
-> UniqFM (Map Module ModuleOrigin)
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM (Bool -> [(ModuleName, Map Module ModuleOrigin)]
es Bool
False) -- parameter here doesn't matter, orig will
                                 -- be overwritten

    hiddens :: [(ModuleName, Map Module ModuleOrigin)]
hiddens = [(ModuleName
m, UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap UnitId
pk ModuleName
m ModuleOrigin
ModHidden) | ModuleName
m <- [ModuleName]
hidden_mods]

    pk :: UnitId
pk = PackageConfig -> UnitId
packageConfigId PackageConfig
pkg
    pkg_lookup :: UnitId -> PackageConfig
pkg_lookup UnitId
uid = Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' (DynFlags -> Bool
isIndefinite DynFlags
dflags) PackageConfigMap
pkg_db UnitId
uid
                        Maybe PackageConfig -> PackageConfig -> PackageConfig
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> PackageConfig
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pkg_lookup" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid)

    exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
pkg
    hidden_mods :: [ModuleName]
hidden_mods = PackageConfig -> [ModuleName]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [modulename]
hiddenModules PackageConfig
pkg

-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages.
mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll
mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll
mkUnusableModuleToPkgConfAll UnusablePackages
unusables =
    (ModuleToPkgConfAll
 -> (PackageConfig, UnusablePackageReason) -> ModuleToPkgConfAll)
-> ModuleToPkgConfAll -> UnusablePackages -> ModuleToPkgConfAll
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' ModuleToPkgConfAll
-> (PackageConfig, UnusablePackageReason) -> ModuleToPkgConfAll
extend_modmap ModuleToPkgConfAll
forall k a. Map k a
Map.empty UnusablePackages
unusables
 where
    extend_modmap :: ModuleToPkgConfAll
-> (PackageConfig, UnusablePackageReason) -> ModuleToPkgConfAll
extend_modmap ModuleToPkgConfAll
modmap (PackageConfig
pkg, UnusablePackageReason
reason) = ModuleToPkgConfAll
-> [(ModuleName, Map Module ModuleOrigin)] -> ModuleToPkgConfAll
forall a k1 k2.
(Monoid a, Ord k1, Ord k2) =>
Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo ModuleToPkgConfAll
modmap [(ModuleName, Map Module ModuleOrigin)]
bindings
      where bindings :: [(ModuleName, Map Module ModuleOrigin)]
            bindings :: [(ModuleName, Map Module ModuleOrigin)]
bindings = [(ModuleName, Map Module ModuleOrigin)]
exposed [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ [(ModuleName, Map Module ModuleOrigin)]
hidden

            origin :: ModuleOrigin
origin = UnusablePackageReason -> ModuleOrigin
ModUnusable UnusablePackageReason
reason
            pkg_id :: UnitId
pkg_id = PackageConfig -> UnitId
packageConfigId PackageConfig
pkg

            exposed :: [(ModuleName, Map Module ModuleOrigin)]
exposed = ((ModuleName, Maybe Module)
 -> (ModuleName, Map Module ModuleOrigin))
-> [(ModuleName, Maybe Module)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Maybe Module) -> (ModuleName, Map Module ModuleOrigin)
get_exposed [(ModuleName, Maybe Module)]
exposed_mods
            hidden :: [(ModuleName, Map Module ModuleOrigin)]
hidden = [(ModuleName
m, UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap UnitId
pkg_id ModuleName
m ModuleOrigin
origin) | ModuleName
m <- [ModuleName]
hidden_mods]

            get_exposed :: (ModuleName, Maybe Module) -> (ModuleName, Map Module ModuleOrigin)
get_exposed (ModuleName
mod, Just Module
mod') = (ModuleName
mod, Module -> ModuleOrigin -> Map Module ModuleOrigin
forall k a. k -> a -> Map k a
Map.singleton Module
mod' ModuleOrigin
origin)
            get_exposed (ModuleName
mod, Maybe Module
_)         = (ModuleName
mod, UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap UnitId
pkg_id ModuleName
mod ModuleOrigin
origin)

            exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
pkg
            hidden_mods :: [ModuleName]
hidden_mods = PackageConfig -> [ModuleName]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [modulename]
hiddenModules PackageConfig
pkg

-- | Add a list of key/value pairs to a nested map.
--
-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
-- when reloading modules in GHCi (see #4029). This ensures that each
-- value is forced before installing into the map.
addListTo :: (Monoid a, Ord k1, Ord k2)
          => Map k1 (Map k2 a)
          -> [(k1, Map k2 a)]
          -> Map k1 (Map k2 a)
addListTo :: Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo = (Map k1 (Map k2 a) -> (k1, Map k2 a) -> Map k1 (Map k2 a))
-> Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map k1 (Map k2 a) -> (k1, Map k2 a) -> Map k1 (Map k2 a)
forall k k a.
(Ord k, Ord k, Monoid a) =>
Map k (Map k a) -> (k, Map k a) -> Map k (Map k a)
merge
  where merge :: Map k (Map k a) -> (k, Map k a) -> Map k (Map k a)
merge Map k (Map k a)
m (k
k, Map k a
v) = (Map k a -> Map k a -> Map k a)
-> k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapStrict.insertWith ((a -> a -> a) -> Map k a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) k
k Map k a
v Map k (Map k a)
m

-- | Create a singleton module mapping
mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap UnitId
pkg ModuleName
mod = Module -> ModuleOrigin -> Map Module ModuleOrigin
forall k a. k -> a -> Map k a
Map.singleton (UnitId -> ModuleName -> Module
mkModule UnitId
pkg ModuleName
mod)

-- -----------------------------------------------------------------------------
-- 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 -> [PreloadUnitId] -> IO [String]
getPackageIncludePath :: DynFlags -> [InstalledUnitId] -> IO [String]
getPackageIncludePath DynFlags
dflags [InstalledUnitId]
pkgs =
  [PackageConfig] -> [String]
collectIncludeDirs ([PackageConfig] -> [String]) -> IO [PackageConfig] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs

collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs :: [PackageConfig] -> [String]
collectIncludeDirs [PackageConfig]
ps = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ((PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
includeDirs [PackageConfig]
ps))

-- | Find all the library paths in these and the preload packages
getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageLibraryPath :: DynFlags -> [InstalledUnitId] -> IO [String]
getPackageLibraryPath DynFlags
dflags [InstalledUnitId]
pkgs =
  DynFlags -> [PackageConfig] -> [String]
collectLibraryPaths DynFlags
dflags ([PackageConfig] -> [String]) -> IO [PackageConfig] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs

collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath]
collectLibraryPaths :: DynFlags -> [PackageConfig] -> [String]
collectLibraryPaths DynFlags
dflags = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> ([PackageConfig] -> [String]) -> [PackageConfig] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull
                           ([String] -> [String])
-> ([PackageConfig] -> [String]) -> [PackageConfig] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> PackageConfig -> [String]
libraryDirsForWay DynFlags
dflags)

-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String])
getPackageLinkOpts :: DynFlags -> [InstalledUnitId] -> IO ([String], [String], [String])
getPackageLinkOpts DynFlags
dflags [InstalledUnitId]
pkgs =
  DynFlags -> [PackageConfig] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags ([PackageConfig] -> ([String], [String], [String]))
-> IO [PackageConfig] -> IO ([String], [String], [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs

collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags [PackageConfig]
ps =
    (
        (PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (PackageConfig -> [String]) -> PackageConfig -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PackageConfig -> [String]
packageHsLibs DynFlags
dflags) [PackageConfig]
ps,
        (PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (PackageConfig -> [String]) -> PackageConfig -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
extraLibraries) [PackageConfig]
ps,
        (PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
ldOptions [PackageConfig]
ps
    )
collectArchives :: DynFlags -> PackageConfig -> IO [FilePath]
collectArchives :: DynFlags -> PackageConfig -> IO [String]
collectArchives DynFlags
dflags PackageConfig
pc =
  (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [ String
searchPath String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a")
                        | String
searchPath <- [String]
searchPaths
                        , String
lib <- [String]
libs ]
  where searchPaths :: [String]
searchPaths = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> (PackageConfig -> [String]) -> PackageConfig -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ([String] -> [String])
-> (PackageConfig -> [String]) -> PackageConfig -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PackageConfig -> [String]
libraryDirsForWay DynFlags
dflags (PackageConfig -> [String]) -> PackageConfig -> [String]
forall a b. (a -> b) -> a -> b
$ PackageConfig
pc
        libs :: [String]
libs        = DynFlags -> PackageConfig -> [String]
packageHsLibs DynFlags
dflags PackageConfig
pc [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
extraLibraries PackageConfig
pc

getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)]
getLibs :: DynFlags -> [InstalledUnitId] -> IO [(String, String)]
getLibs DynFlags
dflags [InstalledUnitId]
pkgs = do
  [PackageConfig]
ps <- DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs
  ([[(String, String)]] -> [(String, String)])
-> IO [[(String, String)]] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(String, String)]] -> IO [(String, String)])
-> ((PackageConfig -> IO [(String, String)])
    -> IO [[(String, String)]])
-> (PackageConfig -> IO [(String, String)])
-> IO [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageConfig]
-> (PackageConfig -> IO [(String, String)])
-> IO [[(String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PackageConfig]
ps ((PackageConfig -> IO [(String, String)]) -> IO [(String, String)])
-> (PackageConfig -> IO [(String, String)])
-> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \PackageConfig
p -> do
    let candidates :: [(String, String)]
candidates = [ (String
l String -> String -> String
</> String
f, String
f) | String
l <- DynFlags -> [PackageConfig] -> [String]
collectLibraryPaths DynFlags
dflags [PackageConfig
p]
                                    , String
f <- (\String
n -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a") (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> PackageConfig -> [String]
packageHsLibs DynFlags
dflags PackageConfig
p ]
    ((String, String) -> IO Bool)
-> [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((String, String) -> String) -> (String, String) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
candidates

packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs DynFlags
dflags PackageConfig
p = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
mkDynName (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addSuffix) (PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
hsLibraries PackageConfig
p)
  where
        ways0 :: [Way]
ways0 = DynFlags -> [Way]
ways DynFlags
dflags

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

        -- debug and profiled RTSs include support for -eventlog
        ways2 :: [Way]
ways2 | Way
WayDebug Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Way]
ways1 Bool -> Bool -> Bool
|| Way
WayProf Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Way]
ways1
              = (Way -> Bool) -> [Way] -> [Way]
forall a. (a -> Bool) -> [a] -> [a]
filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayEventLog) [Way]
ways1
              | Bool
otherwise
              = [Way]
ways1

        tag :: String
tag     = [Way] -> String
mkBuildTag ((Way -> Bool) -> [Way] -> [Way]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Way -> Bool) -> Way -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> Bool
wayRTSOnly) [Way]
ways2)
        rts_tag :: String
rts_tag = [Way] -> String
mkBuildTag [Way]
ways2

        mkDynName :: String -> String
mkDynName String
x
         | Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` DynFlags -> [Way]
ways DynFlags
dflags = String
x
         | String
"HS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x          =
              String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:DynFlags -> String
programName DynFlags
dflags String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> String
projectVersion DynFlags
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 String
x' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"C" String
x = String
x'
         | Bool
otherwise
            = String -> String
forall a. String -> a
panic (String
"Don't understand library name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)

        -- Add _thr and other rts suffixes to packages named
        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts
        -- package is called `rts` only.  However the tooling
        -- usually expects a package name to have a version.
        -- As such we will gradually move towards the `rts-1.0`
        -- package name, at which point the `rts` package name
        -- will eventually be unused.
        --
        -- This change elevates the need to add custom hooks
        -- and handling specifically for the `rts` package for
        -- example in ghc-cabal.
        addSuffix :: String -> String
addSuffix rts :: String
rts@String
"HSrts"    = String
rts       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
        addSuffix rts :: String
rts@String
"HSrts-1.0"= String
rts       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
        addSuffix String
other_lib      = String
other_lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
tag)

        expandTag :: String -> String
expandTag String
t | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t = String
""
                    | Bool
otherwise = Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
t

-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way.
libraryDirsForWay :: DynFlags -> PackageConfig -> [String]
libraryDirsForWay :: DynFlags -> PackageConfig -> [String]
libraryDirsForWay DynFlags
dflags
  | Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags = PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDynDirs
  | Bool
otherwise                 = PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
libraryDirs

-- | Find all the C-compiler options in these and the preload packages
getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageExtraCcOpts :: DynFlags -> [InstalledUnitId] -> IO [String]
getPackageExtraCcOpts DynFlags
dflags [InstalledUnitId]
pkgs = do
  [PackageConfig]
ps <- DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
ccOptions [PackageConfig]
ps)

-- | Find all the package framework paths in these and the preload packages
getPackageFrameworkPath  :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageFrameworkPath :: DynFlags -> [InstalledUnitId] -> IO [String]
getPackageFrameworkPath DynFlags
dflags [InstalledUnitId]
pkgs = do
  [PackageConfig]
ps <- DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ((PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
frameworkDirs [PackageConfig]
ps)))

-- | Find all the package frameworks in these and the preload packages
getPackageFrameworks  :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageFrameworks :: DynFlags -> [InstalledUnitId] -> IO [String]
getPackageFrameworks DynFlags
dflags [InstalledUnitId]
pkgs = do
  [PackageConfig]
ps <- DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgs
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageConfig -> [String]) -> [PackageConfig] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
frameworks [PackageConfig]
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 :: DynFlags -> ModuleName -> [(Module, PackageConfig)]
lookupModuleInAllPackages DynFlags
dflags ModuleName
m
  = case DynFlags -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions DynFlags
dflags ModuleName
m Maybe FastString
forall a. Maybe a
Nothing of
      LookupFound Module
a PackageConfig
b -> [(Module
a,PackageConfig
b)]
      LookupMultiple [(Module, ModuleOrigin)]
rs -> ((Module, ModuleOrigin) -> (Module, PackageConfig))
-> [(Module, ModuleOrigin)] -> [(Module, PackageConfig)]
forall a b. (a -> b) -> [a] -> [b]
map (Module, ModuleOrigin) -> (Module, PackageConfig)
forall b. (Module, b) -> (Module, PackageConfig)
f [(Module, ModuleOrigin)]
rs
        where f :: (Module, b) -> (Module, PackageConfig)
f (Module
m,b
_) = (Module
m, String -> Maybe PackageConfig -> PackageConfig
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"lookupModule" (DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags
                                                         (Module -> UnitId
moduleUnitId Module
m)))
      LookupResult
_ -> []

-- | 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)]
    -- | No modules found, but there were some unusable ones with
    -- an exact name match
  | LookupUnusable [(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 :: DynFlags -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions DynFlags
dflags
  = DynFlags
-> ModuleToPkgConfAll
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' DynFlags
dflags
        (PackageState -> ModuleToPkgConfAll
moduleToPkgConfAll (DynFlags -> PackageState
pkgState DynFlags
dflags))

lookupPluginModuleWithSuggestions :: DynFlags
                                  -> ModuleName
                                  -> Maybe FastString
                                  -> LookupResult
lookupPluginModuleWithSuggestions :: DynFlags -> ModuleName -> Maybe FastString -> LookupResult
lookupPluginModuleWithSuggestions DynFlags
dflags
  = DynFlags
-> ModuleToPkgConfAll
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' DynFlags
dflags
        (PackageState -> ModuleToPkgConfAll
pluginModuleToPkgConfAll (DynFlags -> PackageState
pkgState DynFlags
dflags))

lookupModuleWithSuggestions' :: DynFlags
                            -> ModuleToPkgConfAll
                            -> ModuleName
                            -> Maybe FastString
                            -> LookupResult
lookupModuleWithSuggestions' :: DynFlags
-> ModuleToPkgConfAll
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' DynFlags
dflags ModuleToPkgConfAll
mod_map ModuleName
m Maybe FastString
mb_pn
  = case ModuleName -> ModuleToPkgConfAll -> Maybe (Map Module ModuleOrigin)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
m ModuleToPkgConfAll
mod_map of
        Maybe (Map Module ModuleOrigin)
Nothing -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
        Just Map Module ModuleOrigin
xs ->
          case (([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
  [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
 -> (Module, ModuleOrigin)
 -> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
     [(Module, ModuleOrigin)], [(Module, ModuleOrigin)]))
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)]
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
 [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
classify ([],[],[], []) (Map Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Module ModuleOrigin
xs) of
            ([], [], [], []) -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
            ([(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module
m, ModuleOrigin
_)])             -> Module -> PackageConfig -> LookupResult
LookupFound Module
m (Module -> PackageConfig
mod_pkg Module
m)
            ([(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, exposed :: [(Module, ModuleOrigin)]
exposed@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_))        -> [(Module, ModuleOrigin)] -> LookupResult
LookupMultiple [(Module, ModuleOrigin)]
exposed
            ([], [], unusable :: [(Module, ModuleOrigin)]
unusable@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_), [])    -> [(Module, ModuleOrigin)] -> LookupResult
LookupUnusable [(Module, ModuleOrigin)]
unusable
            ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
_, []) ->
              [(Module, ModuleOrigin)]
-> [(Module, ModuleOrigin)] -> LookupResult
LookupHidden [(Module, ModuleOrigin)]
hidden_pkg [(Module, ModuleOrigin)]
hidden_mod
  where
    classify :: ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
 [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
classify ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed) (Module
m, ModuleOrigin
origin0) =
      let origin :: ModuleOrigin
origin = Maybe FastString -> PackageConfig -> ModuleOrigin -> ModuleOrigin
filterOrigin Maybe FastString
mb_pn (Module -> PackageConfig
mod_pkg Module
m) ModuleOrigin
origin0
          x :: (Module, ModuleOrigin)
x = (Module
m, ModuleOrigin
origin)
      in case ModuleOrigin
origin of
          ModuleOrigin
ModHidden
            -> ([(Module, ModuleOrigin)]
hidden_pkg, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
          ModUnusable UnusablePackageReason
_
            -> ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
          ModuleOrigin
_ | ModuleOrigin -> Bool
originEmpty ModuleOrigin
origin
            -> ([(Module, ModuleOrigin)]
hidden_pkg,   [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
            | ModuleOrigin -> Bool
originVisible ModuleOrigin
origin
            -> ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
exposed)
            | Bool
otherwise
            -> ((Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)

    pkg_lookup :: UnitId -> PackageConfig
pkg_lookup UnitId
p = DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags UnitId
p Maybe PackageConfig -> PackageConfig -> PackageConfig
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> PackageConfig
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupModuleWithSuggestions" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
p SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m)
    mod_pkg :: Module -> PackageConfig
mod_pkg = UnitId -> PackageConfig
pkg_lookup (UnitId -> PackageConfig)
-> (Module -> UnitId) -> Module -> PackageConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId

    -- 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 :: Maybe FastString -> PackageConfig -> ModuleOrigin -> ModuleOrigin
filterOrigin Maybe FastString
Nothing PackageConfig
_ ModuleOrigin
o = ModuleOrigin
o
    filterOrigin (Just FastString
pn) PackageConfig
pkg ModuleOrigin
o =
      case ModuleOrigin
o of
          ModuleOrigin
ModHidden -> if PackageConfig -> Bool
go PackageConfig
pkg then ModuleOrigin
ModHidden else ModuleOrigin
forall a. Monoid a => a
mempty
          (ModUnusable UnusablePackageReason
_) -> if PackageConfig -> Bool
go PackageConfig
pkg then ModuleOrigin
o else ModuleOrigin
forall a. Monoid a => a
mempty
          ModOrigin { fromOrigPackage :: ModuleOrigin -> Maybe Bool
fromOrigPackage = Maybe Bool
e, fromExposedReexport :: ModuleOrigin -> [PackageConfig]
fromExposedReexport = [PackageConfig]
res,
                      fromHiddenReexport :: ModuleOrigin -> [PackageConfig]
fromHiddenReexport = [PackageConfig]
rhs }
            -> ModOrigin :: Maybe Bool
-> [PackageConfig] -> [PackageConfig] -> Bool -> ModuleOrigin
ModOrigin {
                  fromOrigPackage :: Maybe Bool
fromOrigPackage = if PackageConfig -> Bool
go PackageConfig
pkg then Maybe Bool
e else Maybe Bool
forall a. Maybe a
Nothing
                , fromExposedReexport :: [PackageConfig]
fromExposedReexport = (PackageConfig -> Bool) -> [PackageConfig] -> [PackageConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageConfig -> Bool
go [PackageConfig]
res
                , fromHiddenReexport :: [PackageConfig]
fromHiddenReexport = (PackageConfig -> Bool) -> [PackageConfig] -> [PackageConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageConfig -> Bool
go [PackageConfig]
rhs
                , fromPackageFlag :: Bool
fromPackageFlag = Bool
False -- always excluded
                }
      where go :: PackageConfig -> Bool
go PackageConfig
pkg = FastString
pn FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> FastString
fsPackageName PackageConfig
pkg

    suggestions :: [ModuleSuggestion]
suggestions
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HelpfulErrors DynFlags
dflags =
           String -> [(String, ModuleSuggestion)] -> [ModuleSuggestion]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (ModuleName -> String
moduleNameString ModuleName
m) [(String, ModuleSuggestion)]
all_mods
      | Bool
otherwise = []

    all_mods :: [(String, ModuleSuggestion)]     -- All modules
    all_mods :: [(String, ModuleSuggestion)]
all_mods = ((String, ModuleSuggestion)
 -> (String, ModuleSuggestion) -> Ordering)
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, ModuleSuggestion) -> String)
-> (String, ModuleSuggestion)
-> (String, ModuleSuggestion)
-> Ordering
forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing (String, ModuleSuggestion) -> String
forall a b. (a, b) -> a
fst) ([(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)])
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall a b. (a -> b) -> a -> b
$
        [ (ModuleName -> String
moduleNameString ModuleName
m, ModuleSuggestion
suggestion)
        | (ModuleName
m, Map Module ModuleOrigin
e) <- ModuleToPkgConfAll -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList (PackageState -> ModuleToPkgConfAll
moduleToPkgConfAll (DynFlags -> PackageState
pkgState DynFlags
dflags))
        , ModuleSuggestion
suggestion <- ((Module, ModuleOrigin) -> ModuleSuggestion)
-> [(Module, ModuleOrigin)] -> [ModuleSuggestion]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
m) (Map Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Module ModuleOrigin
e)
        ]
    getSuggestion :: ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
name (Module
mod, ModuleOrigin
origin) =
        (if ModuleOrigin -> Bool
originVisible ModuleOrigin
origin then ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestVisible else ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestHidden)
            ModuleName
name Module
mod ModuleOrigin
origin

listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames DynFlags
dflags =
    ((ModuleName, Map Module ModuleOrigin) -> ModuleName)
-> [(ModuleName, Map Module ModuleOrigin)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Map Module ModuleOrigin) -> ModuleName
forall a b. (a, b) -> a
fst (((ModuleName, Map Module ModuleOrigin) -> Bool)
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName, Map Module ModuleOrigin) -> Bool
forall a k. (a, Map k ModuleOrigin) -> Bool
visible (ModuleToPkgConfAll -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList (PackageState -> ModuleToPkgConfAll
moduleToPkgConfAll (DynFlags -> PackageState
pkgState DynFlags
dflags))))
  where visible :: (a, Map k ModuleOrigin) -> Bool
visible (a
_, Map k ModuleOrigin
ms) = (ModuleOrigin -> Bool) -> [ModuleOrigin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleOrigin -> Bool
originVisible (Map k ModuleOrigin -> [ModuleOrigin]
forall k a. Map k a -> [a]
Map.elems Map k ModuleOrigin
ms)

-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd :: DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
pkgids0 =
  let
      pkgids :: [InstalledUnitId]
pkgids  = [InstalledUnitId]
pkgids0 [InstalledUnitId] -> [InstalledUnitId] -> [InstalledUnitId]
forall a. [a] -> [a] -> [a]
++
                  -- An indefinite package will have insts to HOLE,
                  -- which is not a real package. Don't look it up.
                  -- Fixes #14525
                  if DynFlags -> Bool
isIndefinite DynFlags
dflags
                    then []
                    else ((ModuleName, Module) -> InstalledUnitId)
-> [(ModuleName, Module)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> InstalledUnitId
toInstalledUnitId (UnitId -> InstalledUnitId)
-> ((ModuleName, Module) -> UnitId)
-> (ModuleName, Module)
-> InstalledUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId (Module -> UnitId)
-> ((ModuleName, Module) -> Module)
-> (ModuleName, Module)
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd)
                             (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags)
      state :: PackageState
state   = DynFlags -> PackageState
pkgState DynFlags
dflags
      pkg_map :: PackageConfigMap
pkg_map = PackageState -> PackageConfigMap
pkgIdMap PackageState
state
      preload :: [InstalledUnitId]
preload = PackageState -> [InstalledUnitId]
preloadPackages PackageState
state
      pairs :: [(InstalledUnitId, Maybe a)]
pairs = [InstalledUnitId] -> [Maybe a] -> [(InstalledUnitId, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [InstalledUnitId]
pkgids (Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing)
  in do
  [InstalledUnitId]
all_pkgs <- DynFlags -> MaybeErr SDoc [InstalledUnitId] -> IO [InstalledUnitId]
forall a. DynFlags -> MaybeErr SDoc a -> IO a
throwErr DynFlags
dflags (([InstalledUnitId]
 -> (InstalledUnitId, Maybe InstalledUnitId)
 -> MaybeErr SDoc [InstalledUnitId])
-> [InstalledUnitId]
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> MaybeErr SDoc [InstalledUnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> PackageConfigMap
-> [InstalledUnitId]
-> (InstalledUnitId, Maybe InstalledUnitId)
-> MaybeErr SDoc [InstalledUnitId]
add_package DynFlags
dflags PackageConfigMap
pkg_map) [InstalledUnitId]
preload [(InstalledUnitId, Maybe InstalledUnitId)]
forall a. [(InstalledUnitId, Maybe a)]
pairs)
  [PackageConfig] -> IO [PackageConfig]
forall (m :: * -> *) a. Monad m => a -> m a
return ((InstalledUnitId -> PackageConfig)
-> [InstalledUnitId] -> [PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails DynFlags
dflags) [InstalledUnitId]
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
          -> [(InstalledUnitId, Maybe InstalledUnitId)]
          -> IO [InstalledUnitId]
closeDeps :: DynFlags
-> PackageConfigMap
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> IO [InstalledUnitId]
closeDeps DynFlags
dflags PackageConfigMap
pkg_map [(InstalledUnitId, Maybe InstalledUnitId)]
ps
    = DynFlags -> MaybeErr SDoc [InstalledUnitId] -> IO [InstalledUnitId]
forall a. DynFlags -> MaybeErr SDoc a -> IO a
throwErr DynFlags
dflags (DynFlags
-> PackageConfigMap
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> MaybeErr SDoc [InstalledUnitId]
closeDepsErr DynFlags
dflags PackageConfigMap
pkg_map [(InstalledUnitId, Maybe InstalledUnitId)]
ps)

throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr :: DynFlags -> MaybeErr SDoc a -> IO a
throwErr DynFlags
dflags MaybeErr SDoc a
m
              = case MaybeErr SDoc a
m of
                Failed SDoc
e    -> GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
CmdLineError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
e))
                Succeeded a
r -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

closeDepsErr :: DynFlags
             -> PackageConfigMap
             -> [(InstalledUnitId,Maybe InstalledUnitId)]
             -> MaybeErr MsgDoc [InstalledUnitId]
closeDepsErr :: DynFlags
-> PackageConfigMap
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> MaybeErr SDoc [InstalledUnitId]
closeDepsErr DynFlags
dflags PackageConfigMap
pkg_map [(InstalledUnitId, Maybe InstalledUnitId)]
ps = ([InstalledUnitId]
 -> (InstalledUnitId, Maybe InstalledUnitId)
 -> MaybeErr SDoc [InstalledUnitId])
-> [InstalledUnitId]
-> [(InstalledUnitId, Maybe InstalledUnitId)]
-> MaybeErr SDoc [InstalledUnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> PackageConfigMap
-> [InstalledUnitId]
-> (InstalledUnitId, Maybe InstalledUnitId)
-> MaybeErr SDoc [InstalledUnitId]
add_package DynFlags
dflags PackageConfigMap
pkg_map) [] [(InstalledUnitId, Maybe InstalledUnitId)]
ps

-- internal helper
add_package :: DynFlags
            -> PackageConfigMap
            -> [PreloadUnitId]
            -> (PreloadUnitId,Maybe PreloadUnitId)
            -> MaybeErr MsgDoc [PreloadUnitId]
add_package :: DynFlags
-> PackageConfigMap
-> [InstalledUnitId]
-> (InstalledUnitId, Maybe InstalledUnitId)
-> MaybeErr SDoc [InstalledUnitId]
add_package DynFlags
dflags PackageConfigMap
pkg_db [InstalledUnitId]
ps (InstalledUnitId
p, Maybe InstalledUnitId
mb_parent)
  | InstalledUnitId
p InstalledUnitId -> [InstalledUnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [InstalledUnitId]
ps = [InstalledUnitId] -> MaybeErr SDoc [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledUnitId]
ps     -- Check if we've already added this package
  | Bool
otherwise =
      case PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' PackageConfigMap
pkg_db InstalledUnitId
p of
        Maybe PackageConfig
Nothing -> SDoc -> MaybeErr SDoc [InstalledUnitId]
forall err val. err -> MaybeErr err val
Failed (InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
missingPackageMsg InstalledUnitId
p SDoc -> SDoc -> SDoc
<>
                           Maybe InstalledUnitId -> SDoc
missingDependencyMsg Maybe InstalledUnitId
mb_parent)
        Just PackageConfig
pkg -> do
           -- Add the package's dependents also
           [InstalledUnitId]
ps' <- ([InstalledUnitId]
 -> InstalledUnitId -> MaybeErr SDoc [InstalledUnitId])
-> [InstalledUnitId]
-> [InstalledUnitId]
-> MaybeErr SDoc [InstalledUnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [InstalledUnitId]
-> InstalledUnitId -> MaybeErr SDoc [InstalledUnitId]
add_unit_key [InstalledUnitId]
ps (PackageConfig -> [InstalledUnitId]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends PackageConfig
pkg)
           [InstalledUnitId] -> MaybeErr SDoc [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledUnitId
p InstalledUnitId -> [InstalledUnitId] -> [InstalledUnitId]
forall a. a -> [a] -> [a]
: [InstalledUnitId]
ps')
          where
            add_unit_key :: [InstalledUnitId]
-> InstalledUnitId -> MaybeErr SDoc [InstalledUnitId]
add_unit_key [InstalledUnitId]
ps InstalledUnitId
key
              = DynFlags
-> PackageConfigMap
-> [InstalledUnitId]
-> (InstalledUnitId, Maybe InstalledUnitId)
-> MaybeErr SDoc [InstalledUnitId]
add_package DynFlags
dflags PackageConfigMap
pkg_db [InstalledUnitId]
ps (InstalledUnitId
key, InstalledUnitId -> Maybe InstalledUnitId
forall a. a -> Maybe a
Just InstalledUnitId
p)

missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg :: pkgid -> SDoc
missingPackageMsg pkgid
p = String -> SDoc
text String
"unknown package:" SDoc -> SDoc -> SDoc
<+> pkgid -> SDoc
forall a. Outputable a => a -> SDoc
ppr pkgid
p

missingDependencyMsg :: Maybe InstalledUnitId -> SDoc
missingDependencyMsg :: Maybe InstalledUnitId -> SDoc
missingDependencyMsg Maybe InstalledUnitId
Nothing = SDoc
Outputable.empty
missingDependencyMsg (Just InstalledUnitId
parent)
  = SDoc
space SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"dependency of" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext (InstalledUnitId -> FastString
installedUnitIdFS InstalledUnitId
parent))

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

componentIdString :: DynFlags -> ComponentId -> Maybe String
componentIdString :: DynFlags -> ComponentId -> Maybe String
componentIdString DynFlags
dflags ComponentId
cid = do
    PackageConfig
conf <- DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags (ComponentId -> InstalledUnitId
componentIdToInstalledUnitId ComponentId
cid)
    String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
        case PackageConfig -> Maybe PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Maybe srcpkgname
sourceLibName PackageConfig
conf of
            Maybe PackageName
Nothing -> PackageConfig -> String
sourcePackageIdString PackageConfig
conf
            Just (PackageName FastString
libname) ->
                PackageConfig -> String
packageNameString PackageConfig
conf
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion (PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
packageVersion PackageConfig
conf)
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
libname

displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
displayInstalledUnitId DynFlags
dflags InstalledUnitId
uid =
    (PackageConfig -> String) -> Maybe PackageConfig -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageConfig -> String
sourcePackageIdString (DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags InstalledUnitId
uid)

-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that
-- the symbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows
isDllName :: DynFlags -> Module -> Name -> Bool
isDllName DynFlags
dflags Module
this_mod Name
name
  | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs DynFlags
dflags) = Bool
False
  | Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
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.
    = case Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags of
        -- On Windows the hack for #8696 makes it unlinkable.
        -- As the entire setup of the code from Cmm down to the RTS expects
        -- the use of trampolines for the imported functions only when
        -- doing intra-package linking, e.g. refering to a symbol defined in the same
        -- package should not use a trampoline.
        -- I much rather have dynamic TH not supported than the entire Dynamic linking
        -- not due to a hack.
        -- Also not sure this would break on Windows anyway.
        OS
OSMinGW32 -> Module -> UnitId
moduleUnitId Module
mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> UnitId
moduleUnitId Module
this_mod

        -- For the other platforms, still perform the hack
        OS
_         -> Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod

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

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

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

pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
pprPackagesWith PackageConfig -> SDoc
pprIPI DynFlags
dflags =
    [SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
text String
"---") ((PackageConfig -> SDoc) -> [PackageConfig] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageConfig -> SDoc
pprIPI (DynFlags -> [PackageConfig]
listPackageConfigMap DynFlags
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 :: DynFlags -> SDoc
pprPackagesSimple = (PackageConfig -> SDoc) -> DynFlags -> SDoc
pprPackagesWith PackageConfig -> SDoc
forall compid srcpkgid srcpkgname unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> SDoc
pprIPI
    where pprIPI :: InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> SDoc
pprIPI InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
ipi = let i :: FastString
i = InstalledUnitId -> FastString
installedUnitIdFS (InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
ipi)
                           e :: SDoc
e = if InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
exposed InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
ipi then String -> SDoc
text String
"E" else String -> SDoc
text String
" "
                           t :: SDoc
t = if InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted InstalledPackageInfo
  compid srcpkgid srcpkgname InstalledUnitId unitid modulename mod
ipi then String -> SDoc
text String
"T" else String -> SDoc
text String
" "
                       in SDoc
e SDoc -> SDoc -> SDoc
<> SDoc
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"  " SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext FastString
i

-- | Show the mapping of modules to where they come from.
pprModuleMap :: ModuleToPkgConfAll -> SDoc
pprModuleMap :: ModuleToPkgConfAll -> SDoc
pprModuleMap ModuleToPkgConfAll
mod_map =
  [SDoc] -> SDoc
vcat (((ModuleName, Map Module ModuleOrigin) -> SDoc)
-> [(ModuleName, Map Module ModuleOrigin)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Map Module ModuleOrigin) -> SDoc
forall a. Outputable a => (ModuleName, Map Module a) -> SDoc
pprLine (ModuleToPkgConfAll -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList ModuleToPkgConfAll
mod_map))
    where
      pprLine :: (ModuleName, Map Module a) -> SDoc
pprLine (ModuleName
m,Map Module a
e) = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
50 ([SDoc] -> SDoc
vcat (((Module, a) -> SDoc) -> [(Module, a)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> (Module, a) -> SDoc
forall a. Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry ModuleName
m) (Map Module a -> [(Module, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Module a
e)))
      pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
      pprEntry :: ModuleName -> (Module, a) -> SDoc
pprEntry ModuleName
m (Module
m',a
o)
        | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
moduleName Module
m' = UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> UnitId
moduleUnitId Module
m') SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
o)
        | Bool
otherwise = Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m' SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
o)

fsPackageName :: PackageConfig -> FastString
fsPackageName :: PackageConfig -> FastString
fsPackageName = String -> FastString
mkFastString (String -> FastString)
-> (PackageConfig -> String) -> PackageConfig -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> String
packageNameString

-- | Given a fully instantiated 'UnitId', improve it into a
-- 'InstalledUnitId' if we can find it in the package database.
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
improveUnitId PackageConfigMap
_ uid :: UnitId
uid@(DefiniteUnitId WiredUnitId
_) = UnitId
uid -- short circuit
improveUnitId PackageConfigMap
pkg_map UnitId
uid =
    -- Do NOT lookup indefinite ones, they won't be useful!
    case Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' Bool
False PackageConfigMap
pkg_map UnitId
uid of
        Maybe PackageConfig
Nothing  -> UnitId
uid
        Just PackageConfig
pkg ->
            -- Do NOT improve if the indefinite unit id is not
            -- part of the closure unique set.  See
            -- Note [UnitId to InstalledUnitId improvement]
            if PackageConfig -> InstalledUnitId
installedPackageConfigId PackageConfig
pkg InstalledUnitId -> UniqSet InstalledUnitId -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` PackageConfigMap -> UniqSet InstalledUnitId
preloadClosure PackageConfigMap
pkg_map
                then PackageConfig -> UnitId
packageConfigId PackageConfig
pkg
                else UnitId
uid

-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
-- in the @hs-boot@ loop-breaker.
getPackageConfigMap :: DynFlags -> PackageConfigMap
getPackageConfigMap :: DynFlags -> PackageConfigMap
getPackageConfigMap = PackageState -> PackageConfigMap
pkgIdMap (PackageState -> PackageConfigMap)
-> (DynFlags -> PackageState) -> DynFlags -> PackageConfigMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PackageState
pkgState

-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
--
-- We interpret the package environment as a set of package flags; to be
-- specific, if we find a package environment file like
--
-- > clear-package-db
-- > global-package-db
-- > package-db blah/package.conf.d
-- > package-id id1
-- > package-id id2
--
-- we interpret this as
--
-- > [ -hide-all-packages
-- > , -clear-package-db
-- > , -global-package-db
-- > , -package-db blah/package.conf.d
-- > , -package-id id1
-- > , -package-id id2
-- > ]
--
-- There's also an older syntax alias for package-id, which is just an
-- unadorned package id
--
-- > id1
-- > id2
--
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv DynFlags
dflags = do
    Maybe String
mPkgEnv <- MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([MaybeT IO String] -> MaybeT IO String)
-> [MaybeT IO String] -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ [
                   MaybeT IO String
getCmdLineArg MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
env -> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       String -> MaybeT IO String
probeNullEnv String
env
                     , String -> MaybeT IO String
probeEnvFile String
env
                     , String -> MaybeT IO String
probeEnvName String
env
                     , String -> MaybeT IO String
forall a. String -> MaybeT IO a
cmdLineError String
env
                     ]
                 , MaybeT IO String
getEnvVar MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
env -> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       String -> MaybeT IO String
probeNullEnv String
env
                     , String -> MaybeT IO String
probeEnvFile String
env
                     , String -> MaybeT IO String
probeEnvName String
env
                     , String -> MaybeT IO String
forall a. String -> MaybeT IO a
envError     String
env
                     ]
                 , MaybeT IO ()
notIfHideAllPackages MaybeT IO () -> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       MaybeT IO String
findLocalEnvFile MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> MaybeT IO String
probeEnvFile
                     , String -> MaybeT IO String
probeEnvName String
defaultEnvName
                     ]
                 ]
    case Maybe String
mPkgEnv of
      Maybe String
Nothing ->
        -- No environment found. Leave DynFlags unchanged.
        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
      Just String
"-" -> do
        -- Explicitly disabled environment file. Leave DynFlags unchanged.
        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
      Just String
envfile -> do
        String
content <- String -> IO String
readFile String
envfile
        DynFlags -> String -> IO ()
compilationProgressMsg DynFlags
dflags (String
"Loaded package environment from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
envfile)
        let ((Errs, Warns, ())
_, DynFlags
dflags') = CmdLineP DynFlags (Errs, Warns, ())
-> DynFlags -> ((Errs, Warns, ()), DynFlags)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine (EwM (CmdLineP DynFlags) () -> CmdLineP DynFlags (Errs, Warns, ())
forall (m :: * -> *) a. EwM m a -> m (Errs, Warns, a)
runEwM (String -> String -> EwM (CmdLineP DynFlags) ()
setFlagsFromEnvFile String
envfile String
content)) DynFlags
dflags

        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
  where
    -- Loading environments (by name or by location)

    namedEnvPath :: String -> MaybeT IO FilePath
    namedEnvPath :: String -> MaybeT IO String
namedEnvPath String
name = do
     String
appdir <- DynFlags -> MaybeT IO String
versionedAppDir DynFlags
dflags
     String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> MaybeT IO String) -> String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String
appdir String -> String -> String
</> String
"environments" String -> String -> String
</> String
name

    probeEnvName :: String -> MaybeT IO FilePath
    probeEnvName :: String -> MaybeT IO String
probeEnvName String
name = String -> MaybeT IO String
probeEnvFile (String -> MaybeT IO String)
-> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> MaybeT IO String
namedEnvPath String
name

    probeEnvFile :: FilePath -> MaybeT IO FilePath
    probeEnvFile :: String -> MaybeT IO String
probeEnvFile String
path = do
      Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> MaybeT IO Bool -> MaybeT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (String -> IO Bool
doesFileExist String
path)
      String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path

    probeNullEnv :: FilePath -> MaybeT IO FilePath
    probeNullEnv :: String -> MaybeT IO String
probeNullEnv String
"-" = String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"-"
    probeNullEnv String
_   = MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    -- Various ways to define which environment to use

    getCmdLineArg :: MaybeT IO String
    getCmdLineArg :: MaybeT IO String
getCmdLineArg = IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe String
packageEnv DynFlags
dflags

    getEnvVar :: MaybeT IO String
    getEnvVar :: MaybeT IO String
getEnvVar = do
      Either IOException String
mvar <- IO (Either IOException String)
-> MaybeT IO (Either IOException String)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO (Either IOException String)
 -> MaybeT IO (Either IOException String))
-> IO (Either IOException String)
-> MaybeT IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO String -> IO (Either IOException String))
-> IO String -> IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"GHC_ENVIRONMENT"
      case Either IOException String
mvar of
        Right String
var -> String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
var
        Left IOException
err  -> if IOException -> Bool
isDoesNotExistError IOException
err then MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                                else IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ IOException -> IO String
forall e a. Exception e => e -> IO a
throwIO IOException
err

    notIfHideAllPackages :: MaybeT IO ()
    notIfHideAllPackages :: MaybeT IO ()
notIfHideAllPackages =
      Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags))

    defaultEnvName :: String
    defaultEnvName :: String
defaultEnvName = String
"default"

    -- e.g. .ghc.environment.x86_64-linux-7.6.3
    localEnvFileName :: FilePath
    localEnvFileName :: String
localEnvFileName = String
".ghc.environment" String -> String -> String
<.> DynFlags -> String
versionedFilePath DynFlags
dflags

    -- Search for an env file, starting in the current dir and looking upwards.
    -- Fail if we get to the users home dir or the filesystem root. That is,
    -- we don't look for an env file in the user's home dir. The user-wide
    -- env lives in ghc's versionedAppDir/environments/default
    findLocalEnvFile :: MaybeT IO FilePath
    findLocalEnvFile :: MaybeT IO String
findLocalEnvFile = do
        String
curdir  <- IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT IO String
getCurrentDirectory
        String
homedir <- IO String -> MaybeT IO String
forall a. IO a -> MaybeT IO a
tryMaybeT IO String
getHomeDirectory
        let probe :: String -> MaybeT IO String
probe String
dir | String -> Bool
isDrive String
dir Bool -> Bool -> Bool
|| String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
homedir
                      = MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
            probe String
dir = do
              let file :: String
file = String
dir String -> String -> String
</> String
localEnvFileName
              Bool
exists <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (String -> IO Bool
doesFileExist String
file)
              if Bool
exists
                then String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file
                else String -> MaybeT IO String
probe (String -> String
takeDirectory String
dir)
        String -> MaybeT IO String
probe String
curdir

    -- Error reporting

    cmdLineError :: String -> MaybeT IO a
    cmdLineError :: String -> MaybeT IO a
cmdLineError String
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a) -> (String -> IO a) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (String -> GhcException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError (String -> MaybeT IO a) -> String -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
      String
"Package environment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"

    envError :: String -> MaybeT IO a
    envError :: String -> MaybeT IO a
envError String
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a) -> (String -> IO a) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (String -> GhcException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError (String -> MaybeT IO a) -> String -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
         String
"Package environment "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
env
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (specified in GHC_ENVIRONMENT) not found"