State.hs 87.6 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

5
-- | Package manipulation
6
module GHC.Unit.State (
7
        module GHC.Unit.Info,
8 9

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

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

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

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

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

56
        -- * Utils
57 58 59
        mkIndefUnitId,
        updateIndefUnitId,
        unwireUnit,
60
        pprFlag,
61 62
        pprPackages,
        pprPackagesSimple,
63
        pprModuleMap,
Sylvain Henry's avatar
Sylvain Henry committed
64 65
        homeUnitIsIndefinite,
        homeUnitIsDefinite,
66
    )
67 68 69
where

#include "HsVersions.h"
70

71
import GHC.Prelude
72

73
import GHC.Unit.Database
74
import GHC.Unit.Info
75 76 77
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Unit.Subst
Sylvain Henry's avatar
Sylvain Henry committed
78
import GHC.Driver.Session
Sylvain Henry's avatar
Sylvain Henry committed
79
import GHC.Driver.Ways
Sylvain Henry's avatar
Sylvain Henry committed
80 81 82
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
83 84 85 86
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Data.Maybe
87

88
import System.Environment ( getEnv )
89 90
import GHC.Data.FastString
import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,
Sylvain Henry's avatar
Sylvain Henry committed
91
                          withTiming, DumpFormat (..) )
92
import GHC.Utils.Exception
93

Simon Marlow's avatar
Simon Marlow committed
94
import System.Directory
95
import System.FilePath as FilePath
Simon Marlow's avatar
Simon Marlow committed
96
import Control.Monad
97
import Data.Graph (stronglyConnComp, SCC(..))
98
import Data.Char ( toUpper )
99
import Data.List as List
100
import Data.Map (Map)
101
import Data.Set (Set)
Edward Z. Yang's avatar
Edward Z. Yang committed
102
import Data.Monoid (First(..))
103
import qualified Data.Semigroup as Semigroup
104
import qualified Data.Map as Map
105
import qualified Data.Map.Strict as MapStrict
106
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
107

108 109 110
-- ---------------------------------------------------------------------------
-- The Package state

111
-- | Package state is all stored in 'DynFlags', including the details of
112 113 114
-- all packages, which packages are exposed, and which modules they
-- provide.
--
Sylvain Henry's avatar
Sylvain Henry committed
115
-- The package state is computed by 'initUnits', and kept in DynFlags.
116
-- It is influenced by various package flags:
117
--
118 119 120
--   * @-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.
121
--
122
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
123
--
124 125 126 127
--   * (there are a few more flags, check below for their semantics)
--
-- The package state has the following properties.
--
128
--   * Let @exposedPackages@ be the set of packages thus exposed.
129
--     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
130 131
--     their dependencies.
--
Gabor Greif's avatar
Gabor Greif committed
132
--   * When searching for a module from a preload import declaration,
133
--     only the exposed modules in @exposedPackages@ are valid.
134 135
--
--   * When searching for a module from an implicit import, all modules
136
--     from @depExposedPackages@ are valid.
137
--
138
--   * When linking in a compilation manager mode, we link in packages the
139 140
--     program depends on (the compiler knows this list by the
--     time it gets to the link step).  Also, we link in all packages
141
--     which were mentioned with preload @-package@ flags on the command-line,
Ian Lynagh's avatar
Ian Lynagh committed
142
--     or are a transitive dependency of same, or are \"base\"\/\"rts\".
143
--     The reason for this is that we might need packages which don't
144 145 146 147 148
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
149 150 151 152
-- 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
153 154 155
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

156
-- | Given a module name, there may be multiple ways it came into scope,
157 158 159
-- 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!
160
data ModuleOrigin =
161 162 163 164
    -- | 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
165
    -- | Module is unavailable because the package is unusable.
Sylvain Henry's avatar
Sylvain Henry committed
166
  | ModUnusable UnusableUnitReason
167 168 169 170 171 172 173 174 175
    -- | 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.
        fromOrigPackage :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
176
      , fromExposedReexport :: [UnitInfo]
177
        -- | Is the module available from a reexport of a hidden package?
178
      , fromHiddenReexport :: [UnitInfo]
179 180 181 182 183 184
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
185
    ppr ModHidden = text "hidden module"
186
    ppr (ModUnusable _) = text "unusable module"
187 188 189 190 191 192 193 194
    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" <+>
195
                    sep (map (ppr . mkUnit) res)]) ++
196 197 198
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
199
                    sep (map (ppr . mkUnit) res)]) ++
200 201 202
        (if f then [text "package flag"] else [])
        ))

203 204 205 206
-- | 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
207

208
-- | Smart constructor for a module which is in @reexported-modules@.  Takes
209
-- as an argument whether or not the reexporting package is exposed, and
210 211
-- also its 'UnitInfo'.
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
212 213
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
214 215 216 217 218

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

219 220 221 222 223 224 225 226 227 228
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"

229 230
instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
231
    mappend = (Semigroup.<>)
232 233 234

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
235 236
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
237
originVisible (ModUnusable _) = False
238 239 240 241 242 243 244
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
245

246 247
-- | Map from 'UnitId' to 'UnitInfo', plus
-- the transitive closure of preload units.
Sylvain Henry's avatar
Sylvain Henry committed
248 249
data ClosureUnitInfoMap = ClosureUnitInfoMap
   { unClosureUnitInfoMap :: UniqDFM UnitInfo
250 251 252 253 254 255 256 257 258
      -- ^ Map from 'UnitId' to 'UnitInfo'

   , preloadClosure :: UniqSet UnitId
     -- ^ 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]
   }
Edward Z. Yang's avatar
Edward Z. Yang committed
259

260 261
-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
type VisibilityMap = Map Unit UnitVisibility
Edward Z. Yang's avatar
Edward Z. Yang committed
262 263

-- | 'UnitVisibility' records the various aspects of visibility of a particular
264
-- 'Unit'.
Edward Z. Yang's avatar
Edward Z. Yang committed
265 266 267 268 269 270 271
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
272
      -- ^ The package name associated with the 'Unit'.  This is used
Edward Z. Yang's avatar
Edward Z. Yang committed
273 274
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
275
    , uv_requirements :: Map ModuleName (Set InstantiatedModule)
Edward Z. Yang's avatar
Edward Z. Yang committed
276 277 278 279 280 281 282
      -- ^ 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.)
    }
283

Edward Z. Yang's avatar
Edward Z. Yang committed
284 285 286 287 288 289 290 291
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)
292 293 294 295 296 297 298 299 300 301 302

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
303 304 305 306 307 308 309 310
instance Monoid UnitVisibility where
    mempty = UnitVisibility
             { uv_expose_all = False
             , uv_renamings = []
             , uv_package_name = First Nothing
             , uv_requirements = Map.empty
             , uv_explicit = False
             }
311
    mappend = (Semigroup.<>)
312

313 314 315 316 317 318
-- | 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 =
319
    Map ModuleName (Map Module ModuleOrigin)
320

321
data PackageState = PackageState {
322
  -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
323
  -- so that only valid packages are here.  'UnitInfo' reflects
324 325 326
  -- what was stored *on disk*, except for the 'trusted' flag, which
  -- is adjusted at runtime.  (In particular, some packages in this map
  -- may have the 'exposed' flag be 'False'.)
Sylvain Henry's avatar
Sylvain Henry committed
327
  unitInfoMap :: ClosureUnitInfoMap,
328

329
  -- | A mapping of 'PackageName' to 'IndefUnitId'.  This is used when
Edward Z. Yang's avatar
Edward Z. Yang committed
330
  -- users refer to packages in Backpack includes.
331
  packageNameMap            :: Map PackageName IndefUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
332 333 334

  -- | A mapping from wired in names to the original names from the
  -- package database.
Sylvain Henry's avatar
Sylvain Henry committed
335
  unwireMap :: Map UnitId UnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
336

337 338 339
  -- | 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
340
  preloadUnits      :: [UnitId],
341

342 343
  -- | 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
344
  explicitUnits      :: [Unit],
345

346 347 348
  -- | 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.
349
  moduleNameProvidersMap    :: !ModuleNameProvidersMap,
350

351 352
  -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
  pluginModuleNameProvidersMap    :: !ModuleNameProvidersMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
353 354 355 356 357 358 359 360

  -- | 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.
361 362 363 364 365 366 367
  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
368 369
  }

370 371
emptyPackageState :: PackageState
emptyPackageState = PackageState {
Sylvain Henry's avatar
Sylvain Henry committed
372
    unitInfoMap = emptyClosureUnitInfoMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
373 374
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
Sylvain Henry's avatar
Sylvain Henry committed
375 376
    preloadUnits = [],
    explicitUnits = [],
377 378
    moduleNameProvidersMap = Map.empty,
    pluginModuleNameProvidersMap = Map.empty,
379 380
    requirementContext = Map.empty,
    allowVirtualUnits = False
381 382
    }

Sylvain Henry's avatar
Sylvain Henry committed
383 384 385 386
-- | Unit database
data UnitDatabase unit = UnitDatabase
   { unitDatabasePath  :: FilePath
   , unitDatabaseUnits :: [GenUnitInfo unit]
387 388
   }

Sylvain Henry's avatar
Sylvain Henry committed
389
type UnitInfoMap = Map UnitId UnitInfo
390

391
-- | Empty package configuration map
Sylvain Henry's avatar
Sylvain Henry committed
392 393
emptyClosureUnitInfoMap :: ClosureUnitInfoMap
emptyClosureUnitInfoMap = ClosureUnitInfoMap emptyUDFM emptyUniqSet
394

Sylvain Henry's avatar
Sylvain Henry committed
395
-- | Find the unit we know about with the given unit, if any
396 397
lookupUnit :: PackageState -> Unit -> Maybe UnitInfo
lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs)
Edward Z. Yang's avatar
Edward Z. Yang committed
398 399 400

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
Sylvain Henry's avatar
Sylvain Henry committed
401
-- just a 'ClosureUnitInfoMap' rather than a 'PackageState' (so it can
Edward Z. Yang's avatar
Edward Z. Yang committed
402
-- be used while we're initializing 'DynFlags'
Sylvain Henry's avatar
Sylvain Henry committed
403 404 405
lookupUnit' :: Bool -> ClosureUnitInfoMap -> Unit -> Maybe UnitInfo
lookupUnit' False (ClosureUnitInfoMap pkg_map _) uid  = lookupUDFM pkg_map uid
lookupUnit' True m@(ClosureUnitInfoMap pkg_map _) uid = case uid of
406 407
   HoleUnit   -> error "Hole unit"
   RealUnit _ -> lookupUDFM pkg_map uid
Sylvain Henry's avatar
Sylvain Henry committed
408
   VirtUnit i -> fmap (renameUnitInfo m (instUnitInsts i))
409
                      (lookupUDFM pkg_map (instUnitInstanceOf i))
Edward Z. Yang's avatar
Edward Z. Yang committed
410

Sylvain Henry's avatar
Sylvain Henry committed
411 412 413 414 415
-- | Find the unit we know about with the given unit id, if any
lookupUnitId :: PackageState -> UnitId -> Maybe UnitInfo
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
416 417
lookupUnitId' :: ClosureUnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' (ClosureUnitInfoMap db _) uid = lookupUDFM db uid
Sylvain Henry's avatar
Sylvain Henry committed
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432


-- | Looks up the given unit in the package state, panicing if it is not found
unsafeLookupUnit :: HasDebugCallStack => PackageState -> Unit -> UnitInfo
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
unsafeLookupUnitId :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo
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
433 434
-- | 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)
435
lookupPackageName :: PackageState -> PackageName -> Maybe IndefUnitId
Sylvain Henry's avatar
Sylvain Henry committed
436
lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
437 438

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
Sylvain Henry's avatar
Sylvain Henry committed
439 440
searchPackageId :: PackageState -> PackageId -> [UnitInfo]
searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
441
                               (listUnitInfo pkgstate)
442

443 444 445 446 447 448 449 450 451
-- | 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
452 453 454
mkClosureUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkClosureUnitInfoMap infos
  = ClosureUnitInfoMap (foldl' add emptyUDFM infos) emptyUniqSet
Sylvain Henry's avatar
Sylvain Henry committed
455 456
  where
   mkVirt      p = mkVirtUnit (unitInstanceOf p) (unitInstantiations p)
457 458 459 460 461
   add pkg_map p
      | not (null (unitInstantiations p))
      = addToUDFM (addToUDFM pkg_map (mkVirt p) p) (unitId p) p
      | otherwise
      = addToUDFM pkg_map (unitId p) p
462

463
-- | Get a list of entries from the package database.  NB: be careful with
464 465 466
-- 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).
467 468
listUnitInfo :: PackageState -> [UnitInfo]
listUnitInfo pkgstate = eltsUDFM pkg_map
Edward Z. Yang's avatar
Edward Z. Yang committed
469
  where
Sylvain Henry's avatar
Sylvain Henry committed
470
    ClosureUnitInfoMap pkg_map _ = unitInfoMap pkgstate
471

472
-- ----------------------------------------------------------------------------
473
-- Loading the package db files and building up the package state
474

475 476
-- | Read the package database files, and sets up various internal tables of
-- package information, according to the package-related flags on the
477
-- command-line (@-package@, @-hide-package@ etc.)
478 479 480
--
-- 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
481
-- @-package@ flags.
482
--
Sylvain Henry's avatar
Sylvain Henry committed
483
-- 'initUnits' can be called again subsequently after updating the
484
-- 'packageFlags' field of the 'DynFlags', and it will update the
Sylvain Henry's avatar
Sylvain Henry committed
485
-- 'unitState' in 'DynFlags' and return a list of packages to
486
-- link in.
Sylvain Henry's avatar
Sylvain Henry committed
487 488
initUnits :: DynFlags -> IO (DynFlags, [UnitId])
initUnits dflags = withTiming dflags
489 490
                                  (text "initializing package database")
                                  forcePkgDb $ do
491
  read_pkg_dbs <-
Sylvain Henry's avatar
Sylvain Henry committed
492 493
    case unitDatabases dflags of
        Nothing  -> readUnitDatabases dflags
494 495 496
        Just dbs -> return dbs

  let
Sylvain Henry's avatar
Sylvain Henry committed
497
      distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
498 499 500 501 502

      pkg_dbs
         | gopt Opt_DistrustAllPackages dflags = map distrust_all read_pkg_dbs
         | otherwise                           = read_pkg_dbs

503
  (pkg_state, preload, insts)
504
        <- mkPackageState dflags pkg_dbs []
Sylvain Henry's avatar
Sylvain Henry committed
505 506
  return (dflags{ unitDatabases = Just read_pkg_dbs,
                  unitState = pkg_state,
Sylvain Henry's avatar
Sylvain Henry committed
507
                  homeUnitInstantiations = insts },
508
          preload)
509
  where
Sylvain Henry's avatar
Sylvain Henry committed
510
    forcePkgDb (dflags, _) = unitInfoMap (unitState dflags) `seq` ()
511 512

-- -----------------------------------------------------------------------------
Sylvain Henry's avatar
Sylvain Henry committed
513
-- Reading the unit database(s)
514

Sylvain Henry's avatar
Sylvain Henry committed
515 516 517 518 519
readUnitDatabases :: DynFlags -> IO [UnitDatabase UnitId]
readUnitDatabases dflags = do
  conf_refs <- getPackageDbRefs dflags
  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase dflags) conf_refs
  mapM (readUnitDatabase dflags) confs
520

521

Sylvain Henry's avatar
Sylvain Henry committed
522 523
getPackageDbRefs :: DynFlags -> IO [PkgDbRef]
getPackageDbRefs dflags = do
524
  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
525

526
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
527 528 529
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
530
         | not (null path) && isSearchPathSeparator (last path)
531
         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
532
         | otherwise
533
         -> map PkgDbPath (splitSearchPath path)
534

535 536 537 538 539 540 541 542 543 544 545 546 547 548 549
  -- 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"
  --
  return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags))
 where
  doFlag (PackageDB p) dbs = p : dbs
  doFlag NoUserPackageDB dbs = filter isNotUser dbs
  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
  doFlag ClearPackageDBs _ = []

550
  isNotUser UserPkgDb = False
551 552
  isNotUser _ = True

553
  isNotGlobal GlobalPkgDb = False
554
  isNotGlobal _ = True
555

556 557 558
-- | 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.
--
559
-- NB: This logic is reimplemented in Cabal, so if you change it,
560
-- make sure you update Cabal. (Or, better yet, dump it in the
561
-- compiler info so Cabal can use the info.)
Sylvain Henry's avatar
Sylvain Henry committed
562 563 564
resolveUnitDatabase :: DynFlags -> PkgDbRef -> IO (Maybe FilePath)
resolveUnitDatabase dflags GlobalPkgDb = return $ Just (globalPackageDatabasePath dflags)
resolveUnitDatabase dflags UserPkgDb = runMaybeT $ do
565
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
566
  let pkgconf = dir </> "package.conf.d"
567 568
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
Sylvain Henry's avatar
Sylvain Henry committed
569
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
570

Sylvain Henry's avatar
Sylvain Henry committed
571 572
readUnitDatabase :: DynFlags -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase dflags conf_file = do
573 574
  isdir <- doesDirectoryExist conf_file

575
  proto_pkg_configs <-
576
    if isdir
577
       then readDirStyleUnitInfo conf_file
578
       else do
579
            isfile <- doesFileExist conf_file
580
            if isfile
581
               then do
582
                 mpkgs <- tryReadOldFileStyleUnitInfo
583 584 585
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
586 587 588 589
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
590 591
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
592

593
  let
594
      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
595
      conf_file' = dropTrailingPathSeparator conf_file
596
      top_dir = topDir dflags
597
      pkgroot = takeDirectory conf_file'
598
      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo)
599
                         proto_pkg_configs
600
  --
Sylvain Henry's avatar
Sylvain Henry committed
601
  return $ UnitDatabase conf_file' pkg_configs1
602
  where
603
    readDirStyleUnitInfo conf_dir = do
604
      let filename = conf_dir </> "package.cache"
605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
      cache_exists <- doesFileExist filename
      if cache_exists
        then do
          debugTraceMsg dflags 2 $ text "Using binary package database:"
                                    <+> text filename
          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.
          debugTraceMsg dflags 2 $ text "There is no package.cache in"
                               <+> text conf_dir
                                <> text ", checking if the database is empty"
          db_empty <- all (not . isSuffixOf ".conf")
                   <$> getDirectoryContents conf_dir
          if db_empty
            then do
              debugTraceMsg dflags 3 $ text "There are no .conf files in"
                                   <+> text conf_dir <> text ", treating"
                                   <+> text "package database as empty"
              return []
            else do
              throwGhcExceptionIO $ InstallationError $
                "there is no package.cache in " ++ conf_dir ++
                " even though package database is not empty"

632 633 634 635 636 637 638 639 640

    -- 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.
641
    tryReadOldFileStyleUnitInfo = do
642 643 644 645 646 647 648
      content <- readFile conf_file `catchIO` \_ -> return ""
      if take 2 content == "[]"
        then do
          let conf_dir = conf_file <.> "d"
          direxists <- doesDirectoryExist conf_dir
          if direxists
             then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
649
                     liftM Just (readDirStyleUnitInfo conf_dir)
650 651
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
652

653 654
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits pkgs = map distrust pkgs
655
  where
Sylvain Henry's avatar
Sylvain Henry committed
656
    distrust pkg = pkg{ unitIsTrusted = False }
657

658 659 660
mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
661
    mungeDynLibFields
662
  . mungeUnitInfoPaths top_dir pkgroot
663

664
mungeDynLibFields :: UnitInfo -> UnitInfo
665 666
mungeDynLibFields pkg =
    pkg {
Sylvain Henry's avatar
Sylvain Henry committed
667 668 669
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> unitLibraryDirs pkg
         ds -> ds
670 671
    }

672
-- -----------------------------------------------------------------------------
673 674 675 676 677
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
678 679
   -> UnitPrecedenceMap
   -> UnusableUnits
680
   -> [UnitInfo]
681
   -> TrustFlag
682
   -> IO [UnitInfo]
683
applyTrustFlag dflags prec_map unusable pkgs flag =
684 685 686 687
  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 ->
688
       case selectPackages prec_map (PackageArg str) pkgs unusable of
689 690
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
Sylvain Henry's avatar
Sylvain Henry committed
691
          where trust p = p {unitIsTrusted=True}
692 693

    DistrustPackage str ->
694
       case selectPackages prec_map (PackageArg str) pkgs unusable of
695
         Left ps       -> trustFlagErr dflags flag ps
696
         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
697

Sylvain Henry's avatar
Sylvain Henry committed
698
-- | A little utility to tell if the home unit is indefinite
Edward Z. Yang's avatar
Edward Z. Yang committed
699
-- (if it is not, we should never use on-the-fly renaming.)
Sylvain Henry's avatar
Sylvain Henry committed
700 701 702 703 704 705 706
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
707

708
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
709
   :: DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
710 711 712
   -> UnitPrecedenceMap
   -> ClosureUnitInfoMap
   -> UnusableUnits
713 714
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
715
   -> [UnitInfo]
716
   -> VisibilityMap           -- Initially exposed
717
   -> PackageFlag               -- flag to apply
718
   -> IO VisibilityMap        -- Now exposed
719

720
applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
721
  case flag of
722
    ExposePackage _ arg (ModRenaming b rns) ->
723
       case findPackages prec_map pkg_db arg pkgs unusable of
724
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
725
         Right (p:_) -> return vm'
726 727
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
728 729 730 731 732 733 734 735 736

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

737 738 739 740
           collectHoles uid = case uid of
             HoleUnit       -> Map.empty
             RealUnit {}    -> Map.empty -- definite units don't have holes
             VirtUnit indef ->
741
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
742
                                  (moduleName mod)
743 744
                                  (Set.singleton $ Module indef mod_name)
                              | (mod_name, mod) <- instUnitInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
745
                              , isHoleModule mod ]
746 747
                      recurse = [ collectHoles (moduleUnit mod)
                                | (_, mod) <- instUnitInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
748 749 750 751 752 753 754 755 756
                  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
                }
757
           vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
           -- 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
779 780 781
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
782
                            (\k uv -> k == mkUnit p
Edward Z. Yang's avatar
Edward Z. Yang committed
783
                                   || First (Just n) /= uv_package_name uv) vm
784 785
         _ -> panic "applyPackageFlag"

786
    HidePackage str ->
787
       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
788 789
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
790
          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
791 792 793 794

-- | 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
795 796 797 798
findPackages :: UnitPrecedenceMap
             -> ClosureUnitInfoMap -> PackageArg -> [UnitInfo]
             -> UnusableUnits
             -> Either [(UnitInfo, UnusableUnitReason)]
799
                [UnitInfo]
800
findPackages prec_map pkg_db arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
801 802 803 804
  = 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))
805
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
806 807
  where
    finder (PackageArg str) p
Sylvain Henry's avatar
Sylvain Henry committed
808
      = if str == unitPackageIdString p || str == unitPackageNameString p
Edward Z. Yang's avatar
Edward Z. Yang committed
809 810 811
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
812 813 814 815 816 817
      = 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
818
            -> Just (renameUnitInfo pkg_db (instUnitInsts inst) p)
819
          _ -> Nothing
Edward Z. Yang's avatar
Edward Z. Yang committed
820

Sylvain Henry's avatar
Sylvain Henry committed
821 822 823
selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
               -> UnusableUnits
               -> Either [(UnitInfo, UnusableUnitReason)]
824
                  ([UnitInfo], [UnitInfo])
825
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
826 827
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
828 829
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
830
        else Right (sortByPreference prec_map ps, rest)
831

832
-- | Rename a 'UnitInfo' according to some module instantiation.
Sylvain Henry's avatar
Sylvain Henry committed
833 834
renameUnitInfo :: ClosureUnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo pkg_map insts conf =
Edward Z. Yang's avatar
Edward Z. Yang committed
835
    let hsubst = listToUFM insts
836
        smod  = renameHoleModule' pkg_map hsubst
Sylvain Henry's avatar
Sylvain Henry committed
837
        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
838
    in conf {
Sylvain Henry's avatar
Sylvain Henry committed
839 840 841
        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
842 843 844
    }


845 846
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
847
matchingStr :: String -> UnitInfo -> Bool
848
matchingStr str p
Sylvain Henry's avatar
Sylvain Henry committed
849 850
        =  str == unitPackageIdString p
        || str == unitPackageNameString p
851

852 853
matchingId :: UnitId -> UnitInfo -> Bool
matchingId uid p = uid == unitId p
854

855
matching :: PackageArg -> UnitInfo -> Bool
856
matching (PackageArg str) = matchingStr str
857
matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
858
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
859

860 861
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
Sylvain Henry's avatar
Sylvain Henry committed
862
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
863 864 865 866 867 868 869 870 871 872 873
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
874
-- in later package database.
875
--
876 877 878 879 880 881
-- 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
882
-- in the @GHC.Builtin.Names@ module.
883
compareByPreference
Sylvain Henry's avatar
Sylvain Henry committed
884
    :: UnitPrecedenceMap
885 886
    -> UnitInfo
    -> UnitInfo
887
    -> Ordering
888 889 890 891 892 893 894
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
895
  = case comparing unitPackageVersion pkg pkg' of
896 897 898 899 900 901 902 903 904
        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
905

Sylvain Henry's avatar
Sylvain Henry committed
906
  where isIntegerPkg p = unitPackageNameString p `elem`
907 908 909
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
Sylvain Henry's avatar
Sylvain Henry committed
910
          (unitPackageName p /= unitPackageName p')
911

Ian Lynagh's avatar
Ian Lynagh committed
912
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
913 914
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
915 916
packageFlagErr :: DynFlags
               -> PackageFlag
Sylvain Henry's avatar
Sylvain Henry committed
917
               -> [(UnitInfo, UnusableUnitReason)]
918
               -> IO a
919
packageFlagErr dflags flag reasons
920 921 922 923
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
Sylvain Henry's avatar
Sylvain Henry committed
924
             -> [(UnitInfo, UnusableUnitReason)]
925 926 927 928 929 930
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
Sylvain Henry's avatar
Sylvain Henry committed
931
               -> [(UnitInfo, UnusableUnitReason)]
932 933
               -> IO a
packageFlagErr' dflags flag_doc reasons
934
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
935
  where err = text "cannot satisfy " <> flag_doc <>
936
                (if null reasons then Outputable.empty else text ": ") $$
937 938 939
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
940
        ppr_reason (p, reason) =
941
            pprReason (ppr (unitId p) <+> text "is") reason
942

943 944 945
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
946
    ExposePackage doc _ _ -> text doc
947

948 949 950 951 952
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

953
-- -----------------------------------------------------------------------------
954
-- Wired-in units
955
--
956
-- See Note [Wired-in units] in GHC.Unit.Module
957

Sylvain Henry's avatar
Sylvain Henry committed
958
type WiringMap = Map UnitId UnitId
959

960 961
findWiredInPackages
   :: DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
962
   -> UnitPrecedenceMap
963
   -> [UnitInfo]           -- database
964
   -> VisibilityMap             -- info on what packages are visible
965
                                -- for wired in selection
966
   -> IO ([UnitInfo],  -- package database updated for wired in
Sylvain Henry's avatar
Sylvain Henry committed
967
          WiringMap)   -- map from unit id to wired identity
968

969
findWiredInPackages dflags prec_map pkgs vis_map = do
Simon Marlow's avatar
Simon Marlow committed
970
  -- Now we must find our wired-in packages, and rename them to
971
  -- their canonical names (eg. base-1.0 ==> base), as described
972
  -- in Note [Wired-in units] in GHC.Unit.Module
Simon Marlow's avatar
Simon Marlow committed
973
  let
Sylvain Henry's avatar
Sylvain Henry committed
974
        matches :: UnitInfo -> UnitId -> Bool
975
        pc `matches` pid
Sylvain Henry's avatar
Sylvain Henry committed
976
            -- See Note [The integer library] in GHC.Builtin.Names
Sylvain Henry's avatar
Sylvain Henry committed
977
            | pid == integerUnitId
Sylvain Henry's avatar
Sylvain Henry committed
978
            = unitPackageNameString pc `elem` ["integer-gmp", "integer-simple"]
Sylvain Henry's avatar
Sylvain Henry committed
979
        pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
Simon Marlow's avatar
Simon Marlow committed
980

981 982 983 984
        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
        -- update the package and any dependencies to point to the new
        -- one.
985 986
        --
        -- When choosing which package to map to a wired-in package