-- (c) The University of Glasgow, 2006

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

-- | Unit manipulation
module GHC.Unit.State (
        module GHC.Unit.Info,

        -- * Reading the package config, and processing cmdline args
        UnitState(..),
        UnitDatabase (..),
        emptyUnitState,
        initUnits,
        readUnitDatabases,
        readUnitDatabase,
        getUnitDbRefs,
        resolveUnitDatabase,
        listUnitInfo,

        -- * Querying the package config
        lookupUnit,
        lookupUnit',
        unsafeLookupUnit,
        lookupUnitId,
        lookupUnitId',
        unsafeLookupUnitId,

        lookupPackageName,
        improveUnit,
        searchPackageId,
        displayUnitId,
        listVisibleModuleNames,
        lookupModuleInAllUnits,
        lookupModuleWithSuggestions,
        lookupModulePackage,
        lookupPluginModuleWithSuggestions,
        LookupResult(..),
        ModuleSuggestion(..),
        ModuleOrigin(..),
        UnusableUnitReason(..),
        pprReason,

        -- * Inspecting the set of packages in scope
        getUnitIncludePath,
        getUnitLibraryPath,
        getUnitLinkOpts,
        getUnitExtraCcOpts,
        getUnitFrameworkPath,
        getUnitFrameworks,
        getPreloadUnitsAnd,

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

        -- * Module hole substitution
        ShHoleSubst,
        renameHoleUnit,
        renameHoleModule,
        renameHoleUnit',
        renameHoleModule',
        instUnitToUnit,
        instModuleToModule,

        -- * Utils
        mkIndefUnitId,
        updateIndefUnitId,
        unwireUnit,
        pprFlag,
        pprUnits,
        pprUnitsSimple,
        pprModuleMap,
        homeUnitIsIndefinite,
        homeUnitIsDefinite,
    )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Platform
import GHC.Unit.Database
import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Driver.Session
import GHC.Driver.Ways
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Data.Maybe

import System.Environment ( getEnv )
import GHC.Data.FastString
import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,
                          withTiming, DumpFormat (..) )
import GHC.Utils.Exception

import System.Directory
import System.FilePath as FilePath
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

-- ---------------------------------------------------------------------------
-- The Unit state

-- | Unit state is all stored in 'DynFlags', including the details of
-- all units, which units are exposed, and which modules they
-- provide.
--
-- The unit state is computed by 'initUnits', and kept in DynFlags.
-- It is influenced by various command-line 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 unit state has the following properties.
--
--   * Let @exposedUnits@ be the set of packages thus exposed.
--     Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of
--     their dependencies.
--
--   * When searching for a module from a preload import declaration,
--     only the exposed modules in @exposedUnits@ are valid.
--
--   * When searching for a module from an implicit import, all modules
--     from @depExposedUnits@ 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 UnusableUnitReason
    -- | 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
fromOrigUnit :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
      , ModuleOrigin -> [UnitInfo]
fromExposedReexport :: [UnitInfo]
        -- | Is the module available from a reexport of a hidden package?
      , ModuleOrigin -> [UnitInfo]
fromHiddenReexport :: [UnitInfo]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , ModuleOrigin -> Bool
fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
    ppr :: ModuleOrigin -> MsgDoc
ppr ModuleOrigin
ModHidden = [Char] -> MsgDoc
text [Char]
"hidden module"
    ppr (ModUnusable UnusableUnitReason
_) = [Char] -> MsgDoc
text [Char]
"unusable module"
    ppr (ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f) = [MsgDoc] -> MsgDoc
sep (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
comma (
        (case Maybe Bool
e of
            Maybe Bool
Nothing -> []
            Just Bool
False -> [[Char] -> MsgDoc
text [Char]
"hidden package"]
            Just Bool
True -> [[Char] -> MsgDoc
text [Char]
"exposed package"]) [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a. [a] -> [a] -> [a]
++
        (if [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
res
            then []
            else [[Char] -> MsgDoc
text [Char]
"reexport by" MsgDoc -> MsgDoc -> MsgDoc
<+>
                    [MsgDoc] -> MsgDoc
sep ((UnitInfo -> MsgDoc) -> [UnitInfo] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Unit -> MsgDoc) -> (UnitInfo -> Unit) -> UnitInfo -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Unit
mkUnit) [UnitInfo]
res)]) [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a. [a] -> [a] -> [a]
++
        (if [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
rhs
            then []
            else [[Char] -> MsgDoc
text [Char]
"hidden reexport by" MsgDoc -> MsgDoc -> MsgDoc
<+>
                    [MsgDoc] -> MsgDoc
sep ((UnitInfo -> MsgDoc) -> [UnitInfo] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Unit -> MsgDoc) -> (UnitInfo -> Unit) -> UnitInfo -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Unit
mkUnit) [UnitInfo]
res)]) [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a. [a] -> [a] -> [a]
++
        (if Bool
f then [[Char] -> MsgDoc
text [Char]
"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 -> [UnitInfo] -> [UnitInfo] -> 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 exposed, and
-- also its 'UnitInfo'.
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules Bool
True UnitInfo
pkg = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [UnitInfo
pkg] [] Bool
False
fromReexportedModules Bool
False UnitInfo
pkg = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [UnitInfo
pkg] Bool
False

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

instance Semigroup ModuleOrigin where
    ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f <> :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
<> ModOrigin Maybe Bool
e' [UnitInfo]
res' [UnitInfo]
rhs' Bool
f' =
        Maybe Bool -> [UnitInfo] -> [UnitInfo] -> 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') ([UnitInfo]
res [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
res') ([UnitInfo]
rhs [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
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 = [Char] -> Maybe a
forall a. [Char] -> a
panic [Char]
"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 = [Char] -> ModuleOrigin
forall a. [Char] -> a
panic [Char]
"ModOrigin: hidden module redefined"

instance Monoid ModuleOrigin where
    mempty :: ModuleOrigin
mempty = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> 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 UnusableUnitReason
_) = Bool
False
originVisible (ModOrigin Maybe Bool
b [UnitInfo]
res [UnitInfo]
_ 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 ([UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
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

type PreloadUnitClosure = UniqSet UnitId

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

-- | 'UnitVisibility' records the various aspects of visibility of a particular
-- 'Unit'.
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 associated with the 'Unit'.  This is used
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
    , UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements :: Map ModuleName (Set InstantiatedModule)
      -- ^ 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 -> MsgDoc
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 InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
reqs,
        uv_explicit :: UnitVisibility -> Bool
uv_explicit = Bool
explicit
    }) = (Bool, [(ModuleName, ModuleName)], Maybe FastString,
 Map ModuleName (Set InstantiatedModule), Bool)
-> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Bool
b, [(ModuleName, ModuleName)]
rns, Maybe FastString
mb_pn, Map ModuleName (Set InstantiatedModule)
reqs, Bool
explicit)

instance Semigroup UnitVisibility where
    UnitVisibility
uv1 <> :: UnitVisibility -> UnitVisibility -> UnitVisibility
<> UnitVisibility
uv2
        = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> 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 InstantiatedModule)
uv_requirements = (Set InstantiatedModule
 -> Set InstantiatedModule -> Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements UnitVisibility
uv1) (UnitVisibility -> Map ModuleName (Set InstantiatedModule)
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 InstantiatedModule)
-> 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 InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
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.<>)


-- | Unit configuration
data UnitConfig = UnitConfig
   { UnitConfig -> PlatformMini
unitConfigPlatformArchOs :: !PlatformMini  -- ^ Platform
   , UnitConfig -> Set Way
unitConfigWays           :: !(Set Way)     -- ^ Ways to use
   , UnitConfig -> [Char]
unitConfigProgramName    :: !String
      -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
      -- variables such as "GHC[JS]_PACKAGE_PATH".

   , UnitConfig -> [Char]
unitConfigGlobalDB :: !FilePath    -- ^ Path to global DB
   , UnitConfig -> [Char]
unitConfigGHCDir   :: !FilePath    -- ^ Main GHC dir: contains settings, etc.
   , UnitConfig -> [Char]
unitConfigDBName   :: !String      -- ^ User DB name (e.g. "package.conf.d")

   , UnitConfig -> [UnitId]
unitConfigAutoLink       :: ![UnitId] -- ^ Units to link automatically (e.g. base, rts)
   , UnitConfig -> Bool
unitConfigDistrustAll    :: !Bool     -- ^ Distrust all units by default
   , UnitConfig -> Bool
unitConfigHideAll        :: !Bool     -- ^ Hide all units by default
   , UnitConfig -> Bool
unitConfigHideAllPlugins :: !Bool     -- ^ Hide all plugins units by default

   , UnitConfig -> Bool
unitConfigAllowVirtualUnits :: !Bool
      -- ^ Allow the use of virtual units instantiated on-the-fly (see Note
      -- [About units] in GHC.Unit). This should only be used when we are
      -- type-checking an indefinite unit (not producing any code).

   , UnitConfig -> Maybe [UnitDatabase UnitId]
unitConfigDBCache      :: Maybe [UnitDatabase UnitId]
      -- ^ Cache of databases to use, in the order they were specified on the
      -- command line (later databases shadow earlier ones).
      -- If Nothing, databases will be found using `unitConfigFlagsDB`.

   -- command-line flags
   , UnitConfig -> [PackageDBFlag]
unitConfigFlagsDB      :: [PackageDBFlag]     -- ^ Unit databases flags
   , UnitConfig -> [PackageFlag]
unitConfigFlagsExposed :: [PackageFlag]       -- ^ Exposed units
   , UnitConfig -> [IgnorePackageFlag]
unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units
   , UnitConfig -> [TrustFlag]
unitConfigFlagsTrusted :: [TrustFlag]         -- ^ Trusted units
   , UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units
   }

initUnitConfig :: DynFlags -> UnitConfig
initUnitConfig :: DynFlags -> UnitConfig
initUnitConfig DynFlags
dflags =
   let autoLink :: [UnitId]
autoLink
         | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoLinkPackages DynFlags
dflags) = []
         -- By default we add base & rts to the preload units (when they are
         -- found in the unit database) except when we are building them
         | Bool
otherwise = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
homeUnitId DynFlags
dflags) [UnitId
baseUnitId, UnitId
rtsUnitId]

   in UnitConfig :: PlatformMini
-> Set Way
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [UnitId]
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe [UnitDatabase UnitId]
-> [PackageDBFlag]
-> [PackageFlag]
-> [IgnorePackageFlag]
-> [TrustFlag]
-> [PackageFlag]
-> UnitConfig
UnitConfig
      { unitConfigPlatformArchOs :: PlatformMini
unitConfigPlatformArchOs = Platform -> PlatformMini
platformMini (DynFlags -> Platform
targetPlatform DynFlags
dflags)
      , unitConfigProgramName :: [Char]
unitConfigProgramName    = DynFlags -> [Char]
programName DynFlags
dflags
      , unitConfigWays :: Set Way
unitConfigWays           = DynFlags -> Set Way
ways DynFlags
dflags

      , unitConfigGlobalDB :: [Char]
unitConfigGlobalDB       = DynFlags -> [Char]
globalPackageDatabasePath DynFlags
dflags
      , unitConfigGHCDir :: [Char]
unitConfigGHCDir         = DynFlags -> [Char]
topDir DynFlags
dflags
      , unitConfigDBName :: [Char]
unitConfigDBName         = [Char]
"package.conf.d"

      , unitConfigAutoLink :: [UnitId]
unitConfigAutoLink       = [UnitId]
autoLink
      , unitConfigDistrustAll :: Bool
unitConfigDistrustAll    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DistrustAllPackages DynFlags
dflags
      , unitConfigHideAll :: Bool
unitConfigHideAll        = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags
      , unitConfigHideAllPlugins :: Bool
unitConfigHideAllPlugins = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPluginPackages DynFlags
dflags

        -- when the home unit is indefinite, it means we are type-checking it
        -- only (not producing any code). Hence we can use virtual units
        -- instantiated on-the-fly (see Note [About units] in GHC.Unit)
      , unitConfigAllowVirtualUnits :: Bool
unitConfigAllowVirtualUnits = DynFlags -> Bool
homeUnitIsIndefinite DynFlags
dflags

      , unitConfigDBCache :: Maybe [UnitDatabase UnitId]
unitConfigDBCache      = DynFlags -> Maybe [UnitDatabase UnitId]
unitDatabases DynFlags
dflags
      , unitConfigFlagsDB :: [PackageDBFlag]
unitConfigFlagsDB      = DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
dflags
      , unitConfigFlagsExposed :: [PackageFlag]
unitConfigFlagsExposed = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags
      , unitConfigFlagsIgnored :: [IgnorePackageFlag]
unitConfigFlagsIgnored = DynFlags -> [IgnorePackageFlag]
ignorePackageFlags DynFlags
dflags
      , unitConfigFlagsTrusted :: [TrustFlag]
unitConfigFlagsTrusted = DynFlags -> [TrustFlag]
trustFlags DynFlags
dflags
      , unitConfigFlagsPlugins :: [PackageFlag]
unitConfigFlagsPlugins = DynFlags -> [PackageFlag]
pluginPackageFlags DynFlags
dflags

      }

-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
-- its 'ModuleOrigin').
--
-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
-- origin for a given 'Module'
type ModuleNameProvidersMap =
    Map ModuleName (Map Module ModuleOrigin)

data UnitState = UnitState {
  -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
  -- so that only valid units are here.  'UnitInfo' reflects
  -- what was stored *on disk*, except for the 'trusted' flag, which
  -- is adjusted at runtime.  (In particular, some units in this map
  -- may have the 'exposed' flag be 'False'.)
  UnitState -> UnitInfoMap
unitInfoMap :: UnitInfoMap,

  -- | The set of transitively reachable units according
  -- to the explicitly provided command line arguments.
  -- A fully instantiated VirtUnit may only be replaced by a RealUnit from
  -- this set.
  -- See Note [VirtUnit to RealUnit improvement]
  UnitState -> PreloadUnitClosure
preloadClosure :: PreloadUnitClosure,

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

  -- | A mapping from database unit keys to wired in unit ids.
  UnitState -> Map UnitId UnitId
wireMap :: Map UnitId UnitId,

  -- | A mapping from wired in unit ids to unit keys from the database.
  UnitState -> Map UnitId UnitId
unwireMap :: Map UnitId UnitId,

  -- | The units we're going to link in eagerly.  This list
  -- should be in reverse dependency order; that is, a unit
  -- is always mentioned before the units it depends on.
  UnitState -> [UnitId]
preloadUnits      :: [UnitId],

  -- | Units which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  UnitState -> [Unit]
explicitUnits      :: [Unit],

  -- | 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.
  UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap    :: !ModuleNameProvidersMap,

  -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
  UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap    :: !ModuleNameProvidersMap,

  -- | 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.
  UnitState -> Map ModuleName [InstantiatedModule]
requirementContext :: Map ModuleName [InstantiatedModule],

  -- | Indicate if we can instantiate units on-the-fly.
  --
  -- This should only be true when we are type-checking an indefinite unit.
  -- See Note [About units] in GHC.Unit.
  UnitState -> Bool
allowVirtualUnits :: !Bool
  }

emptyUnitState :: UnitState
emptyUnitState :: UnitState
emptyUnitState = UnitState :: UnitInfoMap
-> PreloadUnitClosure
-> Map PackageName IndefUnitId
-> Map UnitId UnitId
-> Map UnitId UnitId
-> [UnitId]
-> [Unit]
-> ModuleNameProvidersMap
-> ModuleNameProvidersMap
-> Map ModuleName [InstantiatedModule]
-> Bool
-> UnitState
UnitState {
    unitInfoMap :: UnitInfoMap
unitInfoMap = UnitInfoMap
forall k a. Map k a
Map.empty,
    preloadClosure :: PreloadUnitClosure
preloadClosure = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet,
    packageNameMap :: Map PackageName IndefUnitId
packageNameMap = Map PackageName IndefUnitId
forall k a. Map k a
Map.empty,
    wireMap :: Map UnitId UnitId
wireMap   = Map UnitId UnitId
forall k a. Map k a
Map.empty,
    unwireMap :: Map UnitId UnitId
unwireMap = Map UnitId UnitId
forall k a. Map k a
Map.empty,
    preloadUnits :: [UnitId]
preloadUnits = [],
    explicitUnits :: [Unit]
explicitUnits = [],
    moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap = ModuleNameProvidersMap
forall k a. Map k a
Map.empty,
    pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = ModuleNameProvidersMap
forall k a. Map k a
Map.empty,
    requirementContext :: Map ModuleName [InstantiatedModule]
requirementContext = Map ModuleName [InstantiatedModule]
forall k a. Map k a
Map.empty,
    allowVirtualUnits :: Bool
allowVirtualUnits = Bool
False
    }

-- | Unit database
data UnitDatabase unit = UnitDatabase
   { forall unit. UnitDatabase unit -> [Char]
unitDatabasePath  :: FilePath
   , forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits :: [GenUnitInfo unit]
   }

type UnitInfoMap = Map UnitId UnitInfo

-- | Find the unit we know about with the given unit, if any
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs = Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' (UnitState -> Bool
allowVirtualUnits UnitState
pkgs) (UnitState -> UnitInfoMap
unitInfoMap UnitState
pkgs) (UnitState -> PreloadUnitClosure
preloadClosure UnitState
pkgs)

-- | A more specialized interface, which doesn't require a 'UnitState' (so it
-- can be used while we're initializing 'DynFlags')
--
-- Parameters:
--    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
--    * a 'UnitInfoMap'
--    * a 'PreloadUnitClosure'
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' Bool
allowOnTheFlyInst UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
u = case Unit
u of
   Unit
HoleUnit   -> [Char] -> Maybe UnitInfo
forall a. HasCallStack => [Char] -> a
error [Char]
"Hole unit"
   RealUnit Definite UnitId
i -> UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Definite UnitId -> UnitId
forall unit. Definite unit -> unit
unDefinite Definite UnitId
i) UnitInfoMap
pkg_map
   VirtUnit GenInstantiatedUnit UnitId
i
      | Bool
allowOnTheFlyInst
      -> -- lookup UnitInfo of the indefinite unit to be instantiated and
         -- instantiate it on-the-fly
         (UnitInfo -> UnitInfo) -> Maybe UnitInfo -> Maybe UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
i))
           (UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (IndefUnitId -> UnitId
forall unit. Indefinite unit -> unit
indefUnit (GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i)) UnitInfoMap
pkg_map)

      | Bool
otherwise
      -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
         -- units. Even if they are real, installed units, they can't use the
         -- `RealUnit` constructor (it is reserved for definite units) so we use
         -- the `VirtUnit` constructor.
         UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenInstantiatedUnit UnitId -> UnitId
virtualUnitId GenInstantiatedUnit UnitId
i) UnitInfoMap
pkg_map

-- | Find the unit we know about with the given unit id, if any
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid = UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state) UnitId
uid

-- | Find the unit we know about with the given unit id, if any
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' UnitInfoMap
db UnitId
uid = UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid UnitInfoMap
db


-- | Looks up the given unit in the unit state, panicing if it is not found
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit UnitState
state Unit
u = case UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
state Unit
u of
   Just UnitInfo
info -> UnitInfo
info
   Maybe UnitInfo
Nothing   -> [Char] -> MsgDoc -> UnitInfo
forall a. HasCallStack => [Char] -> MsgDoc -> a
pprPanic [Char]
"unsafeLookupUnit" (Unit -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Unit
u)

-- | Looks up the given unit id in the unit state, panicing if it is not found
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state UnitId
uid = case UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid of
   Just UnitInfo
info -> UnitInfo
info
   Maybe UnitInfo
Nothing   -> [Char] -> MsgDoc -> UnitInfo
forall a. HasCallStack => [Char] -> MsgDoc -> a
pprPanic [Char]
"unsafeLookupUnitId" (UnitId -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr UnitId
uid)


-- | Find the unit 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 :: UnitState -> PackageName -> Maybe IndefUnitId
lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId
lookupPackageName UnitState
pkgstate PackageName
n = PackageName -> Map PackageName IndefUnitId -> Maybe IndefUnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
n (UnitState -> Map PackageName IndefUnitId
packageNameMap UnitState
pkgstate)

-- | Search for units with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
searchPackageId UnitState
pkgstate PackageId
pid = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PackageId
pid PackageId -> PackageId -> Bool
forall a. Eq a => a -> a -> Bool
==) (PackageId -> Bool) -> (UnitInfo -> PackageId) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> PackageId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
unitPackageId)
                               (UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)

-- | Create a Map UnitId UnitInfo
--
-- For each instantiated unit, we add two map keys:
--    * the real unit id
--    * the virtual unit id made from its instantiation
--
-- We do the same thing for fully indefinite units (which are "instantiated"
-- with module holes).
--
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
infos = (UnitInfoMap -> UnitInfo -> UnitInfoMap)
-> UnitInfoMap -> [UnitInfo] -> UnitInfoMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UnitInfoMap -> UnitInfo -> UnitInfoMap
forall {srcpkgid} {srcpkgname}.
Map
  UnitId
  (GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
add UnitInfoMap
forall k a. Map k a
Map.empty [UnitInfo]
infos
  where
   mkVirt :: GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> UnitId
mkVirt      GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p = GenInstantiatedUnit UnitId -> UnitId
virtualUnitId (IndefUnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
mkInstantiatedUnit (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> IndefUnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p) (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p))
   add :: Map
  UnitId
  (GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
add Map
  UnitId
  (GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
      | Bool -> Bool
not ([(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p))
      = UnitId
-> GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall {srcpkgid} {srcpkgname} {uid}.
GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> UnitId
mkVirt GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
         (Map
   UnitId
   (GenericUnitInfo
      IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
 -> Map
      UnitId
      (GenericUnitInfo
         IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module))
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall a b. (a -> b) -> a -> b
$ UnitId
-> GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
         (Map
   UnitId
   (GenericUnitInfo
      IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
 -> Map
      UnitId
      (GenericUnitInfo
         IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module))
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall a b. (a -> b) -> a -> b
$ Map
  UnitId
  (GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map
      | Bool
otherwise
      = UnitId
-> GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
     UnitId
     (GenericUnitInfo
        IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
  IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p Map
  UnitId
  (GenericUnitInfo
     IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map

-- | Get a list of entries from the unit database.  NB: be careful with
-- this function, although all units in this map are "visible", this
-- does not imply that the exposed-modules of the unit are available
-- (they may have been thinned or renamed).
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo UnitState
state = UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)

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

-- | Read the unit database files, and sets up various internal tables of
-- unit information, according to the unit-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
--
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
initUnits :: DynFlags -> IO DynFlags
initUnits :: DynFlags -> IO DynFlags
initUnits DynFlags
dflags = do

  let forceUnitInfoMap :: (UnitState, b) -> ()
forceUnitInfoMap (UnitState
state, b
_) = UnitState -> UnitInfoMap
unitInfoMap UnitState
state UnitInfoMap -> () -> ()
`seq` ()
  let ctx :: SDocContext
ctx     = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle -- SDocContext used to render exception messages
  let printer :: Int -> MsgDoc -> IO ()
printer = DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags                    -- printer for trace messages

  (UnitState
state,[UnitDatabase UnitId]
dbs) <- DynFlags
-> MsgDoc
-> ((UnitState, [UnitDatabase UnitId]) -> ())
-> IO (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags ([Char] -> MsgDoc
text [Char]
"initializing unit database")
                   (UnitState, [UnitDatabase UnitId]) -> ()
forall {b}. (UnitState, b) -> ()
forceUnitInfoMap
                   (SDocContext
-> (Int -> MsgDoc -> IO ())
-> UnitConfig
-> IO (UnitState, [UnitDatabase UnitId])
mkUnitState SDocContext
ctx Int -> MsgDoc -> IO ()
printer (DynFlags -> UnitConfig
initUnitConfig DynFlags
dflags))

  DynFlags -> DumpFlag -> [Char] -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn (DynFlags
dflags { pprCols :: Int
pprCols = Int
200 }) DumpFlag
Opt_D_dump_mod_map [Char]
"Module Map"
    DumpFormat
FormatText (ModuleNameProvidersMap -> MsgDoc
pprModuleMap (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
state))

  let dflags' :: DynFlags
dflags'  = DynFlags
dflags
                  { unitDatabases :: Maybe [UnitDatabase UnitId]
unitDatabases = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs -- databases are cached and never read again
                  , unitState :: UnitState
unitState     = UnitState
state
                  }
      dflags'' :: DynFlags
dflags'' = DynFlags -> DynFlags
upd_wired_in_home_instantiations DynFlags
dflags'

  DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags''

-- -----------------------------------------------------------------------------
-- Reading the unit database(s)

readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases :: (Int -> MsgDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Int -> MsgDoc -> IO ()
printer UnitConfig
cfg = do
  [PkgDbRef]
conf_refs <- UnitConfig -> IO [PkgDbRef]
getUnitDbRefs UnitConfig
cfg
  [[Char]]
confs     <- ([Maybe [Char]] -> [[Char]]) -> IO [Maybe [Char]] -> IO [[Char]]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe [Char]] -> IO [[Char]])
-> IO [Maybe [Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ (PkgDbRef -> IO (Maybe [Char])) -> [PkgDbRef] -> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (UnitConfig -> PkgDbRef -> IO (Maybe [Char])
resolveUnitDatabase UnitConfig
cfg) [PkgDbRef]
conf_refs
  ([Char] -> IO (UnitDatabase UnitId))
-> [[Char]] -> IO [UnitDatabase UnitId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int -> MsgDoc -> IO ())
-> UnitConfig -> [Char] -> IO (UnitDatabase UnitId)
readUnitDatabase Int -> MsgDoc -> IO ()
printer UnitConfig
cfg) [[Char]]
confs


getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
getUnitDbRefs UnitConfig
cfg = do
  let system_conf_refs :: [PkgDbRef]
system_conf_refs = [PkgDbRef
UserPkgDb, PkgDbRef
GlobalPkgDb]

  Either IOException [Char]
e_pkg_path <- IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO ([Char] -> IO [Char]
getEnv ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (UnitConfig -> [Char]
unitConfigProgramName UnitConfig
cfg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_PACKAGE_PATH")
  let base_conf_refs :: [PkgDbRef]
base_conf_refs = case Either IOException [Char]
e_pkg_path of
        Left IOException
_ -> [PkgDbRef]
system_conf_refs
        Right [Char]
path
         | Bool -> Bool
not ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
path) Bool -> Bool -> Bool
&& Char -> Bool
isSearchPathSeparator ([Char] -> Char
forall a. [a] -> a
last [Char]
path)
         -> ([Char] -> PkgDbRef) -> [[Char]] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> PkgDbRef
PkgDbPath ([Char] -> [[Char]]
splitSearchPath ([Char] -> [Char]
forall a. [a] -> [a]
init [Char]
path)) [PkgDbRef] -> [PkgDbRef] -> [PkgDbRef]
forall a. [a] -> [a] -> [a]
++ [PkgDbRef]
system_conf_refs
         | Bool
otherwise
         -> ([Char] -> PkgDbRef) -> [[Char]] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> PkgDbRef
PkgDbPath ([Char] -> [[Char]]
splitSearchPath [Char]
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"
  --
  [PkgDbRef] -> IO [PkgDbRef]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PkgDbRef] -> IO [PkgDbRef]) -> [PkgDbRef] -> IO [PkgDbRef]
forall a b. (a -> b) -> a -> b
$ [PkgDbRef] -> [PkgDbRef]
forall a. [a] -> [a]
reverse ((PackageDBFlag -> [PkgDbRef] -> [PkgDbRef])
-> [PkgDbRef] -> [PackageDBFlag] -> [PkgDbRef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PackageDBFlag -> [PkgDbRef] -> [PkgDbRef]
doFlag [PkgDbRef]
base_conf_refs (UnitConfig -> [PackageDBFlag]
unitConfigFlagsDB UnitConfig
cfg))
 where
  doFlag :: PackageDBFlag -> [PkgDbRef] -> [PkgDbRef]
doFlag (PackageDB PkgDbRef
p) [PkgDbRef]
dbs = PkgDbRef
p PkgDbRef -> [PkgDbRef] -> [PkgDbRef]
forall a. a -> [a] -> [a]
: [PkgDbRef]
dbs
  doFlag PackageDBFlag
NoUserPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotUser [PkgDbRef]
dbs
  doFlag PackageDBFlag
NoGlobalPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotGlobal [PkgDbRef]
dbs
  doFlag PackageDBFlag
ClearPackageDBs [PkgDbRef]
_ = []

  isNotUser :: PkgDbRef -> Bool
isNotUser PkgDbRef
UserPkgDb = Bool
False
  isNotUser PkgDbRef
_ = Bool
True

  isNotGlobal :: PkgDbRef -> Bool
isNotGlobal PkgDbRef
GlobalPkgDb = Bool
False
  isNotGlobal PkgDbRef
_ = Bool
True

-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
-- when the user database filepath is expected but the latter doesn't exist.
--
-- 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.)
resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe [Char])
resolveUnitDatabase UnitConfig
cfg PkgDbRef
GlobalPkgDb = Maybe [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (UnitConfig -> [Char]
unitConfigGlobalDB UnitConfig
cfg)
resolveUnitDatabase UnitConfig
cfg PkgDbRef
UserPkgDb = MaybeT IO [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Char] -> IO (Maybe [Char]))
-> MaybeT IO [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
  [Char]
dir <- [Char] -> PlatformMini -> MaybeT IO [Char]
versionedAppDir (UnitConfig -> [Char]
unitConfigProgramName UnitConfig
cfg) (UnitConfig -> PlatformMini
unitConfigPlatformArchOs UnitConfig
cfg)
  let pkgconf :: [Char]
pkgconf = [Char]
dir [Char] -> [Char] -> [Char]
</> UnitConfig -> [Char]
unitConfigDBName UnitConfig
cfg
  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
$ [Char] -> IO Bool
doesDirectoryExist [Char]
pkgconf
  if Bool
exist then [Char] -> MaybeT IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
pkgconf else MaybeT IO [Char]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
resolveUnitDatabase UnitConfig
_ (PkgDbPath [Char]
name) = Maybe [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
name

readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase :: (Int -> MsgDoc -> IO ())
-> UnitConfig -> [Char] -> IO (UnitDatabase UnitId)
readUnitDatabase Int -> MsgDoc -> IO ()
printer UnitConfig
cfg [Char]
conf_file = do
  Bool
isdir <- [Char] -> IO Bool
doesDirectoryExist [Char]
conf_file

  [DbUnitInfo]
proto_pkg_configs <-
    if Bool
isdir
       then [Char] -> IO [DbUnitInfo]
readDirStyleUnitInfo [Char]
conf_file
       else do
            Bool
isfile <- [Char] -> IO Bool
doesFileExist [Char]
conf_file
            if Bool
isfile
               then do
                 Maybe [DbUnitInfo]
mpkgs <- IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo
                 case Maybe [DbUnitInfo]
mpkgs of
                   Just [DbUnitInfo]
pkgs -> [DbUnitInfo] -> IO [DbUnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [DbUnitInfo]
pkgs
                   Maybe [DbUnitInfo]
Nothing   -> GhcException -> IO [DbUnitInfo]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [DbUnitInfo])
-> GhcException -> IO [DbUnitInfo]
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
InstallationError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$
                      [Char]
"ghc no longer supports single-file style package " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
"databases (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
conf_file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
") use 'ghc-pkg init' to create the database with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
"the correct format."
               else GhcException -> IO [DbUnitInfo]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [DbUnitInfo])
-> GhcException -> IO [DbUnitInfo]
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
InstallationError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$
                      [Char]
"can't find a package database at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
conf_file

  let
      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
      conf_file' :: [Char]
conf_file' = [Char] -> [Char]
dropTrailingPathSeparator [Char]
conf_file
      top_dir :: [Char]
top_dir = UnitConfig -> [Char]
unitConfigGHCDir UnitConfig
cfg
      pkgroot :: [Char]
pkgroot = [Char] -> [Char]
takeDirectory [Char]
conf_file'
      pkg_configs1 :: [UnitInfo]
pkg_configs1 = (DbUnitInfo -> UnitInfo) -> [DbUnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> UnitInfo -> UnitInfo
mungeUnitInfo [Char]
top_dir [Char]
pkgroot (UnitInfo -> UnitInfo)
-> (DbUnitInfo -> UnitInfo) -> DbUnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitKey -> UnitId)
-> (UnitId -> FastString) -> GenUnitInfo UnitKey -> UnitInfo
forall u v.
(u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v
mapUnitInfo (\(UnitKey FastString
x) -> FastString -> UnitId
UnitId FastString
x) UnitId -> FastString
unitIdFS (GenUnitInfo UnitKey -> UnitInfo)
-> (DbUnitInfo -> GenUnitInfo UnitKey) -> DbUnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbUnitInfo -> GenUnitInfo UnitKey
mkUnitKeyInfo)
                         [DbUnitInfo]
proto_pkg_configs
  --
  UnitDatabase UnitId -> IO (UnitDatabase UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitDatabase UnitId -> IO (UnitDatabase UnitId))
-> UnitDatabase UnitId -> IO (UnitDatabase UnitId)
forall a b. (a -> b) -> a -> b
$ [Char] -> [UnitInfo] -> UnitDatabase UnitId
forall unit. [Char] -> [GenUnitInfo unit] -> UnitDatabase unit
UnitDatabase [Char]
conf_file' [UnitInfo]
pkg_configs1
  where
    readDirStyleUnitInfo :: [Char] -> IO [DbUnitInfo]
readDirStyleUnitInfo [Char]
conf_dir = do
      let filename :: [Char]
filename = [Char]
conf_dir [Char] -> [Char] -> [Char]
</> [Char]
"package.cache"
      Bool
cache_exists <- [Char] -> IO Bool
doesFileExist [Char]
filename
      if Bool
cache_exists
        then do
          Int -> MsgDoc -> IO ()
printer Int
2 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MsgDoc
text [Char]
"Using binary package database:" MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
filename
          [Char] -> IO [DbUnitInfo]
readPackageDbForGhc [Char]
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.
          Int -> MsgDoc -> IO ()
printer Int
2 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MsgDoc
text [Char]
"There is no package.cache in"
                      MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
conf_dir
                       MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
", checking if the database is empty"
          Bool
db_empty <- ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
".conf")
                   ([[Char]] -> Bool) -> IO [[Char]] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents [Char]
conf_dir
          if Bool
db_empty
            then do
              Int -> MsgDoc -> IO ()
printer Int
3 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MsgDoc
text [Char]
"There are no .conf files in"
                          MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
conf_dir MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
", treating"
                          MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
"package database as empty"
              [DbUnitInfo] -> IO [DbUnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do
              GhcException -> IO [DbUnitInfo]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [DbUnitInfo])
-> GhcException -> IO [DbUnitInfo]
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
InstallationError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$
                [Char]
"there is no package.cache in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
conf_dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                [Char]
" 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.
    tryReadOldFileStyleUnitInfo :: IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo = do
      [Char]
content <- [Char] -> IO [Char]
readFile [Char]
conf_file IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
      if Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
2 [Char]
content [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"[]"
        then do
          let conf_dir :: [Char]
conf_dir = [Char]
conf_file [Char] -> [Char] -> [Char]
<.> [Char]
"d"
          Bool
direxists <- [Char] -> IO Bool
doesDirectoryExist [Char]
conf_dir
          if Bool
direxists
             then do Int -> MsgDoc -> IO ()
printer Int
2 ([Char] -> MsgDoc
text [Char]
"Ignoring old file-style db and trying:" MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
conf_dir)
                     ([DbUnitInfo] -> Maybe [DbUnitInfo])
-> IO [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [DbUnitInfo] -> Maybe [DbUnitInfo]
forall a. a -> Maybe a
Just ([Char] -> IO [DbUnitInfo]
readDirStyleUnitInfo [Char]
conf_dir)
             else Maybe [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([DbUnitInfo] -> Maybe [DbUnitInfo]
forall a. a -> Maybe a
Just []) -- ghc-pkg will create it when it's updated
        else Maybe [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [DbUnitInfo]
forall a. Maybe a
Nothing

distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits [UnitInfo]
pkgs = (UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitInfo
forall {compid} {srcpkgid} {srcpkgname} {uid} {modulename} {mod}.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
distrust [UnitInfo]
pkgs
  where
    distrust :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
distrust GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
pkg = GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
pkg{ unitIsTrusted :: Bool
unitIsTrusted = Bool
False }

mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo :: [Char] -> [Char] -> UnitInfo -> UnitInfo
mungeUnitInfo [Char]
top_dir [Char]
pkgroot =
    UnitInfo -> UnitInfo
mungeDynLibFields
  (UnitInfo -> UnitInfo)
-> (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> UnitInfo -> UnitInfo
forall a b c d e f.
[Char]
-> [Char]
-> GenericUnitInfo a b c d e f
-> GenericUnitInfo a b c d e f
mungeUnitInfoPaths [Char]
top_dir [Char]
pkgroot

mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields UnitInfo
pkg =
    UnitInfo
pkg {
      unitLibraryDynDirs :: [[Char]]
unitLibraryDynDirs = case UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitLibraryDynDirs UnitInfo
pkg of
         [] -> UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitLibraryDirs UnitInfo
pkg
         [[Char]]
ds -> [[Char]]
ds
    }

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

applyTrustFlag
   :: SDocContext
   -> UnitPrecedenceMap
   -> UnusableUnits
   -> [UnitInfo]
   -> TrustFlag
   -> IO [UnitInfo]
applyTrustFlag :: SDocContext
-> UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> IO [UnitInfo]
applyTrustFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnusableUnits
unusable [UnitInfo]
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 [Char]
str ->
       case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map ([Char] -> PackageArg
PackageArg [Char]
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps       -> SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO [UnitInfo]
forall a.
SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
         Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> IO [UnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitInfo
forall {compid} {srcpkgid} {srcpkgname} {uid} {modulename} {mod}.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
trust [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)
          where trust :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
trust GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
p = GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
p {unitIsTrusted :: Bool
unitIsTrusted=Bool
True}

    DistrustPackage [Char]
str ->
       case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map ([Char] -> PackageArg
PackageArg [Char]
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps       -> SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO [UnitInfo]
forall a.
SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
         Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> IO [UnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitInfo] -> [UnitInfo]
distrustAllUnits [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)

-- | A little utility to tell if the home unit is indefinite
-- (if it is not, we should never use on-the-fly renaming.)
homeUnitIsIndefinite :: DynFlags -> Bool
homeUnitIsIndefinite :: DynFlags -> Bool
homeUnitIsIndefinite DynFlags
dflags = Bool -> Bool
not (DynFlags -> Bool
homeUnitIsDefinite DynFlags
dflags)

-- | A little utility to tell if the home unit is definite
-- (if it is, we should never use on-the-fly renaming.)
homeUnitIsDefinite :: DynFlags -> Bool
homeUnitIsDefinite :: DynFlags -> Bool
homeUnitIsDefinite DynFlags
dflags = Unit -> Bool
unitIsDefinite (DynFlags -> Unit
homeUnit DynFlags
dflags)

applyPackageFlag
   :: SDocContext
   -> UnitPrecedenceMap
   -> UnitInfoMap
   -> PreloadUnitClosure
   -> UnusableUnits
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
   -> [UnitInfo]
   -> VisibilityMap           -- Initially exposed
   -> PackageFlag               -- flag to apply
   -> IO VisibilityMap        -- Now exposed

applyPackageFlag :: SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure UnusableUnits
unusable Bool
no_hide_others [UnitInfo]
pkgs VisibilityMap
vm PackageFlag
flag =
  case PackageFlag
flag of
    ExposePackage [Char]
_ PackageArg
arg (ModRenaming Bool
b [(ModuleName, ModuleName)]
rns) ->
       case UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps         -> SDocContext
-> PackageFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO VisibilityMap
forall a.
SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
         Right (UnitInfo
p:[UnitInfo]
_) -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
          where
           n :: FastString
n = UnitInfo -> FastString
fsPackageName UnitInfo
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 InstantiatedModule)
reqs | UnitIdArg Unit
orig_uid <- PackageArg
arg = Unit -> Map ModuleName (Set InstantiatedModule)
forall {uid}.
GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles Unit
orig_uid
                | Bool
otherwise                 = Map ModuleName (Set InstantiatedModule)
forall k a. Map k a
Map.empty

           collectHoles :: GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles GenUnit uid
uid = case GenUnit uid
uid of
             GenUnit uid
HoleUnit       -> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. Map k a
Map.empty
             RealUnit {}    -> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. Map k a
Map.empty -- definite units don't have holes
             VirtUnit GenInstantiatedUnit uid
indef ->
                  let local :: [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
local = [ ModuleName
-> Set (GenModule (GenInstantiatedUnit uid))
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. k -> a -> Map k a
Map.singleton
                                  (GenModule (GenUnit uid) -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule (GenUnit uid)
mod)
                                  (GenModule (GenInstantiatedUnit uid)
-> Set (GenModule (GenInstantiatedUnit uid))
forall a. a -> Set a
Set.singleton (GenModule (GenInstantiatedUnit uid)
 -> Set (GenModule (GenInstantiatedUnit uid)))
-> GenModule (GenInstantiatedUnit uid)
-> Set (GenModule (GenInstantiatedUnit uid))
forall a b. (a -> b) -> a -> b
$ GenInstantiatedUnit uid
-> ModuleName -> GenModule (GenInstantiatedUnit uid)
forall unit. unit -> ModuleName -> GenModule unit
Module GenInstantiatedUnit uid
indef ModuleName
mod_name)
                              | (ModuleName
mod_name, GenModule (GenUnit uid)
mod) <- GenInstantiatedUnit uid -> GenInstantiations uid
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit uid
indef
                              , GenModule (GenUnit uid) -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule GenModule (GenUnit uid)
mod ]
                      recurse :: [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
recurse = [ GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles (GenModule (GenUnit uid) -> GenUnit uid
forall unit. GenModule unit -> unit
moduleUnit GenModule (GenUnit uid)
mod)
                                | (ModuleName
_, GenModule (GenUnit uid)
mod) <- GenInstantiatedUnit uid -> GenInstantiations uid
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit uid
indef ]
                  in (Set (GenModule (GenInstantiatedUnit uid))
 -> Set (GenModule (GenInstantiatedUnit uid))
 -> Set (GenModule (GenInstantiatedUnit uid)))
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid))
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
 -> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid))))
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall a b. (a -> b) -> a -> b
$ [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
local [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
forall a. [a] -> [a] -> [a]
++ [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
recurse

           uv :: UnitVisibility
uv = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> 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 InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
reqs
                , uv_explicit :: Bool
uv_explicit = Bool
True
                }
           vm' :: VisibilityMap
vm' = (UnitVisibility -> UnitVisibility -> UnitVisibility)
-> Unit -> 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 (UnitInfo -> Unit
mkUnit UnitInfo
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 = (Unit -> UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                            (\Unit
k UnitVisibility
uv -> Unit
k Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> Unit
mkUnit UnitInfo
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 [(UnitInfo, UnusableUnitReason)] [UnitInfo]
_ -> [Char] -> IO VisibilityMap
forall a. [Char] -> a
panic [Char]
"applyPackageFlag"

    HidePackage [Char]
str ->
       case UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure ([Char] -> PackageArg
PackageArg [Char]
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps  -> SDocContext
-> PackageFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO VisibilityMap
forall a.
SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
         Right [UnitInfo]
ps -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
          where vm' :: VisibilityMap
vm' = (VisibilityMap -> Unit -> VisibilityMap)
-> VisibilityMap -> [Unit] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Unit -> VisibilityMap -> VisibilityMap)
-> VisibilityMap -> Unit -> VisibilityMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip Unit -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) VisibilityMap
vm ((UnitInfo -> Unit) -> [UnitInfo] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> Unit
mkUnit [UnitInfo]
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 :: UnitPrecedenceMap
             -> UnitInfoMap
             -> PreloadUnitClosure
             -> PackageArg -> [UnitInfo]
             -> UnusableUnits
             -> Either [(UnitInfo, UnusableUnitReason)]
                [UnitInfo]
findPackages :: UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable
  = let ps :: [UnitInfo]
ps = (UnitInfo -> Maybe UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg) [UnitInfo]
pkgs
    in if [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
ps
        then [(UnitInfo, UnusableUnitReason)]
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. a -> Either a b
Left (((UnitInfo, UnusableUnitReason)
 -> Maybe (UnitInfo, UnusableUnitReason))
-> [(UnitInfo, UnusableUnitReason)]
-> [(UnitInfo, UnusableUnitReason)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(UnitInfo
x,UnusableUnitReason
y) -> PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg UnitInfo
x Maybe UnitInfo
-> (UnitInfo -> Maybe (UnitInfo, UnusableUnitReason))
-> Maybe (UnitInfo, UnusableUnitReason)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnitInfo
x' -> (UnitInfo, UnusableUnitReason)
-> Maybe (UnitInfo, UnusableUnitReason)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
x',UnusableUnitReason
y))
                            (UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. Map k a -> [a]
Map.elems UnusableUnits
unusable))
        else [UnitInfo] -> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. b -> Either a b
Right (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps)
  where
    finder :: PackageArg -> UnitInfo -> Maybe UnitInfo
finder (PackageArg [Char]
str) UnitInfo
p
      = if [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> [Char]
forall u. GenUnitInfo u -> [Char]
unitPackageIdString UnitInfo
p Bool -> Bool -> Bool
|| [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> [Char]
forall u. GenUnitInfo u -> [Char]
unitPackageNameString UnitInfo
p
          then UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
          else Maybe UnitInfo
forall a. Maybe a
Nothing
    finder (UnitIdArg Unit
uid) UnitInfo
p
      = case Unit
uid of
          RealUnit (Definite UnitId
iuid)
            | UnitId
iuid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p
            -> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
          VirtUnit GenInstantiatedUnit UnitId
inst
            | IndefUnitId -> UnitId
forall unit. Indefinite unit -> unit
indefUnit (GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
inst) UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p
            -> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just (UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
inst) UnitInfo
p)
          Unit
_ -> Maybe UnitInfo
forall a. Maybe a
Nothing

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

-- | Rename a 'UnitInfo' according to some module instantiation.
renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo :: UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure [(ModuleName, Module)]
insts UnitInfo
conf =
    let hsubst :: UniqFM ModuleName Module
hsubst = [(ModuleName, Module)] -> UniqFM ModuleName Module
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts
        smod :: Module -> Module
smod  = UnitInfoMap
-> PreloadUnitClosure
-> UniqFM ModuleName Module
-> Module
-> Module
renameHoleModule' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName 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)) (UnitInfo -> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
conf)
    in UnitInfo
conf {
        unitInstantiations :: [(ModuleName, Module)]
unitInstantiations = [(ModuleName, Module)]
new_insts,
        unitExposedModules :: [(ModuleName, Maybe Module)]
unitExposedModules = ((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))
                             (UnitInfo -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
conf)
    }


-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matchingStr :: String -> UnitInfo -> Bool
matchingStr :: [Char] -> UnitInfo -> Bool
matchingStr [Char]
str UnitInfo
p
        =  [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> [Char]
forall u. GenUnitInfo u -> [Char]
unitPackageIdString UnitInfo
p
        Bool -> Bool -> Bool
|| [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> [Char]
forall u. GenUnitInfo u -> [Char]
unitPackageNameString UnitInfo
p

matchingId :: UnitId -> UnitInfo -> Bool
matchingId :: UnitId -> UnitInfo -> Bool
matchingId UnitId
uid UnitInfo
p = UnitId
uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p

matching :: PackageArg -> UnitInfo -> Bool
matching :: PackageArg -> UnitInfo -> Bool
matching (PackageArg [Char]
str) = [Char] -> UnitInfo -> Bool
matchingStr [Char]
str
matching (UnitIdArg (RealUnit (Definite UnitId
uid))) = UnitId -> UnitInfo -> Bool
matchingId UnitId
uid
matching (UnitIdArg Unit
_)  = \UnitInfo
_ -> 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 :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map = (UnitInfo -> UnitInfo -> Ordering) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((UnitInfo -> UnitInfo -> Ordering)
-> UnitInfo -> UnitInfo -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
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 units
-- in later unit database.
compareByPreference
    :: UnitPrecedenceMap
    -> UnitInfo
    -> UnitInfo
    -> Ordering
compareByPreference :: UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
pkg UnitInfo
pkg'
  = case (UnitInfo -> Version) -> UnitInfo -> UnitInfo -> Ordering
forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing UnitInfo -> Version
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
pkg UnitInfo
pkg' of
        Ordering
GT -> Ordering
GT
        Ordering
EQ | Just Int
prec  <- UnitId -> UnitPrecedenceMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg)  UnitPrecedenceMap
prec_map
           , Just Int
prec' <- UnitId -> UnitPrecedenceMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg') UnitPrecedenceMap
prec_map
           -- Prefer the unit 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

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing :: forall a t. Ord a => (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 :: SDocContext
               -> PackageFlag
               -> [(UnitInfo, UnusableUnitReason)]
               -> IO a
packageFlagErr :: forall a.
SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
  = SDocContext -> MsgDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
forall a.
SDocContext -> MsgDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx (PackageFlag -> MsgDoc
pprFlag PackageFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons

trustFlagErr :: SDocContext
             -> TrustFlag
             -> [(UnitInfo, UnusableUnitReason)]
             -> IO a
trustFlagErr :: forall a.
SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
  = SDocContext -> MsgDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
forall a.
SDocContext -> MsgDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx (TrustFlag -> MsgDoc
pprTrustFlag TrustFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons

packageFlagErr' :: SDocContext
               -> SDoc
               -> [(UnitInfo, UnusableUnitReason)]
               -> IO a
packageFlagErr' :: forall a.
SDocContext -> MsgDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx MsgDoc
flag_doc [(UnitInfo, UnusableUnitReason)]
reasons
  = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO ([Char] -> GhcException
CmdLineError (SDocContext -> MsgDoc -> [Char]
renderWithStyle SDocContext
ctx (MsgDoc -> [Char]) -> MsgDoc -> [Char]
forall a b. (a -> b) -> a -> b
$ MsgDoc
err))
  where err :: MsgDoc
err = [Char] -> MsgDoc
text [Char]
"cannot satisfy " MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
flag_doc MsgDoc -> MsgDoc -> MsgDoc
<>
                (if [(UnitInfo, UnusableUnitReason)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitInfo, UnusableUnitReason)]
reasons then MsgDoc
Outputable.empty else [Char] -> MsgDoc
text [Char]
": ") MsgDoc -> MsgDoc -> MsgDoc
$$
              Int -> MsgDoc -> MsgDoc
nest Int
4 (MsgDoc
ppr_reasons MsgDoc -> MsgDoc -> MsgDoc
$$
                      [Char] -> MsgDoc
text [Char]
"(use -v for more information)")
        ppr_reasons :: MsgDoc
ppr_reasons = [MsgDoc] -> MsgDoc
vcat (((UnitInfo, UnusableUnitReason) -> MsgDoc)
-> [(UnitInfo, UnusableUnitReason)] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitInfo, UnusableUnitReason) -> MsgDoc
forall {a} {compid} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
(GenericUnitInfo compid srcpkgid srcpkgname a modulename mod,
 UnusableUnitReason)
-> MsgDoc
ppr_reason [(UnitInfo, UnusableUnitReason)]
reasons)
        ppr_reason :: (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod,
 UnusableUnitReason)
-> MsgDoc
ppr_reason (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
p, UnusableUnitReason
reason) =
            MsgDoc -> UnusableUnitReason -> MsgDoc
pprReason (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
p) MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
"is") UnusableUnitReason
reason

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

pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag :: TrustFlag -> MsgDoc
pprTrustFlag TrustFlag
flag = case TrustFlag
flag of
    TrustPackage [Char]
p    -> [Char] -> MsgDoc
text [Char]
"-trust " MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
p
    DistrustPackage [Char]
p -> [Char] -> MsgDoc
text [Char]
"-distrust " MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
p

-- -----------------------------------------------------------------------------
-- Wired-in units
--
-- See Note [Wired-in units] in GHC.Unit.Module

type WiringMap = Map UnitId UnitId

findWiredInUnits
   :: (SDoc -> IO ())      -- debug trace
   -> UnitPrecedenceMap
   -> [UnitInfo]           -- database
   -> VisibilityMap             -- info on what units are visible
                                -- for wired in selection
   -> IO ([UnitInfo],  -- unit database updated for wired in
          WiringMap)   -- map from unit id to wired identity

findWiredInUnits :: (MsgDoc -> IO ())
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo], Map UnitId UnitId)
findWiredInUnits MsgDoc -> IO ()
printer UnitPrecedenceMap
prec_map [UnitInfo]
pkgs VisibilityMap
vis_map = do
  -- Now we must find our wired-in units, and rename them to
  -- their canonical names (eg. base-1.0 ==> base), as described
  -- in Note [Wired-in units] in GHC.Unit.Module
  let
        matches :: UnitInfo -> UnitId -> Bool
        UnitInfo
pc matches :: UnitInfo -> UnitId -> Bool
`matches` UnitId
pid = UnitInfo -> PackageName
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
pc PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> PackageName
PackageName (UnitId -> FastString
unitIdFS UnitId
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.
        --
        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs UnitId
wired_pkg =
           let all_ps :: [UnitInfo]
all_ps = [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
pkgs, UnitInfo
p UnitInfo -> UnitId -> Bool
`matches` UnitId
wired_pkg ]
               all_exposed_ps :: [UnitInfo]
all_exposed_ps =
                    [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
all_ps
                        , Unit -> VisibilityMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (UnitInfo -> Unit
mkUnit UnitInfo
p) VisibilityMap
vis_map ] in
           case [UnitInfo]
all_exposed_ps of
            [] -> case [UnitInfo]
all_ps of
                       []   -> IO (Maybe (UnitId, UnitInfo))
forall {a}. IO (Maybe a)
notfound
                       [UnitInfo]
many -> UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick ([UnitInfo] -> UnitInfo
forall a. [a] -> a
head (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
many))
            [UnitInfo]
many -> UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick ([UnitInfo] -> UnitInfo
forall a. [a] -> a
head (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
many))
          where
                notfound :: IO (Maybe a)
notfound = do
                          MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            [Char] -> MsgDoc
text [Char]
"wired-in package "
                                 MsgDoc -> MsgDoc -> MsgDoc
<> FastString -> MsgDoc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
                                 MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
" not found."
                          Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
                pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick UnitInfo
pkg = do
                        MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            [Char] -> MsgDoc
text [Char]
"wired-in package "
                                 MsgDoc -> MsgDoc -> MsgDoc
<> FastString -> MsgDoc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
                                 MsgDoc -> MsgDoc -> MsgDoc
<> [Char] -> MsgDoc
text [Char]
" mapped to "
                                 MsgDoc -> MsgDoc -> MsgDoc
<> UnitId -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg)
                        Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo)
forall a. a -> Maybe a
Just (UnitId
wired_pkg, UnitInfo
pkg))


  [Maybe (UnitId, UnitInfo)]
mb_wired_in_pkgs <- (UnitId -> IO (Maybe (UnitId, UnitInfo)))
-> [UnitId] -> IO [Maybe (UnitId, UnitInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs) [UnitId]
wiredInUnitIds
  let
        wired_in_pkgs :: [(UnitId, UnitInfo)]
wired_in_pkgs = [Maybe (UnitId, UnitInfo)] -> [(UnitId, UnitInfo)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (UnitId, UnitInfo)]
mb_wired_in_pkgs

        wiredInMap :: Map UnitId UnitId
        wiredInMap :: Map UnitId UnitId
wiredInMap = [(UnitId, UnitId)] -> Map UnitId UnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
realUnitInfo, UnitId
wiredInUnitId)
          | (UnitId
wiredInUnitId, UnitInfo
realUnitInfo) <- [(UnitId, UnitInfo)]
wired_in_pkgs
          , Bool -> Bool
not (UnitInfo -> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite UnitInfo
realUnitInfo)
          ]

        updateWiredInDependencies :: [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
updateWiredInDependencies [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
pkgs = (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
 -> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
forall a b. (a -> b) -> [a] -> [b]
map (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall {compid} {srcpkgid} {srcpkgname} {a}.
GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
upd_deps (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
 -> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
    -> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall {f :: * -> *} {srcpkgid} {srcpkgname} {modulename} {mod}.
Functor f =>
GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo
     (f UnitId) srcpkgid srcpkgname UnitId modulename mod
upd_pkg) [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
pkgs
          where upd_pkg :: GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo
     (f UnitId) srcpkgid srcpkgname UnitId modulename mod
upd_pkg GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg
                  | Just UnitId
wiredInUnitId <- UnitId -> Map UnitId UnitId -> Maybe UnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg) Map UnitId UnitId
wiredInMap
                  = GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg { unitId :: UnitId
unitId         = UnitId
wiredInUnitId
                        , unitInstanceOf :: f UnitId
unitInstanceOf = (UnitId -> UnitId) -> f UnitId -> f UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnitId -> UnitId -> UnitId
forall a b. a -> b -> a
const UnitId
wiredInUnitId) (GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> f UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg)
                           -- every non instantiated unit is an instance of
                           -- itself (required by Backpack...)
                           --
                           -- See Note [About Units] in GHC.Unit
                        }
                  | Bool
otherwise
                  = GenericUnitInfo
  (f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg
                upd_deps :: GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
upd_deps GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg = GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg {
                      unitDepends :: [UnitId]
unitDepends = (UnitId -> UnitId) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (Map UnitId UnitId -> UnitId -> UnitId
upd_wired_in Map UnitId UnitId
wiredInMap) (GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg),
                      unitExposedModules :: [(a, Maybe Module)]
unitExposedModules
                        = ((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 UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiredInMap) Maybe Module
v))
                              (GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> [(a, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg)
                    }


  ([UnitInfo], Map UnitId UnitId)
-> IO ([UnitInfo], Map UnitId UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitInfo] -> [UnitInfo]
forall {f :: * -> *} {srcpkgid} {srcpkgname} {a}.
Functor f =>
[GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
updateWiredInDependencies [UnitInfo]
pkgs, Map UnitId UnitId
wiredInMap)

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

-- | Some wired units can be used to instantiate the home unit. We need to
-- replace their unit keys with their wired unit ids.
upd_wired_in_home_instantiations :: DynFlags -> DynFlags
upd_wired_in_home_instantiations :: DynFlags -> DynFlags
upd_wired_in_home_instantiations DynFlags
dflags = DynFlags
dflags { homeUnitInstantiations :: [(ModuleName, Module)]
homeUnitInstantiations = [(ModuleName, Module)]
wiredInsts }
   where
      state :: UnitState
state        = DynFlags -> UnitState
unitState DynFlags
dflags
      wiringMap :: Map UnitId UnitId
wiringMap    = UnitState -> Map UnitId UnitId
wireMap UnitState
state
      unwiredInsts :: [(ModuleName, Module)]
unwiredInsts = DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations DynFlags
dflags
      wiredInsts :: [(ModuleName, Module)]
wiredInsts   = ((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 UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiringMap)) [(ModuleName, Module)]
unwiredInsts


upd_wired_in_mod :: WiringMap -> Module -> Module
upd_wired_in_mod :: Map UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiredInMap (Module Unit
uid ModuleName
m) = Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
Module (Map UnitId UnitId -> Unit -> Unit
upd_wired_in_uid Map UnitId UnitId
wiredInMap Unit
uid) ModuleName
m

upd_wired_in_uid :: WiringMap -> Unit -> Unit
upd_wired_in_uid :: Map UnitId UnitId -> Unit -> Unit
upd_wired_in_uid Map UnitId UnitId
wiredInMap Unit
u = case Unit
u of
   Unit
HoleUnit                -> Unit
forall uid. GenUnit uid
HoleUnit
   RealUnit (Definite UnitId
uid) -> Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite (Map UnitId UnitId -> UnitId -> UnitId
upd_wired_in Map UnitId UnitId
wiredInMap UnitId
uid))
   VirtUnit GenInstantiatedUnit UnitId
indef_uid ->
      GenInstantiatedUnit UnitId -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit (GenInstantiatedUnit UnitId -> Unit)
-> GenInstantiatedUnit UnitId -> Unit
forall a b. (a -> b) -> a -> b
$ IndefUnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
mkInstantiatedUnit
        (GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
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 UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiredInMap Module
y)) (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
indef_uid))

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

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


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

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

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

type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason)

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

reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles :: (MsgDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles MsgDoc -> IO ()
printer [SCC UnitInfo]
sccs = (SCC UnitInfo -> IO ()) -> [SCC UnitInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SCC UnitInfo -> IO ()
forall {b} {compid} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable b =>
SCC (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod)
-> IO ()
report [SCC UnitInfo]
sccs
  where
    report :: SCC (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod)
-> IO ()
report (AcyclicSCC GenericUnitInfo compid srcpkgid srcpkgname b modulename mod
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    report (CyclicSCC [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs) =
        MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> MsgDoc
text [Char]
"these packages are involved in a cycle:" MsgDoc -> MsgDoc -> MsgDoc
$$
            Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
hsep ((GenericUnitInfo compid srcpkgid srcpkgname b modulename mod
 -> MsgDoc)
-> [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
-> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (b -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (b -> MsgDoc)
-> (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod
    -> b)
-> GenericUnitInfo compid srcpkgid srcpkgname b modulename mod
-> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo compid srcpkgid srcpkgname b modulename mod -> b
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId) [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs))

reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable :: (MsgDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable MsgDoc -> IO ()
printer UnusableUnits
pkgs = ((UnitId, (UnitInfo, UnusableUnitReason)) -> IO ())
-> [(UnitId, (UnitInfo, UnusableUnitReason))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UnitId, (UnitInfo, UnusableUnitReason)) -> IO ()
forall {a} {a}.
Outputable a =>
(a, (a, UnusableUnitReason)) -> IO ()
report (UnusableUnits -> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall k a. Map k a -> [(k, a)]
Map.toList UnusableUnits
pkgs)
  where
    report :: (a, (a, UnusableUnitReason)) -> IO ()
report (a
ipid, (a
_, UnusableUnitReason
reason)) =
       MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
         MsgDoc -> UnusableUnitReason -> MsgDoc
pprReason
           ([Char] -> MsgDoc
text [Char]
"package" MsgDoc -> MsgDoc -> MsgDoc
<+> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
ipid MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
"is") UnusableUnitReason
reason

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

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

-- | Compute the reverse dependency index of a unit database.
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
db = (RevIndex -> UnitInfo -> RevIndex)
-> RevIndex -> UnitInfoMap -> RevIndex
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' RevIndex -> UnitInfo -> RevIndex
forall {a} {compid} {srcpkgid} {srcpkgname} {modulename} {mod}.
Ord a =>
Map a [a]
-> GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
-> Map a [a]
go RevIndex
forall k a. Map k a
Map.empty UnitInfoMap
db
  where
    go :: Map a [a]
-> GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
-> Map a [a]
go Map a [a]
r GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
pkg = (Map a [a] -> a -> Map a [a]) -> Map a [a] -> [a] -> Map a [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (a -> Map a [a] -> a -> Map a [a]
forall {k} {a}. Ord k => a -> Map k [a] -> k -> Map k [a]
go' (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
pkg)) Map a [a]
r (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod -> [a]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends GenericUnitInfo compid srcpkgid srcpkgname a 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 'UnitId's to remove, a database,
-- and a reverse dependency index (as computed by 'reverseDeps'),
-- remove those units, plus any units which depend on them.
-- Returns the pruned database, as well as a list of 'UnitInfo's
-- that was removed.
removeUnits :: [UnitId] -> RevIndex
               -> UnitInfoMap
               -> (UnitInfoMap, [UnitInfo])
removeUnits :: [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits [UnitId]
uids RevIndex
index UnitInfoMap
m = [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
forall {a}. [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (UnitInfoMap
m,[])
  where
    go :: [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [] (Map UnitId a
m,[a]
pkgs) = (Map UnitId a
m,[a]
pkgs)
    go (UnitId
uid:[UnitId]
uids) (Map UnitId a
m,[a]
pkgs)
        | Just a
pkg <- UnitId -> Map UnitId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
m
        = case UnitId -> RevIndex -> Maybe [UnitId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid RevIndex
index of
            Maybe [UnitId]
Nothing    -> [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (UnitId -> Map UnitId a -> Map UnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UnitId
uid Map UnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
            Just [UnitId]
rdeps -> [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go ([UnitId]
rdeps [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
uids) (UnitId -> Map UnitId a -> Map UnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UnitId
uid Map UnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
        | Bool
otherwise
        = [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (Map UnitId a
m,[a]
pkgs)

-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
-- which correspond to units that do not exist in the index.
depsNotAvailable :: UnitInfoMap
                 -> UnitInfo
                 -> [UnitId]
depsNotAvailable :: UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map UnitInfo
pkg = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitId -> Bool) -> UnitId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> UnitInfoMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` UnitInfoMap
pkg_map)) (UnitInfo -> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
pkg)

-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
-- 'unitAbiDepends' which correspond to units that do not exist, OR have
-- mismatching ABIs.
depsAbiMismatch :: UnitInfoMap
                -> UnitInfo
                -> [UnitId]
depsAbiMismatch :: UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map UnitInfo
pkg = ((UnitId, [Char]) -> UnitId) -> [(UnitId, [Char])] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, [Char]) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, [Char])] -> [UnitId])
-> ([(UnitId, [Char])] -> [(UnitId, [Char])])
-> [(UnitId, [Char])]
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnitId, [Char]) -> Bool)
-> [(UnitId, [Char])] -> [(UnitId, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((UnitId, [Char]) -> Bool) -> (UnitId, [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, [Char]) -> Bool
abiMatch) ([(UnitId, [Char])] -> [UnitId]) -> [(UnitId, [Char])] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [(UnitId, [Char])]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(uid, [Char])]
unitAbiDepends UnitInfo
pkg
  where
    abiMatch :: (UnitId, [Char]) -> Bool
abiMatch (UnitId
dep_uid, [Char]
abi)
        | Just UnitInfo
dep_pkg <- UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
dep_uid UnitInfoMap
pkg_map
        = UnitInfo -> [Char]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [Char]
unitAbiHash UnitInfo
dep_pkg [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
abi
        | Bool
otherwise
        = Bool
False

-- -----------------------------------------------------------------------------
-- Ignore units

ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
flags [UnitInfo]
pkgs = [(UnitId, (UnitInfo, UnusableUnitReason))] -> UnusableUnits
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))])
-> [IgnorePackageFlag]
-> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit [IgnorePackageFlag]
flags)
  where
  doit :: IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit (IgnorePackage [Char]
str) =
     case (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Char] -> UnitInfo -> Bool
matchingStr [Char]
str) [UnitInfo]
pkgs of
         ([UnitInfo]
ps, [UnitInfo]
_) -> [ (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p, (UnitInfo
p, UnusableUnitReason
IgnoredWithFlag))
                    | UnitInfo
p <- [UnitInfo]
ps ]
        -- missing unit 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 unit, a mapping from uid -> i indicates that this
-- unit was brought into GHC by the ith @-package-db@ flag on
-- the command line.  We use this mapping to make sure we prefer
-- units that were defined later on the command line, if there
-- is an ambiguity.
type UnitPrecedenceMap = Map UnitId Int

-- | Given a list of databases, merge them together, where
-- units 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 :: (SDoc -> IO ()) -> [UnitDatabase UnitId]
               -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases :: (MsgDoc -> IO ())
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases MsgDoc -> IO ()
printer = ((UnitInfoMap, UnitPrecedenceMap)
 -> (Int, UnitDatabase UnitId)
 -> IO (UnitInfoMap, UnitPrecedenceMap))
-> (UnitInfoMap, UnitPrecedenceMap)
-> [(Int, UnitDatabase UnitId)]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
forall k a. Map k a
Map.empty, UnitPrecedenceMap
forall k a. Map k a
Map.empty) ([(Int, UnitDatabase UnitId)]
 -> IO (UnitInfoMap, UnitPrecedenceMap))
-> ([UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)])
-> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
  where
    merge :: (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
pkg_map, UnitPrecedenceMap
prec_map) (Int
i, UnitDatabase [Char]
db_path [UnitInfo]
db) = do
      MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> MsgDoc
text [Char]
"loading package database" MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
db_path
      [UnitId] -> (UnitId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
override_set) ((UnitId -> IO ()) -> IO ()) -> (UnitId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UnitId
pkg ->
          MsgDoc -> IO ()
printer (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
              [Char] -> MsgDoc
text [Char]
"package" MsgDoc -> MsgDoc -> MsgDoc
<+> UnitId -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr UnitId
pkg MsgDoc -> MsgDoc -> MsgDoc
<+>
              [Char] -> MsgDoc
text [Char]
"overrides a previously defined package"
      (UnitInfoMap, UnitPrecedenceMap)
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfoMap
pkg_map', UnitPrecedenceMap
prec_map')
     where
      db_map :: UnitInfoMap
db_map = [UnitInfo] -> UnitInfoMap
forall {compid} {srcpkgid} {srcpkgname} {modulename} {mod}.
[GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
     UnitId
     (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map [UnitInfo]
db
      mk_pkg_map :: [GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
     UnitId
     (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map = [(UnitId,
  GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
-> Map
     UnitId
     (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UnitId,
   GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
 -> Map
      UnitId
      (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod))
-> ([GenericUnitInfo
       compid srcpkgid srcpkgname UnitId modulename mod]
    -> [(UnitId,
         GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)])
-> [GenericUnitInfo
      compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
     UnitId
     (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
 -> (UnitId,
     GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod))
-> [GenericUnitInfo
      compid srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
     GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
forall a b. (a -> b) -> [a] -> [b]
map (\GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
p -> (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
p, GenericUnitInfo compid srcpkgid srcpkgname 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 UnitId
      override_set :: Set UnitId
override_set = Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (UnitInfoMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet UnitInfoMap
db_map)
                                      (UnitInfoMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet UnitInfoMap
pkg_map)

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

      prec_map' :: UnitPrecedenceMap
      prec_map' :: UnitPrecedenceMap
prec_map' = UnitPrecedenceMap -> UnitPrecedenceMap -> UnitPrecedenceMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((UnitInfo -> Int) -> UnitInfoMap -> UnitPrecedenceMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int -> UnitInfo -> Int
forall a b. a -> b -> a
const Int
i) UnitInfoMap
db_map) UnitPrecedenceMap
prec_map

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

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

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

    -- Find broken units
    directly_broken :: [UnitInfo]
directly_broken = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map1)
                             (UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map1)
    (UnitInfoMap
pkg_map2, [UnitInfo]
broken) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId [UnitInfo]
directly_broken) RevIndex
index UnitInfoMap
pkg_map1
    unusable_broken :: UnusableUnits
unusable_broken = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {compid} {srcpkgid} {srcpkgname}
       {modulename} {mod}.
Ord k =>
(t -> b)
-> (t
    -> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
    -> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
     k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
BrokenDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map2 [UnitInfo]
broken

    -- Find recursive units
    sccs :: [SCC UnitInfo]
sccs = [(UnitInfo, UnitId, [UnitId])] -> [SCC UnitInfo]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [ (UnitInfo
pkg, UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg, UnitInfo -> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
pkg)
                            | UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map2 ]
    getCyclicSCC :: SCC (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod)
-> [b]
getCyclicSCC (CyclicSCC [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs) = (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod -> b)
-> [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
-> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenericUnitInfo compid srcpkgid srcpkgname b modulename mod -> b
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs
    getCyclicSCC (AcyclicSCC GenericUnitInfo compid srcpkgid srcpkgname b modulename mod
_) = []
    (UnitInfoMap
pkg_map3, [UnitInfo]
cyclic) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((SCC UnitInfo -> [UnitId]) -> [SCC UnitInfo] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC UnitInfo -> [UnitId]
forall {compid} {srcpkgid} {srcpkgname} {b} {modulename} {mod}.
SCC (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod)
-> [b]
getCyclicSCC [SCC UnitInfo]
sccs) RevIndex
index UnitInfoMap
pkg_map2
    unusable_cyclic :: UnusableUnits
unusable_cyclic = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {compid} {srcpkgid} {srcpkgname}
       {modulename} {mod}.
Ord k =>
(t -> b)
-> (t
    -> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
    -> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
     k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
CyclicDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map3 [UnitInfo]
cyclic

    -- Apply ignore flags
    directly_ignored :: UnusableUnits
directly_ignored = [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
ignore_flags (UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map3)
    (UnitInfoMap
pkg_map4, [UnitInfo]
ignored) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits (UnusableUnits -> [UnitId]
forall k a. Map k a -> [k]
Map.keys UnusableUnits
directly_ignored) RevIndex
index UnitInfoMap
pkg_map3
    unusable_ignored :: UnusableUnits
unusable_ignored = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {compid} {srcpkgid} {srcpkgname}
       {modulename} {mod}.
Ord k =>
(t -> b)
-> (t
    -> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
    -> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
     k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
IgnoredDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map4 [UnitInfo]
ignored

    -- Knock out units whose dependencies don't agree with ABI
    -- (i.e., got invalidated due to shadowing)
    directly_shadowed :: [UnitInfo]
directly_shadowed = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map4)
                               (UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map4)
    (UnitInfoMap
pkg_map5, [UnitInfo]
shadowed) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId [UnitInfo]
directly_shadowed) RevIndex
index UnitInfoMap
pkg_map4
    unusable_shadowed :: UnusableUnits
unusable_shadowed = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {compid} {srcpkgid} {srcpkgname}
       {modulename} {mod}.
Ord k =>
(t -> b)
-> (t
    -> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
    -> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
     k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
ShadowedDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map5 [UnitInfo]
shadowed

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

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

mkUnitState
    :: SDocContext            -- ^ SDocContext used to render exception messages
    -> (Int -> SDoc -> IO ()) -- ^ Trace printer
    -> UnitConfig
    -> IO (UnitState,[UnitDatabase UnitId])
mkUnitState :: SDocContext
-> (Int -> MsgDoc -> IO ())
-> UnitConfig
-> IO (UnitState, [UnitDatabase UnitId])
mkUnitState SDocContext
ctx Int -> MsgDoc -> IO ()
printer UnitConfig
cfg = 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 was 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.
-}

  -- if databases have not been provided, read the database flags
  [UnitDatabase UnitId]
raw_dbs <- case UnitConfig -> Maybe [UnitDatabase UnitId]
unitConfigDBCache UnitConfig
cfg of
               Maybe [UnitDatabase UnitId]
Nothing  -> (Int -> MsgDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Int -> MsgDoc -> IO ()
printer UnitConfig
cfg
               Just [UnitDatabase UnitId]
dbs -> [UnitDatabase UnitId] -> IO [UnitDatabase UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return [UnitDatabase UnitId]
dbs

  -- distrust all units if the flag is set
  let distrust_all :: UnitDatabase UnitId -> UnitDatabase UnitId
distrust_all UnitDatabase UnitId
db = UnitDatabase UnitId
db { unitDatabaseUnits :: [UnitInfo]
unitDatabaseUnits = [UnitInfo] -> [UnitInfo]
distrustAllUnits (UnitDatabase UnitId -> [UnitInfo]
forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits UnitDatabase UnitId
db) }
      dbs :: [UnitDatabase UnitId]
dbs | UnitConfig -> Bool
unitConfigDistrustAll UnitConfig
cfg = (UnitDatabase UnitId -> UnitDatabase UnitId)
-> [UnitDatabase UnitId] -> [UnitDatabase UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitDatabase UnitId -> UnitDatabase UnitId
distrust_all [UnitDatabase UnitId]
raw_dbs
          | Bool
otherwise                 = [UnitDatabase UnitId]
raw_dbs


  -- This, and the other reverse's that you will see, are due to the fact 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 (UnitConfig -> [PackageFlag]
unitConfigFlagsExposed UnitConfig
cfg)
  Int -> MsgDoc -> IO ()
printer Int
2 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> MsgDoc
text [Char]
"package flags" MsgDoc -> MsgDoc -> MsgDoc
<+> [PackageFlag] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [PackageFlag]
other_flags

  -- Merge databases together, without checking validity
  (UnitInfoMap
pkg_map1, UnitPrecedenceMap
prec_map) <- (MsgDoc -> IO ())
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases (Int -> MsgDoc -> IO ()
printer Int
2) [UnitDatabase UnitId]
dbs

  -- Now that we've merged everything together, prune out unusable
  -- packages.
  let (UnitInfoMap
pkg_map2, UnusableUnits
unusable, [SCC UnitInfo]
sccs) = UnitConfig
-> UnitInfoMap -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase UnitConfig
cfg UnitInfoMap
pkg_map1

  (MsgDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles   (Int -> MsgDoc -> IO ()
printer Int
2) [SCC UnitInfo]
sccs
  (MsgDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable (Int -> MsgDoc -> IO ()
printer Int
2) UnusableUnits
unusable

  -- Apply trust flags (these flags apply regardless of whether
  -- or not packages are visible or not)
  [UnitInfo]
pkgs1 <- ([UnitInfo] -> TrustFlag -> IO [UnitInfo])
-> [UnitInfo] -> [TrustFlag] -> IO [UnitInfo]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SDocContext
-> UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> IO [UnitInfo]
applyTrustFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnusableUnits
unusable)
                 (UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map2) ([TrustFlag] -> [TrustFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [TrustFlag]
unitConfigFlagsTrusted UnitConfig
cfg))
  let prelim_pkg_db :: UnitInfoMap
prelim_pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
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 :: UnitInfo -> UnitInfo -> UnitInfo
preferLater UnitInfo
unit UnitInfo
unit' =
        case UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
unit UnitInfo
unit' of
            Ordering
GT -> UnitInfo
unit
            Ordering
_  -> UnitInfo
unit'
      addIfMorePreferable :: UniqDFM FastString UnitInfo
-> UnitInfo -> UniqDFM FastString UnitInfo
addIfMorePreferable UniqDFM FastString UnitInfo
m UnitInfo
unit = (UnitInfo -> UnitInfo -> UnitInfo)
-> UniqDFM FastString UnitInfo
-> FastString
-> UnitInfo
-> UniqDFM FastString UnitInfo
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM_C UnitInfo -> UnitInfo -> UnitInfo
preferLater UniqDFM FastString UnitInfo
m (UnitInfo -> FastString
fsPackageName UnitInfo
unit) UnitInfo
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 :: UniqDFM FastString UnitInfo
mostPreferablePackageReps = if UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg
                    then UniqDFM FastString UnitInfo
forall key elt. UniqDFM key elt
emptyUDFM
                    else (UniqDFM FastString UnitInfo
 -> UnitInfo -> UniqDFM FastString UnitInfo)
-> UniqDFM FastString UnitInfo
-> [UnitInfo]
-> UniqDFM FastString UnitInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqDFM FastString UnitInfo
-> UnitInfo -> UniqDFM FastString UnitInfo
addIfMorePreferable UniqDFM FastString UnitInfo
forall key elt. UniqDFM key elt
emptyUDFM [UnitInfo]
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 package 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 :: UnitInfo -> Bool
mostPreferable UnitInfo
u =
        case UniqDFM FastString UnitInfo -> FastString -> Maybe UnitInfo
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM UniqDFM FastString UnitInfo
mostPreferablePackageReps (UnitInfo -> FastString
fsPackageName UnitInfo
u) of
          Maybe UnitInfo
Nothing -> Bool
False
          Just UnitInfo
u' -> UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
u UnitInfo
u' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
      vis_map1 :: VisibilityMap
vis_map1 = (VisibilityMap -> UnitInfo -> VisibilityMap)
-> VisibilityMap -> [UnitInfo] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\VisibilityMap
vm UnitInfo
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 UnitInfo -> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsExposed UnitInfo
p Bool -> Bool -> Bool
&& Unit -> Bool
unitIsDefinite (UnitInfo -> Unit
mkUnit UnitInfo
p) Bool -> Bool -> Bool
&& UnitInfo -> Bool
mostPreferable UnitInfo
p
                               then Unit -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitInfo -> Unit
mkUnit UnitInfo
p)
                                               UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> 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 (UnitInfo -> FastString
fsPackageName UnitInfo
p)),
                                                 uv_requirements :: Map ModuleName (Set InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
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 [UnitInfo]
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 (SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnitInfoMap
prelim_pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet UnusableUnits
unusable
                        (UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg) [UnitInfo]
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.
  --
  ([UnitInfo]
pkgs2, Map UnitId UnitId
wired_map) <- (MsgDoc -> IO ())
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo], Map UnitId UnitId)
findWiredInUnits (Int -> MsgDoc -> IO ()
printer Int
2) UnitPrecedenceMap
prec_map [UnitInfo]
pkgs1 VisibilityMap
vis_map2
  let pkg_db :: UnitInfoMap
pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs2

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

  let hide_plugin_pkgs :: Bool
hide_plugin_pkgs = UnitConfig -> Bool
unitConfigHideAllPlugins UnitConfig
cfg
  VisibilityMap
plugin_vis_map <-
    case UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins UnitConfig
cfg 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 (SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnitInfoMap
prelim_pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet UnusableUnits
unusable
                                Bool
hide_plugin_pkgs [UnitInfo]
pkgs1)
                             VisibilityMap
plugin_vis_map1
                             ([PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins UnitConfig
cfg))
                -- 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 UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map UnitId UnitId
wired_map VisibilityMap
plugin_vis_map2)

  let pkgname_map :: Map PackageName IndefUnitId
pkgname_map = (Map PackageName IndefUnitId
 -> UnitInfo -> Map PackageName IndefUnitId)
-> Map PackageName IndefUnitId
-> [UnitInfo]
-> Map PackageName IndefUnitId
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PackageName IndefUnitId
-> UnitInfo -> Map PackageName IndefUnitId
forall {srcpkgname} {a} {srcpkgid} {uid} {modulename} {mod}.
Ord srcpkgname =>
Map srcpkgname a
-> GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> Map srcpkgname a
add Map PackageName IndefUnitId
forall k a. Map k a
Map.empty [UnitInfo]
pkgs2
        where add :: Map srcpkgname a
-> GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> Map srcpkgname a
add Map srcpkgname a
pn_map GenericUnitInfo a srcpkgid srcpkgname uid 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 (GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> srcpkgname
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
p) (GenericUnitInfo a srcpkgid srcpkgname uid modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
p) Map srcpkgname a
pn_map

  -- The explicitUnits accurately reflects the set of units 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 :: [Unit]
explicit_pkgs = VisibilityMap -> [Unit]
forall k a. Map k a -> [k]
Map.keys VisibilityMap
vis_map
      req_ctx :: Map ModuleName [InstantiatedModule]
req_ctx = (Set InstantiatedModule -> [InstantiatedModule])
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName [InstantiatedModule]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Set InstantiatedModule -> [InstantiatedModule]
forall a. Set a -> [a]
Set.toList)
              (Map ModuleName (Set InstantiatedModule)
 -> Map ModuleName [InstantiatedModule])
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName [InstantiatedModule]
forall a b. (a -> b) -> a -> b
$ (Set InstantiatedModule
 -> Set InstantiatedModule -> Set InstantiatedModule)
-> [Map ModuleName (Set InstantiatedModule)]
-> Map ModuleName (Set InstantiatedModule)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((UnitVisibility -> Map ModuleName (Set InstantiatedModule))
-> [UnitVisibility] -> [Map ModuleName (Set InstantiatedModule)]
forall a b. (a -> b) -> [a] -> [b]
map UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements (VisibilityMap -> [UnitVisibility]
forall k a. Map k a -> [a]
Map.elems VisibilityMap
vis_map))


  --
  -- 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 :: [Unit]
preload1 = VisibilityMap -> [Unit]
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)

      -- add default preload units if they can be found in the db
      basicLinkedUnits :: [Unit]
basicLinkedUnits = (UnitId -> Unit) -> [UnitId] -> [Unit]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (Definite UnitId -> Unit)
-> (UnitId -> Definite UnitId) -> UnitId -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite)
                         ([UnitId] -> [Unit]) -> [UnitId] -> [Unit]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitInfoMap -> Bool) -> UnitInfoMap -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> UnitInfoMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member UnitInfoMap
pkg_db)
                         ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitConfig -> [UnitId]
unitConfigAutoLink UnitConfig
cfg
      preload3 :: [Unit]
preload3 = [Unit] -> [Unit]
forall a. Ord a => [a] -> [a]
ordNub ([Unit] -> [Unit]) -> [Unit] -> [Unit]
forall a b. (a -> b) -> a -> b
$ ([Unit]
basicLinkedUnits [Unit] -> [Unit] -> [Unit]
forall a. [a] -> [a] -> [a]
++ [Unit]
preload1)

  -- Close the preload packages with their dependencies
  let dep_preload_err :: MaybeErr MsgDoc [UnitId]
dep_preload_err = UnitInfoMap -> [(UnitId, Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]
closeUnitDeps UnitInfoMap
pkg_db ([UnitId] -> [Maybe UnitId] -> [(UnitId, Maybe UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Unit -> UnitId) -> [Unit] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Unit -> UnitId
toUnitId [Unit]
preload3) (Maybe UnitId -> [Maybe UnitId]
forall a. a -> [a]
repeat Maybe UnitId
forall a. Maybe a
Nothing))
  [UnitId]
dep_preload <- SDocContext -> MaybeErr MsgDoc [UnitId] -> IO [UnitId]
forall a. SDocContext -> MaybeErr MsgDoc a -> IO a
throwErr SDocContext
ctx MaybeErr MsgDoc [UnitId]
dep_preload_err

  let mod_map1 :: ModuleNameProvidersMap
mod_map1 = SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
vis_map
      mod_map2 :: ModuleNameProvidersMap
mod_map2 = UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusable
      mod_map :: ModuleNameProvidersMap
mod_map = ModuleNameProvidersMap
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ModuleNameProvidersMap
mod_map1 ModuleNameProvidersMap
mod_map2

  -- Force the result to avoid leaking input parameters
  let !state :: UnitState
state = UnitState :: UnitInfoMap
-> PreloadUnitClosure
-> Map PackageName IndefUnitId
-> Map UnitId UnitId
-> Map UnitId UnitId
-> [UnitId]
-> [Unit]
-> ModuleNameProvidersMap
-> ModuleNameProvidersMap
-> Map ModuleName [InstantiatedModule]
-> Bool
-> UnitState
UnitState
         { preloadUnits :: [UnitId]
preloadUnits                 = [UnitId]
dep_preload
         , explicitUnits :: [Unit]
explicitUnits                = [Unit]
explicit_pkgs
         , unitInfoMap :: UnitInfoMap
unitInfoMap                  = UnitInfoMap
pkg_db
         , preloadClosure :: PreloadUnitClosure
preloadClosure               = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet
         , moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap       = ModuleNameProvidersMap
mod_map
         , pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
plugin_vis_map
         , packageNameMap :: Map PackageName IndefUnitId
packageNameMap               = Map PackageName IndefUnitId
pkgname_map
         , wireMap :: Map UnitId UnitId
wireMap                      = Map UnitId UnitId
wired_map
         , unwireMap :: Map UnitId UnitId
unwireMap                    = [(UnitId, UnitId)] -> Map UnitId UnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (UnitId
v,UnitId
k) | (UnitId
k,UnitId
v) <- Map UnitId UnitId -> [(UnitId, UnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map UnitId UnitId
wired_map ]
         , requirementContext :: Map ModuleName [InstantiatedModule]
requirementContext           = Map ModuleName [InstantiatedModule]
req_ctx
         , allowVirtualUnits :: Bool
allowVirtualUnits            = UnitConfig -> Bool
unitConfigAllowVirtualUnits UnitConfig
cfg
         }

  (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitState
state, [UnitDatabase UnitId]
raw_dbs)

-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
-- that it was recorded as in the package database.
unwireUnit :: UnitState -> Unit-> Unit
unwireUnit :: UnitState -> Unit -> Unit
unwireUnit UnitState
state uid :: Unit
uid@(RealUnit (Definite UnitId
def_uid)) =
    Unit -> (UnitId -> Unit) -> Maybe UnitId -> Unit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Unit
uid (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (Definite UnitId -> Unit)
-> (UnitId -> Definite UnitId) -> UnitId -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite) (UnitId -> Map UnitId UnitId -> Maybe UnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
def_uid (UnitState -> Map UnitId UnitId
unwireMap UnitState
state))
unwireUnit UnitState
_ Unit
uid = Unit
uid

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

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

mkModuleNameProvidersMap
  :: SDocContext     -- ^ SDocContext used to render exception messages
  -> UnitConfig
  -> UnitInfoMap
  -> PreloadUnitClosure
  -> VisibilityMap
  -> ModuleNameProvidersMap
mkModuleNameProvidersMap :: SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_map PreloadUnitClosure
closure 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_map is awkward because if we have an
    --      Backpack instantiation, we need to possibly add a
    --      package from pkg_map multiple times to the actual
    --      ModuleNameProvidersMap.  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.
    (ModuleNameProvidersMap
 -> Unit -> UnitVisibility -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> VisibilityMap
-> ModuleNameProvidersMap
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey ModuleNameProvidersMap
-> Unit -> UnitVisibility -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
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 = [(Unit, UnitVisibility)] -> VisibilityMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (UnitInfo -> Unit
mkUnit UnitInfo
pkg, UnitVisibility
forall a. Monoid a => a
mempty)
                  | UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map
                  -- Exclude specific instantiations of an indefinite
                  -- package
                  , UnitInfo -> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite UnitInfo
pkg Bool -> Bool -> Bool
|| [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnitInfo -> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
pkg)
                  ]

  emptyMap :: Map k a
emptyMap = Map k a
forall k a. Map k a
Map.empty
  setOrigins :: f a -> b -> f b
setOrigins f a
m b
os = (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> b
forall a b. a -> b -> a
const b
os) f a
m
  extend_modmap :: ModuleNameProvidersMap
-> Unit -> UnitVisibility -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
modmap Unit
uid
    UnitVisibility { uv_expose_all :: UnitVisibility -> Bool
uv_expose_all = Bool
b, uv_renamings :: UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns }
    = ModuleNameProvidersMap
-> [(ModuleName, Map Module ModuleOrigin)]
-> ModuleNameProvidersMap
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 ModuleNameProvidersMap
modmap [(ModuleName, Map Module ModuleOrigin)]
theBindings
   where
    pkg :: UnitInfo
pkg = Unit -> UnitInfo
unit_lookup Unit
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 :: * -> *} {a} {b}. Functor f => f a -> b -> f b
setOrigins Map Module ModuleOrigin
origEntry ModuleOrigin
fromFlag)
     where origEntry :: Map Module ModuleOrigin
origEntry = case UniqFM ModuleName (Map Module ModuleOrigin)
-> ModuleName -> Maybe (Map Module ModuleOrigin)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName (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 ([Char] -> GhcException
CmdLineError (SDocContext -> MsgDoc -> [Char]
renderWithStyle SDocContext
ctx
                        ([Char] -> MsgDoc
text [Char]
"package flag: could not find module name" MsgDoc -> MsgDoc -> MsgDoc
<+>
                            ModuleName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ModuleName
orig MsgDoc -> MsgDoc -> MsgDoc
<+> [Char] -> MsgDoc
text [Char]
"in package" MsgDoc -> MsgDoc -> MsgDoc
<+> Unit -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Unit
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 (Unit
pk', ModuleName
m', ModuleOrigin
origin') =
          case Maybe Module
exposedReexport of
           Maybe Module
Nothing -> (Unit
pk, ModuleName
m, Bool -> ModuleOrigin
fromExposedModules Bool
e)
           Just (Module Unit
pk' ModuleName
m') ->
              (Unit
pk', ModuleName
m', Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules Bool
e UnitInfo
pkg)
     (ModuleName, Map Module ModuleOrigin)
-> [(ModuleName, Map Module ModuleOrigin)]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pk' ModuleName
m' ModuleOrigin
origin')

    esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
    esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
esmap = [(ModuleName, Map Module ModuleOrigin)]
-> UniqFM ModuleName (Map Module ModuleOrigin)
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key 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, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pk ModuleName
m ModuleOrigin
ModHidden) | ModuleName
m <- [ModuleName]
hidden_mods]

    pk :: Unit
pk = UnitInfo -> Unit
mkUnit UnitInfo
pkg
    unit_lookup :: Unit -> UnitInfo
unit_lookup Unit
uid = Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' (UnitConfig -> Bool
unitConfigAllowVirtualUnits UnitConfig
cfg) UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
uid
                        Maybe UnitInfo -> UnitInfo -> UnitInfo
forall a. Maybe a -> a -> a
`orElse` [Char] -> MsgDoc -> UnitInfo
forall a. HasCallStack => [Char] -> MsgDoc -> a
pprPanic [Char]
"unit_lookup" (Unit -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Unit
uid)

    exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = UnitInfo -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
    hidden_mods :: [ModuleName]
hidden_mods  = UnitInfo -> [ModuleName]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
pkg

-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusables =
    (ModuleNameProvidersMap
 -> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> UnusableUnits
-> ModuleNameProvidersMap
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' ModuleNameProvidersMap
-> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
forall k a. Map k a
Map.empty UnusableUnits
unusables
 where
    extend_modmap :: ModuleNameProvidersMap
-> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
modmap (UnitInfo
pkg, UnusableUnitReason
reason) = ModuleNameProvidersMap
-> [(ModuleName, Map Module ModuleOrigin)]
-> ModuleNameProvidersMap
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 ModuleNameProvidersMap
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 = UnusableUnitReason -> ModuleOrigin
ModUnusable UnusableUnitReason
reason
            pkg_id :: Unit
pkg_id = UnitInfo -> Unit
mkUnit UnitInfo
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, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
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, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pkg_id ModuleName
mod ModuleOrigin
origin)

            exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = UnitInfo -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
            hidden_mods :: [ModuleName]
hidden_mods  = UnitInfo -> [ModuleName]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
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 :: 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 = (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 :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pkg ModuleName
mod = Module -> ModuleOrigin -> Map Module ModuleOrigin
forall k a. k -> a -> Map k a
Map.singleton (Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule Unit
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
getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String]
getUnitIncludePath :: DynFlags -> [UnitId] -> IO [[Char]]
getUnitIncludePath DynFlags
dflags [UnitId]
pkgs =
  [UnitInfo] -> [[Char]]
collectIncludeDirs ([UnitInfo] -> [[Char]]) -> IO [UnitInfo] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs

collectIncludeDirs :: [UnitInfo] -> [FilePath]
collectIncludeDirs :: [UnitInfo] -> [[Char]]
collectIncludeDirs [UnitInfo]
ps = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
ordNub (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
forall a. [a] -> Bool
notNull ((UnitInfo -> [[Char]]) -> [UnitInfo] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitIncludeDirs [UnitInfo]
ps))

-- | Find all the library paths in these and the preload packages
getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String]
getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [[Char]]
getUnitLibraryPath DynFlags
dflags [UnitId]
pkgs =
  DynFlags -> [UnitInfo] -> [[Char]]
collectLibraryPaths DynFlags
dflags ([UnitInfo] -> [[Char]]) -> IO [UnitInfo] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs

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

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

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

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

packageHsLibs :: DynFlags -> UnitInfo -> [String]
packageHsLibs :: DynFlags -> UnitInfo -> [[Char]]
packageHsLibs DynFlags
dflags UnitInfo
p = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
mkDynName ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
addSuffix) (UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitLibraries UnitInfo
p)
  where
        ways0 :: Set Way
ways0 = DynFlags -> Set Way
ways DynFlags
dflags

        ways1 :: Set Way
ways1 = (Way -> Bool) -> Set Way -> Set Way
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayDyn) Set 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 :: Set Way
ways2 | Way
WayDebug Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Way
ways1 Bool -> Bool -> Bool
|| Way
WayProf Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Way
ways1
              = (Way -> Bool) -> Set Way -> Set Way
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayEventLog) Set Way
ways1
              | Bool
otherwise
              = Set Way
ways1

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

        mkDynName :: [Char] -> [Char]
mkDynName [Char]
x
         | Way
WayDyn Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` DynFlags -> Set Way
ways DynFlags
dflags = [Char]
x
         | [Char]
"HS" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
x                =
              [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:DynFlags -> [Char]
programName DynFlags
dflags [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Char]
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 [Char]
x' <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"C" [Char]
x = [Char]
x'
         | Bool
otherwise
            = [Char] -> [Char]
forall a. [Char] -> a
panic ([Char]
"Don't understand library name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 :: [Char] -> [Char]
addSuffix rts :: [Char]
rts@[Char]
"HSrts"      = [Char]
rts       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]
expandTag [Char]
rts_tag)
        addSuffix rts :: [Char]
rts@[Char]
"HSrts-1.0.2"= [Char]
rts       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]
expandTag [Char]
rts_tag)
        addSuffix [Char]
other_lib        = [Char]
other_lib [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]
expandTag [Char]
tag)

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

-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
libraryDirsForWay :: DynFlags -> UnitInfo -> [String]
libraryDirsForWay :: DynFlags -> UnitInfo -> [[Char]]
libraryDirsForWay DynFlags
dflags
  | Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags = UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitLibraryDynDirs
  | Bool
otherwise                 = UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitLibraryDirs

-- | Find all the C-compiler options in these and the preload packages
getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [[Char]]
getUnitExtraCcOpts DynFlags
dflags [UnitId]
pkgs = do
  [UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
  [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> [[Char]]) -> [UnitInfo] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitCcOptions [UnitInfo]
ps)

-- | Find all the package framework paths in these and the preload packages
getUnitFrameworkPath  :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [[Char]]
getUnitFrameworkPath DynFlags
dflags [UnitId]
pkgs = do
  [UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
  [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
ordNub (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
forall a. [a] -> Bool
notNull ((UnitInfo -> [[Char]]) -> [UnitInfo] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitExtDepFrameworkDirs [UnitInfo]
ps)))

-- | Find all the package frameworks in these and the preload packages
getUnitFrameworks  :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworks :: DynFlags -> [UnitId] -> IO [[Char]]
getUnitFrameworks DynFlags
dflags [UnitId]
pkgs = do
  [UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
  [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> [[Char]]) -> [UnitInfo] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [[Char]]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [[Char]]
unitExtDepFrameworks [UnitInfo]
ps)

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

-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
                          -> ModuleName
                          -> [(Module, UnitInfo)]
lookupModuleInAllUnits :: UnitState -> ModuleName -> [(Module, UnitInfo)]
lookupModuleInAllUnits UnitState
pkgs ModuleName
m
  = case UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs ModuleName
m Maybe FastString
forall a. Maybe a
Nothing of
      LookupFound Module
a (UnitInfo, ModuleOrigin)
b -> [(Module
a,(UnitInfo, ModuleOrigin) -> UnitInfo
forall a b. (a, b) -> a
fst (UnitInfo, ModuleOrigin)
b)]
      LookupMultiple [(Module, ModuleOrigin)]
rs -> ((Module, ModuleOrigin) -> (Module, UnitInfo))
-> [(Module, ModuleOrigin)] -> [(Module, UnitInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (Module, ModuleOrigin) -> (Module, UnitInfo)
forall {b}. (Module, b) -> (Module, UnitInfo)
f [(Module, ModuleOrigin)]
rs
        where f :: (Module, b) -> (Module, UnitInfo)
f (Module
m,b
_) = (Module
m, [Char] -> Maybe UnitInfo -> UnitInfo
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"lookupModule" (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs
                                                         (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m)))
      LookupResult
_ -> []

-- | The result of performing a lookup
data LookupResult =
    -- | Found the module uniquely, nothing else to do
    LookupFound Module (UnitInfo, ModuleOrigin)
    -- | 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 :: UnitState
                            -> ModuleName
                            -> Maybe FastString
                            -> LookupResult
lookupModuleWithSuggestions :: UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs
  = UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs)

-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage UnitState
pkgs ModuleName
mn Maybe FastString
mfs =
    case UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs) ModuleName
mn Maybe FastString
mfs of
      LookupFound Module
_ (UnitInfo
orig_unit, ModuleOrigin
origin) ->
        case ModuleOrigin
origin of
          ModOrigin {Maybe Bool
fromOrigUnit :: Maybe Bool
fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit, [UnitInfo]
fromExposedReexport :: [UnitInfo]
fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport} ->
            case Maybe Bool
fromOrigUnit of
              -- Just True means, the import is available from its original location
              Just Bool
True ->
                [UnitInfo] -> Maybe [UnitInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo
orig_unit]
              -- Otherwise, it must be available from a reexport
              Maybe Bool
_ -> [UnitInfo] -> Maybe [UnitInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo]
fromExposedReexport

          ModuleOrigin
_ -> Maybe [UnitInfo]
forall a. Maybe a
Nothing

      LookupResult
_ -> Maybe [UnitInfo]
forall a. Maybe a
Nothing

lookupPluginModuleWithSuggestions :: UnitState
                                  -> ModuleName
                                  -> Maybe FastString
                                  -> LookupResult
lookupPluginModuleWithSuggestions :: UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupPluginModuleWithSuggestions UnitState
pkgs
  = UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> L