State.hs 88 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(..),
11 12
        PackageDatabase (..),
        UnitInfoMap,
13
        emptyPackageState,
14
        initPackages,
15 16
        readPackageDatabases,
        readPackageDatabase,
17
        getPackageConfRefs,
18 19
        resolvePackageDatabase,
        listUnitInfoMap,
20 21

        -- * Querying the package config
22 23
        lookupUnit,
        lookupUnit',
24
        lookupInstalledPackage,
Edward Z. Yang's avatar
Edward Z. Yang committed
25
        lookupPackageName,
26
        improveUnit,
27
        searchPackageId,
28
        unsafeLookupUnit,
29
        getInstalledPackageDetails,
30
        displayUnitId,
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 48

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
        getPreloadPackagesAnd,
49

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

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

#include "HsVersions.h"
68

69
import GHC.Prelude
70

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

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

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

106 107 108
-- ---------------------------------------------------------------------------
-- The Package state

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

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

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

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

201 202 203 204
-- | 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
205

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

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

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

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

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

244 245 246 247 248 249 250 251 252 253 254 255 256
-- | Map from 'UnitId' to 'UnitInfo', plus
-- the transitive closure of preload units.
data UnitInfoMap = UnitInfoMap
   { unUnitInfoMap :: UniqDFM UnitInfo
      -- ^ 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
257

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

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

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

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

311
type WiredUnitId = DefUnitId
312
type PreloadUnitId = UnitId
313

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

322
data PackageState = PackageState {
323
  -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
324
  -- so that only valid packages are here.  'UnitInfo' reflects
325 326 327
  -- 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'.)
328
  unitInfoMap :: UnitInfoMap,
329

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

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

338 339 340
  -- | 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.
341
  preloadPackages      :: [PreloadUnitId],
342

343 344
  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
345
  explicitPackages      :: [Unit],
346

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

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

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

371 372
emptyPackageState :: PackageState
emptyPackageState = PackageState {
373
    unitInfoMap = emptyUnitInfoMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
374 375
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
376
    preloadPackages = [],
377
    explicitPackages = [],
378 379
    moduleNameProvidersMap = Map.empty,
    pluginModuleNameProvidersMap = Map.empty,
380 381
    requirementContext = Map.empty,
    allowVirtualUnits = False
382 383
    }

384
-- | Package database
385
data PackageDatabase unit = PackageDatabase
386
   { packageDatabasePath  :: FilePath
387
   , packageDatabaseUnits :: [GenUnitInfo unit]
388 389
   }

390
type InstalledPackageIndex = Map UnitId UnitInfo
391

392
-- | Empty package configuration map
393 394
emptyUnitInfoMap :: UnitInfoMap
emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet
395

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

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

-- | 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)
414
lookupPackageName :: PackageState -> PackageName -> Maybe IndefUnitId
Sylvain Henry's avatar
Sylvain Henry committed
415
lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
416 417

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
Sylvain Henry's avatar
Sylvain Henry committed
418 419
searchPackageId :: PackageState -> PackageId -> [UnitInfo]
searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
Sylvain Henry's avatar
Sylvain Henry committed
420
                               (listUnitInfoMap pkgstate)
421

422
-- | Extends the package configuration map with a list of package configs.
423 424 425 426
extendUnitInfoMap
   :: UnitInfoMap -> [UnitInfo] -> UnitInfoMap
extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs
  = UnitInfoMap (foldl' add pkg_map new_pkgs) closure
427 428
    -- We also add the expanded version of the mkUnit, so that
    -- 'improveUnit' can find it.
429
  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedUnitInfoId p) p)
430
                                  (unitId p) p
431

432 433
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
434 435 436 437 438
unsafeLookupUnit :: HasDebugCallStack => PackageState -> Unit -> UnitInfo
unsafeLookupUnit pkgs pid =
    case lookupUnit pkgs pid of
      Just info -> info
      Nothing   -> pprPanic "unsafeLookupUnit" (ppr pid)
439

440
lookupInstalledPackage :: PackageState -> UnitId -> Maybe UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
441
lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid
442

443
lookupInstalledPackage' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
444
lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid
445

446
getInstalledPackageDetails :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
447 448
getInstalledPackageDetails pkgstate uid =
    case lookupInstalledPackage pkgstate uid of
Ben Gamari's avatar
Ben Gamari committed
449 450
      Just config -> config
      Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid)
451

452
-- | Get a list of entries from the package database.  NB: be careful with
453 454 455
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
Sylvain Henry's avatar
Sylvain Henry committed
456 457
listUnitInfoMap :: PackageState -> [UnitInfo]
listUnitInfoMap pkgstate = eltsUDFM pkg_map
Edward Z. Yang's avatar
Edward Z. Yang committed
458
  where
Sylvain Henry's avatar
Sylvain Henry committed
459
    UnitInfoMap pkg_map _ = unitInfoMap pkgstate
460

461
-- ----------------------------------------------------------------------------
462
-- Loading the package db files and building up the package state
463

464 465
-- | Read the package database files, and sets up various internal tables of
-- package information, according to the package-related flags on the
466
-- command-line (@-package@, @-hide-package@ etc.)
467 468 469
--
-- 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
470
-- @-package@ flags.
471 472 473
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
474
-- 'pkgState' in 'DynFlags' and return a list of packages to
475
-- link in.
476
initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
477
initPackages dflags = withTiming dflags
478 479
                                  (text "initializing package database")
                                  forcePkgDb $ do
480
  read_pkg_dbs <-
481
    case pkgDatabase dflags of
482 483 484 485 486 487 488 489 490 491
        Nothing  -> readPackageDatabases dflags
        Just dbs -> return dbs

  let
      distrust_all db = db { packageDatabaseUnits = distrustAllUnits (packageDatabaseUnits db) }

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

492
  (pkg_state, preload, insts)
493 494
        <- mkPackageState dflags pkg_dbs []
  return (dflags{ pkgDatabase = Just read_pkg_dbs,
495
                  pkgState = pkg_state,
Sylvain Henry's avatar
Sylvain Henry committed
496
                  homeUnitInstantiations = insts },
497
          preload)
498
  where
499
    forcePkgDb (dflags, _) = unitInfoMap (pkgState dflags) `seq` ()
500 501

-- -----------------------------------------------------------------------------
502 503
-- Reading the package database(s)

504
readPackageDatabases :: DynFlags -> IO [PackageDatabase UnitId]
505
readPackageDatabases dflags = do
506
  conf_refs <- getPackageConfRefs dflags
507 508
  confs     <- liftM catMaybes $ mapM (resolvePackageDatabase dflags) conf_refs
  mapM (readPackageDatabase dflags) confs
509

510

511
getPackageConfRefs :: DynFlags -> IO [PkgDbRef]
512
getPackageConfRefs dflags = do
513
  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
514

515
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
516 517 518
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
519
         | not (null path) && isSearchPathSeparator (last path)
520
         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
521
         | otherwise
522
         -> map PkgDbPath (splitSearchPath path)
523

524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
  -- 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 _ = []

539
  isNotUser UserPkgDb = False
540 541
  isNotUser _ = True

542
  isNotGlobal GlobalPkgDb = False
543
  isNotGlobal _ = True
544

545 546 547
-- | 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.
--
548
-- NB: This logic is reimplemented in Cabal, so if you change it,
549
-- make sure you update Cabal. (Or, better yet, dump it in the
550
-- compiler info so Cabal can use the info.)
551 552 553
resolvePackageDatabase :: DynFlags -> PkgDbRef -> IO (Maybe FilePath)
resolvePackageDatabase dflags GlobalPkgDb = return $ Just (globalPackageDatabasePath dflags)
resolvePackageDatabase dflags UserPkgDb = runMaybeT $ do
554
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
555
  let pkgconf = dir </> "package.conf.d"
556 557
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
558
resolvePackageDatabase _ (PkgDbPath name) = return $ Just name
559

560
readPackageDatabase :: DynFlags -> FilePath -> IO (PackageDatabase UnitId)
561
readPackageDatabase dflags conf_file = do
562 563
  isdir <- doesDirectoryExist conf_file

564
  proto_pkg_configs <-
565
    if isdir
566
       then readDirStyleUnitInfo conf_file
567
       else do
568
            isfile <- doesFileExist conf_file
569
            if isfile
570
               then do
571
                 mpkgs <- tryReadOldFileStyleUnitInfo
572 573 574
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
575 576 577 578
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
579 580
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
581

582
  let
583
      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
584
      conf_file' = dropTrailingPathSeparator conf_file
585
      top_dir = topDir dflags
586
      pkgroot = takeDirectory conf_file'
587
      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo)
588
                         proto_pkg_configs
589
  --
590
  return $ PackageDatabase conf_file' pkg_configs1
591
  where
592
    readDirStyleUnitInfo conf_dir = do
593
      let filename = conf_dir </> "package.cache"
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620
      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"

621 622 623 624 625 626 627 628 629

    -- 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.
630
    tryReadOldFileStyleUnitInfo = do
631 632 633 634 635 636 637
      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)
638
                     liftM Just (readDirStyleUnitInfo conf_dir)
639 640
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
641

642 643
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits pkgs = map distrust pkgs
644
  where
Sylvain Henry's avatar
Sylvain Henry committed
645
    distrust pkg = pkg{ unitIsTrusted = False }
646

647 648 649
mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
650
    mungeDynLibFields
651
  . mungeUnitInfoPaths top_dir pkgroot
652

653
mungeDynLibFields :: UnitInfo -> UnitInfo
654 655
mungeDynLibFields pkg =
    pkg {
Sylvain Henry's avatar
Sylvain Henry committed
656 657 658
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> unitLibraryDirs pkg
         ds -> ds
659 660
    }

661
-- -----------------------------------------------------------------------------
662 663 664 665 666
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
667
   -> PackagePrecedenceIndex
668
   -> UnusablePackages
669
   -> [UnitInfo]
670
   -> TrustFlag
671
   -> IO [UnitInfo]
672
applyTrustFlag dflags prec_map unusable pkgs flag =
673 674 675 676
  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 ->
677
       case selectPackages prec_map (PackageArg str) pkgs unusable of
678 679
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
Sylvain Henry's avatar
Sylvain Henry committed
680
          where trust p = p {unitIsTrusted=True}
681 682

    DistrustPackage str ->
683
       case selectPackages prec_map (PackageArg str) pkgs unusable of
684
         Left ps       -> trustFlagErr dflags flag ps
685
         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
686

Sylvain Henry's avatar
Sylvain Henry committed
687
-- | A little utility to tell if the home unit is indefinite
Edward Z. Yang's avatar
Edward Z. Yang committed
688
-- (if it is not, we should never use on-the-fly renaming.)
Sylvain Henry's avatar
Sylvain Henry committed
689 690 691 692 693 694 695
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
696

697
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
698
   :: DynFlags
699
   -> PackagePrecedenceIndex
700
   -> UnitInfoMap
Ian Lynagh's avatar
Ian Lynagh committed
701
   -> UnusablePackages
702 703
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
704
   -> [UnitInfo]
705
   -> VisibilityMap           -- Initially exposed
706
   -> PackageFlag               -- flag to apply
707
   -> IO VisibilityMap        -- Now exposed
708

709
applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
710
  case flag of
711
    ExposePackage _ arg (ModRenaming b rns) ->
712
       case findPackages prec_map pkg_db arg pkgs unusable of
713
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
714
         Right (p:_) -> return vm'
715 716
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
717 718 719 720 721 722 723 724 725

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

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

775
    HidePackage str ->
776
       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
777 778
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
779
          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
780 781 782 783

-- | 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.
784
findPackages :: PackagePrecedenceIndex
785
             -> UnitInfoMap -> PackageArg -> [UnitInfo]
Edward Z. Yang's avatar
Edward Z. Yang committed
786
             -> UnusablePackages
787 788
             -> Either [(UnitInfo, UnusablePackageReason)]
                [UnitInfo]
789
findPackages prec_map pkg_db arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
790 791 792 793
  = 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))
794
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
795 796
  where
    finder (PackageArg str) p
Sylvain Henry's avatar
Sylvain Henry committed
797
      = if str == unitPackageIdString p || str == unitPackageNameString p
Edward Z. Yang's avatar
Edward Z. Yang committed
798 799 800
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
801 802 803 804 805 806 807 808
      = case uid of
          RealUnit (Definite iuid)
            | iuid == unitId p
            -> Just p
          VirtUnit inst
            | indefUnit (instUnitInstanceOf inst) == unitId p
            -> Just (renamePackage pkg_db (instUnitInsts inst) p)
          _ -> Nothing
Edward Z. Yang's avatar
Edward Z. Yang committed
809

810
selectPackages :: PackagePrecedenceIndex -> PackageArg -> [UnitInfo]
811
               -> UnusablePackages
812 813
               -> Either [(UnitInfo, UnusablePackageReason)]
                  ([UnitInfo], [UnitInfo])
814
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
815 816
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
817 818
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
819
        else Right (sortByPreference prec_map ps, rest)
820

821 822 823
-- | Rename a 'UnitInfo' according to some module instantiation.
renamePackage :: UnitInfoMap -> [(ModuleName, Module)]
              -> UnitInfo -> UnitInfo
Edward Z. Yang's avatar
Edward Z. Yang committed
824 825
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
826
        smod  = renameHoleModule' pkg_map hsubst
Sylvain Henry's avatar
Sylvain Henry committed
827
        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
828
    in conf {
Sylvain Henry's avatar
Sylvain Henry committed
829 830 831
        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
832 833 834
    }


835 836
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
837
matchingStr :: String -> UnitInfo -> Bool
838
matchingStr str p
Sylvain Henry's avatar
Sylvain Henry committed
839 840
        =  str == unitPackageIdString p
        || str == unitPackageNameString p
841

842 843
matchingId :: UnitId -> UnitInfo -> Bool
matchingId uid p = uid == unitId p
844

845
matching :: PackageArg -> UnitInfo -> Bool
846
matching (PackageArg str) = matchingStr str
847
matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
848
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
849

850 851
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
852
sortByPreference :: PackagePrecedenceIndex -> [UnitInfo] -> [UnitInfo]
853 854 855 856 857 858 859 860 861 862 863
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
864
-- in later package database.
865
--
866 867 868 869 870 871
-- 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
872
-- in the @GHC.Builtin.Names@ module.
873 874
compareByPreference
    :: PackagePrecedenceIndex
875 876
    -> UnitInfo
    -> UnitInfo
877
    -> Ordering
878 879 880 881 882 883 884
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
885
  = case comparing unitPackageVersion pkg pkg' of
886 887 888 889 890 891 892 893 894
        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
895

Sylvain Henry's avatar
Sylvain Henry committed
896
  where isIntegerPkg p = unitPackageNameString p `elem`
897 898 899
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
Sylvain Henry's avatar
Sylvain Henry committed
900
          (unitPackageName p /= unitPackageName p')
901

Ian Lynagh's avatar
Ian Lynagh committed
902
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
903 904
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
905 906
packageFlagErr :: DynFlags
               -> PackageFlag
907
               -> [(UnitInfo, UnusablePackageReason)]
908
               -> IO a
909
packageFlagErr dflags flag reasons
910 911 912 913
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
914
             -> [(UnitInfo, UnusablePackageReason)]
915 916 917 918 919 920
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
921
               -> [(UnitInfo, UnusablePackageReason)]
922 923
               -> IO a
packageFlagErr' dflags flag_doc reasons
924
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
925
  where err = text "cannot satisfy " <> flag_doc <>
926
                (if null reasons then Outputable.empty else text ": ") $$
927 928 929
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
930
        ppr_reason (p, reason) =
931
            pprReason (ppr (unitId p) <+> text "is") reason
932

933 934 935
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
936
    ExposePackage doc _ _ -> text doc
937

938 939 940 941 942
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

943
-- -----------------------------------------------------------------------------
944
-- Wired-in units
945
--
946
-- See Note [Wired-in units] in GHC.Unit.Module
947

948
type WiredInUnitId = String
949
type WiredPackagesMap = Map WiredUnitId WiredUnitId
950

951
wired_in_unitids :: [WiredInUnitId]
952
wired_in_unitids = map unitString wiredInUnitIds
953

954 955
findWiredInPackages
   :: DynFlags
956
   -> PackagePrecedenceIndex
957
   -> [UnitInfo]           -- database
958
   -> VisibilityMap             -- info on what packages are visible
959
                                -- for wired in selection
960
   -> IO ([UnitInfo],  -- package database updated for wired in