State.hs 95.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2
-- (c) The University of Glasgow, 2006

Edward Z. Yang's avatar
Edward Z. Yang committed
3
{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
4

Sylvain Henry's avatar
Sylvain Henry committed
5
-- | Unit manipulation
6
module GHC.Unit.State (
7
        module GHC.Unit.Info,
8 9

        -- * Reading the package config, and processing cmdline args
Sylvain Henry's avatar
Sylvain Henry committed
10
        UnitState(..),
Sylvain Henry's avatar
Sylvain Henry committed
11
        UnitDatabase (..),
Sylvain Henry's avatar
Sylvain Henry committed
12
        emptyUnitState,
Sylvain Henry's avatar
Sylvain Henry committed
13 14 15
        initUnits,
        readUnitDatabases,
        readUnitDatabase,
Sylvain Henry's avatar
Sylvain Henry committed
16
        getUnitDbRefs,
Sylvain Henry's avatar
Sylvain Henry committed
17
        resolveUnitDatabase,
18
        listUnitInfo,
19 20

        -- * Querying the package config
21 22
        lookupUnit,
        lookupUnit',
Sylvain Henry's avatar
Sylvain Henry committed
23 24 25 26 27
        unsafeLookupUnit,
        lookupUnitId,
        lookupUnitId',
        unsafeLookupUnitId,

Edward Z. Yang's avatar
Edward Z. Yang committed
28
        lookupPackageName,
29
        improveUnit,
30
        searchPackageId,
31
        displayUnitId,
32
        listVisibleModuleNames,
Sylvain Henry's avatar
Sylvain Henry committed
33
        lookupModuleInAllUnits,
34
        lookupModuleWithSuggestions,
35
        lookupPluginModuleWithSuggestions,
36
        LookupResult(..),
37 38
        ModuleSuggestion(..),
        ModuleOrigin(..),
Sylvain Henry's avatar
Sylvain Henry committed
39
        UnusableUnitReason(..),
40
        pprReason,
41 42

        -- * Inspecting the set of packages in scope
Sylvain Henry's avatar
Sylvain Henry committed
43 44 45 46 47 48 49
        getUnitIncludePath,
        getUnitLibraryPath,
        getUnitLinkOpts,
        getUnitExtraCcOpts,
        getUnitFrameworkPath,
        getUnitFrameworks,
        getPreloadUnitsAnd,
50

Moritz Angermann's avatar
Moritz Angermann committed
51
        collectArchives,
52
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
53
        packageHsLibs, getLibs,
54

Sylvain Henry's avatar
Sylvain Henry committed
55 56 57 58 59 60 61 62 63
        -- * Module hole substitution
        ShHoleSubst,
        renameHoleUnit,
        renameHoleModule,
        renameHoleUnit',
        renameHoleModule',
        instUnitToUnit,
        instModuleToModule,

64
        -- * Utils
65 66 67
        mkIndefUnitId,
        updateIndefUnitId,
        unwireUnit,
68
        pprFlag,
Sylvain Henry's avatar
Sylvain Henry committed
69 70
        pprUnits,
        pprUnitsSimple,
71
        pprModuleMap,
Sylvain Henry's avatar
Sylvain Henry committed
72 73
        homeUnitIsIndefinite,
        homeUnitIsDefinite,
74
    )
75 76 77
where

#include "HsVersions.h"
78

79
import GHC.Prelude
80

81
import GHC.Platform
82
import GHC.Unit.Database
83
import GHC.Unit.Info
84 85
import GHC.Unit.Types
import GHC.Unit.Module
Sylvain Henry's avatar
Sylvain Henry committed
86
import GHC.Driver.Session
Sylvain Henry's avatar
Sylvain Henry committed
87
import GHC.Driver.Ways
Sylvain Henry's avatar
Sylvain Henry committed
88 89 90
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
Sylvain Henry's avatar
Sylvain Henry committed
91
import GHC.Types.Unique.DSet
92 93 94 95
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Data.Maybe
96

97
import System.Environment ( getEnv )
98 99
import GHC.Data.FastString
import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,
Sylvain Henry's avatar
Sylvain Henry committed
100
                          withTiming, DumpFormat (..) )
101
import GHC.Utils.Exception
102

Simon Marlow's avatar
Simon Marlow committed
103
import System.Directory
104
import System.FilePath as FilePath
Simon Marlow's avatar
Simon Marlow committed
105
import Control.Monad
106
import Data.Graph (stronglyConnComp, SCC(..))
107
import Data.Char ( toUpper )
108
import Data.List as List
109
import Data.Map (Map)
110
import Data.Set (Set)
Edward Z. Yang's avatar
Edward Z. Yang committed
111
import Data.Monoid (First(..))
112
import qualified Data.Semigroup as Semigroup
113
import qualified Data.Map as Map
114
import qualified Data.Map.Strict as MapStrict
115
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
116

117
-- ---------------------------------------------------------------------------
Sylvain Henry's avatar
Sylvain Henry committed
118
-- The Unit state
119

Sylvain Henry's avatar
Sylvain Henry committed
120 121
-- | Unit state is all stored in 'DynFlags', including the details of
-- all units, which units are exposed, and which modules they
122 123
-- provide.
--
Sylvain Henry's avatar
Sylvain Henry committed
124 125
-- The unit state is computed by 'initUnits', and kept in DynFlags.
-- It is influenced by various command-line flags:
126
--
127 128 129
--   * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
--     If @-hide-all-packages@ was not specified, these commands also cause
--      all other packages with the same name to become hidden.
130
--
131
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
132
--
133 134
--   * (there are a few more flags, check below for their semantics)
--
Sylvain Henry's avatar
Sylvain Henry committed
135
-- The unit state has the following properties.
136
--
Sylvain Henry's avatar
Sylvain Henry committed
137 138
--   * Let @exposedUnits@ be the set of packages thus exposed.
--     Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of
139 140
--     their dependencies.
--
Gabor Greif's avatar
Gabor Greif committed
141
--   * When searching for a module from a preload import declaration,
Sylvain Henry's avatar
Sylvain Henry committed
142
--     only the exposed modules in @exposedUnits@ are valid.
143 144
--
--   * When searching for a module from an implicit import, all modules
Sylvain Henry's avatar
Sylvain Henry committed
145
--     from @depExposedUnits@ are valid.
146
--
147
--   * When linking in a compilation manager mode, we link in packages the
148 149
--     program depends on (the compiler knows this list by the
--     time it gets to the link step).  Also, we link in all packages
150
--     which were mentioned with preload @-package@ flags on the command-line,
Ian Lynagh's avatar
Ian Lynagh committed
151
--     or are a transitive dependency of same, or are \"base\"\/\"rts\".
152
--     The reason for this is that we might need packages which don't
153 154 155 156 157
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

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

165
-- | Given a module name, there may be multiple ways it came into scope,
166 167 168
-- possibly simultaneously.  This data type tracks all the possible ways
-- it could have come into scope.  Warning: don't use the record functions,
-- they're partial!
169
data ModuleOrigin =
170 171 172 173
    -- | Module is hidden, and thus never will be available for import.
    -- (But maybe the user didn't realize), so we'll still keep track
    -- of these modules.)
    ModHidden
174
    -- | Module is unavailable because the package is unusable.
Sylvain Henry's avatar
Sylvain Henry committed
175
  | ModUnusable UnusableUnitReason
176 177 178 179 180 181
    -- | Module is public, and could have come from some places.
  | ModOrigin {
        -- | @Just False@ means that this module is in
        -- someone's @exported-modules@ list, but that package is hidden;
        -- @Just True@ means that it is available; @Nothing@ means neither
        -- applies.
Sylvain Henry's avatar
Sylvain Henry committed
182
        fromOrigUnit :: Maybe Bool
183 184
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
185
      , fromExposedReexport :: [UnitInfo]
186
        -- | Is the module available from a reexport of a hidden package?
187
      , fromHiddenReexport :: [UnitInfo]
188 189 190 191 192 193
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
194
    ppr ModHidden = text "hidden module"
195
    ppr (ModUnusable _) = text "unusable module"
196 197 198 199 200 201 202 203
    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
        (case e of
            Nothing -> []
            Just False -> [text "hidden package"]
            Just True -> [text "exposed package"]) ++
        (if null res
            then []
            else [text "reexport by" <+>
204
                    sep (map (ppr . mkUnit) res)]) ++
205 206 207
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
208
                    sep (map (ppr . mkUnit) res)]) ++
209 210 211
        (if f then [text "package flag"] else [])
        ))

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

217
-- | Smart constructor for a module which is in @reexported-modules@.  Takes
218
-- as an argument whether or not the reexporting package is exposed, and
219 220
-- also its 'UnitInfo'.
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
221 222
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
223 224 225 226 227

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

228 229 230 231 232 233 234 235 236 237
instance Semigroup ModuleOrigin where
    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    _x <> _y = panic "ModOrigin: hidden module redefined"

238 239
instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
240
    mappend = (Semigroup.<>)
241 242 243

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

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

255 256
type PreloadUnitClosure = UniqSet UnitId

257 258
-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
type VisibilityMap = Map Unit UnitVisibility
Edward Z. Yang's avatar
Edward Z. Yang committed
259 260

-- | 'UnitVisibility' records the various aspects of visibility of a particular
261
-- 'Unit'.
Edward Z. Yang's avatar
Edward Z. Yang committed
262 263 264 265 266 267 268
data UnitVisibility = UnitVisibility
    { uv_expose_all :: Bool
      --  ^ Should all modules in exposed-modules should be dumped into scope?
    , uv_renamings :: [(ModuleName, ModuleName)]
      -- ^ Any custom renamings that should bring extra 'ModuleName's into
      -- scope.
    , uv_package_name :: First FastString
269
      -- ^ The package name associated with the 'Unit'.  This is used
Edward Z. Yang's avatar
Edward Z. Yang committed
270 271
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
272
    , uv_requirements :: Map ModuleName (Set InstantiatedModule)
Edward Z. Yang's avatar
Edward Z. Yang committed
273 274 275 276 277 278 279
      -- ^ The signatures which are contributed to the requirements context
      -- from this unit ID.
    , uv_explicit :: Bool
      -- ^ Whether or not this unit was explicitly brought into scope,
      -- as opposed to implicitly via the 'exposed' fields in the
      -- package database (when @-hide-all-packages@ is not passed.)
    }
280

Edward Z. Yang's avatar
Edward Z. Yang committed
281 282 283 284 285 286 287 288
instance Outputable UnitVisibility where
    ppr (UnitVisibility {
        uv_expose_all = b,
        uv_renamings = rns,
        uv_package_name = First mb_pn,
        uv_requirements = reqs,
        uv_explicit = explicit
    }) = ppr (b, rns, mb_pn, reqs, explicit)
289 290 291 292 293 294 295 296 297 298 299

instance Semigroup UnitVisibility where
    uv1 <> uv2
        = UnitVisibility
          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
          }

Edward Z. Yang's avatar
Edward Z. Yang committed
300 301 302 303 304 305 306 307
instance Monoid UnitVisibility where
    mempty = UnitVisibility
             { uv_expose_all = False
             , uv_renamings = []
             , uv_package_name = First Nothing
             , uv_requirements = Map.empty
             , uv_explicit = False
             }
308
    mappend = (Semigroup.<>)
309

310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375

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

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

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

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

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

initUnitConfig :: DynFlags -> IO UnitConfig
initUnitConfig dflags = do

   let autoLink
         | not (gopt Opt_AutoLinkPackages dflags) = []
         -- By default we add base & rts to the preload units (when they are
         -- found in the unit database) except when we are building them
         | otherwise = filter (/= homeUnitId dflags) [baseUnitId, rtsUnitId]

   pure $ UnitConfig
      { unitConfigPlatformArchOs = platformMini (targetPlatform dflags)
      , unitConfigProgramName    = programName dflags
      , unitConfigWays           = ways dflags

      , unitConfigGlobalDB       = globalPackageDatabasePath dflags
      , unitConfigGHCDir         = topDir dflags
      , unitConfigDBName         = "package.conf.d"

      , unitConfigAutoLink       = autoLink
      , unitConfigDistrustAll    = gopt Opt_DistrustAllPackages dflags
      , unitConfigHideAll        = gopt Opt_HideAllPackages dflags
      , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags

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

      , unitConfigFlagsDB      = packageDBFlags dflags
      , unitConfigFlagsExposed = packageFlags dflags
      , unitConfigFlagsIgnored = ignorePackageFlags dflags
      , unitConfigFlagsTrusted = trustFlags dflags
      , unitConfigFlagsPlugins = pluginPackageFlags dflags
      }

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

Sylvain Henry's avatar
Sylvain Henry committed
384
data UnitState = UnitState {
385
  -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
Sylvain Henry's avatar
Sylvain Henry committed
386
  -- so that only valid units are here.  'UnitInfo' reflects
387
  -- what was stored *on disk*, except for the 'trusted' flag, which
Sylvain Henry's avatar
Sylvain Henry committed
388
  -- is adjusted at runtime.  (In particular, some units in this map
389
  -- may have the 'exposed' flag be 'False'.)
Sylvain Henry's avatar
Sylvain Henry committed
390 391 392 393 394 395 396 397
  unitInfoMap :: UnitInfoMap,

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

399
  -- | A mapping of 'PackageName' to 'IndefUnitId'.  This is used when
Edward Z. Yang's avatar
Edward Z. Yang committed
400
  -- users refer to packages in Backpack includes.
401
  packageNameMap            :: Map PackageName IndefUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
402

403 404 405 406
  -- | A mapping from database unit keys to wired in unit ids.
  wireMap :: Map UnitId UnitId,

  -- | A mapping from wired in unit ids to unit keys from the database.
Sylvain Henry's avatar
Sylvain Henry committed
407
  unwireMap :: Map UnitId UnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
408

409 410 411
  -- | The packages we're going to link in eagerly.  This list
  -- should be in reverse dependency order; that is, a package
  -- is always mentioned before the packages it depends on.
Sylvain Henry's avatar
Sylvain Henry committed
412
  preloadUnits      :: [UnitId],
413

414 415
  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
Sylvain Henry's avatar
Sylvain Henry committed
416
  explicitUnits      :: [Unit],
417

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

423 424
  -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
  pluginModuleNameProvidersMap    :: !ModuleNameProvidersMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
425 426 427 428 429 430 431 432

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

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

Sylvain Henry's avatar
Sylvain Henry committed
442 443
emptyUnitState :: UnitState
emptyUnitState = UnitState {
Sylvain Henry's avatar
Sylvain Henry committed
444 445
    unitInfoMap = Map.empty,
    preloadClosure = emptyUniqSet,
Edward Z. Yang's avatar
Edward Z. Yang committed
446
    packageNameMap = Map.empty,
447
    wireMap   = Map.empty,
Edward Z. Yang's avatar
Edward Z. Yang committed
448
    unwireMap = Map.empty,
Sylvain Henry's avatar
Sylvain Henry committed
449 450
    preloadUnits = [],
    explicitUnits = [],
451 452
    moduleNameProvidersMap = Map.empty,
    pluginModuleNameProvidersMap = Map.empty,
453 454
    requirementContext = Map.empty,
    allowVirtualUnits = False
455 456
    }

Sylvain Henry's avatar
Sylvain Henry committed
457 458 459 460
-- | Unit database
data UnitDatabase unit = UnitDatabase
   { unitDatabasePath  :: FilePath
   , unitDatabaseUnits :: [GenUnitInfo unit]
461 462
   }

Sylvain Henry's avatar
Sylvain Henry committed
463
type UnitInfoMap = Map UnitId UnitInfo
464

Sylvain Henry's avatar
Sylvain Henry committed
465
-- | Find the unit we know about with the given unit, if any
Sylvain Henry's avatar
Sylvain Henry committed
466
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
467 468
lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs)

Sylvain Henry's avatar
Sylvain Henry committed
469
-- | A more specialized interface, which doesn't require a 'UnitState' (so it
Sylvain Henry's avatar
Sylvain Henry committed
470 471 472 473 474 475 476 477
-- can be used while we're initializing 'DynFlags')
--
-- Parameters:
--    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
--    * a 'UnitInfoMap'
--    * a 'PreloadUnitClosure'
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of
478
   HoleUnit   -> error "Hole unit"
479 480 481 482 483
   RealUnit i -> Map.lookup (unDefinite i) pkg_map
   VirtUnit i
      | allowOnTheFlyInst
      -> -- lookup UnitInfo of the indefinite unit to be instantiated and
         -- instantiate it on-the-fly
Sylvain Henry's avatar
Sylvain Henry committed
484
         fmap (renameUnitInfo pkg_map closure (instUnitInsts i))
485 486 487 488 489 490 491 492
           (Map.lookup (indefUnit (instUnitInstanceOf i)) pkg_map)

      | otherwise
      -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
         -- units. Even if they are real, installed units, they can't use the
         -- `RealUnit` constructor (it is reserved for definite units) so we use
         -- the `VirtUnit` constructor.
         Map.lookup (virtualUnitId i) pkg_map
Edward Z. Yang's avatar
Edward Z. Yang committed
493

Sylvain Henry's avatar
Sylvain Henry committed
494
-- | Find the unit we know about with the given unit id, if any
Sylvain Henry's avatar
Sylvain Henry committed
495
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
496 497 498
lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid

-- | Find the unit we know about with the given unit id, if any
Sylvain Henry's avatar
Sylvain Henry committed
499 500
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' db uid = Map.lookup uid db
Sylvain Henry's avatar
Sylvain Henry committed
501 502 503


-- | Looks up the given unit in the package state, panicing if it is not found
Sylvain Henry's avatar
Sylvain Henry committed
504
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
505 506 507 508 509
unsafeLookupUnit state u = case lookupUnit state u of
   Just info -> info
   Nothing   -> pprPanic "unsafeLookupUnit" (ppr u)

-- | Looks up the given unit id in the package state, panicing if it is not found
Sylvain Henry's avatar
Sylvain Henry committed
510
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
511 512 513 514 515
unsafeLookupUnitId state uid = case lookupUnitId state uid of
   Just info -> info
   Nothing   -> pprPanic "unsafeLookupUnitId" (ppr uid)


Edward Z. Yang's avatar
Edward Z. Yang committed
516 517
-- | Find the package we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
Sylvain Henry's avatar
Sylvain Henry committed
518
lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId
Sylvain Henry's avatar
Sylvain Henry committed
519
lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
520 521

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
Sylvain Henry's avatar
Sylvain Henry committed
522
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
523
searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
524
                               (listUnitInfo pkgstate)
525

526 527 528 529 530 531 532 533 534
-- | Create a Map UnitId UnitInfo
--
-- For each instantiated unit, we add two map keys:
--    * the real unit id
--    * the virtual unit id made from its instantiation
--
-- We do the same thing for fully indefinite units (which are "instantiated"
-- with module holes).
--
Sylvain Henry's avatar
Sylvain Henry committed
535 536
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap infos = foldl' add Map.empty infos
Sylvain Henry's avatar
Sylvain Henry committed
537
  where
538
   mkVirt      p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))
539 540
   add pkg_map p
      | not (null (unitInstantiations p))
541 542 543
      = Map.insert (mkVirt p) p
         $ Map.insert (unitId p) p
         $ pkg_map
544
      | otherwise
545
      = Map.insert (unitId p) p pkg_map
546

547
-- | Get a list of entries from the package database.  NB: be careful with
548 549 550
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
Sylvain Henry's avatar
Sylvain Henry committed
551
listUnitInfo :: UnitState -> [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
552
listUnitInfo state = Map.elems (unitInfoMap state)
553

554
-- ----------------------------------------------------------------------------
555
-- Loading the package db files and building up the package state
556

557 558
-- | Read the package database files, and sets up various internal tables of
-- package information, according to the package-related flags on the
559
-- command-line (@-package@, @-hide-package@ etc.)
560 561 562
--
-- Returns a list of packages to link in if we're doing dynamic linking.
-- This list contains the packages that the user explicitly mentioned with
563
-- @-package@ flags.
564
--
Sylvain Henry's avatar
Sylvain Henry committed
565
-- 'initUnits' can be called again subsequently after updating the
566
-- 'packageFlags' field of the 'DynFlags', and it will update the
Sylvain Henry's avatar
Sylvain Henry committed
567
-- 'unitState' in 'DynFlags' and return a list of packages to
568
-- link in.
Sylvain Henry's avatar
Sylvain Henry committed
569
initUnits :: DynFlags -> IO (DynFlags, [UnitId])
570
initUnits dflags = do
571

572
  let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
573
  (state,dbs) <- withTiming dflags
574
                                (text "initializing package database")
575 576 577 578 579 580 581
                                forceUnitInfoMap $ do

    cfg <- initUnitConfig dflags

    -- init SDocContext used to render exception messages
    let ctx = initSDocContext dflags defaultUserStyle
    let printer = debugTraceMsg dflags
582

583
    -- read the databases if they have not been already read
584
    dbs <- case unitDatabases dflags of
585
          Nothing  -> readUnitDatabases printer cfg
586
          Just dbs -> return dbs
587

588
    -- create the UnitState
589
    state <- mkUnitState ctx (printer 2) cfg dbs
590

591
    return (state, dbs)
592 593 594 595 596

  dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map"
    FormatText
    (pprModuleMap (moduleNameProvidersMap state))

597 598 599 600 601
  let dflags'  = dflags
                  { unitDatabases = Just dbs
                  , unitState     = state
                  }
      dflags'' = upd_wired_in_home_instantiations dflags'
602

603
  return (dflags'', preloadUnits state)
604 605

-- -----------------------------------------------------------------------------
Sylvain Henry's avatar
Sylvain Henry committed
606
-- Reading the unit database(s)
607

608 609 610 611 612
readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases printer cfg = do
  conf_refs <- getUnitDbRefs cfg
  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
  mapM (readUnitDatabase printer cfg) confs
613

614

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

619
  e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH")
620 621 622
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
623
         | not (null path) && isSearchPathSeparator (last path)
624
         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
625
         | otherwise
626
         -> map PkgDbPath (splitSearchPath path)
627

628 629 630 631 632 633 634 635
  -- Apply the package DB-related flags from the command line to get the
  -- final list of package DBs.
  --
  -- Notes on ordering:
  --  * The list of flags is reversed (later ones first)
  --  * We work with the package DB list in "left shadows right" order
  --  * and finally reverse it at the end, to get "right shadows left"
  --
636
  return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg))
637 638 639 640 641 642
 where
  doFlag (PackageDB p) dbs = p : dbs
  doFlag NoUserPackageDB dbs = filter isNotUser dbs
  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
  doFlag ClearPackageDBs _ = []

643
  isNotUser UserPkgDb = False
644 645
  isNotUser _ = True

646
  isNotGlobal GlobalPkgDb = False
647
  isNotGlobal _ = True
648

649 650 651
-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
-- when the user database filepath is expected but the latter doesn't exist.
--
652
-- NB: This logic is reimplemented in Cabal, so if you change it,
653
-- make sure you update Cabal. (Or, better yet, dump it in the
654
-- compiler info so Cabal can use the info.)
655 656 657 658 659
resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
  dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOs cfg)
  let pkgconf = dir </> unitConfigDBName cfg
660 661
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
Sylvain Henry's avatar
Sylvain Henry committed
662
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
663

664 665
readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase printer cfg conf_file = do
666 667
  isdir <- doesDirectoryExist conf_file

668
  proto_pkg_configs <-
669
    if isdir
670
       then readDirStyleUnitInfo conf_file
671
       else do
672
            isfile <- doesFileExist conf_file
673
            if isfile
674
               then do
675
                 mpkgs <- tryReadOldFileStyleUnitInfo
676 677 678
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
679 680 681 682
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
683 684
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
685

686
  let
687
      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
688
      conf_file' = dropTrailingPathSeparator conf_file
689
      top_dir = unitConfigGHCDir cfg
690
      pkgroot = takeDirectory conf_file'
691
      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo)
692
                         proto_pkg_configs
693
  --
Sylvain Henry's avatar
Sylvain Henry committed
694
  return $ UnitDatabase conf_file' pkg_configs1
695
  where
696
    readDirStyleUnitInfo conf_dir = do
697
      let filename = conf_dir </> "package.cache"
698 699 700
      cache_exists <- doesFileExist filename
      if cache_exists
        then do
701
          printer 2 $ text "Using binary package database:" <+> text filename
702 703 704 705 706 707
          readPackageDbForGhc filename
        else do
          -- If there is no package.cache file, we check if the database is not
          -- empty by inspecting if the directory contains any .conf file. If it
          -- does, something is wrong and we fail. Otherwise we assume that the
          -- database is empty.
708 709 710
          printer 2 $ text "There is no package.cache in"
                      <+> text conf_dir
                       <> text ", checking if the database is empty"
711 712 713 714
          db_empty <- all (not . isSuffixOf ".conf")
                   <$> getDirectoryContents conf_dir
          if db_empty
            then do
715 716 717
              printer 3 $ text "There are no .conf files in"
                          <+> text conf_dir <> text ", treating"
                          <+> text "package database as empty"
718 719 720 721 722 723
              return []
            else do
              throwGhcExceptionIO $ InstallationError $
                "there is no package.cache in " ++ conf_dir ++
                " even though package database is not empty"

724 725 726 727 728 729 730 731 732

    -- Single-file style package dbs have been deprecated for some time, but
    -- it turns out that Cabal was using them in one place. So this is a
    -- workaround to allow older Cabal versions to use this newer ghc.
    -- We check if the file db contains just "[]" and if so, we look for a new
    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    -- We cannot just replace the file with a new dir style since Cabal still
    -- assumes it's a file and tries to overwrite with 'writeFile'.
    -- ghc-pkg also cooperates with this workaround.
733
    tryReadOldFileStyleUnitInfo = do
734 735 736 737 738 739
      content <- readFile conf_file `catchIO` \_ -> return ""
      if take 2 content == "[]"
        then do
          let conf_dir = conf_file <.> "d"
          direxists <- doesDirectoryExist conf_dir
          if direxists
740
             then do printer 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
741
                     liftM Just (readDirStyleUnitInfo conf_dir)
742 743
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
744

745 746
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits pkgs = map distrust pkgs
747
  where
Sylvain Henry's avatar
Sylvain Henry committed
748
    distrust pkg = pkg{ unitIsTrusted = False }
749

750 751 752
mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
753
    mungeDynLibFields
754
  . mungeUnitInfoPaths top_dir pkgroot
755

756
mungeDynLibFields :: UnitInfo -> UnitInfo
757 758
mungeDynLibFields pkg =
    pkg {
Sylvain Henry's avatar
Sylvain Henry committed
759 760 761
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> unitLibraryDirs pkg
         ds -> ds
762 763
    }

764
-- -----------------------------------------------------------------------------
765 766 767 768
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
769
   :: SDocContext
Sylvain Henry's avatar
Sylvain Henry committed
770 771
   -> UnitPrecedenceMap
   -> UnusableUnits
772
   -> [UnitInfo]
773
   -> TrustFlag
774
   -> IO [UnitInfo]
775
applyTrustFlag ctx prec_map unusable pkgs flag =
776 777 778 779
  case flag of
    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage str ->
780
       case selectPackages prec_map (PackageArg str) pkgs unusable of
781
         Left ps       -> trustFlagErr ctx flag ps
782
         Right (ps,qs) -> return (map trust ps ++ qs)
Sylvain Henry's avatar
Sylvain Henry committed
783
          where trust p = p {unitIsTrusted=True}
784 785

    DistrustPackage str ->
786
       case selectPackages prec_map (PackageArg str) pkgs unusable of
787
         Left ps       -> trustFlagErr ctx flag ps
788
         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
789

Sylvain Henry's avatar
Sylvain Henry committed
790
-- | A little utility to tell if the home unit is indefinite
Edward Z. Yang's avatar
Edward Z. Yang committed
791
-- (if it is not, we should never use on-the-fly renaming.)
Sylvain Henry's avatar
Sylvain Henry committed
792 793 794 795 796 797 798
homeUnitIsIndefinite :: DynFlags -> Bool
homeUnitIsIndefinite dflags = not (homeUnitIsDefinite dflags)

-- | A little utility to tell if the home unit is definite
-- (if it is, we should never use on-the-fly renaming.)
homeUnitIsDefinite :: DynFlags -> Bool
homeUnitIsDefinite dflags = unitIsDefinite (homeUnit dflags)
Edward Z. Yang's avatar
Edward Z. Yang committed
799

800
applyPackageFlag
801
   :: SDocContext
Sylvain Henry's avatar
Sylvain Henry committed
802
   -> UnitPrecedenceMap
Sylvain Henry's avatar
Sylvain Henry committed
803 804
   -> UnitInfoMap
   -> PreloadUnitClosure
Sylvain Henry's avatar
Sylvain Henry committed
805
   -> UnusableUnits
806 807
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
808
   -> [UnitInfo]
809
   -> VisibilityMap           -- Initially exposed
810
   -> PackageFlag               -- flag to apply
811
   -> IO VisibilityMap        -- Now exposed
812

813
applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
814
  case flag of
815
    ExposePackage _ arg (ModRenaming b rns) ->
Sylvain Henry's avatar
Sylvain Henry committed
816
       case findPackages prec_map pkg_map closure arg pkgs unusable of
817
         Left ps         -> packageFlagErr ctx flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
818
         Right (p:_) -> return vm'
819 820
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
821 822 823 824 825 826 827 828 829

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

830 831 832 833
           collectHoles uid = case uid of
             HoleUnit       -> Map.empty
             RealUnit {}    -> Map.empty -- definite units don't have holes
             VirtUnit indef ->
834
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
835
                                  (moduleName mod)
836 837
                                  (Set.singleton $ Module indef mod_name)
                              | (mod_name, mod) <- instUnitInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
838
                              , isHoleModule mod ]
839 840
                      recurse = [ collectHoles (moduleUnit mod)
                                | (_, mod) <- instUnitInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
841 842 843 844 845 846 847 848 849
                  in Map.unionsWith Set.union $ local ++ recurse

           uv = UnitVisibility
                { uv_expose_all = b
                , uv_renamings = rns
                , uv_package_name = First (Just n)
                , uv_requirements = reqs
                , uv_explicit = True
                }
850
           vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871
           -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
           -- (or if p-0.1 was registered in the pkgdb as exposed: True),
           -- the second package flag would override the first one and you
           -- would only see p-0.2 in exposed modules.  This is good for
           -- usability.
           --
           -- However, with thinning and renaming (or Backpack), there might be
           -- situations where you legitimately want to see two versions of a
           -- package at the same time, and this behavior would make it
           -- impossible to do so.  So we decided that if you pass
           -- -hide-all-packages, this should turn OFF the overriding behavior
           -- where an exposed package hides all other packages with the same
           -- name.  This should not affect Cabal at all, which only ever
           -- exposes one package at a time.
           --
           -- NB: Why a variable no_hide_others?  We have to apply this logic to
           -- -plugin-package too, and it's more consistent if the switch in
           -- behavior is based off of
           -- -hide-all-packages/-hide-all-plugin-packages depending on what
           -- flag is in question.
           vm_cleared | no_hide_others = vm
Edward Z. Yang's avatar
Edward Z. Yang committed
872 873 874
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
875
                            (\k uv -> k == mkUnit p
Edward Z. Yang's avatar
Edward Z. Yang committed
876
                                   || First (Just n) /= uv_package_name uv) vm
877 878
         _ -> panic "applyPackageFlag"

879
    HidePackage str ->
Sylvain Henry's avatar
Sylvain Henry committed
880
       case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
881
         Left ps  -> packageFlagErr ctx flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
882
         Right ps -> return vm'
883
          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
884 885 886 887

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
Sylvain Henry's avatar
Sylvain Henry committed
888
findPackages :: UnitPrecedenceMap
Sylvain Henry's avatar
Sylvain Henry committed
889 890 891
             -> UnitInfoMap
             -> PreloadUnitClosure
             -> PackageArg -> [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
892 893
             -> UnusableUnits
             -> Either [(UnitInfo, UnusableUnitReason)]
894
                [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
895
findPackages prec_map pkg_map closure arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
896 897 898 899
  = let ps = mapMaybe (finder arg) pkgs
    in if null ps
        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
                            (Map.elems unusable))
900
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
901 902
  where
    finder (PackageArg str) p
Sylvain Henry's avatar
Sylvain Henry committed
903
      = if str == unitPackageIdString p || str == unitPackageNameString p
Edward Z. Yang's avatar
Edward Z. Yang committed
904 905 906
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
907 908 909 910 911 912
      = case uid of
          RealUnit (Definite iuid)
            | iuid == unitId p
            -> Just p
          VirtUnit inst
            | indefUnit (instUnitInstanceOf inst) == unitId p
Sylvain Henry's avatar
Sylvain Henry committed
913
            -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p)
914
          _ -> Nothing
Edward Z. Yang's avatar
Edward Z. Yang committed
915

Sylvain Henry's avatar
Sylvain Henry committed
916 917 918
selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
               -> UnusableUnits
               -> Either [(UnitInfo, UnusableUnitReason)]
919
                  ([UnitInfo], [UnitInfo])
920
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
921 922
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
923 924
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
925
        else Right (sortByPreference prec_map ps, rest)
926

927
-- | Rename a 'UnitInfo' according to some module instantiation.
Sylvain Henry's avatar
Sylvain Henry committed
928 929
renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo pkg_map closure insts conf =
Edward Z. Yang's avatar
Edward Z. Yang committed
930
    let hsubst = listToUFM insts
Sylvain Henry's avatar
Sylvain Henry committed
931
        smod  = renameHoleModule' pkg_map closure hsubst
Sylvain Henry's avatar
Sylvain Henry committed
932
        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
933
    in conf {
Sylvain Henry's avatar
Sylvain Henry committed
934 935 936
        unitInstantiations = new_insts,
        unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
                             (unitExposedModules conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
937 938 939
    }


940 941
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
942
matchingStr :: String -> UnitInfo -> Bool
943
matchingStr str p
Sylvain Henry's avatar
Sylvain Henry committed
944 945
        =  str == unitPackageIdString p
        || str == unitPackageNameString p
946

947 948
matchingId :: UnitId -> UnitInfo -> Bool
matchingId uid p = uid == unitId p
949

950
matching :: PackageArg -> UnitInfo -> Bool
951
matching (PackageArg str) = matchingStr str
952
matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
953
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
954

955 956
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
Sylvain Henry's avatar
Sylvain Henry committed
957
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
958 959 960 961 962 963 964 965 966 967 968
sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))

-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
-- which should be "active".  Here is the order of preference:
--
--      1. First, prefer the latest version
--      2. If the versions are the same, prefer the package that
--      came in the latest package database.
--
-- Pursuant to #12518, we could change this policy to, for example, remove
-- the version preference, meaning that we would always prefer the packages
969
-- in later package database.
970
--
971 972 973 974 975 976
-- Instead, we use that preference based policy only when one of the packages
-- is integer-gmp and the other is integer-simple.
-- This currently only happens when we're looking up which concrete
-- package to use in place of @integer-wired-in@ and that two different
-- package databases supply a different integer library. For more about
-- the fake @integer-wired-in@ package, see Note [The integer library]
Sylvain Henry's avatar
Sylvain Henry committed
977
-- in the @GHC.Builtin.Names@ module.
978
compareByPreference
Sylvain Henry's avatar
Sylvain Henry committed
979
    :: UnitPrecedenceMap
980 981
    -> UnitInfo
    -> UnitInfo
982
    -> Ordering
983 984 985 986 987 988 989
compareByPreference prec_map pkg pkg'
  | Just prec  <- Map.lookup (unitId pkg)  prec_map
  , Just prec' <- Map.lookup (unitId pkg') prec_map
  , differentIntegerPkgs pkg pkg'
  = compare prec prec'

  | otherwise
Sylvain Henry's avatar
Sylvain Henry committed
990
  = case comparing unitPackageVersion pkg pkg' of
991 992 993 994 995 996 997 998 999
        GT -> GT
        EQ | Just prec  <- Map.lookup (unitId pkg)  prec_map
           , Just prec' <- Map.lookup (unitId pkg') prec_map
           -- Prefer the package from the later DB flag (i.e., higher
           -- precedence)
           -> compare prec prec'
           | otherwise
           -> EQ
        LT -> LT
Ian Lynagh's avatar
Ian Lynagh committed
1000

Sylvain Henry's avatar
Sylvain Henry committed
1001
  where isIntegerPkg p = unitPackageNameString p `elem`
1002 1003 1004
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
Sylvain Henry's avatar
Sylvain Henry committed
1005
          (unitPackageName p /= unitPackageName p')
1006

Ian Lynagh's avatar
Ian Lynagh committed
1007
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
1008 1009
comparing f a b = f a `compare` f b

1010
packageFlagErr :: SDocContext
Ian Lynagh's avatar
Ian Lynagh committed
1011
               -> PackageFlag
Sylvain Henry's avatar
Sylvain Henry committed
1012
               -> [(UnitInfo, UnusableUnitReason)]
1013
               -> IO a
1014 1015
packageFlagErr ctx flag reasons
  = packageFlagErr' ctx (pprFlag flag) reasons