never executed always true always false
    1 -- (c) The University of Glasgow, 2006
    2 
    3 {-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
    4 {-# LANGUAGE LambdaCase #-}
    5 {-# LANGUAGE NamedFieldPuns #-}
    6 
    7 -- | Unit manipulation
    8 module GHC.Unit.State (
    9         module GHC.Unit.Info,
   10 
   11         -- * Reading the package config, and processing cmdline args
   12         UnitState(..),
   13         PreloadUnitClosure,
   14         UnitDatabase (..),
   15         UnitErr (..),
   16         emptyUnitState,
   17         initUnits,
   18         readUnitDatabases,
   19         readUnitDatabase,
   20         getUnitDbRefs,
   21         resolveUnitDatabase,
   22         listUnitInfo,
   23 
   24         -- * Querying the package config
   25         UnitInfoMap,
   26         lookupUnit,
   27         lookupUnit',
   28         unsafeLookupUnit,
   29         lookupUnitId,
   30         lookupUnitId',
   31         unsafeLookupUnitId,
   32 
   33         lookupPackageName,
   34         improveUnit,
   35         searchPackageId,
   36         listVisibleModuleNames,
   37         lookupModuleInAllUnits,
   38         lookupModuleWithSuggestions,
   39         lookupModulePackage,
   40         lookupPluginModuleWithSuggestions,
   41         requirementMerges,
   42         LookupResult(..),
   43         ModuleSuggestion(..),
   44         ModuleOrigin(..),
   45         UnusableUnitReason(..),
   46         pprReason,
   47 
   48         closeUnitDeps,
   49         closeUnitDeps',
   50         mayThrowUnitErr,
   51 
   52         -- * Module hole substitution
   53         ShHoleSubst,
   54         renameHoleUnit,
   55         renameHoleModule,
   56         renameHoleUnit',
   57         renameHoleModule',
   58         instUnitToUnit,
   59         instModuleToModule,
   60 
   61         -- * Pretty-printing
   62         pprFlag,
   63         pprUnits,
   64         pprUnitsSimple,
   65         pprUnitIdForUser,
   66         pprUnitInfoForUser,
   67         pprModuleMap,
   68         pprWithUnitState,
   69 
   70         -- * Utils
   71         unwireUnit,
   72         implicitPackageDeps)
   73 where
   74 
   75 import GHC.Prelude
   76 
   77 import GHC.Driver.Session
   78 
   79 import GHC.Platform
   80 import GHC.Platform.Ways
   81 
   82 import GHC.Unit.Database
   83 import GHC.Unit.Info
   84 import GHC.Unit.Ppr
   85 import GHC.Unit.Types
   86 import GHC.Unit.Module
   87 import GHC.Unit.Home
   88 
   89 import GHC.Types.Unique.FM
   90 import GHC.Types.Unique.DFM
   91 import GHC.Types.Unique.Set
   92 import GHC.Types.Unique.DSet
   93 import GHC.Types.PkgQual
   94 
   95 import GHC.Utils.Misc
   96 import GHC.Utils.Panic
   97 import GHC.Utils.Outputable as Outputable
   98 import GHC.Data.Maybe
   99 
  100 import System.Environment ( getEnv )
  101 import GHC.Data.FastString
  102 import qualified GHC.Data.ShortText as ST
  103 import GHC.Utils.Logger
  104 import GHC.Utils.Error
  105 import GHC.Utils.Exception
  106 
  107 import System.Directory
  108 import System.FilePath as FilePath
  109 import Control.Monad
  110 import Data.Graph (stronglyConnComp, SCC(..))
  111 import Data.Char ( toUpper )
  112 import Data.List ( intersperse, partition, sortBy, isSuffixOf )
  113 import Data.Map (Map)
  114 import Data.Set (Set)
  115 import Data.Monoid (First(..))
  116 import qualified Data.Semigroup as Semigroup
  117 import qualified Data.Map as Map
  118 import qualified Data.Map.Strict as MapStrict
  119 import qualified Data.Set as Set
  120 import GHC.LanguageExtensions
  121 
  122 -- ---------------------------------------------------------------------------
  123 -- The Unit state
  124 
  125 -- The unit state is computed by 'initUnits', and kept in HscEnv.
  126 -- It is influenced by various command-line flags:
  127 --
  128 --   * @-package \<pkg>@ and @-package-id \<pkg>@ cause @\<pkg>@ to become exposed.
  129 --     If @-hide-all-packages@ was not specified, these commands also cause
  130 --      all other packages with the same name to become hidden.
  131 --
  132 --   * @-hide-package \<pkg>@ causes @\<pkg>@ to become hidden.
  133 --
  134 --   * (there are a few more flags, check below for their semantics)
  135 --
  136 -- The unit state has the following properties.
  137 --
  138 --   * Let @exposedUnits@ be the set of packages thus exposed.
  139 --     Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of
  140 --     their dependencies.
  141 --
  142 --   * When searching for a module from a preload import declaration,
  143 --     only the exposed modules in @exposedUnits@ are valid.
  144 --
  145 --   * When searching for a module from an implicit import, all modules
  146 --     from @depExposedUnits@ are valid.
  147 --
  148 --   * When linking in a compilation manager mode, we link in packages the
  149 --     program depends on (the compiler knows this list by the
  150 --     time it gets to the link step).  Also, we link in all packages
  151 --     which were mentioned with preload @-package@ flags on the command-line,
  152 --     or are a transitive dependency of same, or are \"base\"\/\"rts\".
  153 --     The reason for this is that we might need packages which don't
  154 --     contain any Haskell modules, and therefore won't be discovered
  155 --     by the normal mechanism of dependency tracking.
  156 
  157 -- Notes on DLLs
  158 -- ~~~~~~~~~~~~~
  159 -- When compiling module A, which imports module B, we need to
  160 -- know whether B will be in the same DLL as A.
  161 --      If it's in the same DLL, we refer to B_f_closure
  162 --      If it isn't, we refer to _imp__B_f_closure
  163 -- When compiling A, we record in B's Module value whether it's
  164 -- in a different DLL, by setting the DLL flag.
  165 
  166 -- | Given a module name, there may be multiple ways it came into scope,
  167 -- possibly simultaneously.  This data type tracks all the possible ways
  168 -- it could have come into scope.  Warning: don't use the record functions,
  169 -- they're partial!
  170 data ModuleOrigin =
  171     -- | Module is hidden, and thus never will be available for import.
  172     -- (But maybe the user didn't realize), so we'll still keep track
  173     -- of these modules.)
  174     ModHidden
  175     -- | Module is unavailable because the package is unusable.
  176   | ModUnusable UnusableUnitReason
  177     -- | Module is public, and could have come from some places.
  178   | ModOrigin {
  179         -- | @Just False@ means that this module is in
  180         -- someone's @exported-modules@ list, but that package is hidden;
  181         -- @Just True@ means that it is available; @Nothing@ means neither
  182         -- applies.
  183         fromOrigUnit :: Maybe Bool
  184         -- | Is the module available from a reexport of an exposed package?
  185         -- There could be multiple.
  186       , fromExposedReexport :: [UnitInfo]
  187         -- | Is the module available from a reexport of a hidden package?
  188       , fromHiddenReexport :: [UnitInfo]
  189         -- | Did the module export come from a package flag? (ToDo: track
  190         -- more information.
  191       , fromPackageFlag :: Bool
  192       }
  193 
  194 instance Outputable ModuleOrigin where
  195     ppr ModHidden = text "hidden module"
  196     ppr (ModUnusable _) = text "unusable module"
  197     ppr (ModOrigin e res rhs f) = sep (punctuate comma (
  198         (case e of
  199             Nothing -> []
  200             Just False -> [text "hidden package"]
  201             Just True -> [text "exposed package"]) ++
  202         (if null res
  203             then []
  204             else [text "reexport by" <+>
  205                     sep (map (ppr . mkUnit) res)]) ++
  206         (if null rhs
  207             then []
  208             else [text "hidden reexport by" <+>
  209                     sep (map (ppr . mkUnit) res)]) ++
  210         (if f then [text "package flag"] else [])
  211         ))
  212 
  213 -- | Smart constructor for a module which is in @exposed-modules@.  Takes
  214 -- as an argument whether or not the defining package is exposed.
  215 fromExposedModules :: Bool -> ModuleOrigin
  216 fromExposedModules e = ModOrigin (Just e) [] [] False
  217 
  218 -- | Smart constructor for a module which is in @reexported-modules@.  Takes
  219 -- as an argument whether or not the reexporting package is exposed, and
  220 -- also its 'UnitInfo'.
  221 fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
  222 fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
  223 fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
  224 
  225 -- | Smart constructor for a module which was bound by a package flag.
  226 fromFlag :: ModuleOrigin
  227 fromFlag = ModOrigin Nothing [] [] True
  228 
  229 instance Semigroup ModuleOrigin where
  230     x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =
  231         ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
  232       where g (Just b) (Just b')
  233                 | b == b'   = Just b
  234                 | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $
  235                     text "x: " <> ppr x $$ text "y: " <> ppr y
  236             g Nothing x = x
  237             g x Nothing = x
  238     x <> y = pprPanic "ModOrigin: hidden module redefined" $
  239                  text "x: " <> ppr x $$ text "y: " <> ppr y
  240 
  241 instance Monoid ModuleOrigin where
  242     mempty = ModOrigin Nothing [] [] False
  243     mappend = (Semigroup.<>)
  244 
  245 -- | Is the name from the import actually visible? (i.e. does it cause
  246 -- ambiguity, or is it only relevant when we're making suggestions?)
  247 originVisible :: ModuleOrigin -> Bool
  248 originVisible ModHidden = False
  249 originVisible (ModUnusable _) = False
  250 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
  251 
  252 -- | Are there actually no providers for this module?  This will never occur
  253 -- except when we're filtering based on package imports.
  254 originEmpty :: ModuleOrigin -> Bool
  255 originEmpty (ModOrigin Nothing [] [] False) = True
  256 originEmpty _ = False
  257 
  258 type PreloadUnitClosure = UniqSet UnitId
  259 
  260 -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
  261 type VisibilityMap = Map Unit UnitVisibility
  262 
  263 -- | 'UnitVisibility' records the various aspects of visibility of a particular
  264 -- 'Unit'.
  265 data UnitVisibility = UnitVisibility
  266     { uv_expose_all :: Bool
  267       --  ^ Should all modules in exposed-modules should be dumped into scope?
  268     , uv_renamings :: [(ModuleName, ModuleName)]
  269       -- ^ Any custom renamings that should bring extra 'ModuleName's into
  270       -- scope.
  271     , uv_package_name :: First FastString
  272       -- ^ The package name associated with the 'Unit'.  This is used
  273       -- to implement legacy behavior where @-package foo-0.1@ implicitly
  274       -- hides any packages named @foo@
  275     , uv_requirements :: Map ModuleName (Set InstantiatedModule)
  276       -- ^ The signatures which are contributed to the requirements context
  277       -- from this unit ID.
  278     , uv_explicit :: Bool
  279       -- ^ Whether or not this unit was explicitly brought into scope,
  280       -- as opposed to implicitly via the 'exposed' fields in the
  281       -- package database (when @-hide-all-packages@ is not passed.)
  282     }
  283 
  284 instance Outputable UnitVisibility where
  285     ppr (UnitVisibility {
  286         uv_expose_all = b,
  287         uv_renamings = rns,
  288         uv_package_name = First mb_pn,
  289         uv_requirements = reqs,
  290         uv_explicit = explicit
  291     }) = ppr (b, rns, mb_pn, reqs, explicit)
  292 
  293 instance Semigroup UnitVisibility where
  294     uv1 <> uv2
  295         = UnitVisibility
  296           { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
  297           , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
  298           , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
  299           , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
  300           , uv_explicit = uv_explicit uv1 || uv_explicit uv2
  301           }
  302 
  303 instance Monoid UnitVisibility where
  304     mempty = UnitVisibility
  305              { uv_expose_all = False
  306              , uv_renamings = []
  307              , uv_package_name = First Nothing
  308              , uv_requirements = Map.empty
  309              , uv_explicit = False
  310              }
  311     mappend = (Semigroup.<>)
  312 
  313 
  314 -- | Unit configuration
  315 data UnitConfig = UnitConfig
  316    { unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS
  317    , unitConfigWays           :: !Ways          -- ^ Ways to use
  318 
  319    , unitConfigAllowVirtual   :: !Bool          -- ^ Allow virtual units
  320       -- ^ Do we allow the use of virtual units instantiated on-the-fly (see Note
  321       -- [About units] in GHC.Unit). This should only be true when we are
  322       -- type-checking an indefinite unit (not producing any code).
  323 
  324    , unitConfigProgramName    :: !String
  325       -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
  326       -- variables such as "GHC[JS]_PACKAGE_PATH".
  327 
  328    , unitConfigGlobalDB :: !FilePath    -- ^ Path to global DB
  329    , unitConfigGHCDir   :: !FilePath    -- ^ Main GHC dir: contains settings, etc.
  330    , unitConfigDBName   :: !String      -- ^ User DB name (e.g. "package.conf.d")
  331 
  332    , unitConfigAutoLink       :: ![UnitId] -- ^ Units to link automatically (e.g. base, rts)
  333    , unitConfigDistrustAll    :: !Bool     -- ^ Distrust all units by default
  334    , unitConfigHideAll        :: !Bool     -- ^ Hide all units by default
  335    , unitConfigHideAllPlugins :: !Bool     -- ^ Hide all plugins units by default
  336 
  337    , unitConfigDBCache      :: Maybe [UnitDatabase UnitId]
  338       -- ^ Cache of databases to use, in the order they were specified on the
  339       -- command line (later databases shadow earlier ones).
  340       -- If Nothing, databases will be found using `unitConfigFlagsDB`.
  341 
  342    -- command-line flags
  343    , unitConfigFlagsDB      :: [PackageDBFlag]     -- ^ Unit databases flags
  344    , unitConfigFlagsExposed :: [PackageFlag]       -- ^ Exposed units
  345    , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units
  346    , unitConfigFlagsTrusted :: [TrustFlag]         -- ^ Trusted units
  347    , unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units
  348    }
  349 
  350 initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig
  351 initUnitConfig dflags cached_dbs =
  352    let !hu_id             = homeUnitId_ dflags
  353        !hu_instanceof     = homeUnitInstanceOf_ dflags
  354        !hu_instantiations = homeUnitInstantiations_ dflags
  355 
  356        autoLink
  357          | not (gopt Opt_AutoLinkPackages dflags) = []
  358          -- By default we add base & rts to the preload units (when they are
  359          -- found in the unit database) except when we are building them
  360          | otherwise = filter (hu_id /=) [baseUnitId, rtsUnitId]
  361 
  362        -- if the home unit is indefinite, it means we are type-checking it only
  363        -- (not producing any code). Hence we can use virtual units instantiated
  364        -- on-the-fly. See Note [About units] in GHC.Unit
  365        allow_virtual_units = case (hu_instanceof, hu_instantiations) of
  366             (Just u, is) -> u == hu_id && any (isHoleModule . snd) is
  367             _            -> False
  368 
  369    in UnitConfig
  370       { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags)
  371       , unitConfigProgramName    = programName dflags
  372       , unitConfigWays           = ways dflags
  373       , unitConfigAllowVirtual   = allow_virtual_units
  374 
  375       , unitConfigGlobalDB       = globalPackageDatabasePath dflags
  376       , unitConfigGHCDir         = topDir dflags
  377       , unitConfigDBName         = "package.conf.d"
  378 
  379       , unitConfigAutoLink       = autoLink
  380       , unitConfigDistrustAll    = gopt Opt_DistrustAllPackages dflags
  381       , unitConfigHideAll        = gopt Opt_HideAllPackages dflags
  382       , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags
  383 
  384       , unitConfigDBCache      = cached_dbs
  385       , unitConfigFlagsDB      = packageDBFlags dflags
  386       , unitConfigFlagsExposed = packageFlags dflags
  387       , unitConfigFlagsIgnored = ignorePackageFlags dflags
  388       , unitConfigFlagsTrusted = trustFlags dflags
  389       , unitConfigFlagsPlugins = pluginPackageFlags dflags
  390 
  391       }
  392 
  393 -- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
  394 -- its 'ModuleOrigin').
  395 --
  396 -- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
  397 -- origin for a given 'Module'
  398 type ModuleNameProvidersMap =
  399     Map ModuleName (Map Module ModuleOrigin)
  400 
  401 data UnitState = UnitState {
  402   -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
  403   -- so that only valid units are here.  'UnitInfo' reflects
  404   -- what was stored *on disk*, except for the 'trusted' flag, which
  405   -- is adjusted at runtime.  (In particular, some units in this map
  406   -- may have the 'exposed' flag be 'False'.)
  407   unitInfoMap :: UnitInfoMap,
  408 
  409   -- | The set of transitively reachable units according
  410   -- to the explicitly provided command line arguments.
  411   -- A fully instantiated VirtUnit may only be replaced by a RealUnit from
  412   -- this set.
  413   -- See Note [VirtUnit to RealUnit improvement]
  414   preloadClosure :: PreloadUnitClosure,
  415 
  416   -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
  417   -- package name (e.g. different instantiations), then we return one of them...
  418   -- This is used when users refer to packages in Backpack includes.
  419   -- And also to resolve package qualifiers with the PackageImports extension.
  420   packageNameMap            :: UniqFM PackageName UnitId,
  421 
  422   -- | A mapping from database unit keys to wired in unit ids.
  423   wireMap :: Map UnitId UnitId,
  424 
  425   -- | A mapping from wired in unit ids to unit keys from the database.
  426   unwireMap :: Map UnitId UnitId,
  427 
  428   -- | The units we're going to link in eagerly.  This list
  429   -- should be in reverse dependency order; that is, a unit
  430   -- is always mentioned before the units it depends on.
  431   preloadUnits      :: [UnitId],
  432 
  433   -- | Units which we explicitly depend on (from a command line flag).
  434   -- We'll use this to generate version macros.
  435   explicitUnits      :: [Unit],
  436 
  437   -- | This is a full map from 'ModuleName' to all modules which may possibly
  438   -- be providing it.  These providers may be hidden (but we'll still want
  439   -- to report them in error messages), or it may be an ambiguous import.
  440   moduleNameProvidersMap    :: !ModuleNameProvidersMap,
  441 
  442   -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
  443   pluginModuleNameProvidersMap    :: !ModuleNameProvidersMap,
  444 
  445   -- | A map saying, for each requirement, what interfaces must be merged
  446   -- together when we use them.  For example, if our dependencies
  447   -- are @p[A=\<A>]@ and @q[A=\<A>,B=r[C=\<A>]:B]@, then the interfaces
  448   -- to merge for A are @p[A=\<A>]:A@, @q[A=\<A>,B=r[C=\<A>]:B]:A@
  449   -- and @r[C=\<A>]:C@.
  450   --
  451   -- There's an entry in this map for each hole in our home library.
  452   requirementContext :: Map ModuleName [InstantiatedModule],
  453 
  454   -- | Indicate if we can instantiate units on-the-fly.
  455   --
  456   -- This should only be true when we are type-checking an indefinite unit.
  457   -- See Note [About units] in GHC.Unit.
  458   allowVirtualUnits :: !Bool
  459   }
  460 
  461 emptyUnitState :: UnitState
  462 emptyUnitState = UnitState {
  463     unitInfoMap = Map.empty,
  464     preloadClosure = emptyUniqSet,
  465     packageNameMap = emptyUFM,
  466     wireMap   = Map.empty,
  467     unwireMap = Map.empty,
  468     preloadUnits = [],
  469     explicitUnits = [],
  470     moduleNameProvidersMap = Map.empty,
  471     pluginModuleNameProvidersMap = Map.empty,
  472     requirementContext = Map.empty,
  473     allowVirtualUnits = False
  474     }
  475 
  476 -- | Unit database
  477 data UnitDatabase unit = UnitDatabase
  478    { unitDatabasePath  :: FilePath
  479    , unitDatabaseUnits :: [GenUnitInfo unit]
  480    }
  481 
  482 type UnitInfoMap = Map UnitId UnitInfo
  483 
  484 -- | Find the unit we know about with the given unit, if any
  485 lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
  486 lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs)
  487 
  488 -- | A more specialized interface, which doesn't require a 'UnitState' (so it
  489 -- can be used while we're initializing 'DynFlags')
  490 --
  491 -- Parameters:
  492 --    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
  493 --    * a 'UnitInfoMap'
  494 --    * a 'PreloadUnitClosure'
  495 lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
  496 lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of
  497    HoleUnit   -> error "Hole unit"
  498    RealUnit i -> Map.lookup (unDefinite i) pkg_map
  499    VirtUnit i
  500       | allowOnTheFlyInst
  501       -> -- lookup UnitInfo of the indefinite unit to be instantiated and
  502          -- instantiate it on-the-fly
  503          fmap (renameUnitInfo pkg_map closure (instUnitInsts i))
  504            (Map.lookup (instUnitInstanceOf i) pkg_map)
  505 
  506       | otherwise
  507       -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
  508          -- units. Even if they are real, installed units, they can't use the
  509          -- `RealUnit` constructor (it is reserved for definite units) so we use
  510          -- the `VirtUnit` constructor.
  511          Map.lookup (virtualUnitId i) pkg_map
  512 
  513 -- | Find the unit we know about with the given unit id, if any
  514 lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
  515 lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid
  516 
  517 -- | Find the unit we know about with the given unit id, if any
  518 lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
  519 lookupUnitId' db uid = Map.lookup uid db
  520 
  521 
  522 -- | Looks up the given unit in the unit state, panicing if it is not found
  523 unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
  524 unsafeLookupUnit state u = case lookupUnit state u of
  525    Just info -> info
  526    Nothing   -> pprPanic "unsafeLookupUnit" (ppr u)
  527 
  528 -- | Looks up the given unit id in the unit state, panicing if it is not found
  529 unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
  530 unsafeLookupUnitId state uid = case lookupUnitId state uid of
  531    Just info -> info
  532    Nothing   -> pprPanic "unsafeLookupUnitId" (ppr uid)
  533 
  534 
  535 -- | Find the unit we know about with the given package name (e.g. @foo@), if any
  536 -- (NB: there might be a locally defined unit name which overrides this)
  537 lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
  538 lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n
  539 
  540 -- | Search for units with a given package ID (e.g. \"foo-0.1\")
  541 searchPackageId :: UnitState -> PackageId -> [UnitInfo]
  542 searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
  543                                (listUnitInfo pkgstate)
  544 
  545 -- | Create a Map UnitId UnitInfo
  546 --
  547 -- For each instantiated unit, we add two map keys:
  548 --    * the real unit id
  549 --    * the virtual unit id made from its instantiation
  550 --
  551 -- We do the same thing for fully indefinite units (which are "instantiated"
  552 -- with module holes).
  553 --
  554 mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
  555 mkUnitInfoMap infos = foldl' add Map.empty infos
  556   where
  557    mkVirt      p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))
  558    add pkg_map p
  559       | not (null (unitInstantiations p))
  560       = Map.insert (mkVirt p) p
  561          $ Map.insert (unitId p) p
  562          $ pkg_map
  563       | otherwise
  564       = Map.insert (unitId p) p pkg_map
  565 
  566 -- | Get a list of entries from the unit database.  NB: be careful with
  567 -- this function, although all units in this map are "visible", this
  568 -- does not imply that the exposed-modules of the unit are available
  569 -- (they may have been thinned or renamed).
  570 listUnitInfo :: UnitState -> [UnitInfo]
  571 listUnitInfo state = Map.elems (unitInfoMap state)
  572 
  573 -- ----------------------------------------------------------------------------
  574 -- Loading the unit db files and building up the unit state
  575 
  576 -- | Read the unit database files, and sets up various internal tables of
  577 -- unit information, according to the unit-related flags on the
  578 -- command-line (@-package@, @-hide-package@ etc.)
  579 --
  580 -- 'initUnits' can be called again subsequently after updating the
  581 -- 'packageFlags' field of the 'DynFlags', and it will update the
  582 -- 'unitState' in 'DynFlags'.
  583 initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
  584 initUnits logger dflags cached_dbs = do
  585 
  586   let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
  587 
  588   (unit_state,dbs) <- withTiming logger (text "initializing unit database")
  589                    forceUnitInfoMap
  590                  $ mkUnitState logger (initUnitConfig dflags cached_dbs)
  591 
  592   putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
  593     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
  594                 $ pprModuleMap (moduleNameProvidersMap unit_state))
  595 
  596   let home_unit = mkHomeUnit unit_state
  597                              (homeUnitId_ dflags)
  598                              (homeUnitInstanceOf_ dflags)
  599                              (homeUnitInstantiations_ dflags)
  600 
  601   -- Try to find platform constants
  602   --
  603   -- See Note [Platform constants] in GHC.Platform
  604   mconstants <- if homeUnitId_ dflags == rtsUnitId
  605     then do
  606       -- we're building the RTS! Lookup DerivedConstants.h in the include paths
  607       lookupPlatformConstants (includePathsGlobal (includePaths dflags))
  608     else
  609       -- lookup the DerivedConstants.h header bundled with the RTS unit. We
  610       -- don't fail if we can't find the RTS unit as it can be a valid (but
  611       -- uncommon) case, e.g. building a C utility program (not depending on the
  612       -- RTS) before building the RTS. In any case, we will fail later on if we
  613       -- really need to use the platform constants but they have not been loaded.
  614       case lookupUnitId unit_state rtsUnitId of
  615         Nothing   -> return Nothing
  616         Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info))
  617 
  618   return (dbs,unit_state,home_unit,mconstants)
  619 
  620 mkHomeUnit
  621     :: UnitState
  622     -> UnitId                 -- ^ Home unit id
  623     -> Maybe UnitId           -- ^ Home unit instance of
  624     -> [(ModuleName, Module)] -- ^ Home unit instantiations
  625     -> HomeUnit
  626 mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
  627     let
  628         -- Some wired units can be used to instantiate the home unit. We need to
  629         -- replace their unit keys with their wired unit ids.
  630         wmap              = wireMap unit_state
  631         hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_
  632     in case (hu_instanceof, hu_instantiations) of
  633       (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
  634       (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
  635       (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")
  636       (Just u, is)
  637          -- detect fully indefinite units: all their instantiations are hole
  638          -- modules and the home unit id is the same as the instantiating unit
  639          -- id (see Note [About units] in GHC.Unit)
  640          | all (isHoleModule . snd) is && u == hu_id
  641          -> IndefiniteHomeUnit u is
  642          -- otherwise it must be that we (fully) instantiate an indefinite unit
  643          -- to make it definite.
  644          -- TODO: error when the unit is partially instantiated??
  645          | otherwise
  646          -> DefiniteHomeUnit hu_id (Just (u, is))
  647 
  648 -- -----------------------------------------------------------------------------
  649 -- Reading the unit database(s)
  650 
  651 readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
  652 readUnitDatabases logger cfg = do
  653   conf_refs <- getUnitDbRefs cfg
  654   confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
  655   mapM (readUnitDatabase logger cfg) confs
  656 
  657 
  658 getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
  659 getUnitDbRefs cfg = do
  660   let system_conf_refs = [UserPkgDb, GlobalPkgDb]
  661 
  662   e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH")
  663   let base_conf_refs = case e_pkg_path of
  664         Left _ -> system_conf_refs
  665         Right path
  666          | not (null path) && isSearchPathSeparator (last path)
  667          -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
  668          | otherwise
  669          -> map PkgDbPath (splitSearchPath path)
  670 
  671   -- Apply the package DB-related flags from the command line to get the
  672   -- final list of package DBs.
  673   --
  674   -- Notes on ordering:
  675   --  * The list of flags is reversed (later ones first)
  676   --  * We work with the package DB list in "left shadows right" order
  677   --  * and finally reverse it at the end, to get "right shadows left"
  678   --
  679   return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg))
  680  where
  681   doFlag (PackageDB p) dbs = p : dbs
  682   doFlag NoUserPackageDB dbs = filter isNotUser dbs
  683   doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
  684   doFlag ClearPackageDBs _ = []
  685 
  686   isNotUser UserPkgDb = False
  687   isNotUser _ = True
  688 
  689   isNotGlobal GlobalPkgDb = False
  690   isNotGlobal _ = True
  691 
  692 -- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
  693 -- when the user database filepath is expected but the latter doesn't exist.
  694 --
  695 -- NB: This logic is reimplemented in Cabal, so if you change it,
  696 -- make sure you update Cabal. (Or, better yet, dump it in the
  697 -- compiler info so Cabal can use the info.)
  698 resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
  699 resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
  700 resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
  701   dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
  702   let pkgconf = dir </> unitConfigDBName cfg
  703   exist <- tryMaybeT $ doesDirectoryExist pkgconf
  704   if exist then return pkgconf else mzero
  705 resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
  706 
  707 readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
  708 readUnitDatabase logger cfg conf_file = do
  709   isdir <- doesDirectoryExist conf_file
  710 
  711   proto_pkg_configs <-
  712     if isdir
  713        then readDirStyleUnitInfo conf_file
  714        else do
  715             isfile <- doesFileExist conf_file
  716             if isfile
  717                then do
  718                  mpkgs <- tryReadOldFileStyleUnitInfo
  719                  case mpkgs of
  720                    Just pkgs -> return pkgs
  721                    Nothing   -> throwGhcExceptionIO $ InstallationError $
  722                       "ghc no longer supports single-file style package " ++
  723                       "databases (" ++ conf_file ++
  724                       ") use 'ghc-pkg init' to create the database with " ++
  725                       "the correct format."
  726                else throwGhcExceptionIO $ InstallationError $
  727                       "can't find a package database at " ++ conf_file
  728 
  729   let
  730       -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
  731       conf_file' = dropTrailingPathSeparator conf_file
  732       top_dir = unitConfigGHCDir cfg
  733       pkgroot = takeDirectory conf_file'
  734       pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
  735                          proto_pkg_configs
  736   --
  737   return $ UnitDatabase conf_file' pkg_configs1
  738   where
  739     readDirStyleUnitInfo conf_dir = do
  740       let filename = conf_dir </> "package.cache"
  741       cache_exists <- doesFileExist filename
  742       if cache_exists
  743         then do
  744           debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
  745           readPackageDbForGhc filename
  746         else do
  747           -- If there is no package.cache file, we check if the database is not
  748           -- empty by inspecting if the directory contains any .conf file. If it
  749           -- does, something is wrong and we fail. Otherwise we assume that the
  750           -- database is empty.
  751           debugTraceMsg logger 2 $ text "There is no package.cache in"
  752                       <+> text conf_dir
  753                        <> text ", checking if the database is empty"
  754           db_empty <- all (not . isSuffixOf ".conf")
  755                    <$> getDirectoryContents conf_dir
  756           if db_empty
  757             then do
  758               debugTraceMsg logger 3 $ text "There are no .conf files in"
  759                           <+> text conf_dir <> text ", treating"
  760                           <+> text "package database as empty"
  761               return []
  762             else
  763               throwGhcExceptionIO $ InstallationError $
  764                 "there is no package.cache in " ++ conf_dir ++
  765                 " even though package database is not empty"
  766 
  767 
  768     -- Single-file style package dbs have been deprecated for some time, but
  769     -- it turns out that Cabal was using them in one place. So this is a
  770     -- workaround to allow older Cabal versions to use this newer ghc.
  771     -- We check if the file db contains just "[]" and if so, we look for a new
  772     -- dir-style db in conf_file.d/, ie in a dir next to the given file.
  773     -- We cannot just replace the file with a new dir style since Cabal still
  774     -- assumes it's a file and tries to overwrite with 'writeFile'.
  775     -- ghc-pkg also cooperates with this workaround.
  776     tryReadOldFileStyleUnitInfo = do
  777       content <- readFile conf_file `catchIO` \_ -> return ""
  778       if take 2 content == "[]"
  779         then do
  780           let conf_dir = conf_file <.> "d"
  781           direxists <- doesDirectoryExist conf_dir
  782           if direxists
  783              then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
  784                      liftM Just (readDirStyleUnitInfo conf_dir)
  785              else return (Just []) -- ghc-pkg will create it when it's updated
  786         else return Nothing
  787 
  788 distrustAllUnits :: [UnitInfo] -> [UnitInfo]
  789 distrustAllUnits pkgs = map distrust pkgs
  790   where
  791     distrust pkg = pkg{ unitIsTrusted = False }
  792 
  793 mungeUnitInfo :: FilePath -> FilePath
  794                    -> UnitInfo -> UnitInfo
  795 mungeUnitInfo top_dir pkgroot =
  796     mungeDynLibFields
  797   . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
  798 
  799 mungeDynLibFields :: UnitInfo -> UnitInfo
  800 mungeDynLibFields pkg =
  801     pkg {
  802       unitLibraryDynDirs = case unitLibraryDynDirs pkg of
  803          [] -> unitLibraryDirs pkg
  804          ds -> ds
  805     }
  806 
  807 -- -----------------------------------------------------------------------------
  808 -- Modify our copy of the unit database based on trust flags,
  809 -- -trust and -distrust.
  810 
  811 applyTrustFlag
  812    :: UnitPrecedenceMap
  813    -> UnusableUnits
  814    -> [UnitInfo]
  815    -> TrustFlag
  816    -> MaybeErr UnitErr [UnitInfo]
  817 applyTrustFlag prec_map unusable pkgs flag =
  818   case flag of
  819     -- we trust all matching packages. Maybe should only trust first one?
  820     -- and leave others the same or set them untrusted
  821     TrustPackage str ->
  822        case selectPackages prec_map (PackageArg str) pkgs unusable of
  823          Left ps       -> Failed (TrustFlagErr flag ps)
  824          Right (ps,qs) -> Succeeded (map trust ps ++ qs)
  825           where trust p = p {unitIsTrusted=True}
  826 
  827     DistrustPackage str ->
  828        case selectPackages prec_map (PackageArg str) pkgs unusable of
  829          Left ps       -> Failed (TrustFlagErr flag ps)
  830          Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)
  831 
  832 applyPackageFlag
  833    :: UnitPrecedenceMap
  834    -> UnitInfoMap
  835    -> PreloadUnitClosure
  836    -> UnusableUnits
  837    -> Bool -- if False, if you expose a package, it implicitly hides
  838            -- any previously exposed packages with the same name
  839    -> [UnitInfo]
  840    -> VisibilityMap           -- Initially exposed
  841    -> PackageFlag             -- flag to apply
  842    -> MaybeErr UnitErr VisibilityMap -- Now exposed
  843 
  844 applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
  845   case flag of
  846     ExposePackage _ arg (ModRenaming b rns) ->
  847        case findPackages prec_map pkg_map closure arg pkgs unusable of
  848          Left ps     -> Failed (PackageFlagErr flag ps)
  849          Right (p:_) -> Succeeded vm'
  850           where
  851            n = fsPackageName p
  852 
  853            -- If a user says @-unit-id p[A=<A>]@, this imposes
  854            -- a requirement on us: whatever our signature A is,
  855            -- it must fulfill all of p[A=<A>]:A's requirements.
  856            -- This method is responsible for computing what our
  857            -- inherited requirements are.
  858            reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
  859                 | otherwise                 = Map.empty
  860 
  861            collectHoles uid = case uid of
  862              HoleUnit       -> Map.empty
  863              RealUnit {}    -> Map.empty -- definite units don't have holes
  864              VirtUnit indef ->
  865                   let local = [ Map.singleton
  866                                   (moduleName mod)
  867                                   (Set.singleton $ Module indef mod_name)
  868                               | (mod_name, mod) <- instUnitInsts indef
  869                               , isHoleModule mod ]
  870                       recurse = [ collectHoles (moduleUnit mod)
  871                                 | (_, mod) <- instUnitInsts indef ]
  872                   in Map.unionsWith Set.union $ local ++ recurse
  873 
  874            uv = UnitVisibility
  875                 { uv_expose_all = b
  876                 , uv_renamings = rns
  877                 , uv_package_name = First (Just n)
  878                 , uv_requirements = reqs
  879                 , uv_explicit = True
  880                 }
  881            vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
  882            -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
  883            -- (or if p-0.1 was registered in the pkgdb as exposed: True),
  884            -- the second package flag would override the first one and you
  885            -- would only see p-0.2 in exposed modules.  This is good for
  886            -- usability.
  887            --
  888            -- However, with thinning and renaming (or Backpack), there might be
  889            -- situations where you legitimately want to see two versions of a
  890            -- package at the same time, and this behavior would make it
  891            -- impossible to do so.  So we decided that if you pass
  892            -- -hide-all-packages, this should turn OFF the overriding behavior
  893            -- where an exposed package hides all other packages with the same
  894            -- name.  This should not affect Cabal at all, which only ever
  895            -- exposes one package at a time.
  896            --
  897            -- NB: Why a variable no_hide_others?  We have to apply this logic to
  898            -- -plugin-package too, and it's more consistent if the switch in
  899            -- behavior is based off of
  900            -- -hide-all-packages/-hide-all-plugin-packages depending on what
  901            -- flag is in question.
  902            vm_cleared | no_hide_others = vm
  903                       -- NB: renamings never clear
  904                       | (_:_) <- rns = vm
  905                       | otherwise = Map.filterWithKey
  906                             (\k uv -> k == mkUnit p
  907                                    || First (Just n) /= uv_package_name uv) vm
  908          _ -> panic "applyPackageFlag"
  909 
  910     HidePackage str ->
  911        case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
  912          Left ps  -> Failed (PackageFlagErr flag ps)
  913          Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)
  914 
  915 -- | Like 'selectPackages', but doesn't return a list of unmatched
  916 -- packages.  Furthermore, any packages it returns are *renamed*
  917 -- if the 'UnitArg' has a renaming associated with it.
  918 findPackages :: UnitPrecedenceMap
  919              -> UnitInfoMap
  920              -> PreloadUnitClosure
  921              -> PackageArg -> [UnitInfo]
  922              -> UnusableUnits
  923              -> Either [(UnitInfo, UnusableUnitReason)]
  924                 [UnitInfo]
  925 findPackages prec_map pkg_map closure arg pkgs unusable
  926   = let ps = mapMaybe (finder arg) pkgs
  927     in if null ps
  928         then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
  929                             (Map.elems unusable))
  930         else Right (sortByPreference prec_map ps)
  931   where
  932     finder (PackageArg str) p
  933       = if matchingStr str p
  934           then Just p
  935           else Nothing
  936     finder (UnitIdArg uid) p
  937       = case uid of
  938           RealUnit (Definite iuid)
  939             | iuid == unitId p
  940             -> Just p
  941           VirtUnit inst
  942             | instUnitInstanceOf inst == unitId p
  943             -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p)
  944           _ -> Nothing
  945 
  946 selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
  947                -> UnusableUnits
  948                -> Either [(UnitInfo, UnusableUnitReason)]
  949                   ([UnitInfo], [UnitInfo])
  950 selectPackages prec_map arg pkgs unusable
  951   = let matches = matching arg
  952         (ps,rest) = partition matches pkgs
  953     in if null ps
  954         then Left (filter (matches.fst) (Map.elems unusable))
  955         else Right (sortByPreference prec_map ps, rest)
  956 
  957 -- | Rename a 'UnitInfo' according to some module instantiation.
  958 renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
  959 renameUnitInfo pkg_map closure insts conf =
  960     let hsubst = listToUFM insts
  961         smod  = renameHoleModule' pkg_map closure hsubst
  962         new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
  963     in conf {
  964         unitInstantiations = new_insts,
  965         unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
  966                              (unitExposedModules conf)
  967     }
  968 
  969 
  970 -- A package named on the command line can either include the
  971 -- version, or just the name if it is unambiguous.
  972 matchingStr :: String -> UnitInfo -> Bool
  973 matchingStr str p
  974         =  str == unitPackageIdString p
  975         || str == unitPackageNameString p
  976 
  977 matchingId :: UnitId -> UnitInfo -> Bool
  978 matchingId uid p = uid == unitId p
  979 
  980 matching :: PackageArg -> UnitInfo -> Bool
  981 matching (PackageArg str) = matchingStr str
  982 matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
  983 matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
  984 
  985 -- | This sorts a list of packages, putting "preferred" packages first.
  986 -- See 'compareByPreference' for the semantics of "preference".
  987 sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
  988 sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))
  989 
  990 -- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
  991 -- which should be "active".  Here is the order of preference:
  992 --
  993 --      1. First, prefer the latest version
  994 --      2. If the versions are the same, prefer the package that
  995 --      came in the latest package database.
  996 --
  997 -- Pursuant to #12518, we could change this policy to, for example, remove
  998 -- the version preference, meaning that we would always prefer the units
  999 -- in later unit database.
 1000 compareByPreference
 1001     :: UnitPrecedenceMap
 1002     -> UnitInfo
 1003     -> UnitInfo
 1004     -> Ordering
 1005 compareByPreference prec_map pkg pkg'
 1006   = case comparing unitPackageVersion pkg pkg' of
 1007         GT -> GT
 1008         EQ | Just prec  <- Map.lookup (unitId pkg)  prec_map
 1009            , Just prec' <- Map.lookup (unitId pkg') prec_map
 1010            -- Prefer the unit from the later DB flag (i.e., higher
 1011            -- precedence)
 1012            -> compare prec prec'
 1013            | otherwise
 1014            -> EQ
 1015         LT -> LT
 1016 
 1017 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 1018 comparing f a b = f a `compare` f b
 1019 
 1020 pprFlag :: PackageFlag -> SDoc
 1021 pprFlag flag = case flag of
 1022     HidePackage p   -> text "-hide-package " <> text p
 1023     ExposePackage doc _ _ -> text doc
 1024 
 1025 pprTrustFlag :: TrustFlag -> SDoc
 1026 pprTrustFlag flag = case flag of
 1027     TrustPackage p    -> text "-trust " <> text p
 1028     DistrustPackage p -> text "-distrust " <> text p
 1029 
 1030 -- -----------------------------------------------------------------------------
 1031 -- Wired-in units
 1032 --
 1033 -- See Note [Wired-in units] in GHC.Unit.Module
 1034 
 1035 type WiringMap = Map UnitId UnitId
 1036 
 1037 findWiredInUnits
 1038    :: Logger
 1039    -> UnitPrecedenceMap
 1040    -> [UnitInfo]           -- database
 1041    -> VisibilityMap             -- info on what units are visible
 1042                                 -- for wired in selection
 1043    -> IO ([UnitInfo],  -- unit database updated for wired in
 1044           WiringMap)   -- map from unit id to wired identity
 1045 
 1046 findWiredInUnits logger prec_map pkgs vis_map = do
 1047   -- Now we must find our wired-in units, and rename them to
 1048   -- their canonical names (eg. base-1.0 ==> base), as described
 1049   -- in Note [Wired-in units] in GHC.Unit.Module
 1050   let
 1051         matches :: UnitInfo -> UnitId -> Bool
 1052         pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
 1053 
 1054         -- find which package corresponds to each wired-in package
 1055         -- delete any other packages with the same name
 1056         -- update the package and any dependencies to point to the new
 1057         -- one.
 1058         --
 1059         -- When choosing which package to map to a wired-in package
 1060         -- name, we try to pick the latest version of exposed packages.
 1061         -- However, if there are no exposed wired in packages available
 1062         -- (e.g. -hide-all-packages was used), we can't bail: we *have*
 1063         -- to assign a package for the wired-in package: so we try again
 1064         -- with hidden packages included to (and pick the latest
 1065         -- version).
 1066         --
 1067         -- You can also override the default choice by using -ignore-package:
 1068         -- this works even when there is no exposed wired in package
 1069         -- available.
 1070         --
 1071         findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
 1072         findWiredInUnit pkgs wired_pkg =
 1073            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
 1074                all_exposed_ps =
 1075                     [ p | p <- all_ps
 1076                         , Map.member (mkUnit p) vis_map ] in
 1077            case all_exposed_ps of
 1078             [] -> case all_ps of
 1079                        []   -> notfound
 1080                        many -> pick (head (sortByPreference prec_map many))
 1081             many -> pick (head (sortByPreference prec_map many))
 1082           where
 1083                 notfound = do
 1084                           debugTraceMsg logger 2 $
 1085                             text "wired-in package "
 1086                                  <> ftext (unitIdFS wired_pkg)
 1087                                  <> text " not found."
 1088                           return Nothing
 1089                 pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
 1090                 pick pkg = do
 1091                         debugTraceMsg logger 2 $
 1092                             text "wired-in package "
 1093                                  <> ftext (unitIdFS wired_pkg)
 1094                                  <> text " mapped to "
 1095                                  <> ppr (unitId pkg)
 1096                         return (Just (wired_pkg, pkg))
 1097 
 1098 
 1099   mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
 1100   let
 1101         wired_in_pkgs = catMaybes mb_wired_in_pkgs
 1102 
 1103         wiredInMap :: Map UnitId UnitId
 1104         wiredInMap = Map.fromList
 1105           [ (unitId realUnitInfo, wiredInUnitId)
 1106           | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
 1107           , not (unitIsIndefinite realUnitInfo)
 1108           ]
 1109 
 1110         updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
 1111           where upd_pkg pkg
 1112                   | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap
 1113                   = pkg { unitId         = wiredInUnitId
 1114                         , unitInstanceOf = wiredInUnitId
 1115                            -- every non instantiated unit is an instance of
 1116                            -- itself (required by Backpack...)
 1117                            --
 1118                            -- See Note [About Units] in GHC.Unit
 1119                         }
 1120                   | otherwise
 1121                   = pkg
 1122                 upd_deps pkg = pkg {
 1123                       unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
 1124                       unitExposedModules
 1125                         = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
 1126                               (unitExposedModules pkg)
 1127                     }
 1128 
 1129 
 1130   return (updateWiredInDependencies pkgs, wiredInMap)
 1131 
 1132 -- Helper functions for rewiring Module and Unit.  These
 1133 -- rewrite Units of modules in wired-in packages to the form known to the
 1134 -- compiler, as described in Note [Wired-in units] in GHC.Unit.Module.
 1135 --
 1136 -- For instance, base-4.9.0.0 will be rewritten to just base, to match
 1137 -- what appears in GHC.Builtin.Names.
 1138 
 1139 upd_wired_in_mod :: WiringMap -> Module -> Module
 1140 upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
 1141 
 1142 upd_wired_in_uid :: WiringMap -> Unit -> Unit
 1143 upd_wired_in_uid wiredInMap u = case u of
 1144    HoleUnit                -> HoleUnit
 1145    RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
 1146    VirtUnit indef_uid ->
 1147       VirtUnit $ mkInstantiatedUnit
 1148         (instUnitInstanceOf indef_uid)
 1149         (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid))
 1150 
 1151 upd_wired_in :: WiringMap -> UnitId -> UnitId
 1152 upd_wired_in wiredInMap key
 1153     | Just key' <- Map.lookup key wiredInMap = key'
 1154     | otherwise = key
 1155 
 1156 updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
 1157 updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
 1158   where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of
 1159                     Nothing -> vm
 1160                     Just r -> Map.insert (RealUnit (Definite to)) r
 1161                                 (Map.delete (RealUnit (Definite from)) vm)
 1162 
 1163 
 1164 -- ----------------------------------------------------------------------------
 1165 
 1166 -- | The reason why a unit is unusable.
 1167 data UnusableUnitReason
 1168   = -- | We ignored it explicitly using @-ignore-package@.
 1169     IgnoredWithFlag
 1170     -- | This unit transitively depends on a unit that was never present
 1171     -- in any of the provided databases.
 1172   | BrokenDependencies   [UnitId]
 1173     -- | This unit transitively depends on a unit involved in a cycle.
 1174     -- Note that the list of 'UnitId' reports the direct dependencies
 1175     -- of this unit that (transitively) depended on the cycle, and not
 1176     -- the actual cycle itself (which we report separately at high verbosity.)
 1177   | CyclicDependencies   [UnitId]
 1178     -- | This unit transitively depends on a unit which was ignored.
 1179   | IgnoredDependencies  [UnitId]
 1180     -- | This unit transitively depends on a unit which was
 1181     -- shadowed by an ABI-incompatible unit.
 1182   | ShadowedDependencies [UnitId]
 1183 
 1184 instance Outputable UnusableUnitReason where
 1185     ppr IgnoredWithFlag = text "[ignored with flag]"
 1186     ppr (BrokenDependencies uids)   = brackets (text "broken" <+> ppr uids)
 1187     ppr (CyclicDependencies uids)   = brackets (text "cyclic" <+> ppr uids)
 1188     ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)
 1189     ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
 1190 
 1191 type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason)
 1192 
 1193 pprReason :: SDoc -> UnusableUnitReason -> SDoc
 1194 pprReason pref reason = case reason of
 1195   IgnoredWithFlag ->
 1196       pref <+> text "ignored due to an -ignore-package flag"
 1197   BrokenDependencies deps ->
 1198       pref <+> text "unusable due to missing dependencies:" $$
 1199         nest 2 (hsep (map ppr deps))
 1200   CyclicDependencies deps ->
 1201       pref <+> text "unusable due to cyclic dependencies:" $$
 1202         nest 2 (hsep (map ppr deps))
 1203   IgnoredDependencies deps ->
 1204       pref <+> text ("unusable because the -ignore-package flag was used to " ++
 1205                      "ignore at least one of its dependencies:") $$
 1206         nest 2 (hsep (map ppr deps))
 1207   ShadowedDependencies deps ->
 1208       pref <+> text "unusable due to shadowed dependencies:" $$
 1209         nest 2 (hsep (map ppr deps))
 1210 
 1211 reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
 1212 reportCycles logger sccs = mapM_ report sccs
 1213   where
 1214     report (AcyclicSCC _) = return ()
 1215     report (CyclicSCC vs) =
 1216         debugTraceMsg logger 2 $
 1217           text "these packages are involved in a cycle:" $$
 1218             nest 2 (hsep (map (ppr . unitId) vs))
 1219 
 1220 reportUnusable :: Logger -> UnusableUnits -> IO ()
 1221 reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)
 1222   where
 1223     report (ipid, (_, reason)) =
 1224        debugTraceMsg logger 2 $
 1225          pprReason
 1226            (text "package" <+> ppr ipid <+> text "is") reason
 1227 
 1228 -- ----------------------------------------------------------------------------
 1229 --
 1230 -- Utilities on the database
 1231 --
 1232 
 1233 -- | A reverse dependency index, mapping an 'UnitId' to
 1234 -- the 'UnitId's which have a dependency on it.
 1235 type RevIndex = Map UnitId [UnitId]
 1236 
 1237 -- | Compute the reverse dependency index of a unit database.
 1238 reverseDeps :: UnitInfoMap -> RevIndex
 1239 reverseDeps db = Map.foldl' go Map.empty db
 1240   where
 1241     go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg)
 1242     go' from r to = Map.insertWith (++) to [from] r
 1243 
 1244 -- | Given a list of 'UnitId's to remove, a database,
 1245 -- and a reverse dependency index (as computed by 'reverseDeps'),
 1246 -- remove those units, plus any units which depend on them.
 1247 -- Returns the pruned database, as well as a list of 'UnitInfo's
 1248 -- that was removed.
 1249 removeUnits :: [UnitId] -> RevIndex
 1250                -> UnitInfoMap
 1251                -> (UnitInfoMap, [UnitInfo])
 1252 removeUnits uids index m = go uids (m,[])
 1253   where
 1254     go [] (m,pkgs) = (m,pkgs)
 1255     go (uid:uids) (m,pkgs)
 1256         | Just pkg <- Map.lookup uid m
 1257         = case Map.lookup uid index of
 1258             Nothing    -> go uids (Map.delete uid m, pkg:pkgs)
 1259             Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)
 1260         | otherwise
 1261         = go uids (m,pkgs)
 1262 
 1263 -- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
 1264 -- which correspond to units that do not exist in the index.
 1265 depsNotAvailable :: UnitInfoMap
 1266                  -> UnitInfo
 1267                  -> [UnitId]
 1268 depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg)
 1269 
 1270 -- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
 1271 -- 'unitAbiDepends' which correspond to units that do not exist, OR have
 1272 -- mismatching ABIs.
 1273 depsAbiMismatch :: UnitInfoMap
 1274                 -> UnitInfo
 1275                 -> [UnitId]
 1276 depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg
 1277   where
 1278     abiMatch (dep_uid, abi)
 1279         | Just dep_pkg <- Map.lookup dep_uid pkg_map
 1280         = unitAbiHash dep_pkg == abi
 1281         | otherwise
 1282         = False
 1283 
 1284 -- -----------------------------------------------------------------------------
 1285 -- Ignore units
 1286 
 1287 ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
 1288 ignoreUnits flags pkgs = Map.fromList (concatMap doit flags)
 1289   where
 1290   doit (IgnorePackage str) =
 1291      case partition (matchingStr str) pkgs of
 1292          (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
 1293                     | p <- ps ]
 1294         -- missing unit is not an error for -ignore-package,
 1295         -- because a common usage is to -ignore-package P as
 1296         -- a preventative measure just in case P exists.
 1297 
 1298 -- ----------------------------------------------------------------------------
 1299 --
 1300 -- Merging databases
 1301 --
 1302 
 1303 -- | For each unit, a mapping from uid -> i indicates that this
 1304 -- unit was brought into GHC by the ith @-package-db@ flag on
 1305 -- the command line.  We use this mapping to make sure we prefer
 1306 -- units that were defined later on the command line, if there
 1307 -- is an ambiguity.
 1308 type UnitPrecedenceMap = Map UnitId Int
 1309 
 1310 -- | Given a list of databases, merge them together, where
 1311 -- units with the same unit id in later databases override
 1312 -- earlier ones.  This does NOT check if the resulting database
 1313 -- makes sense (that's done by 'validateDatabase').
 1314 mergeDatabases :: Logger -> [UnitDatabase UnitId]
 1315                -> IO (UnitInfoMap, UnitPrecedenceMap)
 1316 mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]
 1317   where
 1318     merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
 1319       debugTraceMsg logger 2 $
 1320           text "loading package database" <+> text db_path
 1321       forM_ (Set.toList override_set) $ \pkg ->
 1322           debugTraceMsg logger 2 $
 1323               text "package" <+> ppr pkg <+>
 1324               text "overrides a previously defined package"
 1325       return (pkg_map', prec_map')
 1326      where
 1327       db_map = mk_pkg_map db
 1328       mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
 1329 
 1330       -- The set of UnitIds which appear in both db and pkgs.  These are the
 1331       -- ones that get overridden.  Compute this just to give some
 1332       -- helpful debug messages at -v2
 1333       override_set :: Set UnitId
 1334       override_set = Set.intersection (Map.keysSet db_map)
 1335                                       (Map.keysSet pkg_map)
 1336 
 1337       -- Now merge the sets together (NB: in case of duplicate,
 1338       -- first argument preferred)
 1339       pkg_map' :: UnitInfoMap
 1340       pkg_map' = Map.union db_map pkg_map
 1341 
 1342       prec_map' :: UnitPrecedenceMap
 1343       prec_map' = Map.union (Map.map (const i) db_map) prec_map
 1344 
 1345 -- | Validates a database, removing unusable units from it
 1346 -- (this includes removing units that the user has explicitly
 1347 -- ignored.)  Our general strategy:
 1348 --
 1349 -- 1. Remove all broken units (dangling dependencies)
 1350 -- 2. Remove all units that are cyclic
 1351 -- 3. Apply ignore flags
 1352 -- 4. Remove all units which have deps with mismatching ABIs
 1353 --
 1354 validateDatabase :: UnitConfig -> UnitInfoMap
 1355                  -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
 1356 validateDatabase cfg pkg_map1 =
 1357     (pkg_map5, unusable, sccs)
 1358   where
 1359     ignore_flags = reverse (unitConfigFlagsIgnored cfg)
 1360 
 1361     -- Compute the reverse dependency index
 1362     index = reverseDeps pkg_map1
 1363 
 1364     -- Helper function
 1365     mk_unusable mk_err dep_matcher m uids =
 1366       Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
 1367                    | pkg <- uids ]
 1368 
 1369     -- Find broken units
 1370     directly_broken = filter (not . null . depsNotAvailable pkg_map1)
 1371                              (Map.elems pkg_map1)
 1372     (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1
 1373     unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
 1374 
 1375     -- Find recursive units
 1376     sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
 1377                             | pkg <- Map.elems pkg_map2 ]
 1378     getCyclicSCC (CyclicSCC vs) = map unitId vs
 1379     getCyclicSCC (AcyclicSCC _) = []
 1380     (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
 1381     unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
 1382 
 1383     -- Apply ignore flags
 1384     directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3)
 1385     (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3
 1386     unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
 1387 
 1388     -- Knock out units whose dependencies don't agree with ABI
 1389     -- (i.e., got invalidated due to shadowing)
 1390     directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
 1391                                (Map.elems pkg_map4)
 1392     (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4
 1393     unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
 1394 
 1395     unusable = directly_ignored `Map.union` unusable_ignored
 1396                                 `Map.union` unusable_broken
 1397                                 `Map.union` unusable_cyclic
 1398                                 `Map.union` unusable_shadowed
 1399 
 1400 -- -----------------------------------------------------------------------------
 1401 -- When all the command-line options are in, we can process our unit
 1402 -- settings and populate the unit state.
 1403 
 1404 mkUnitState
 1405     :: Logger
 1406     -> UnitConfig
 1407     -> IO (UnitState,[UnitDatabase UnitId])
 1408 mkUnitState logger cfg = do
 1409 {-
 1410    Plan.
 1411 
 1412    There are two main steps for making the package state:
 1413 
 1414     1. We want to build a single, unified package database based
 1415        on all of the input databases, which upholds the invariant that
 1416        there is only one package per any UnitId and there are no
 1417        dangling dependencies.  We'll do this by merging, and
 1418        then successively filtering out bad dependencies.
 1419 
 1420        a) Merge all the databases together.
 1421           If an input database defines unit ID that is already in
 1422           the unified database, that package SHADOWS the existing
 1423           package in the current unified database.  Note that
 1424           order is important: packages defined later in the list of
 1425           command line arguments shadow those defined earlier.
 1426 
 1427        b) Remove all packages with missing dependencies, or
 1428           mutually recursive dependencies.
 1429 
 1430        b) Remove packages selected by -ignore-package from input database
 1431 
 1432        c) Remove all packages which depended on packages that are now
 1433           shadowed by an ABI-incompatible package
 1434 
 1435        d) report (with -v) any packages that were removed by steps 1-3
 1436 
 1437     2. We want to look at the flags controlling package visibility,
 1438        and build a mapping of what module names are in scope and
 1439        where they live.
 1440 
 1441        a) on the final, unified database, we apply -trust/-distrust
 1442           flags directly, modifying the database so that the 'trusted'
 1443           field has the correct value.
 1444 
 1445        b) we use the -package/-hide-package flags to compute a
 1446           visibility map, stating what packages are "exposed" for
 1447           the purposes of computing the module map.
 1448           * if any flag refers to a package which was removed by 1-5, then
 1449             we can give an error message explaining why
 1450           * if -hide-all-packages was not specified, this step also
 1451             hides packages which are superseded by later exposed packages
 1452           * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
 1453             are used
 1454 
 1455        c) based on the visibility map, we pick wired packages and rewrite
 1456           them to have the expected unitId.
 1457 
 1458        d) finally, using the visibility map and the package database,
 1459           we build a mapping saying what every in scope module name points to.
 1460 -}
 1461 
 1462   -- if databases have not been provided, read the database flags
 1463   raw_dbs <- case unitConfigDBCache cfg of
 1464                Nothing  -> readUnitDatabases logger cfg
 1465                Just dbs -> return dbs
 1466 
 1467   -- distrust all units if the flag is set
 1468   let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
 1469       dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
 1470           | otherwise                 = raw_dbs
 1471 
 1472 
 1473   -- This, and the other reverse's that you will see, are due to the fact that
 1474   -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
 1475   -- than they are on the command line.
 1476   let other_flags = reverse (unitConfigFlagsExposed cfg)
 1477   debugTraceMsg logger 2 $
 1478       text "package flags" <+> ppr other_flags
 1479 
 1480   -- Merge databases together, without checking validity
 1481   (pkg_map1, prec_map) <- mergeDatabases logger dbs
 1482 
 1483   -- Now that we've merged everything together, prune out unusable
 1484   -- packages.
 1485   let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
 1486 
 1487   reportCycles   logger sccs
 1488   reportUnusable logger unusable
 1489 
 1490   -- Apply trust flags (these flags apply regardless of whether
 1491   -- or not packages are visible or not)
 1492   pkgs1 <- mayThrowUnitErr
 1493             $ foldM (applyTrustFlag prec_map unusable)
 1494                  (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
 1495   let prelim_pkg_db = mkUnitInfoMap pkgs1
 1496 
 1497   --
 1498   -- Calculate the initial set of units from package databases, prior to any package flags.
 1499   --
 1500   -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
 1501   -- (not units). This is empty if we have -hide-all-packages.
 1502   --
 1503   -- Then we create an initial visibility map with default visibilities for all
 1504   -- exposed, definite units which belong to the latest valid packages.
 1505   --
 1506   let preferLater unit unit' =
 1507         case compareByPreference prec_map unit unit' of
 1508             GT -> unit
 1509             _  -> unit'
 1510       addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
 1511       -- This is the set of maximally preferable packages. In fact, it is a set of
 1512       -- most preferable *units* keyed by package name, which act as stand-ins in
 1513       -- for "a package in a database". We use units here because we don't have
 1514       -- "a package in a database" as a type currently.
 1515       mostPreferablePackageReps = if unitConfigHideAll cfg
 1516                     then emptyUDFM
 1517                     else foldl' addIfMorePreferable emptyUDFM pkgs1
 1518       -- When exposing units, we want to consider all of those in the most preferable
 1519       -- packages. We can implement that by looking for units that are equi-preferable
 1520       -- with the most preferable unit for package. Being equi-preferable means that
 1521       -- they must be in the same database, with the same version, and the same package name.
 1522       --
 1523       -- We must take care to consider all these units and not just the most
 1524       -- preferable one, otherwise we can end up with problems like #16228.
 1525       mostPreferable u =
 1526         case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
 1527           Nothing -> False
 1528           Just u' -> compareByPreference prec_map u u' == EQ
 1529       vis_map1 = foldl' (\vm p ->
 1530                             -- Note: we NEVER expose indefinite packages by
 1531                             -- default, because it's almost assuredly not
 1532                             -- what you want (no mix-in linking has occurred).
 1533                             if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
 1534                                then Map.insert (mkUnit p)
 1535                                                UnitVisibility {
 1536                                                  uv_expose_all = True,
 1537                                                  uv_renamings = [],
 1538                                                  uv_package_name = First (Just (fsPackageName p)),
 1539                                                  uv_requirements = Map.empty,
 1540                                                  uv_explicit = False
 1541                                                }
 1542                                                vm
 1543                                else vm)
 1544                          Map.empty pkgs1
 1545 
 1546   --
 1547   -- Compute a visibility map according to the command-line flags (-package,
 1548   -- -hide-package).  This needs to know about the unusable packages, since if a
 1549   -- user tries to enable an unusable package, we should let them know.
 1550   --
 1551   vis_map2 <- mayThrowUnitErr
 1552                 $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
 1553                         (unitConfigHideAll cfg) pkgs1)
 1554                             vis_map1 other_flags
 1555 
 1556   --
 1557   -- Sort out which packages are wired in. This has to be done last, since
 1558   -- it modifies the unit ids of wired in packages, but when we process
 1559   -- package arguments we need to key against the old versions.
 1560   --
 1561   (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
 1562   let pkg_db = mkUnitInfoMap pkgs2
 1563 
 1564   -- Update the visibility map, so we treat wired packages as visible.
 1565   let vis_map = updateVisibilityMap wired_map vis_map2
 1566 
 1567   let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
 1568   plugin_vis_map <-
 1569     case unitConfigFlagsPlugins cfg of
 1570         -- common case; try to share the old vis_map
 1571         [] | not hide_plugin_pkgs -> return vis_map
 1572            | otherwise -> return Map.empty
 1573         _ -> do let plugin_vis_map1
 1574                         | hide_plugin_pkgs = Map.empty
 1575                         -- Use the vis_map PRIOR to wired in,
 1576                         -- because otherwise applyPackageFlag
 1577                         -- won't work.
 1578                         | otherwise = vis_map2
 1579                 plugin_vis_map2
 1580                     <- mayThrowUnitErr
 1581                         $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
 1582                                 hide_plugin_pkgs pkgs1)
 1583                              plugin_vis_map1
 1584                              (reverse (unitConfigFlagsPlugins cfg))
 1585                 -- Updating based on wired in packages is mostly
 1586                 -- good hygiene, because it won't matter: no wired in
 1587                 -- package has a compiler plugin.
 1588                 -- TODO: If a wired in package had a compiler plugin,
 1589                 -- and you tried to pick different wired in packages
 1590                 -- with the plugin flags and the normal flags... what
 1591                 -- would happen?  I don't know!  But this doesn't seem
 1592                 -- likely to actually happen.
 1593                 return (updateVisibilityMap wired_map plugin_vis_map2)
 1594 
 1595   let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
 1596                               | p <- pkgs2
 1597                               ]
 1598   -- The explicitUnits accurately reflects the set of units we have turned
 1599   -- on; as such, it also is the only way one can come up with requirements.
 1600   -- The requirement context is directly based off of this: we simply
 1601   -- look for nested unit IDs that are directly fed holes: the requirements
 1602   -- of those units are precisely the ones we need to track
 1603   let explicit_pkgs = Map.keys vis_map
 1604       req_ctx = Map.map (Set.toList)
 1605               $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
 1606 
 1607 
 1608   --
 1609   -- Here we build up a set of the packages mentioned in -package
 1610   -- flags on the command line; these are called the "preload"
 1611   -- packages.  we link these packages in eagerly.  The preload set
 1612   -- should contain at least rts & base, which is why we pretend that
 1613   -- the command line contains -package rts & -package base.
 1614   --
 1615   -- NB: preload IS important even for type-checking, because we
 1616   -- need the correct include path to be set.
 1617   --
 1618   let preload1 = Map.keys (Map.filter uv_explicit vis_map)
 1619 
 1620       -- add default preload units if they can be found in the db
 1621       basicLinkedUnits = fmap (RealUnit . Definite)
 1622                          $ filter (flip Map.member pkg_db)
 1623                          $ unitConfigAutoLink cfg
 1624       preload3 = ordNub $ (basicLinkedUnits ++ preload1)
 1625 
 1626   -- Close the preload packages with their dependencies
 1627   dep_preload <- mayThrowUnitErr
 1628                     $ closeUnitDeps pkg_db
 1629                     $ zip (map toUnitId preload3) (repeat Nothing)
 1630 
 1631   let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
 1632       mod_map2 = mkUnusableModuleNameProvidersMap unusable
 1633       mod_map = Map.union mod_map1 mod_map2
 1634 
 1635   -- Force the result to avoid leaking input parameters
 1636   let !state = UnitState
 1637          { preloadUnits                 = dep_preload
 1638          , explicitUnits                = explicit_pkgs
 1639          , unitInfoMap                  = pkg_db
 1640          , preloadClosure               = emptyUniqSet
 1641          , moduleNameProvidersMap       = mod_map
 1642          , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
 1643          , packageNameMap               = pkgname_map
 1644          , wireMap                      = wired_map
 1645          , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
 1646          , requirementContext           = req_ctx
 1647          , allowVirtualUnits            = unitConfigAllowVirtual cfg
 1648          }
 1649   return (state, raw_dbs)
 1650 
 1651 -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
 1652 -- that it was recorded as in the package database.
 1653 unwireUnit :: UnitState -> Unit -> Unit
 1654 unwireUnit state uid@(RealUnit (Definite def_uid)) =
 1655     maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))
 1656 unwireUnit _ uid = uid
 1657 
 1658 -- -----------------------------------------------------------------------------
 1659 -- | Makes the mapping from ModuleName to package info
 1660 
 1661 -- Slight irritation: we proceed by leafing through everything
 1662 -- in the installed package database, which makes handling indefinite
 1663 -- packages a bit bothersome.
 1664 
 1665 mkModuleNameProvidersMap
 1666   :: Logger
 1667   -> UnitConfig
 1668   -> UnitInfoMap
 1669   -> PreloadUnitClosure
 1670   -> VisibilityMap
 1671   -> ModuleNameProvidersMap
 1672 mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
 1673     -- What should we fold on?  Both situations are awkward:
 1674     --
 1675     --    * Folding on the visibility map means that we won't create
 1676     --      entries for packages that aren't mentioned in vis_map
 1677     --      (e.g., hidden packages, causing #14717)
 1678     --
 1679     --    * Folding on pkg_map is awkward because if we have an
 1680     --      Backpack instantiation, we need to possibly add a
 1681     --      package from pkg_map multiple times to the actual
 1682     --      ModuleNameProvidersMap.  Also, we don't really want
 1683     --      definite package instantiations to show up in the
 1684     --      list of possibilities.
 1685     --
 1686     -- So what will we do instead?  We'll extend vis_map with
 1687     -- entries for every definite (for non-Backpack) and
 1688     -- indefinite (for Backpack) package, so that we get the
 1689     -- hidden entries we need.
 1690     Map.foldlWithKey extend_modmap emptyMap vis_map_extended
 1691  where
 1692   vis_map_extended = Map.union vis_map {- preferred -} default_vis
 1693 
 1694   default_vis = Map.fromList
 1695                   [ (mkUnit pkg, mempty)
 1696                   | pkg <- Map.elems pkg_map
 1697                   -- Exclude specific instantiations of an indefinite
 1698                   -- package
 1699                   , unitIsIndefinite pkg || null (unitInstantiations pkg)
 1700                   ]
 1701 
 1702   emptyMap = Map.empty
 1703   setOrigins m os = fmap (const os) m
 1704   extend_modmap modmap uid
 1705     UnitVisibility { uv_expose_all = b, uv_renamings = rns }
 1706     = addListTo modmap theBindings
 1707    where
 1708     pkg = unit_lookup uid
 1709 
 1710     theBindings :: [(ModuleName, Map Module ModuleOrigin)]
 1711     theBindings = newBindings b rns
 1712 
 1713     newBindings :: Bool
 1714                 -> [(ModuleName, ModuleName)]
 1715                 -> [(ModuleName, Map Module ModuleOrigin)]
 1716     newBindings e rns  = es e ++ hiddens ++ map rnBinding rns
 1717 
 1718     rnBinding :: (ModuleName, ModuleName)
 1719               -> (ModuleName, Map Module ModuleOrigin)
 1720     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
 1721      where origEntry = case lookupUFM esmap orig of
 1722             Just r -> r
 1723             Nothing -> throwGhcException (CmdLineError (renderWithContext
 1724                         (log_default_user_context (logFlags logger))
 1725                         (text "package flag: could not find module name" <+>
 1726                             ppr orig <+> text "in package" <+> ppr pk)))
 1727 
 1728     es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
 1729     es e = do
 1730      (m, exposedReexport) <- exposed_mods
 1731      let (pk', m', origin') =
 1732           case exposedReexport of
 1733            Nothing -> (pk, m, fromExposedModules e)
 1734            Just (Module pk' m') ->
 1735               (pk', m', fromReexportedModules e pkg)
 1736      return (m, mkModMap pk' m' origin')
 1737 
 1738     esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
 1739     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
 1740                                  -- be overwritten
 1741 
 1742     hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
 1743 
 1744     pk = mkUnit pkg
 1745     unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid
 1746                         `orElse` pprPanic "unit_lookup" (ppr uid)
 1747 
 1748     exposed_mods = unitExposedModules pkg
 1749     hidden_mods  = unitHiddenModules pkg
 1750 
 1751 -- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
 1752 mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
 1753 mkUnusableModuleNameProvidersMap unusables =
 1754     Map.foldl' extend_modmap Map.empty unusables
 1755  where
 1756     extend_modmap modmap (pkg, reason) = addListTo modmap bindings
 1757       where bindings :: [(ModuleName, Map Module ModuleOrigin)]
 1758             bindings = exposed ++ hidden
 1759 
 1760             origin = ModUnusable reason
 1761             pkg_id = mkUnit pkg
 1762 
 1763             exposed = map get_exposed exposed_mods
 1764             hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
 1765 
 1766             get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
 1767             get_exposed (mod, _)         = (mod, mkModMap pkg_id mod origin)
 1768 
 1769             exposed_mods = unitExposedModules pkg
 1770             hidden_mods  = unitHiddenModules pkg
 1771 
 1772 -- | Add a list of key/value pairs to a nested map.
 1773 --
 1774 -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
 1775 -- when reloading modules in GHCi (see #4029). This ensures that each
 1776 -- value is forced before installing into the map.
 1777 addListTo :: (Monoid a, Ord k1, Ord k2)
 1778           => Map k1 (Map k2 a)
 1779           -> [(k1, Map k2 a)]
 1780           -> Map k1 (Map k2 a)
 1781 addListTo = foldl' merge
 1782   where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
 1783 
 1784 -- | Create a singleton module mapping
 1785 mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
 1786 mkModMap pkg mod = Map.singleton (mkModule pkg mod)
 1787 
 1788 
 1789 -- -----------------------------------------------------------------------------
 1790 -- Package Utils
 1791 
 1792 -- | Takes a 'ModuleName', and if the module is in any package returns
 1793 -- list of modules which take that name.
 1794 lookupModuleInAllUnits :: UnitState
 1795                           -> ModuleName
 1796                           -> [(Module, UnitInfo)]
 1797 lookupModuleInAllUnits pkgs m
 1798   = case lookupModuleWithSuggestions pkgs m NoPkgQual of
 1799       LookupFound a b -> [(a,fst b)]
 1800       LookupMultiple rs -> map f rs
 1801         where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
 1802                                                          (moduleUnit m)))
 1803       _ -> []
 1804 
 1805 -- | The result of performing a lookup
 1806 data LookupResult =
 1807     -- | Found the module uniquely, nothing else to do
 1808     LookupFound Module (UnitInfo, ModuleOrigin)
 1809     -- | Multiple modules with the same name in scope
 1810   | LookupMultiple [(Module, ModuleOrigin)]
 1811     -- | No modules found, but there were some hidden ones with
 1812     -- an exact name match.  First is due to package hidden, second
 1813     -- is due to module being hidden
 1814   | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
 1815     -- | No modules found, but there were some unusable ones with
 1816     -- an exact name match
 1817   | LookupUnusable [(Module, ModuleOrigin)]
 1818     -- | Nothing found, here are some suggested different names
 1819   | LookupNotFound [ModuleSuggestion] -- suggestions
 1820 
 1821 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
 1822                       | SuggestHidden ModuleName Module ModuleOrigin
 1823 
 1824 lookupModuleWithSuggestions :: UnitState
 1825                             -> ModuleName
 1826                             -> PkgQual
 1827                             -> LookupResult
 1828 lookupModuleWithSuggestions pkgs
 1829   = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
 1830 
 1831 -- | The package which the module **appears** to come from, this could be
 1832 -- the one which reexports the module from it's original package. This function
 1833 -- is currently only used for -Wunused-packages
 1834 lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
 1835 lookupModulePackage pkgs mn mfs =
 1836     case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
 1837       LookupFound _ (orig_unit, origin) ->
 1838         case origin of
 1839           ModOrigin {fromOrigUnit, fromExposedReexport} ->
 1840             case fromOrigUnit of
 1841               -- Just True means, the import is available from its original location
 1842               Just True ->
 1843                 pure [orig_unit]
 1844               -- Otherwise, it must be available from a reexport
 1845               _ -> pure fromExposedReexport
 1846 
 1847           _ -> Nothing
 1848 
 1849       _ -> Nothing
 1850 
 1851 lookupPluginModuleWithSuggestions :: UnitState
 1852                                   -> ModuleName
 1853                                   -> PkgQual
 1854                                   -> LookupResult
 1855 lookupPluginModuleWithSuggestions pkgs
 1856   = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
 1857 
 1858 lookupModuleWithSuggestions' :: UnitState
 1859                             -> ModuleNameProvidersMap
 1860                             -> ModuleName
 1861                             -> PkgQual
 1862                             -> LookupResult
 1863 lookupModuleWithSuggestions' pkgs mod_map m mb_pn
 1864   = case Map.lookup m mod_map of
 1865         Nothing -> LookupNotFound suggestions
 1866         Just xs ->
 1867           case foldl' classify ([],[],[], []) (Map.toList xs) of
 1868             ([], [], [], []) -> LookupNotFound suggestions
 1869             (_, _, _, [(m, o)])             -> LookupFound m (mod_unit m, o)
 1870             (_, _, _, exposed@(_:_))        -> LookupMultiple exposed
 1871             ([], [], unusable@(_:_), [])    -> LookupUnusable unusable
 1872             (hidden_pkg, hidden_mod, _, []) ->
 1873               LookupHidden hidden_pkg hidden_mod
 1874   where
 1875     classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) =
 1876       let origin = filterOrigin mb_pn (mod_unit m) origin0
 1877           x = (m, origin)
 1878       in case origin of
 1879           ModHidden
 1880             -> (hidden_pkg, x:hidden_mod, unusable, exposed)
 1881           ModUnusable _
 1882             -> (hidden_pkg, hidden_mod, x:unusable, exposed)
 1883           _ | originEmpty origin
 1884             -> (hidden_pkg,   hidden_mod, unusable, exposed)
 1885             | originVisible origin
 1886             -> (hidden_pkg, hidden_mod, unusable, x:exposed)
 1887             | otherwise
 1888             -> (x:hidden_pkg, hidden_mod, unusable, exposed)
 1889 
 1890     unit_lookup p = lookupUnit pkgs p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
 1891     mod_unit = unit_lookup . moduleUnit
 1892 
 1893     -- Filters out origins which are not associated with the given package
 1894     -- qualifier.  No-op if there is no package qualifier.  Test if this
 1895     -- excluded all origins with 'originEmpty'.
 1896     filterOrigin :: PkgQual
 1897                  -> UnitInfo
 1898                  -> ModuleOrigin
 1899                  -> ModuleOrigin
 1900     filterOrigin NoPkgQual _ o = o
 1901     filterOrigin (ThisPkg _) _ o = o
 1902     filterOrigin (OtherPkg u) pkg o =
 1903       let match_pkg p = u == unitId p
 1904       in case o of
 1905           ModHidden
 1906             | match_pkg pkg -> ModHidden
 1907             | otherwise     -> mempty
 1908           ModUnusable _
 1909             | match_pkg pkg -> o
 1910             | otherwise     -> mempty
 1911           ModOrigin { fromOrigUnit = e, fromExposedReexport = res,
 1912                       fromHiddenReexport = rhs }
 1913             -> ModOrigin
 1914                 { fromOrigUnit        = if match_pkg pkg then e else Nothing
 1915                 , fromExposedReexport = filter match_pkg res
 1916                 , fromHiddenReexport  = filter match_pkg rhs
 1917                 , fromPackageFlag     = False -- always excluded
 1918                 }
 1919 
 1920     suggestions = fuzzyLookup (moduleNameString m) all_mods
 1921 
 1922     all_mods :: [(String, ModuleSuggestion)]     -- All modules
 1923     all_mods = sortBy (comparing fst) $
 1924         [ (moduleNameString m, suggestion)
 1925         | (m, e) <- Map.toList (moduleNameProvidersMap pkgs)
 1926         , suggestion <- map (getSuggestion m) (Map.toList e)
 1927         ]
 1928     getSuggestion name (mod, origin) =
 1929         (if originVisible origin then SuggestVisible else SuggestHidden)
 1930             name mod origin
 1931 
 1932 listVisibleModuleNames :: UnitState -> [ModuleName]
 1933 listVisibleModuleNames state =
 1934     map fst (filter visible (Map.toList (moduleNameProvidersMap state)))
 1935   where visible (_, ms) = any originVisible (Map.elems ms)
 1936 
 1937 -- | Takes a list of UnitIds (and their "parent" dependency, used for error
 1938 -- messages), and returns the list with dependencies included, in reverse
 1939 -- dependency order (a units appears before those it depends on).
 1940 closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
 1941 closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
 1942 
 1943 -- | Similar to closeUnitDeps but takes a list of already loaded units as an
 1944 -- additional argument.
 1945 closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
 1946 closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
 1947 
 1948 -- | Add a UnitId and those it depends on (recursively) to the given list of
 1949 -- UnitIds if they are not already in it. Return a list in reverse dependency
 1950 -- order (a unit appears before those it depends on).
 1951 --
 1952 -- The UnitId is looked up in the given UnitInfoMap (to find its dependencies).
 1953 -- It it's not found, the optional parent unit is used to return a more precise
 1954 -- error message ("dependency of <PARENT>").
 1955 add_unit :: UnitInfoMap
 1956             -> [UnitId]
 1957             -> (UnitId,Maybe UnitId)
 1958             -> MaybeErr UnitErr [UnitId]
 1959 add_unit pkg_map ps (p, mb_parent)
 1960   | p `elem` ps = return ps     -- Check if we've already added this unit
 1961   | otherwise   = case lookupUnitId' pkg_map p of
 1962       Nothing   -> Failed (CloseUnitErr p mb_parent)
 1963       Just info -> do
 1964          -- Add the unit's dependents also
 1965          ps' <- foldM add_unit_key ps (unitDepends info)
 1966          return (p : ps')
 1967         where
 1968           add_unit_key ps key
 1969             = add_unit pkg_map ps (key, Just p)
 1970 
 1971 data UnitErr
 1972   = CloseUnitErr !UnitId !(Maybe UnitId)
 1973   | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
 1974   | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]
 1975 
 1976 mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
 1977 mayThrowUnitErr = \case
 1978     Failed e    -> throwGhcExceptionIO
 1979                     $ CmdLineError
 1980                     $ renderWithContext defaultSDocContext
 1981                     $ withPprStyle defaultUserStyle
 1982                     $ ppr e
 1983     Succeeded a -> return a
 1984 
 1985 instance Outputable UnitErr where
 1986     ppr = \case
 1987         CloseUnitErr p mb_parent
 1988             -> (ftext (fsLit "unknown unit:") <+> ppr p)
 1989                <> case mb_parent of
 1990                      Nothing     -> Outputable.empty
 1991                      Just parent -> space <> parens (text "dependency of"
 1992                                               <+> ftext (unitIdFS parent))
 1993         PackageFlagErr flag reasons
 1994             -> flag_err (pprFlag flag) reasons
 1995 
 1996         TrustFlagErr flag reasons
 1997             -> flag_err (pprTrustFlag flag) reasons
 1998       where
 1999         flag_err flag_doc reasons =
 2000             text "cannot satisfy "
 2001             <> flag_doc
 2002             <> (if null reasons then Outputable.empty else text ": ")
 2003             $$ nest 4 (vcat (map ppr_reason reasons) $$
 2004                       text "(use -v for more information)")
 2005 
 2006         ppr_reason (p, reason) =
 2007             pprReason (ppr (unitId p) <+> text "is") reason
 2008 
 2009 -- | Return this list of requirement interfaces that need to be merged
 2010 -- to form @mod_name@, or @[]@ if this is not a requirement.
 2011 requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
 2012 requirementMerges pkgstate mod_name =
 2013     fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
 2014 
 2015 -- -----------------------------------------------------------------------------
 2016 
 2017 -- | Pretty-print a UnitId for the user.
 2018 --
 2019 -- Cabal packages may contain several components (programs, libraries, etc.).
 2020 -- As far as GHC is concerned, installed package components ("units") are
 2021 -- identified by an opaque UnitId string provided by Cabal. As the string
 2022 -- contains a hash, we don't want to display it to users so GHC queries the
 2023 -- database to retrieve some infos about the original source package (name,
 2024 -- version, component name).
 2025 --
 2026 -- Instead we want to display: packagename-version[:componentname]
 2027 --
 2028 -- Component name is only displayed if it isn't the default library
 2029 --
 2030 -- To do this we need to query a unit database.
 2031 pprUnitIdForUser :: UnitState -> UnitId -> SDoc
 2032 pprUnitIdForUser state uid@(UnitId fs) =
 2033    case lookupUnitPprInfo state uid of
 2034       Nothing -> ftext fs -- we didn't find the unit at all
 2035       Just i  -> ppr i
 2036 
 2037 pprUnitInfoForUser :: UnitInfo -> SDoc
 2038 pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info)
 2039 
 2040 lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
 2041 lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid)
 2042 
 2043 -- -----------------------------------------------------------------------------
 2044 -- Displaying packages
 2045 
 2046 -- | Show (very verbose) package info
 2047 pprUnits :: UnitState -> SDoc
 2048 pprUnits = pprUnitsWith pprUnitInfo
 2049 
 2050 pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
 2051 pprUnitsWith pprIPI pkgstate =
 2052     vcat (intersperse (text "---") (map pprIPI (listUnitInfo pkgstate)))
 2053 
 2054 -- | Show simplified unit info.
 2055 --
 2056 -- The idea is to only print package id, and any information that might
 2057 -- be different from the package databases (exposure, trust)
 2058 pprUnitsSimple :: UnitState -> SDoc
 2059 pprUnitsSimple = pprUnitsWith pprIPI
 2060     where pprIPI ipi = let i = unitIdFS (unitId ipi)
 2061                            e = if unitIsExposed ipi then text "E" else text " "
 2062                            t = if unitIsTrusted ipi then text "T" else text " "
 2063                        in e <> t <> text "  " <> ftext i
 2064 
 2065 -- | Show the mapping of modules to where they come from.
 2066 pprModuleMap :: ModuleNameProvidersMap -> SDoc
 2067 pprModuleMap mod_map =
 2068   vcat (map pprLine (Map.toList mod_map))
 2069     where
 2070       pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
 2071       pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
 2072       pprEntry m (m',o)
 2073         | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)
 2074         | otherwise = ppr m' <+> parens (ppr o)
 2075 
 2076 fsPackageName :: UnitInfo -> FastString
 2077 fsPackageName info = fs
 2078    where
 2079       PackageName fs = unitPackageName info
 2080 
 2081 
 2082 -- | Given a fully instantiated 'InstantiatedUnit', improve it into a
 2083 -- 'RealUnit' if we can find it in the package database.
 2084 improveUnit :: UnitState -> Unit -> Unit
 2085 improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u
 2086 
 2087 -- | Given a fully instantiated 'InstantiatedUnit', improve it into a
 2088 -- 'RealUnit' if we can find it in the package database.
 2089 improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
 2090 improveUnit' _       _       uid@(RealUnit _) = uid -- short circuit
 2091 improveUnit' pkg_map closure uid =
 2092     -- Do NOT lookup indefinite ones, they won't be useful!
 2093     case lookupUnit' False pkg_map closure uid of
 2094         Nothing  -> uid
 2095         Just pkg ->
 2096             -- Do NOT improve if the indefinite unit id is not
 2097             -- part of the closure unique set.  See
 2098             -- Note [VirtUnit to RealUnit improvement]
 2099             if unitId pkg `elementOfUniqSet` closure
 2100                 then mkUnit pkg
 2101                 else uid
 2102 
 2103 -- | Check the database to see if we already have an installed unit that
 2104 -- corresponds to the given 'InstantiatedUnit'.
 2105 --
 2106 -- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or
 2107 -- references a matching installed unit.
 2108 --
 2109 -- See Note [VirtUnit to RealUnit improvement]
 2110 instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit
 2111 instUnitToUnit state iuid =
 2112     -- NB: suppose that we want to compare the instantiated
 2113     -- unit p[H=impl:H] against p+abcd (where p+abcd
 2114     -- happens to be the existing, installed version of
 2115     -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]
 2116     -- VirtUnit, they won't compare equal; only
 2117     -- after improvement will the equality hold.
 2118     improveUnit state $ VirtUnit iuid
 2119 
 2120 
 2121 -- | Substitution on module variables, mapping module names to module
 2122 -- identifiers.
 2123 type ShHoleSubst = ModuleNameEnv Module
 2124 
 2125 -- | Substitutes holes in a 'Module'.  NOT suitable for being called
 2126 -- directly on a 'nameModule', see Note [Representation of module/name variable].
 2127 -- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
 2128 -- similarly, @\<A>@ maps to @q():A@.
 2129 renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module
 2130 renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state)
 2131 
 2132 -- | Substitutes holes in a 'Unit', suitable for renaming when
 2133 -- an include occurs; see Note [Representation of module/name variable].
 2134 --
 2135 -- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@.
 2136 renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
 2137 renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state)
 2138 
 2139 -- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap'
 2140 -- so it can be used by "GHC.Unit.State".
 2141 renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module
 2142 renameHoleModule' pkg_map closure env m
 2143   | not (isHoleModule m) =
 2144         let uid = renameHoleUnit' pkg_map closure env (moduleUnit m)
 2145         in mkModule uid (moduleName m)
 2146   | Just m' <- lookupUFM env (moduleName m) = m'
 2147   -- NB m = <Blah>, that's what's in scope.
 2148   | otherwise = m
 2149 
 2150 -- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap'
 2151 -- so it can be used by "GHC.Unit.State".
 2152 renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit
 2153 renameHoleUnit' pkg_map closure env uid =
 2154     case uid of
 2155       (VirtUnit
 2156         InstantiatedUnit{ instUnitInstanceOf = cid
 2157                         , instUnitInsts      = insts
 2158                         , instUnitHoles      = fh })
 2159           -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
 2160                 then uid
 2161                 -- Functorially apply the substitution to the instantiation,
 2162                 -- then check the 'ClosureUnitInfoMap' to see if there is
 2163                 -- a compiled version of this 'InstantiatedUnit' we can improve to.
 2164                 -- See Note [VirtUnit to RealUnit improvement]
 2165                 else improveUnit' pkg_map closure $
 2166                         mkVirtUnit cid
 2167                             (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts)
 2168       _ -> uid
 2169 
 2170 -- | Injects an 'InstantiatedModule' to 'Module' (see also
 2171 -- 'instUnitToUnit'.
 2172 instModuleToModule :: UnitState -> InstantiatedModule -> Module
 2173 instModuleToModule pkgstate (Module iuid mod_name) =
 2174     mkModule (instUnitToUnit pkgstate iuid) mod_name
 2175 
 2176 -- | Print unit-ids with UnitInfo found in the given UnitState
 2177 pprWithUnitState :: UnitState -> SDoc -> SDoc
 2178 pprWithUnitState state = updSDocContext (\ctx -> ctx
 2179    { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
 2180    })
 2181 
 2182 -- | Add package dependencies on the wired-in packages we use
 2183 implicitPackageDeps :: DynFlags -> [UnitId]
 2184 implicitPackageDeps dflags
 2185    = [thUnitId | xopt TemplateHaskellQuotes dflags]
 2186    -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but
 2187    -- it is possible to not depend on base (for example, see `ghc-prim`)
 2188