-- (c) The University of Glasgow, 2006

{-# LANGUAGE LambdaCase #-}

-- | Unit manipulation
module GHC.Unit.State (
        module GHC.Unit.Info,
        -- * Reading the package config, and processing cmdline args
        UnitState(..),
        UnitDatabase (..),
        UnitErr (..),
        emptyUnitState,
        initUnits,
        readUnitDatabases,
        readUnitDatabase,
        getUnitDbRefs,
        resolveUnitDatabase,
        listUnitInfo,
        -- * Overlays over the unit set
        TrustOverlay,
        IsTrusted(..),
        lookupTrustOverlay,
        distrustUnits,
        trustUnits,
        emptyTrustOverlay,
        -- * Querying the package config
        lookupUnit,
        lookupUnit',
        unsafeLookupUnit,
        lookupUnitId,
        lookupUnitId',
        unsafeLookupUnitId,
        isUnitTrusted,
        isUnitIdTrusted,
        isUnitInfoTrusted,

        lookupPackageName,
        resolvePackageImport,
        searchPackageId,
        listVisibleModuleNames,
        lookupModuleInAllUnits,
        lookupModuleWithSuggestions,
        lookupModulePackage,
        lookupPluginModuleWithSuggestions,
        requirementMerges,
        LookupResult(..),
        ModuleSuggestion(..),
        ModuleOrigin(..),
        UnusableUnit(..),
        UnusableUnitReason(..),
        pprReason,

        closeUnitDeps,
        closeUnitDeps',
        mayThrowUnitErr,

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

        -- * Pretty-printing
        pprFlag,
        pprUnits,
        pprUnitsSimple,
        pprUnitIdForUser,
        pprUnitInfoForUser,
        pprModuleMap,
        pprWithUnitState,
        pprRawUnitIds,

        -- * Utils
        unwireUnit,
        selectHptFlag,
        )
where

import GHC.Prelude

import GHC.Driver.DynFlags

import GHC.Platform
import GHC.Platform.Ways

import GHC.Unit.Database
import GHC.Unit.Home
import GHC.Unit.Info
import GHC.Unit.Module
import GHC.Unit.Ppr

import GHC.Unit.External.Database
import GHC.Unit.External.Index
import GHC.Unit.External.ModuleOrigin
import GHC.Unit.External.Providers
import GHC.Unit.External.Query
import GHC.Unit.External.Substitution
import GHC.Unit.External.Validate
import GHC.Unit.External.Visibility
import GHC.Unit.External.Wired

import GHC.Types.PkgQual
import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map

import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic

import GHC.Data.FastString
import GHC.Data.OsPath qualified as OsPath
import GHC.Data.ShortText qualified as ST
import GHC.Utils.Error
import GHC.Utils.Logger

import Control.Monad
import Data.Graph (SCC (..))
import Data.List (intersperse, partition, sortOn)
import Data.Monoid (First (..))
import Data.Set (Set)
import Data.Set qualified as Set

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

-- The unit state is computed by 'initUnits', and kept in HscEnv.
-- 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.

-- | Unit configuration
data UnitConfig = UnitConfig
   { UnitConfig -> ArchOS
unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS
   , UnitConfig -> Ways
unitConfigWays           :: !Ways          -- ^ Ways to use

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

   , UnitConfig -> String
unitConfigProgramName    :: !String
      -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
      -- variables such as "GHC[JS]_PACKAGE_PATH".

   , UnitConfig -> String
unitConfigGlobalDB :: !FilePath    -- ^ Path to global DB
   , UnitConfig -> String
unitConfigGHCDir   :: !FilePath    -- ^ Main GHC dir: contains settings, etc.
   , UnitConfig -> String
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

   -- 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
   , UnitConfig -> Set UnitId
unitConfigHomeUnits    :: Set.Set UnitId
   }

initUnitConfig :: DynFlags -> Set.Set UnitId -> UnitConfig
initUnitConfig :: DynFlags -> Set UnitId -> UnitConfig
initUnitConfig DynFlags
dflags Set UnitId
home_units =
   let !hu_id :: UnitId
hu_id             = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags
       !hu_instanceof :: Maybe UnitId
hu_instanceof     = DynFlags -> Maybe UnitId
homeUnitInstanceOf_ DynFlags
dflags
       !hu_instantiations :: [(ModuleName, Module)]
hu_instantiations = DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations_ DynFlags
dflags

       autoLink :: [UnitId]
autoLink
         | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoLinkPackages DynFlags
dflags) = []
         -- By default we add base, ghc-internal and rts to the preload units (when they are
         -- found in the unit database) except when we are building them
         --
         -- Since "base" is not wired in, then the unit-id is discovered
         -- from the settings file by default, but can be overriden by power-users
         -- by specifying `-base-unit-id` flag.
         | Bool
otherwise = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId
hu_id UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/=) [DynFlags -> UnitId
baseUnitId DynFlags
dflags, UnitId
ghcInternalUnitId, UnitId
rtsUnitId]

       -- if 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
       allow_virtual_units :: Bool
allow_virtual_units = case (Maybe UnitId
hu_instanceof, [(ModuleName, Module)]
hu_instantiations) of
            (Just UnitId
u, [(ModuleName, Module)]
is) -> UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
hu_id Bool -> Bool -> Bool
&& ((ModuleName, Module) -> Bool) -> [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule (Module -> Bool)
-> ((ModuleName, Module) -> Module) -> (ModuleName, Module) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
is
            (Maybe UnitId, [(ModuleName, Module)])
_            -> Bool
False

   in UnitConfig
      { unitConfigPlatformArchOS :: ArchOS
unitConfigPlatformArchOS = Platform -> ArchOS
platformArchOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
      , unitConfigProgramName :: String
unitConfigProgramName    = DynFlags -> String
programName DynFlags
dflags
      , unitConfigWays :: Ways
unitConfigWays           = DynFlags -> Ways
ways DynFlags
dflags
      , unitConfigAllowVirtual :: Bool
unitConfigAllowVirtual   = Bool
allow_virtual_units

      , unitConfigGlobalDB :: String
unitConfigGlobalDB       = DynFlags -> String
globalPackageDatabasePath DynFlags
dflags
      , unitConfigGHCDir :: String
unitConfigGHCDir         = DynFlags -> String
topDir DynFlags
dflags
      , unitConfigDBName :: String
unitConfigDBName         = String
"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

      , unitConfigFlagsDB :: [PackageDBFlag]
unitConfigFlagsDB      = (PackageDBFlag -> PackageDBFlag)
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String -> PackageDBFlag -> PackageDBFlag
offsetPackageDb (DynFlags -> Maybe String
workingDirectory DynFlags
dflags)) ([PackageDBFlag] -> [PackageDBFlag])
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> a -> b
$ 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
      , unitConfigHomeUnits :: Set UnitId
unitConfigHomeUnits    = Set UnitId
home_units

      }

  where
    offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
    offsetPackageDb :: Maybe String -> PackageDBFlag -> PackageDBFlag
offsetPackageDb (Just String
offset) (PackageDB (PkgDbPath OsPath
p)) | OsPath -> Bool
OsPath.isRelative OsPath
p = PkgDbRef -> PackageDBFlag
PackageDB (OsPath -> PkgDbRef
PkgDbPath (HasCallStack => String -> OsPath
String -> OsPath
OsPath.unsafeEncodeUtf String
offset OsPath -> OsPath -> OsPath
OsPath.</> OsPath
p))
    offsetPackageDb Maybe String
_ PackageDBFlag
p = PackageDBFlag
p

data IsTrusted
  = Trusted
  | Distrusted
  deriving ( IsTrusted -> IsTrusted -> Bool
(IsTrusted -> IsTrusted -> Bool)
-> (IsTrusted -> IsTrusted -> Bool) -> Eq IsTrusted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsTrusted -> IsTrusted -> Bool
== :: IsTrusted -> IsTrusted -> Bool
$c/= :: IsTrusted -> IsTrusted -> Bool
/= :: IsTrusted -> IsTrusted -> Bool
Eq, Eq IsTrusted
Eq IsTrusted =>
(IsTrusted -> IsTrusted -> Ordering)
-> (IsTrusted -> IsTrusted -> Bool)
-> (IsTrusted -> IsTrusted -> Bool)
-> (IsTrusted -> IsTrusted -> Bool)
-> (IsTrusted -> IsTrusted -> Bool)
-> (IsTrusted -> IsTrusted -> IsTrusted)
-> (IsTrusted -> IsTrusted -> IsTrusted)
-> Ord IsTrusted
IsTrusted -> IsTrusted -> Bool
IsTrusted -> IsTrusted -> Ordering
IsTrusted -> IsTrusted -> IsTrusted
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IsTrusted -> IsTrusted -> Ordering
compare :: IsTrusted -> IsTrusted -> Ordering
$c< :: IsTrusted -> IsTrusted -> Bool
< :: IsTrusted -> IsTrusted -> Bool
$c<= :: IsTrusted -> IsTrusted -> Bool
<= :: IsTrusted -> IsTrusted -> Bool
$c> :: IsTrusted -> IsTrusted -> Bool
> :: IsTrusted -> IsTrusted -> Bool
$c>= :: IsTrusted -> IsTrusted -> Bool
>= :: IsTrusted -> IsTrusted -> Bool
$cmax :: IsTrusted -> IsTrusted -> IsTrusted
max :: IsTrusted -> IsTrusted -> IsTrusted
$cmin :: IsTrusted -> IsTrusted -> IsTrusted
min :: IsTrusted -> IsTrusted -> IsTrusted
Ord )

-- | The 'TrustOverlay' stores user overwrites of the on-disk 'unitIsTrusted' status.
--
-- The user can overwrite this value via flags such as @-distrust-all-packages@.
-- We do not modify the 'UnitInfo' directory, but rather store this user selection
-- in the 'TrustOverlay'.
--
-- This allows us to share the 'UnitInfo' completely and saves us memory.
newtype TrustOverlay = TrustOverlay
  { TrustOverlay -> UniqMap UnitId IsTrusted
trustOverlay :: UniqMap UnitId IsTrusted
  }

lookupTrustOverlay :: TrustOverlay -> UnitId -> Maybe IsTrusted
lookupTrustOverlay :: TrustOverlay -> UnitId -> Maybe IsTrusted
lookupTrustOverlay TrustOverlay
to = UniqMap UnitId IsTrusted -> UnitId -> Maybe IsTrusted
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (TrustOverlay -> UniqMap UnitId IsTrusted
trustOverlay TrustOverlay
to)

distrustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
distrustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
distrustUnits [UnitId]
elements (TrustOverlay UniqMap UnitId IsTrusted
to) = UniqMap UnitId IsTrusted -> TrustOverlay
TrustOverlay (UniqMap UnitId IsTrusted -> TrustOverlay)
-> UniqMap UnitId IsTrusted -> TrustOverlay
forall a b. (a -> b) -> a -> b
$ (UniqMap UnitId IsTrusted -> UnitId -> UniqMap UnitId IsTrusted)
-> UniqMap UnitId IsTrusted -> [UnitId] -> UniqMap UnitId IsTrusted
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ UniqMap UnitId IsTrusted
acc UnitId
uid -> UniqMap UnitId IsTrusted
-> UnitId -> IsTrusted -> UniqMap UnitId IsTrusted
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap UniqMap UnitId IsTrusted
acc UnitId
uid IsTrusted
Distrusted) UniqMap UnitId IsTrusted
to [UnitId]
elements

trustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
trustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
trustUnits [UnitId]
elements (TrustOverlay UniqMap UnitId IsTrusted
to) = UniqMap UnitId IsTrusted -> TrustOverlay
TrustOverlay (UniqMap UnitId IsTrusted -> TrustOverlay)
-> UniqMap UnitId IsTrusted -> TrustOverlay
forall a b. (a -> b) -> a -> b
$ (UniqMap UnitId IsTrusted -> UnitId -> UniqMap UnitId IsTrusted)
-> UniqMap UnitId IsTrusted -> [UnitId] -> UniqMap UnitId IsTrusted
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ UniqMap UnitId IsTrusted
acc UnitId
uid -> UniqMap UnitId IsTrusted
-> UnitId -> IsTrusted -> UniqMap UnitId IsTrusted
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap UniqMap UnitId IsTrusted
acc UnitId
uid IsTrusted
Trusted) UniqMap UnitId IsTrusted
to [UnitId]
elements

emptyTrustOverlay :: TrustOverlay
emptyTrustOverlay :: TrustOverlay
emptyTrustOverlay = UniqMap UnitId IsTrusted -> TrustOverlay
TrustOverlay UniqMap UnitId IsTrusted
forall k a. UniqMap k a
emptyUniqMap

{-
Note [Sharing 'UnitInfo's across the 'UnitEnv']
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The 'UnitState' and 'UnitIndex' are closely related.

The 'UnitState' stores all information about the external units referenced by
a single 'HomeUnitEnv'.
As a reminder, the 'HomeUnitEnv' stores all information specific to a single home unit,
such as the 'HomePackageTable', 'DynFlags' and the 'UnitState'.
The 'UnitState' retains the 'unitInfoMap', an in-memory representation of
the unit databases that a 'HomeUnitEnv' depends on.
Multiple home units can depend on the same unit database, and reference the same
'UnitInfo's across the GHC session.
We share all 'UnitInfo's across multiple 'HomeUnitEnv's, saving a lot of
duplication of the same 'UnitInfo'.
This what the 'UnitIndex' takes care of.

The 'UnitIndex' stores all fully-resolved 'UnitInfo's that can be referenced
by the 'UnitState'.'unitInfoMap'.
We consider a 'UnitInfo' as fully-resolved, if its dependencies were updated to reference the
wired-in units (e.g., 'wiringMap') and the wired-in units are updated as well.
See Note [Wired-in units] for more details on wired-in units.
Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
variables such as @${pkgroot}@ in paths.

As such, we can consider the 'UnitIndex' to be global data that is referenced by
the 'UnitState' for better sharing of 'UnitInfo's.

In fact, using the 'UnitIndex', we can impose a hard upper bound on the number
of live 'UnitInfo's in a GHC session:

> For each on-disk 'GenericUnitInfo', there are at most two objects alive.

One instance is stored in 'ExternalUnitDatabases' where variables are resolved,
but the wired-in units haven't been resolved.

The second instance is the fully-resolved 'UnitInfo' stored in the 'UnitIndex'.

See the module documentation for 'GHC.Unit.External.Index' for an overview
of how the types relate to each other.
-}

-- | The 'UnitState' contains a plethora of information local to a single 'HomeUnitEnv'.
--
-- It stores module visibilities, unit trust for @SafeHaskell@, available units for error messages,
-- explicit unit dependencies and knows how to instantiate backpack signature and holes
-- on demand.
--
-- A 'HomeUnitEnv' should rarely/never have to look into the 'UnitIndex', all external
-- unit related information is stored in the 'UnitState'.
--
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'.)
  --
  -- All values are shared with 'UnitIndex'.'globalUnits'.
  -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
  UnitState -> UnitInfoMap
unitInfoMap :: UnitInfoMap,

  -- | Set of units that we trust.
  --
  -- Local overlay of 'UnitInfo'.
  -- This avoids modifying the 'UnitInfo' directly, potentially saving
  -- a lot of duplication.
  --
  -- We keep this in WHNF as it is relatively cheap but could easily retain
  -- references to bigger structures.
  UnitState -> TrustOverlay
trustedUnits :: !TrustOverlay,

  -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
  -- package name (e.g. different instantiations), then we return one of them...
  -- This is used when users refer to packages in Backpack includes.
  -- And also to resolve package qualifiers with the PackageImports extension.
  UnitState -> UniqFM PackageName UnitId
packageNameMap            :: UniqFM PackageName 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 and the unused packages warning. The
  -- original flag which was used to bring the unit into scope is recorded for the
  -- -Wunused-packages warning.
  UnitState -> [(Unit, Maybe PackageArg)]
explicitUnits :: [(Unit, Maybe PackageArg)],

  UnitState -> Set UnitId
homeUnitDepends    :: Set UnitId,

  -- | This is a full map from 'ModuleName' to all modules which may possibly
  -- be providing it.  These providers may be hidden (but we'll still want
  -- to report them in error messages), or it may be an ambiguous import.
  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 -> UniqMap ModuleName [InstantiatedModule]
requirementContext :: UniqMap 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 :: UnitInfoMap
unitInfoMap    = UnitInfoMap
forall k a. UniqMap k a
emptyUniqMap,
    trustedUnits :: TrustOverlay
trustedUnits   = TrustOverlay
emptyTrustOverlay,
    packageNameMap :: UniqFM PackageName UnitId
packageNameMap = UniqFM PackageName UnitId
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM,
    preloadUnits :: [UnitId]
preloadUnits   = [],
    explicitUnits :: [(Unit, Maybe PackageArg)]
explicitUnits  = [],
    homeUnitDepends :: Set UnitId
homeUnitDepends = Set UnitId
forall a. Set a
Set.empty,
    moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap       = ModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap,
    pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = ModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap,
    requirementContext :: UniqMap ModuleName [InstantiatedModule]
requirementContext           = UniqMap ModuleName [InstantiatedModule]
forall k a. UniqMap k a
emptyUniqMap,
    allowVirtualUnits :: Bool
allowVirtualUnits = Bool
False
    }

-- | 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 -> Unit -> Maybe UnitInfo
lookupUnit' (UnitState -> Bool
allowVirtualUnits UnitState
pkgs) (UnitState -> UnitInfoMap
unitInfoMap UnitState
pkgs)

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

-- | Looks up the given unit in the unit state, panicking 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   -> String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsafeLookupUnit" (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
u)

-- | Looks up the given unit id in the unit state, panicking 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   -> String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsafeLookupUnitId" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
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)
-- This function is unsafe to use in general because it doesn't respect package
-- visibility.
lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
lookupPackageName UnitState
pkgstate PackageName
n = UniqFM PackageName UnitId -> PackageName -> Maybe UnitId
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (UnitState -> UniqFM PackageName UnitId
packageNameMap UnitState
pkgstate) PackageName
n

-- | 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 srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> srcpkgid
unitPackageId)
                               (UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)

-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
resolvePackageImport UnitState
unit_st ModuleName
mn PackageName
pn = do
  -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
  providers <- (ModuleOrigin -> Bool)
-> UniqMap Module ModuleOrigin -> UniqMap Module ModuleOrigin
forall a k. (a -> Bool) -> UniqMap k a -> UniqMap k a
filterUniqMap ModuleOrigin -> Bool
originVisible (UniqMap Module ModuleOrigin -> UniqMap Module ModuleOrigin)
-> Maybe (UniqMap Module ModuleOrigin)
-> Maybe (UniqMap Module ModuleOrigin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleNameProvidersMap
-> ModuleName -> Maybe (UniqMap Module ModuleOrigin)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
unit_st) ModuleName
mn
  -- 2. Get the UnitIds of the candidates
  let candidates_uid = ((Module, ModuleOrigin) -> [UnitId])
-> [(Module, ModuleOrigin)] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Module, ModuleOrigin) -> [UnitId]
to_uid ([(Module, ModuleOrigin)] -> [UnitId])
-> [(Module, ModuleOrigin)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ((Module, ModuleOrigin) -> Module)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Module, ModuleOrigin) -> Module
forall a b. (a, b) -> a
fst ([(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a b. (a -> b) -> a -> b
$ UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
providers
  -- 3. Get the package names of the candidates
  let candidates_units = (UnitInfo -> (PackageName, UnitId))
-> [UnitInfo] -> [(PackageName, UnitId)]
forall a b. (a -> b) -> [a] -> [b]
map (\UnitInfo
ui -> ((UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui), UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui))
                              ([UnitInfo] -> [(PackageName, UnitId)])
-> [UnitInfo] -> [(PackageName, UnitId)]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Maybe UnitInfo) -> [UnitId] -> [UnitInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\UnitId
uid -> UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UnitInfoMap
unitInfoMap UnitState
unit_st) UnitId
uid) [UnitId]
candidates_uid
  -- 4. Check to see if the PackageName helps us disambiguate any candidates.
  lookup pn candidates_units

  where

    -- Get the UnitId from which a visible identifier is from
    to_uid :: (Module, ModuleOrigin) -> [UnitId]
    to_uid :: (Module, ModuleOrigin) -> [UnitId]
to_uid (Module
mod, ModOrigin Maybe Bool
mo [UnitInfo]
re_exps [UnitInfo]
_ Bool
_) =
      case Maybe Bool
mo of
        -- Available directly, but also potentially from re-exports
        Just Bool
True ->  (Unit -> UnitId
toUnitId (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod)) UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
re_exps
        -- Just available from these re-exports
        Maybe Bool
_ -> (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
re_exps
    to_uid (Module, ModuleOrigin)
_ = []

-- | 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. UniqMap k a -> [a]
nonDetEltsUniqMap (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)

-- | Do we trust the 'UnitInfo' for the given 'UnitId'?
isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool
isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool
isUnitIdTrusted UnitState
ue UnitId
u =
    case TrustOverlay -> UnitId -> Maybe IsTrusted
lookupTrustOverlay (UnitState -> TrustOverlay
trustedUnits UnitState
ue) UnitId
u of
      Just IsTrusted
Trusted -> Bool
True
      Just IsTrusted
Distrusted -> Bool
False
      Maybe IsTrusted
Nothing -> UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted (HasDebugCallStack => UnitState -> UnitId -> UnitInfo
UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
ue UnitId
u) -- No overlay for this unit, check the on-disk value

-- | Do we trust the 'UnitInfo' for the given 'Unit'?
isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool
isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool
isUnitTrusted UnitState
ue Unit
u =
  HasDebugCallStack => UnitState -> UnitId -> Bool
UnitState -> UnitId -> Bool
isUnitIdTrusted UnitState
ue (Unit -> UnitId
toUnitId Unit
u)

-- | Do we trust the given 'UnitInfo'?
isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool
isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool
isUnitInfoTrusted UnitState
ue UnitInfo
u =
  HasDebugCallStack => UnitState -> UnitId -> Bool
UnitState -> UnitId -> Bool
isUnitIdTrusted UnitState
ue (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
u)

-- ----------------------------------------------------------------------------
-- 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' and 'packageDBFlags' fields of the 'DynFlags', and it will
-- update the 'unitState' in 'DynFlags'.
--
-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for implementation details.
initUnits :: Logger -> DynFlags -> UnitIndexCache -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
initUnits :: Logger
-> DynFlags
-> UnitIndexCache
-> Set UnitId
-> IO (UnitState, HomeUnit, Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags UnitIndexCache
unit_index Set UnitId
home_units = do

  let forceUnitInfoMap :: UnitState -> ()
forceUnitInfoMap UnitState
state = UnitState -> UnitInfoMap
unitInfoMap UnitState
state UnitInfoMap -> () -> ()
forall a b. a -> b -> b
`seq` ()

  unit_state <- Logger -> SDoc -> (UnitState -> ()) -> IO UnitState -> IO UnitState
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"initializing unit database")
                   UnitState -> ()
forceUnitInfoMap
                 (IO UnitState -> IO UnitState) -> IO UnitState -> IO UnitState
forall a b. (a -> b) -> a -> b
$ Logger -> UnitIndexCache -> UnitConfig -> IO UnitState
mkUnitState Logger
logger UnitIndexCache
unit_index (DynFlags -> Set UnitId -> UnitConfig
initUnitConfig DynFlags
dflags  Set UnitId
home_units)

  putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
    FormatText (updSDocContext (\SDocContext
ctx -> SDocContext
ctx {sdocLineLength = 200})
                $ pprModuleMap (moduleNameProvidersMap unit_state))

  wireMap <- wiringMap <$> readUnitIndex unit_index

  let home_unit = WireMap
-> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> HomeUnit
mkHomeUnit WireMap
wireMap
                             (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
                             (DynFlags -> Maybe UnitId
homeUnitInstanceOf_ DynFlags
dflags)
                             (DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations_ DynFlags
dflags)

  -- Try to find platform constants
  --
  -- See Note [Platform constants] in GHC.Platform
  mconstants <- if homeUnitId_ dflags == rtsUnitId
    then do
      -- we're building the RTS! Lookup DerivedConstants.h in the include paths
      lookupPlatformConstants (includePathsGlobal (includePaths dflags))
    else
      -- lookup the DerivedConstants.h header bundled with the RTS unit. We
      -- don't fail if we can't find the RTS unit as it can be a valid (but
      -- uncommon) case, e.g. building a C utility program (not depending on the
      -- RTS) before building the RTS. In any case, we will fail later on if we
      -- really need to use the platform constants but they have not been loaded.
      case lookupUnitId unit_state rtsUnitId of
        Maybe UnitInfo
Nothing   -> Maybe PlatformConstants -> IO (Maybe PlatformConstants)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PlatformConstants
forall a. Maybe a
Nothing
        Just UnitInfo
info -> [String] -> IO (Maybe PlatformConstants)
lookupPlatformConstants ((ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortText -> String
ST.unpack (UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs UnitInfo
info))

  return (unit_state,home_unit,mconstants)

mkHomeUnit
    :: WireMap
    -> UnitId                 -- ^ Home unit id
    -> Maybe UnitId           -- ^ Home unit instance of
    -> [(ModuleName, Module)] -- ^ Home unit instantiations
    -> HomeUnit
mkHomeUnit :: WireMap
-> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> HomeUnit
mkHomeUnit WireMap
wmap UnitId
hu_id Maybe UnitId
hu_instanceof [(ModuleName, Module)]
hu_instantiations_ =
    let
        -- Some wired units can be used to instantiate the home unit. We need to
        -- replace their unit keys with their wired unit ids.
        hu_instantiations :: [(ModuleName, Module)]
hu_instantiations = ((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map ((Module -> Module) -> (ModuleName, Module) -> (ModuleName, Module)
forall a b. (a -> b) -> (ModuleName, a) -> (ModuleName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WireMap -> Module -> Module
updateWiredInUnitIdInModule WireMap
wmap)) [(ModuleName, Module)]
hu_instantiations_
    in case (Maybe UnitId
hu_instanceof, [(ModuleName, Module)]
hu_instantiations) of
      (Maybe UnitId
Nothing,[]) -> UnitId -> Maybe (UnitId, [(ModuleName, Module)]) -> HomeUnit
forall u. UnitId -> Maybe (u, GenInstantiations u) -> GenHomeUnit u
DefiniteHomeUnit UnitId
hu_id Maybe (UnitId, [(ModuleName, Module)])
forall a. Maybe a
Nothing
      (Maybe UnitId
Nothing, [(ModuleName, Module)]
_) -> GhcException -> HomeUnit
forall a. HasCallStack => GhcException -> a
throwGhcException (GhcException -> HomeUnit) -> GhcException -> HomeUnit
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String
"Use of -instantiated-with requires -this-component-id")
      (Just UnitId
_, []) -> GhcException -> HomeUnit
forall a. HasCallStack => GhcException -> a
throwGhcException (GhcException -> HomeUnit) -> GhcException -> HomeUnit
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String
"Use of -this-component-id requires -instantiated-with")
      (Just UnitId
u, [(ModuleName, Module)]
is)
         -- detect fully indefinite units: all their instantiations are hole
         -- modules and the home unit id is the same as the instantiating unit
         -- id (see Note [About units] in GHC.Unit)
         | ((ModuleName, Module) -> Bool) -> [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule (Module -> Bool)
-> ((ModuleName, Module) -> Module) -> (ModuleName, Module) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
is Bool -> Bool -> Bool
&& UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
hu_id
         -> UnitId -> [(ModuleName, Module)] -> HomeUnit
forall u. UnitId -> GenInstantiations u -> GenHomeUnit u
IndefiniteHomeUnit UnitId
u [(ModuleName, Module)]
is
         -- otherwise it must be that we (fully) instantiate an indefinite unit
         -- to make it definite.
         -- TODO: error when the unit is partially instantiated??
         | Bool
otherwise
         -> UnitId -> Maybe (UnitId, [(ModuleName, Module)]) -> HomeUnit
forall u. UnitId -> Maybe (u, GenInstantiations u) -> GenHomeUnit u
DefiniteHomeUnit UnitId
hu_id ((UnitId, [(ModuleName, Module)])
-> Maybe (UnitId, [(ModuleName, Module)])
forall a. a -> Maybe a
Just (UnitId
u, [(ModuleName, Module)]
is))

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

applyTrustFlag
   :: UnitPrecedenceMap
   -> UnusableUnits
   -> [UnitInfo]
   -> TrustOverlay
   -> TrustFlag
   -> MaybeErr UnitErr TrustOverlay
applyTrustFlag :: UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustOverlay
-> TrustFlag
-> MaybeErr UnitErr TrustOverlay
applyTrustFlag UnitPrecedenceMap
prec_map UnusableUnits
unusable [UnitInfo]
pkgs TrustOverlay
overlay TrustFlag
flag =
  case TrustFlag
flag of
    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage String
str ->
       case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps       -> UnitErr -> MaybeErr UnitErr TrustOverlay
forall err val. err -> MaybeErr err val
Failed (TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
         Right ([UnitInfo]
ps,[UnitInfo]
_) -> TrustOverlay -> MaybeErr UnitErr TrustOverlay
forall err val. val -> MaybeErr err val
Succeeded ([UnitId] -> TrustOverlay -> TrustOverlay
trustUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
ps) TrustOverlay
overlay)

    DistrustPackage String
str ->
       case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps       -> UnitErr -> MaybeErr UnitErr TrustOverlay
forall err val. err -> MaybeErr err val
Failed (TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
         Right ([UnitInfo]
ps,[UnitInfo]
_) -> TrustOverlay -> MaybeErr UnitErr TrustOverlay
forall err val. val -> MaybeErr err val
Succeeded ([UnitId] -> TrustOverlay -> TrustOverlay
distrustUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
ps) TrustOverlay
overlay)

applyPackageFlag
   :: UnitPrecedenceMap
   -> UnitInfoMap
   -> 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
   -> MaybeErr UnitErr VisibilityMap -- Now exposed

applyPackageFlag :: UnitPrecedenceMap
-> UnitInfoMap
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> MaybeErr UnitErr VisibilityMap
applyPackageFlag UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map UnusableUnits
unusable Bool
no_hide_others [UnitInfo]
pkgs VisibilityMap
vm PackageFlag
flag =
  case PackageFlag
flag of
    ExposePackage String
_ PackageArg
arg (ModRenaming Bool
b [(ModuleName, ModuleName)]
rns) ->
       case UnitPrecedenceMap
-> UnitInfoMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps     -> UnitErr -> MaybeErr UnitErr VisibilityMap
forall err val. err -> MaybeErr err val
Failed (PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
         Right (UnitInfo
p:[UnitInfo]
_) -> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall err val. val -> MaybeErr err val
Succeeded 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 :: UniqMap ModuleName (Set InstantiatedModule)
reqs | UnitIdArg Unit
orig_uid <- PackageArg
arg = Unit -> UniqMap ModuleName (Set InstantiatedModule)
forall {u}.
GenUnit u
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
collectHoles Unit
orig_uid
                | Bool
otherwise                 = UniqMap ModuleName (Set InstantiatedModule)
forall k a. UniqMap k a
emptyUniqMap

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

           uv :: UnitVisibility
uv = 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 :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
reqs
                , uv_explicit :: Maybe PackageArg
uv_explicit = PackageArg -> Maybe PackageArg
forall a. a -> Maybe a
Just PackageArg
arg
                }
           vm' :: VisibilityMap
vm' = (UnitVisibility -> UnitVisibility -> UnitVisibility)
-> VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Monoid a => a -> a -> a
mappend VisibilityMap
vm_cleared (UnitInfo -> Unit
mkUnit UnitInfo
p) UnitVisibility
uv
           -- 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) -> UniqMap k a -> UniqMap k a
filterWithKeyUniqMap
                            (\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]
_ -> String -> MaybeErr UnitErr VisibilityMap
forall a. HasCallStack => String -> a
panic String
"applyPackageFlag"

    HidePackage String
str ->
       case UnitPrecedenceMap
-> UnitInfoMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
         Left [(UnitInfo, UnusableUnitReason)]
ps  -> UnitErr -> MaybeErr UnitErr VisibilityMap
forall err val. err -> MaybeErr err val
Failed (PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
         Right [UnitInfo]
ps -> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall err val. val -> MaybeErr err val
Succeeded (VisibilityMap -> MaybeErr UnitErr VisibilityMap)
-> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall a b. (a -> b) -> a -> b
$ (VisibilityMap -> Unit -> VisibilityMap)
-> VisibilityMap -> [Unit] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> Unit -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap VisibilityMap
vm ((UnitInfo -> Unit) -> [UnitInfo] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> Unit
mkUnit [UnitInfo]
ps)

updateVisibilityMap :: WireMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap :: WireMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap WireMap
wiredInMap VisibilityMap
vis_map = (VisibilityMap -> (UnitId, UnitId) -> VisibilityMap)
-> VisibilityMap -> [(UnitId, UnitId)] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vis_map (WireMap -> [(UnitId, UnitId)]
listWireMap WireMap
wiredInMap)
  where f :: VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vm (UnitId
from, UnitId
to) = case VisibilityMap -> Unit -> Maybe UnitVisibility
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap VisibilityMap
vis_map (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)) of
                    Maybe UnitVisibility
Nothing -> VisibilityMap
vm
                    Just UnitVisibility
r -> VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap (VisibilityMap -> Unit -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap VisibilityMap
vm (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)))
                              (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
to)) UnitVisibility
r

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

reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
reportCycles Logger
logger [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 ()
report [SCC UnitInfo]
sccs
  where
    report :: SCC UnitInfo -> IO ()
report (AcyclicSCC UnitInfo
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    report (CyclicSCC [UnitInfo]
vs) =
        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"these packages are involved in a cycle:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> SDoc) -> (UnitInfo -> UnitId) -> UnitInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId) [UnitInfo]
vs))


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

mkUnitState
    :: Logger
    -> UnitIndexCache
    -> UnitConfig
    -> IO UnitState
mkUnitState :: Logger -> UnitIndexCache -> UnitConfig -> IO UnitState
mkUnitState Logger
logger UnitIndexCache
unit_index 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.
-}

  dbs <- Logger
-> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Logger
logger UnitIndexCache
unit_index (UnitConfig -> UnitDbConfig
initUnitDbConfig UnitConfig
cfg)

  -- distrust all units if the flag is set
  let distrustUnitsOfDb TrustOverlay
overlay UnitDatabase UnitId
db = (TrustOverlay -> UnitInfo -> TrustOverlay)
-> TrustOverlay -> [UnitInfo] -> TrustOverlay
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ TrustOverlay
acc UnitInfo
ui -> [UnitId] -> TrustOverlay -> TrustOverlay
distrustUnits [UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui] TrustOverlay
acc) TrustOverlay
overlay (UnitDatabase UnitId -> [UnitInfo]
forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits UnitDatabase UnitId
db)
      distrustAllUnits = (TrustOverlay -> UnitDatabase UnitId -> TrustOverlay)
-> TrustOverlay -> [UnitDatabase UnitId] -> TrustOverlay
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TrustOverlay -> UnitDatabase UnitId -> TrustOverlay
distrustUnitsOfDb TrustOverlay
emptyTrustOverlay [UnitDatabase UnitId]
dbs

      distrustedUnitsOverlay
        | UnitConfig -> Bool
unitConfigDistrustAll UnitConfig
cfg = TrustOverlay
distrustAllUnits
        | Bool
otherwise = TrustOverlay
emptyTrustOverlay

  -- 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 raw_other_flags = [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [PackageFlag]
unitConfigFlagsExposed UnitConfig
cfg)
      (hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags
  debugTraceMsg logger 2 $
      text "package flags" <+> ppr other_flags

  let home_unit_deps = Set UnitId -> [PackageFlag] -> Set UnitId
selectHomeUnits (UnitConfig -> Set UnitId
unitConfigHomeUnits UnitConfig
cfg) [PackageFlag]
hpt_flags

  -- Merge databases together, without checking validity
  (pkg_map1, prec_map) <- mergeDatabases logger dbs

  -- Now that we've merged everything together, prune out unusable
  -- packages.
  let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1

  reportCycles   logger sccs
  reportUnusable logger unusable

  -- Compute trust flags (these flags apply regardless of whether
  -- or not packages are visible or not)
  trustUnitsOverlay <- mayThrowUnitErr
            $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
                 distrustedUnitsOverlay (reverse (unitConfigFlagsTrusted cfg))
  let pkgs1 = UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map2
  let 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
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
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 = if UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg
                    then UniqDFM FastString UnitInfo
forall {k} (key :: k) elt. UniqDFM key elt
emptyUDFM
                    else (UniqDFM FastString UnitInfo
 -> UnitInfo -> UniqDFM FastString UnitInfo)
-> UniqDFM FastString UnitInfo
-> [UnitInfo]
-> UniqDFM FastString UnitInfo
forall b a. (b -> a -> b) -> b -> [a] -> b
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 {k} (key :: k) 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
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 -> UnitInfo -> VisibilityMap)
-> VisibilityMap -> [UnitInfo] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
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 srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo 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 VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap VisibilityMap
vm (UnitInfo -> Unit
mkUnit UnitInfo
p)
                                               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 (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ UnitInfo -> FastString
fsPackageName UnitInfo
p),
                                                 uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
forall k a. UniqMap k a
emptyUniqMap,
                                                 uv_explicit :: Maybe PackageArg
uv_explicit = Maybe PackageArg
forall a. Maybe a
Nothing
                                               }
                               else VisibilityMap
vm)
                         VisibilityMap
forall k a. UniqMap k a
emptyUniqMap [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.
  --
  vis_map2 <- mayThrowUnitErr
                $ foldM (applyPackageFlag prec_map prelim_pkg_db unusable
                        (unitConfigHideAll cfg) pkgs1)
                            vis_map1 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.
  --
  wired_map <- setupWiredInUnits logger prec_map pkgs1 vis_map2 unit_index
  pkgs2 <- updateWiredInUnitIndex wired_map pkgs1 unit_index

  let pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs2

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

  let hide_plugin_pkgs = UnitConfig -> Bool
unitConfigHideAllPlugins UnitConfig
cfg
  plugin_vis_map <-
    case unitConfigFlagsPlugins cfg of
        -- common case; try to share the old vis_map
        [] | Bool -> Bool
not Bool
hide_plugin_pkgs -> VisibilityMap -> IO VisibilityMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vis_map
           | Bool
otherwise -> VisibilityMap -> IO VisibilityMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
forall k a. UniqMap k a
emptyUniqMap
        [PackageFlag]
_ -> do let plugin_vis_map1 :: VisibilityMap
plugin_vis_map1
                        | Bool
hide_plugin_pkgs = VisibilityMap
forall k a. UniqMap k a
emptyUniqMap
                        -- Use the vis_map PRIOR to wired in,
                        -- because otherwise applyPackageFlag
                        -- won't work.
                        | Bool
otherwise = VisibilityMap
vis_map2
                plugin_vis_map2
                    <- MaybeErr UnitErr VisibilityMap -> IO VisibilityMap
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr
                        (MaybeErr UnitErr VisibilityMap -> IO VisibilityMap)
-> MaybeErr UnitErr VisibilityMap -> IO VisibilityMap
forall a b. (a -> b) -> a -> b
$ (VisibilityMap -> PackageFlag -> MaybeErr UnitErr VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> MaybeErr UnitErr VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitPrecedenceMap
-> UnitInfoMap
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> MaybeErr UnitErr VisibilityMap
applyPackageFlag UnitPrecedenceMap
prec_map UnitInfoMap
prelim_pkg_db 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.
                return (updateVisibilityMap wired_map plugin_vis_map2)

  let pkgname_map = [(PackageName, UnitId)] -> UniqFM PackageName UnitId
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
p, UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitInstanceOf UnitInfo
p)
                              | UnitInfo
p <- [UnitInfo]
pkgs2
                              ]
  -- 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
k, UnitVisibility -> Maybe PackageArg
uv_explicit UnitVisibility
v) | (Unit
k, UnitVisibility
v) <- VisibilityMap -> [(Unit, UnitVisibility)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList VisibilityMap
vis_map]
      req_ctx = (Set InstantiatedModule -> [InstantiatedModule])
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName [InstantiatedModule]
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap (Set InstantiatedModule -> [InstantiatedModule]
forall a. Set a -> [a]
Set.toList)
              (UniqMap ModuleName (Set InstantiatedModule)
 -> UniqMap ModuleName [InstantiatedModule])
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName [InstantiatedModule]
forall a b. (a -> b) -> a -> b
$ (Set InstantiatedModule
 -> Set InstantiatedModule -> Set InstantiatedModule)
-> [UniqMap ModuleName (Set InstantiatedModule)]
-> UniqMap ModuleName (Set InstantiatedModule)
forall a k. (a -> a -> a) -> [UniqMap k a] -> UniqMap k a
plusUniqMapListWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule))
-> [UnitVisibility]
-> [UniqMap ModuleName (Set InstantiatedModule)]
forall a b. (a -> b) -> [a] -> [b]
map UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements (VisibilityMap -> [UnitVisibility]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap 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 = VisibilityMap -> [Unit]
forall k a. UniqMap k a -> [k]
nonDetKeysUniqMap ((UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall a k. (a -> Bool) -> UniqMap k a -> UniqMap k a
filterUniqMap (Maybe PackageArg -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PackageArg -> Bool)
-> (UnitVisibility -> Maybe PackageArg) -> UnitVisibility -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitVisibility -> Maybe PackageArg
uv_explicit) VisibilityMap
vis_map)

      -- add default preload units if they can be found in the db
      basicLinkedUnits = (UnitId -> Unit) -> [UnitId] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
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. Uniquable k => k -> UniqMap k a -> Bool
elemUniqMap UnitInfoMap
pkg_db)
                         ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitConfig -> [UnitId]
unitConfigAutoLink UnitConfig
cfg
      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
  dep_preload <- mayThrowUnitErr
                    $ closeUnitDeps pkg_db
                    $ zip (map toUnitId preload3) (repeat Nothing)

  let mod_map1 = Logger
-> Bool -> UnitInfoMap -> VisibilityMap -> ModuleNameProvidersMap
mkModuleNameProvidersMap Logger
logger (UnitConfig -> Bool
unitConfigAllowVirtual UnitConfig
cfg) UnitInfoMap
pkg_db VisibilityMap
vis_map
      mod_map2 = UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusable
      mod_map = ModuleNameProvidersMap
mod_map2 ModuleNameProvidersMap
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` ModuleNameProvidersMap
mod_map1

  -- Force the result to avoid leaking input parameters
  let !state = UnitState
         { preloadUnits :: [UnitId]
preloadUnits                 = [UnitId]
dep_preload
         , explicitUnits :: [(Unit, Maybe PackageArg)]
explicitUnits                = [(Unit, Maybe PackageArg)]
explicit_pkgs
         , homeUnitDepends :: Set UnitId
homeUnitDepends              = Set UnitId
home_unit_deps
         , unitInfoMap :: UnitInfoMap
unitInfoMap                  = UnitInfoMap
pkg_db
         , trustedUnits :: TrustOverlay
trustedUnits                 = TrustOverlay
trustUnitsOverlay
         , moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap       = ModuleNameProvidersMap
mod_map
         , pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = Logger
-> Bool -> UnitInfoMap -> VisibilityMap -> ModuleNameProvidersMap
mkModuleNameProvidersMap Logger
logger (UnitConfig -> Bool
unitConfigAllowVirtual UnitConfig
cfg) UnitInfoMap
pkg_db VisibilityMap
plugin_vis_map
         , packageNameMap :: UniqFM PackageName UnitId
packageNameMap               = UniqFM PackageName UnitId
pkgname_map
         , requirementContext :: UniqMap ModuleName [InstantiatedModule]
requirementContext           = UniqMap ModuleName [InstantiatedModule]
req_ctx
         , allowVirtualUnits :: Bool
allowVirtualUnits            = UnitConfig -> Bool
unitConfigAllowVirtual UnitConfig
cfg
         }
  return state

selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
selectHptFlag :: Set UnitId -> PackageFlag -> Bool
selectHptFlag Set UnitId
home_units (ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_) | Unit -> UnitId
toUnitId Unit
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
home_units = Bool
True
selectHptFlag Set UnitId
_ PackageFlag
_ = Bool
False

selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId
selectHomeUnits :: Set UnitId -> [PackageFlag] -> Set UnitId
selectHomeUnits Set UnitId
home_units [PackageFlag]
flags = (Set UnitId -> PackageFlag -> Set UnitId)
-> Set UnitId -> [PackageFlag] -> Set UnitId
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set UnitId -> PackageFlag -> Set UnitId
go Set UnitId
forall a. Set a
Set.empty [PackageFlag]
flags
  where
    go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId
    go :: Set UnitId -> PackageFlag -> Set UnitId
go Set UnitId
cur (ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_) | Unit -> UnitId
toUnitId Unit
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
home_units = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert (Unit -> UnitId
toUnitId Unit
uid) Set UnitId
cur
    -- MP: This does not yet support thinning/renaming
    go Set UnitId
cur PackageFlag
_ = Set UnitId
cur

initUnitDbConfig :: UnitConfig -> UnitDbConfig
initUnitDbConfig :: UnitConfig -> UnitDbConfig
initUnitDbConfig UnitConfig
uc = UnitDbConfig
  { unitDbConfigFlagsDB :: [PackageDBFlag]
unitDbConfigFlagsDB = UnitConfig -> [PackageDBFlag]
unitConfigFlagsDB UnitConfig
uc
  , unitDbConfigProgramName :: String
unitDbConfigProgramName = UnitConfig -> String
unitConfigProgramName UnitConfig
uc
  , unitDbConfigDBName :: String
unitDbConfigDBName = UnitConfig -> String
unitConfigDBName UnitConfig
uc
  , unitDbConfigPlatformArchOS :: ArchOS
unitDbConfigPlatformArchOS = UnitConfig -> ArchOS
unitConfigPlatformArchOS UnitConfig
uc
  , unitDbConfigGlobalDB :: String
unitDbConfigGlobalDB = UnitConfig -> String
unitConfigGlobalDB UnitConfig
uc
  , unitDbConfigGHCDir :: String
unitDbConfigGHCDir = UnitConfig -> String
unitConfigGHCDir UnitConfig
uc
  }

-- -----------------------------------------------------------------------------
-- 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 -> PkgQual -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs ModuleName
m PkgQual
NoPkgQual 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)
f [(Module, ModuleOrigin)]
rs
        where f :: (Module, ModuleOrigin) -> (Module, UnitInfo)
f (Module
m,ModuleOrigin
_) = (Module
m, Maybe UnitInfo -> UnitInfo
forall a. HasCallStack => Maybe a -> a
expectJust (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 [UnitInfo] [(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
                            -> PkgQual
                            -> LookupResult
lookupModuleWithSuggestions :: UnitState -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs
  = UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> 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 -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
pkgs ModuleName
mn PkgQual
mfs =
    case UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs) ModuleName
mn PkgQual
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 a. a -> Maybe a
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 a. a -> Maybe a
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
                                  -> PkgQual
                                  -> LookupResult
lookupPluginModuleWithSuggestions :: UnitState -> ModuleName -> PkgQual -> LookupResult
lookupPluginModuleWithSuggestions UnitState
pkgs
  = UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap UnitState
pkgs)

lookupModuleWithSuggestions' :: UnitState
                            -> ModuleNameProvidersMap
                            -> ModuleName
                            -> PkgQual
                            -> LookupResult
lookupModuleWithSuggestions' :: UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs ModuleNameProvidersMap
mod_map ModuleName
name PkgQual
mb_pn
  = case ModuleNameProvidersMap
-> ModuleName -> Maybe (UniqMap Module ModuleOrigin)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap ModuleNameProvidersMap
mod_map ModuleName
name of
        Maybe (UniqMap Module ModuleOrigin)
Nothing -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
        Just UniqMap Module ModuleOrigin
xs ->
          case (([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
  [(Module, ModuleOrigin)])
 -> (Module, ModuleOrigin)
 -> ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
     [(Module, ModuleOrigin)]))
-> ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)]
-> ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
 [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)])
classify ([],[],[], []) (((Module, ModuleOrigin) -> Module)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Module, ModuleOrigin) -> Module
forall a b. (a, b) -> a
fst ([(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a b. (a -> b) -> a -> b
$ UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
xs) of
            ([], [], [], []) -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
            ([UnitInfo]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module
m, ModuleOrigin
o)])             -> Module -> (UnitInfo, ModuleOrigin) -> LookupResult
LookupFound Module
m (Module -> UnitInfo
mod_unit Module
m, ModuleOrigin
o)
            ([UnitInfo]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, exposed :: [(Module, ModuleOrigin)]
exposed@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_))        -> [(Module, ModuleOrigin)] -> LookupResult
LookupMultiple [(Module, ModuleOrigin)]
exposed
            ([], [], unusable :: [(Module, ModuleOrigin)]
unusable@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_), [])    -> [(Module, ModuleOrigin)] -> LookupResult
LookupUnusable [(Module, ModuleOrigin)]
unusable
            ([UnitInfo]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
_, []) ->
              [UnitInfo] -> [(Module, ModuleOrigin)] -> LookupResult
LookupHidden [UnitInfo]
hidden_pkg [(Module, ModuleOrigin)]
hidden_mod
  where
    classify :: ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
 [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([UnitInfo], [(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
    [(Module, ModuleOrigin)])
classify ([UnitInfo]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed) (Module
m, ModuleOrigin
origin0) =
      let origin :: ModuleOrigin
origin = PkgQual -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin PkgQual
mb_pn (Module -> UnitInfo
mod_unit Module
m) ModuleOrigin
origin0
          x :: (Module, ModuleOrigin)
x = (Module
m, ModuleOrigin
origin)
      in case ModuleOrigin
origin of
          ModuleOrigin
ModHidden
            -> ([UnitInfo]
hidden_pkg, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
          ModUnusable UnusableUnit
_
            -> ([UnitInfo]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
          ModOrigin { fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit = Maybe Bool
origAvailableUnderSameName, [UnitInfo]
fromHiddenReexport :: [UnitInfo]
fromHiddenReexport :: ModuleOrigin -> [UnitInfo]
fromHiddenReexport }
            | ModuleOrigin -> Bool
originEmpty ModuleOrigin
origin
            -> ([UnitInfo]
hidden_pkg,   [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
            | ModuleOrigin -> Bool
originVisible ModuleOrigin
origin
            -> ([UnitInfo]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
exposed)
            | Bool
otherwise
            -> ([UnitInfo]
reexports [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ ([UnitInfo] -> [UnitInfo])
-> (UnitInfo -> [UnitInfo] -> [UnitInfo])
-> Maybe UnitInfo
-> [UnitInfo]
-> [UnitInfo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [UnitInfo] -> [UnitInfo]
forall a. a -> a
id (:) Maybe UnitInfo
origUnit [UnitInfo]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
            where
              reexports :: [UnitInfo]
              reexports :: [UnitInfo]
reexports = (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
fromHiddenReexport

              origUnit :: Maybe UnitInfo
              origUnit :: Maybe UnitInfo
origUnit = Maybe Bool
origAvailableUnderSameName Maybe Bool -> Maybe UnitInfo -> Maybe UnitInfo
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m)

    unit_lookup :: Unit -> UnitInfo
unit_lookup Unit
p = UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs Unit
p Maybe UnitInfo -> UnitInfo -> UnitInfo
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupModuleWithSuggestions" (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
p SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
name)
    mod_unit :: Module -> UnitInfo
mod_unit = Unit -> UnitInfo
unit_lookup (Unit -> UnitInfo) -> (Module -> Unit) -> Module -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit

    -- Filters out origins which are not associated with the given package
    -- qualifier.  No-op if there is no package qualifier.  Test if this
    -- excluded all origins with 'originEmpty'.
    filterOrigin :: PkgQual
                 -> UnitInfo
                 -> ModuleOrigin
                 -> ModuleOrigin
    filterOrigin :: PkgQual -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin PkgQual
NoPkgQual UnitInfo
_ ModuleOrigin
o = ModuleOrigin
o
    filterOrigin (ThisPkg UnitId
_) UnitInfo
_ ModuleOrigin
o = ModuleOrigin
o
    filterOrigin (OtherPkg UnitId
u) UnitInfo
pkg ModuleOrigin
o =
      let match_pkg :: UnitInfo -> Bool
match_pkg UnitInfo
p = UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
      in case ModuleOrigin
o of
          ModuleOrigin
ModHidden
            | UnitInfo -> Bool
match_pkg UnitInfo
pkg -> ModuleOrigin
ModHidden
            | Bool
otherwise     -> ModuleOrigin
forall a. Monoid a => a
mempty
          ModUnusable UnusableUnit
_
            | UnitInfo -> Bool
match_pkg UnitInfo
pkg -> ModuleOrigin
o
            | Bool
otherwise     -> ModuleOrigin
forall a. Monoid a => a
mempty
          ModOrigin { fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit = Maybe Bool
e, fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport = [UnitInfo]
res,
                      fromHiddenReexport :: ModuleOrigin -> [UnitInfo]
fromHiddenReexport = [UnitInfo]
rhs }
            -> ModOrigin
                { fromOrigUnit :: Maybe Bool
fromOrigUnit        = if UnitInfo -> Bool
match_pkg UnitInfo
pkg then Maybe Bool
e else Maybe Bool
forall a. Maybe a
Nothing
                , fromExposedReexport :: [UnitInfo]
fromExposedReexport = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitInfo -> Bool
match_pkg [UnitInfo]
res
                , fromHiddenReexport :: [UnitInfo]
fromHiddenReexport  = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitInfo -> Bool
match_pkg [UnitInfo]
rhs
                , fromPackageFlag :: Bool
fromPackageFlag     = Bool
False -- always excluded
                }

    suggestions :: [ModuleSuggestion]
suggestions = String -> [(String, ModuleSuggestion)] -> [ModuleSuggestion]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (ModuleName -> String
moduleNameString ModuleName
name) [(String, ModuleSuggestion)]
all_mods

    all_mods :: [(String, ModuleSuggestion)]     -- All modules
    all_mods :: [(String, ModuleSuggestion)]
all_mods = ((String, ModuleSuggestion) -> String)
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, ModuleSuggestion) -> String
forall a b. (a, b) -> a
fst ([(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)])
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall a b. (a -> b) -> a -> b
$
        [ (ModuleName -> String
moduleNameString ModuleName
m, ModuleSuggestion
suggestion)
        | (ModuleName
m, UniqMap Module ModuleOrigin
e) <- ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs)
        , ModuleSuggestion
suggestion <- ((Module, ModuleOrigin) -> ModuleSuggestion)
-> [(Module, ModuleOrigin)] -> [ModuleSuggestion]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
m) (UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
e)
        ]
    getSuggestion :: ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
name (Module
mod, ModuleOrigin
origin) =
        (if ModuleOrigin -> Bool
originVisible ModuleOrigin
origin then ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestVisible else ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestHidden)
            ModuleName
name Module
mod ModuleOrigin
origin

listVisibleModuleNames :: UnitState -> [ModuleName]
listVisibleModuleNames :: UnitState -> [ModuleName]
listVisibleModuleNames UnitState
state =
    ((ModuleName, UniqMap Module ModuleOrigin) -> ModuleName)
-> [(ModuleName, UniqMap Module ModuleOrigin)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, UniqMap Module ModuleOrigin) -> ModuleName
forall a b. (a, b) -> a
fst (((ModuleName, UniqMap Module ModuleOrigin) -> Bool)
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName, UniqMap Module ModuleOrigin) -> Bool
forall {a} {k}. (a, UniqMap k ModuleOrigin) -> Bool
visible (ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
state)))
  where visible :: (a, UniqMap k ModuleOrigin) -> Bool
visible (a
_, UniqMap k ModuleOrigin
ms) = (ModuleOrigin -> Bool) -> UniqMap k ModuleOrigin -> Bool
forall a k. (a -> Bool) -> UniqMap k a -> Bool
anyUniqMap ModuleOrigin -> Bool
originVisible UniqMap k ModuleOrigin
ms



-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
pkgstate ModuleName
mod_name =
  [InstantiatedModule]
-> Maybe [InstantiatedModule] -> [InstantiatedModule]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqMap ModuleName [InstantiatedModule]
-> ModuleName -> Maybe [InstantiatedModule]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UniqMap ModuleName [InstantiatedModule]
requirementContext UnitState
pkgstate) ModuleName
mod_name)

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

-- | Pretty-print a UnitId for the user.
--
-- Cabal packages may contain several components (programs, libraries, etc.).
-- As far as GHC is concerned, installed package components ("units") are
-- identified by an opaque UnitId string provided by Cabal. As the string
-- contains a hash, we don't want to display it to users so GHC queries the
-- database to retrieve some infos about the original source package (name,
-- version, component name).
--
-- Instead we want to display: packagename-version[:componentname]
--
-- Component name is only displayed if it isn't the default library
--
-- To do this we need to query a unit database.
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
pprUnitIdForUser UnitState
state uid :: UnitId
uid@(UnitId FastString
fs) =
   case UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo UnitState
state UnitId
uid of
      Maybe UnitPprInfo
Nothing -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
fs -- we didn't find the unit at all
      Just UnitPprInfo
i  -> UnitPprInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitPprInfo
i

pprUnitInfoForUser :: UnitInfo -> SDoc
pprUnitInfoForUser :: UnitInfo -> SDoc
pprUnitInfoForUser UnitInfo
info = UnitPprInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((UnitId -> FastString) -> UnitInfo -> UnitPprInfo
forall u. (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo UnitId -> FastString
unitIdFS UnitInfo
info)

lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo UnitState
state UnitId
uid = (UnitInfo -> UnitPprInfo) -> Maybe UnitInfo -> Maybe UnitPprInfo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UnitId -> FastString) -> UnitInfo -> UnitPprInfo
forall u. (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo UnitId -> FastString
unitIdFS) (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid)

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

-- | Show (very verbose) package info
pprUnits :: UnitState -> SDoc
pprUnits :: UnitState -> SDoc
pprUnits = (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
pprUnitInfo

pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
pprIPI UnitState
pkgstate =
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---") ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> SDoc
pprIPI (UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)))

-- | Show simplified unit info.
--
-- The idea is to only print package id, and any information that might
-- be different from the package databases (exposure, trust)
pprUnitsSimple :: UnitState -> SDoc
pprUnitsSimple :: UnitState -> SDoc
pprUnitsSimple UnitState
ue = (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
pprIPI UnitState
ue
    where pprIPI :: UnitInfo -> SDoc
pprIPI UnitInfo
ipi = let i :: FastString
i = UnitId -> FastString
unitIdFS (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ipi)
                           e :: SDoc
e = if UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsExposed UnitInfo
ipi then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"E" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" "
                           t :: SDoc
t = if HasDebugCallStack => UnitState -> UnitInfo -> Bool
UnitState -> UnitInfo -> Bool
isUnitInfoTrusted UnitState
ue UnitInfo
ipi then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"T" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" "
                       in SDoc
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
i

-- | Print unit-ids with UnitInfo found in the given UnitState
pprWithUnitState :: UnitState -> SDoc -> SDoc
pprWithUnitState :: UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state = (SDocContext -> SDocContext) -> SDoc -> SDoc
updSDocContext (\SDocContext
ctx -> SDocContext
ctx
   { sdocUnitIdForUser = \FastString
fs -> UnitState -> UnitId -> SDoc
pprUnitIdForUser UnitState
state (FastString -> UnitId
UnitId FastString
fs)
   })

-- | Print raw unit-ids, without removing the hash
pprRawUnitIds :: SDoc -> SDoc
pprRawUnitIds :: SDoc -> SDoc
pprRawUnitIds = (SDocContext -> SDocContext) -> SDoc -> SDoc
updSDocContext (\SDocContext
ctx -> SDocContext
ctx { sdocUnitIdForUser = ftext })

fsPackageName :: UnitInfo -> FastString
fsPackageName :: UnitInfo -> FastString
fsPackageName UnitInfo
info = FastString
fs
   where
      PackageName FastString
fs = UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
info

-- -----------------------------------------------------------------------------
-- Module renaming

-- | Substitutes holes in a 'Module'.  NOT suitable for being called
-- directly on a 'nameModule', see Note [Representation of module/name variables].
-- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
-- similarly, @\<A>@ maps to @q():A@.
renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module
renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module
renameHoleModule UnitState
state = UnitInfoMap -> ShHoleSubst -> Module -> Module
renameHoleModule' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)

-- | Substitutes holes in a 'Unit', suitable for renaming when
-- an include occurs; see Note [Representation of module/name variables].
--
-- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@.
renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit UnitState
state = UnitInfoMap -> ShHoleSubst -> Unit -> Unit
renameHoleUnit' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)

-- | Injects an 'InstantiatedModule' to 'Module' (see also
-- 'instUnitToUnit'.
instModuleToModule :: InstantiatedModule -> Module
instModuleToModule :: InstantiatedModule -> Module
instModuleToModule (Module GenInstantiatedUnit UnitId
iuid ModuleName
mod_name) =
    Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule (GenInstantiatedUnit UnitId -> Unit
instUnitToUnit GenInstantiatedUnit UnitId
iuid) ModuleName
mod_name

-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged.
instUnitToUnit :: InstantiatedUnit -> Unit
instUnitToUnit :: GenInstantiatedUnit UnitId -> Unit
instUnitToUnit GenInstantiatedUnit UnitId
iuid =
    -- NB: suppose that we want to compare the instantiated
    -- unit p[H=impl:H] against p+abcd (where p+abcd
    -- happens to be the existing, installed version of
    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]
    -- VirtUnit, they won't compare equal; only
    -- after improvement will the equality hold.
    GenInstantiatedUnit UnitId -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit GenInstantiatedUnit UnitId
iuid