Packages.hs 90.7 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 Packages (
7 8 9
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
10
        PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext),
Edward Z. Yang's avatar
Edward Z. Yang committed
11
        PackageConfigMap,
12
        emptyPackageState,
13
        initPackages,
14 15 16 17
        readPackageConfigs,
        getPackageConfRefs,
        resolvePackageConfig,
        readPackageConfig,
Edsko de Vries's avatar
Edsko de Vries committed
18
        listPackageConfigMap,
19 20 21

        -- * Querying the package config
        lookupPackage,
Edward Z. Yang's avatar
Edward Z. Yang committed
22
        lookupPackage',
23
        lookupInstalledPackage,
Edward Z. Yang's avatar
Edward Z. Yang committed
24 25
        lookupPackageName,
        improveUnitId,
26
        searchPackageId,
27
        getPackageDetails,
28
        getInstalledPackageDetails,
Edward Z. Yang's avatar
Edward Z. Yang committed
29
        componentIdString,
30
        displayInstalledUnitId,
31
        listVisibleModuleNames,
32 33
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
34
        lookupPluginModuleWithSuggestions,
35
        LookupResult(..),
36 37
        ModuleSuggestion(..),
        ModuleOrigin(..),
38 39
        UnusablePackageReason(..),
        pprReason,
40 41 42 43 44 45 46 47

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
Edward Z. Yang's avatar
Edward Z. Yang committed
48
        getPackageConfigMap,
49
        getPreloadPackagesAnd,
50

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

55
        -- * Utils
Edward Z. Yang's avatar
Edward Z. Yang committed
56
        unwireUnitId,
57
        pprFlag,
58 59
        pprPackages,
        pprPackagesSimple,
60
        pprModuleMap,
61
        isDllName
62
    )
63 64 65
where

#include "HsVersions.h"
66

67 68
import GhcPrelude

69
import GHC.PackageDb
70
import PackageConfig
71
import DynFlags
72
import Name             ( Name, nameModule_maybe )
73
import UniqFM
niteria's avatar
niteria committed
74
import UniqDFM
75
import UniqSet
76
import Module
77 78
import Util
import Panic
Tamar Christina's avatar
Tamar Christina committed
79
import Platform
80
import Outputable
81
import Maybes
82

83
import System.Environment ( getEnv )
84
import FastString
Edward Z. Yang's avatar
Edward Z. Yang committed
85
import ErrUtils         ( debugTraceMsg, MsgDoc, printInfoForUser )
86
import Exception
87

Simon Marlow's avatar
Simon Marlow committed
88
import System.Directory
89 90
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
91
import Control.Monad
92
import Data.Graph (stronglyConnComp, SCC(..))
93
import Data.Char ( toUpper )
94
import Data.List as List
95
import Data.Map (Map)
96
import Data.Set (Set)
Edward Z. Yang's avatar
Edward Z. Yang committed
97
import Data.Monoid (First(..))
98
import qualified Data.Semigroup as Semigroup
99
import qualified Data.Map as Map
100
import qualified Data.Map.Strict as MapStrict
101
import qualified Data.Set as Set
102
import Data.Version
Simon Marlow's avatar
Simon Marlow committed
103

104 105 106
-- ---------------------------------------------------------------------------
-- The Package state

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

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

152
-- | Given a module name, there may be multiple ways it came into scope,
153 154 155
-- 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!
156
data ModuleOrigin =
157 158 159 160
    -- | 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
161 162
    -- | Module is unavailable because the package is unusable.
  | ModUnusable UnusablePackageReason
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
    -- | 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.
      , fromExposedReexport :: [PackageConfig]
        -- | Is the module available from a reexport of a hidden package?
      , fromHiddenReexport :: [PackageConfig]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

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

199 200 201 202
-- | 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
203

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

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

215 216 217 218 219 220 221 222 223 224
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"

225 226
instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
227
    mappend = (Semigroup.<>)
228 229 230

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

242 243 244 245 246 247 248 249 250 251 252 253
-- | 'UniqFM' map from 'InstalledUnitId'
type InstalledUnitIdMap = UniqDFM

-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
-- the transitive closure of preload packages.
data PackageConfigMap = PackageConfigMap {
        unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
        -- | The set of transitively reachable packages according
        -- to the explicitly provided command line arguments.
        -- See Note [UnitId to InstalledUnitId improvement]
        preloadClosure :: UniqSet InstalledUnitId
    }
Edward Z. Yang's avatar
Edward Z. Yang committed
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269

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

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

Edward Z. Yang's avatar
Edward Z. Yang committed
279 280 281 282 283 284 285 286
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)
287 288 289 290 291 292 293 294 295 296 297

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
298 299 300 301 302 303 304 305
instance Monoid UnitVisibility where
    mempty = UnitVisibility
             { uv_expose_all = False
             , uv_renamings = []
             , uv_package_name = First Nothing
             , uv_requirements = Map.empty
             , uv_explicit = False
             }
306
    mappend = (Semigroup.<>)
307

308 309 310
type WiredUnitId = DefUnitId
type PreloadUnitId = InstalledUnitId

311 312 313 314 315
-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
-- (since this is the slow path, we'll just look it up again).
type ModuleToPkgConfAll =
    Map ModuleName (Map Module ModuleOrigin)
316

317
data PackageState = PackageState {
318
  -- | A mapping of 'UnitId' to 'PackageConfig'.  This list is adjusted
319 320 321 322
  -- so that only valid packages are here.  'PackageConfig' reflects
  -- 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'.)
323 324
  pkgIdMap              :: PackageConfigMap,

Edward Z. Yang's avatar
Edward Z. Yang committed
325 326 327 328 329 330
  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when
  -- users refer to packages in Backpack includes.
  packageNameMap            :: Map PackageName ComponentId,

  -- | A mapping from wired in names to the original names from the
  -- package database.
331
  unwireMap :: Map WiredUnitId WiredUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
332

333 334 335
  -- | 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.
336
  preloadPackages      :: [PreloadUnitId],
337

338 339 340 341
  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  explicitPackages      :: [UnitId],

342 343 344
  -- | 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.
345
  moduleToPkgConfAll    :: !ModuleToPkgConfAll,
346 347

  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
Edward Z. Yang's avatar
Edward Z. Yang committed
348 349 350 351 352 353 354 355 356
  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | 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.
357
  requirementContext :: Map ModuleName [IndefModule]
358 359
  }

360 361
emptyPackageState :: PackageState
emptyPackageState = PackageState {
niteria's avatar
niteria committed
362
    pkgIdMap = emptyPackageConfigMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
363 364
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
365
    preloadPackages = [],
366
    explicitPackages = [],
367
    moduleToPkgConfAll = Map.empty,
Edward Z. Yang's avatar
Edward Z. Yang committed
368 369
    pluginModuleToPkgConfAll = Map.empty,
    requirementContext = Map.empty
370 371
    }

372
type InstalledPackageIndex = Map InstalledUnitId PackageConfig
373

374
-- | Empty package configuration map
375
emptyPackageConfigMap :: PackageConfigMap
376
emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet
377

Edward Z. Yang's avatar
Edward Z. Yang committed
378
-- | Find the package we know about with the given unit id, if any
379
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
Edward Z. Yang's avatar
Edward Z. Yang committed
380 381 382 383 384 385 386
lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
-- be used while we're initializing 'DynFlags'
lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
387 388
lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
Edward Z. Yang's avatar
Edward Z. Yang committed
389
    case splitUnitIdInsts uid of
390 391
        (iuid, Just indef) ->
            fmap (renamePackage m (indefUnitIdInsts indef))
Edward Z. Yang's avatar
Edward Z. Yang committed
392 393 394
                 (lookupUDFM pkg_map iuid)
        (_, Nothing) -> lookupUDFM pkg_map uid

395
{-
Edward Z. Yang's avatar
Edward Z. Yang committed
396 397 398 399 400 401 402
-- | Find the indefinite package for a given 'ComponentId'.
-- The way this works is just by fiat'ing that every indefinite package's
-- unit key is precisely its component ID; and that they share uniques.
lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
  where
    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
403
-}
404

Edward Z. Yang's avatar
Edward Z. Yang committed
405 406 407 408
-- | 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)
lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
409 410

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
411
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
412 413
searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
                               (listPackageConfigMap dflags)
414

415
-- | Extends the package configuration map with a list of package configs.
416 417
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
418
extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
419
  = PackageConfigMap (foldl' add pkg_map new_pkgs) closure
Edward Z. Yang's avatar
Edward Z. Yang committed
420 421 422
    -- We also add the expanded version of the packageConfigId, so that
    -- 'improveUnitId' can find it.
  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
423
                                  (installedPackageConfigId p) p
424

425 426
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
427
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
428 429 430
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

431 432 433 434 435 436 437 438 439 440 441
lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid

lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid

getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails dflags uid =
    expectJust "getInstalledPackageDetails" $
        lookupInstalledPackage dflags uid

442
-- | Get a list of entries from the package database.  NB: be careful with
443 444 445
-- 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).
446
listPackageConfigMap :: DynFlags -> [PackageConfig]
Edward Z. Yang's avatar
Edward Z. Yang committed
447 448
listPackageConfigMap dflags = eltsUDFM pkg_map
  where
449
    PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)
450

451
-- ----------------------------------------------------------------------------
452
-- Loading the package db files and building up the package state
453

454
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
455
-- database files, and sets up various internal tables of package
456 457
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
458 459 460
--
-- 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
461
-- @-package@ flags.
462 463 464
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
465
-- 'pkgState' in 'DynFlags' and return a list of packages to
466
-- link in.
467
initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
468 469
initPackages dflags0 = do
  dflags <- interpretPackageEnv dflags0
470 471 472 473 474
  pkg_db <-
    case pkgDatabase dflags of
        Nothing -> readPackageConfigs dflags
        Just db -> return $ map (\(p, pkgs)
                                    -> (p, setBatchPackageFlags dflags pkgs)) db
475
  (pkg_state, preload, insts)
476
        <- mkPackageState dflags pkg_db []
477
  return (dflags{ pkgDatabase = Just pkg_db,
478 479
                  pkgState = pkg_state,
                  thisUnitIdInsts_ = insts },
480
          preload)
481 482

-- -----------------------------------------------------------------------------
483 484
-- Reading the package database(s)

485
readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
486
readPackageConfigs dflags = do
487 488
  conf_refs <- getPackageConfRefs dflags
  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
489 490
  mapM (readPackageConfig dflags) confs

491 492 493

getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
getPackageConfRefs dflags = do
494
  let system_conf_refs = [UserPkgConf, GlobalPkgConf]
495

496
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
497 498 499
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
500 501
         | not (null path) && isSearchPathSeparator (last path)
         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
502
         | otherwise
503
         -> map PkgConfFile (splitSearchPath path)
504

505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
  -- 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 _ = []

  isNotUser UserPkgConf = False
  isNotUser _ = True

  isNotGlobal GlobalPkgConf = False
  isNotGlobal _ = True
525 526 527

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
528 529 530
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal.  (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
531
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
532
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
533
  let pkgconf = dir </> "package.conf.d"
534 535
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
536
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
537

538
readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
539
readPackageConfig dflags conf_file = do
540 541
  isdir <- doesDirectoryExist conf_file

542
  proto_pkg_configs <-
543
    if isdir
544
       then readDirStylePackageConfig conf_file
545
       else do
546
            isfile <- doesFileExist conf_file
547
            if isfile
548 549 550 551 552
               then do
                 mpkgs <- tryReadOldFileStylePackageConfig
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
553 554 555 556
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
557 558
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
559

560 561
  let
      top_dir = topDir dflags
562
      pkgroot = takeDirectory conf_file
563 564
      pkg_configs1 = map (mungePackageConfig top_dir pkgroot)
                         proto_pkg_configs
565
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
566
  --
567
  return (conf_file, pkg_configs2)
568 569 570
  where
    readDirStylePackageConfig conf_dir = do
      let filename = conf_dir </> "package.cache"
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597
      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"

598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617

    -- 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.
    tryReadOldFileStylePackageConfig = do
      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)
                     liftM Just (readDirStylePackageConfig conf_dir)
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
618

619
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
620
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
621
  where
622
    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
623
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
624 625
      | otherwise                           = pkgs'

dterei's avatar
dterei committed
626
    distrust pkg = pkg{ trusted = False }
627

628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
mungePackageConfig :: FilePath -> FilePath
                   -> PackageConfig -> PackageConfig
mungePackageConfig top_dir pkgroot =
    mungeDynLibFields
  . mungePackagePaths top_dir pkgroot

mungeDynLibFields :: PackageConfig -> PackageConfig
mungeDynLibFields pkg =
    pkg {
      libraryDynDirs     = libraryDynDirs pkg
                `orIfNull` libraryDirs pkg
    }
  where
    orIfNull [] flags = flags
    orIfNull flags _  = flags

644
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
645 646 647 648 649 650 651 652 653 654 655 656 657 658
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
    pkg {
      importDirs  = munge_paths (importDirs pkg),
      includeDirs = munge_paths (includeDirs pkg),
      libraryDirs = munge_paths (libraryDirs pkg),
659
      libraryDynDirs = munge_paths (libraryDynDirs pkg),
660 661 662 663
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
664
  where
665 666 667 668
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
669 670 671
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
672 673

    munge_url p
674 675 676
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
677 678 679

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
680 681 682 683 684 685 686 687 688 689 690 691 692
                 ++ FilePath.Posix.joinPath
                        (r : -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             dropWhile (all isPathSeparator)
                                       (FilePath.splitDirectories p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix var path = case stripPrefix var path of
                              Just [] -> Just []
                              Just cs@(c : _) | isPathSeparator c -> Just cs
                              _ -> Nothing
693

694

695
-- -----------------------------------------------------------------------------
696 697 698 699 700
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
701
   -> PackagePrecedenceIndex
702 703 704 705
   -> UnusablePackages
   -> [PackageConfig]
   -> TrustFlag
   -> IO [PackageConfig]
706
applyTrustFlag dflags prec_map unusable pkgs flag =
707 708 709 710
  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 ->
711
       case selectPackages prec_map (PackageArg str) pkgs unusable of
712 713 714 715 716
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
          where trust p = p {trusted=True}

    DistrustPackage str ->
717
       case selectPackages prec_map (PackageArg str) pkgs unusable of
718 719 720
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
          where distrust p = p {trusted=False}
721

Edward Z. Yang's avatar
Edward Z. Yang committed
722 723 724 725 726
-- | A little utility to tell if the 'thisPackage' is indefinite
-- (if it is not, we should never use on-the-fly renaming.)
isIndefinite :: DynFlags -> Bool
isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))

727
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
728
   :: DynFlags
729
   -> PackagePrecedenceIndex
Edward Z. Yang's avatar
Edward Z. Yang committed
730
   -> PackageConfigMap
Ian Lynagh's avatar
Ian Lynagh committed
731
   -> UnusablePackages
732 733
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
734 735
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
736
   -> PackageFlag               -- flag to apply
737
   -> IO VisibilityMap        -- Now exposed
738

739
applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
740
  case flag of
741
    ExposePackage _ arg (ModRenaming b rns) ->
742
       case findPackages prec_map pkg_db arg pkgs unusable of
743
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
744
         Right (p:_) -> return vm'
745 746
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
747 748 749 750 751 752 753 754 755 756

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

           collectHoles uid = case splitUnitIdInsts uid of
757 758
                (_, Just indef) ->
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
759
                                  (moduleName mod)
760 761
                                  (Set.singleton $ IndefModule indef mod_name)
                              | (mod_name, mod) <- indefUnitIdInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
762 763
                              , isHoleModule mod ]
                      recurse = [ collectHoles (moduleUnitId mod)
764
                                | (_, mod) <- indefUnitIdInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
765 766 767 768 769 770 771 772 773 774 775 776 777
                  in Map.unionsWith Set.union $ local ++ recurse
                -- Other types of unit identities don't have holes
                (_, Nothing) -> Map.empty


           uv = UnitVisibility
                { uv_expose_all = b
                , uv_renamings = rns
                , uv_package_name = First (Just n)
                , uv_requirements = reqs
                , uv_explicit = True
                }
           vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
           -- 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
799 800 801 802 803
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
                            (\k uv -> k == packageConfigId p
                                   || First (Just n) /= uv_package_name uv) vm
804 805
         _ -> panic "applyPackageFlag"

806
    HidePackage str ->
807
       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
808 809 810 811 812 813 814
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
          where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
815 816
findPackages :: PackagePrecedenceIndex
             -> PackageConfigMap -> PackageArg -> [PackageConfig]
Edward Z. Yang's avatar
Edward Z. Yang committed
817 818 819
             -> UnusablePackages
             -> Either [(PackageConfig, UnusablePackageReason)]
                [PackageConfig]
820
findPackages prec_map pkg_db arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
821 822 823 824
  = 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))
825
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
826 827 828 829 830 831
  where
    finder (PackageArg str) p
      = if str == sourcePackageIdString p || str == packageNameString p
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
832
      = let (iuid, mb_indef) = splitUnitIdInsts uid
833
        in if iuid == installedPackageConfigId p
834
              then Just (case mb_indef of
Edward Z. Yang's avatar
Edward Z. Yang committed
835
                            Nothing    -> p
836
                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
Edward Z. Yang's avatar
Edward Z. Yang committed
837 838
              else Nothing

839
selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig]
840 841 842
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
843
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
844 845
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
846 847
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
848
        else Right (sortByPreference prec_map ps, rest)
849

Edward Z. Yang's avatar
Edward Z. Yang committed
850 851 852 853 854
-- | Rename a 'PackageConfig' according to some module instantiation.
renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
              -> PackageConfig -> PackageConfig
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
855 856
        smod  = renameHoleModule' pkg_map hsubst
        new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
857
    in conf {
858
        instantiatedWith = new_insts,
Edward Z. Yang's avatar
Edward Z. Yang committed
859 860 861 862 863
        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
                             (exposedModules conf)
    }


864 865
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
866 867
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
868 869
        =  str == sourcePackageIdString p
        || str == packageNameString p
870

871 872
matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId uid p = uid == installedPackageConfigId p
873

874 875
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
876 877
matching (UnitIdArg (DefiniteUnitId (DefUnitId uid)))  = matchingId uid
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
878

879 880 881 882 883 884 885 886 887 888 889 890 891 892
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
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
893
-- in later package database.
894
--
895 896 897 898 899 900 901
-- 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]
-- in the @PrelNames@ module.
902 903 904 905 906
compareByPreference
    :: PackagePrecedenceIndex
    -> PackageConfig
    -> PackageConfig
    -> Ordering
907 908 909 910 911 912 913 914
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
  = case comparing packageVersion pkg pkg' of
915 916 917 918 919 920 921 922 923
        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
924

925 926 927 928 929 930
  where isIntegerPkg p = packageNameString p `elem`
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
          (packageName p /= packageName p')

Ian Lynagh's avatar
Ian Lynagh committed
931
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
932 933
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
934 935
packageFlagErr :: DynFlags
               -> PackageFlag
936 937
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
938
packageFlagErr dflags flag reasons
939 940 941 942 943 944 945 946 947 948 949 950 951 952
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
             -> [(PackageConfig, UnusablePackageReason)]
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
packageFlagErr' dflags flag_doc reasons
953
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
954
  where err = text "cannot satisfy " <> flag_doc <>
955
                (if null reasons then Outputable.empty else text ": ") $$
956 957 958
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
959
        ppr_reason (p, reason) =
960
            pprReason (ppr (unitId p) <+> text "is") reason
961

962 963 964
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
965
    ExposePackage doc _ _ -> text doc
966

967 968 969 970 971
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

972 973
-- -----------------------------------------------------------------------------
-- Wired-in packages
974 975
--
-- See Note [Wired-in packages] in Module
976

977
type WiredInUnitId = String
978
type WiredPackagesMap = Map WiredUnitId WiredUnitId
979

980 981 982
wired_in_pkgids :: [WiredInUnitId]
wired_in_pkgids = map unitIdString wiredInUnitIds

983 984
findWiredInPackages
   :: DynFlags
985
   -> PackagePrecedenceIndex
986
   -> [PackageConfig]           -- database
987
   -> VisibilityMap             -- info on what packages are visible
988 989 990
                                -- for wired in selection
   -> IO ([PackageConfig],  -- package database updated for wired in
          WiredPackagesMap) -- map from unit id to wired identity
991

992
findWiredInPackages dflags prec_map pkgs vis_map = do
Simon Marlow's avatar
Simon Marlow committed
993
  -- Now we must find our wired-in packages, and rename them to
994 995
  -- their canonical names (eg. base-1.0 ==> base), as described
  -- in Note [Wired-in packages] in Module
Simon Marlow's avatar
Simon Marlow committed
996
  let
997 998 999 1000 1001
        matches :: PackageConfig -> WiredInUnitId -> Bool
        pc `matches` pid
            -- See Note [The integer library] in PrelNames
            | pid == unitIdString integerUnitId
            = packageNameString pc `elem` ["integer-gmp", "integer-simple"]
1002
        pc `matches` pid = packageNameString pc == pid
Simon Marlow's avatar
Simon Marlow committed
1003

1004 1005 1006 1007
        -- 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.
1008 1009
        --
        -- When choosing which package to map to a wired-in package
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
        -- name, we try to pick the latest version of exposed packages.
        -- However, if there are no exposed wired in packages available
        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
        -- to assign a package for the wired-in package: so we try again
        -- with hidden packages included to (and pick the latest
        -- version).
        --
        -- You can also override the default choice by using -ignore-package:
        -- this works even when there is no exposed wired in package
        -- available.
1020
        --
1021 1022
        findWiredInPackage :: [PackageConfig] -> WiredInUnitId
                           -> IO (Maybe (WiredInUnitId, PackageConfig))
1023
        findWiredInPackage pkgs wired_pkg =
1024 1025 1026
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
               all_exposed_ps =
                    [ p | p <- all_ps
Edward Z. Yang's avatar
Edward Z. Yang committed
1027
                        , Map.member (packageConfigId p) vis_map ] in
1028 1029 1030
           case all_exposed_ps of
            [] -> case all_ps of
                       []   -> notfound
1031 1032
                       many -> pick (head (sortByPreference prec_map many))
            many -> pick (head (sortByPreference prec_map many))
1033 1034
          where
                notfound = do
1035
                          debugTraceMsg dflags 2 $
1036
                            text "wired-in package "
1037
                                 <> text wired_pkg
1038
                                 <> text " not found."
1039
                          return Nothing
1040
                pick :: PackageConfig
1041
                     -> IO (Maybe (WiredInUnitId, PackageConfig))
1042 1043
                pick pkg = do
                        debugTraceMsg dflags 2 $
1044
                            text "wired-in package "
1045
                                 <> text wired_pkg
1046
                                 <> text " mapped to "
1047
                                 <> ppr (unitId pkg)
1048
                        return (Just (wired_pkg, pkg))
1049

Simon Marlow's avatar
Simon Marlow committed
1050

1051
  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
1052
  let
1053
        wired_in_pkgs = catMaybes mb_wired_in_pkgs
Simon Marlow's avatar
Simon Marlow committed
1054

1055 1056 1057 1058 1059 1060 1061 1062
        -- this is old: we used to assume that if there were
        -- multiple versions of wired-in packages installed that
        -- they were mutually exclusive.  Now we're assuming that
        -- you have one "main" version of each wired-in package
        -- (the latest version), and the others are backward-compat
        -- wrappers that depend on this one.  e.g. base-4.0 is the
        -- latest, base-3.0 is a compat wrapper depending on base-4.0.
        {-
1063 1064
        deleteOtherWiredInPackages pkgs = filterOut bad pkgs
          where bad p = any (p `matches`) wired_in_pkgids
1065 1066
                      && package p `notElem` map fst wired_in_ids
        -}
Simon Marlow's avatar
Simon Marlow committed
1067

1068
        wiredInMap :: Map WiredUnitId WiredUnitId
1069 1070 1071 1072 1073
        wiredInMap = Map.fromList
          [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId))
          | (wiredInUnitId, pkg) <- wired_in_pkgs
          , Just key <- pure $ definitePackageConfigId pkg
          ]
1074 1075

        updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
Duncan Coutts's avatar