State.hs 87.2 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
        unsafeGetUnitInfo,
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,
62
        isIndefinite,
63
    )
64 65 66
where

#include "HsVersions.h"
67

68
import GHC.Prelude
69

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

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

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

105 106 107
-- ---------------------------------------------------------------------------
-- The Package state

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

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

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

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

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

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

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

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

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

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

243 244 245 246 247 248 249 250 251 252 253 254 255
-- | 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
256

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

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

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

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

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

310
type WiredUnitId = DefUnitId
311
type PreloadUnitId = UnitId
312

313 314 315 316 317 318
-- | Map from 'ModuleName' to a set of of module providers (i.e. a 'Module' and
-- its 'ModuleOrigin').
--
-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
-- origin for a given 'Module'
type ModuleNameProvidersMap =
319
    Map ModuleName (Map Module ModuleOrigin)
320

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

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

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

337 338 339
  -- | The packages we're going to link in eagerly.  This list
  -- should be in reverse dependency order; that is, a package
  -- is always mentioned before the packages it depends on.
340
  preloadPackages      :: [PreloadUnitId],
341

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

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

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

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

364 365
emptyPackageState :: PackageState
emptyPackageState = PackageState {
366
    unitInfoMap = emptyUnitInfoMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
367 368
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
369
    preloadPackages = [],
370
    explicitPackages = [],
371 372
    moduleNameProvidersMap = Map.empty,
    pluginModuleNameProvidersMap = Map.empty,
Edward Z. Yang's avatar
Edward Z. Yang committed
373
    requirementContext = Map.empty
374 375
    }

376
-- | Package database
377
data PackageDatabase unit = PackageDatabase
378
   { packageDatabasePath  :: FilePath
379
   , packageDatabaseUnits :: [GenUnitInfo unit]
380 381
   }

382
type InstalledPackageIndex = Map UnitId UnitInfo
383

384
-- | Empty package configuration map
385 386
emptyUnitInfoMap :: UnitInfoMap
emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet
387

388
-- | Find the unit we know about with the given unit id, if any
389
lookupUnit :: DynFlags -> Unit -> Maybe UnitInfo
390
lookupUnit dflags = lookupUnit' (isIndefinite dflags) (unitInfoMap (pkgState dflags))
Edward Z. Yang's avatar
Edward Z. Yang committed
391 392 393

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
394
-- just a 'UnitInfoMap' rather than a 'DynFlags' (so it can
Edward Z. Yang's avatar
Edward Z. Yang committed
395
-- be used while we're initializing 'DynFlags'
396 397 398 399 400 401 402
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
403 404 405

-- | 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)
406
lookupPackageName :: PackageState -> PackageName -> Maybe IndefUnitId
Sylvain Henry's avatar
Sylvain Henry committed
407
lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
408 409

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

414
-- | Extends the package configuration map with a list of package configs.
415 416 417 418
extendUnitInfoMap
   :: UnitInfoMap -> [UnitInfo] -> UnitInfoMap
extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs
  = UnitInfoMap (foldl' add pkg_map new_pkgs) closure
419 420
    -- We also add the expanded version of the mkUnit, so that
    -- 'improveUnit' can find it.
421
  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedUnitInfoId p) p)
422
                                  (unitId p) p
423

424 425
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
426 427
unsafeGetUnitInfo :: HasDebugCallStack => DynFlags -> Unit -> UnitInfo
unsafeGetUnitInfo dflags pid =
428
    case lookupUnit dflags pid of
Ben Gamari's avatar
Ben Gamari committed
429
      Just config -> config
430
      Nothing -> pprPanic "unsafeGetUnitInfo" (ppr pid)
431

432
lookupInstalledPackage :: PackageState -> UnitId -> Maybe UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
433
lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid
434

435
lookupInstalledPackage' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
436
lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid
437

438
getInstalledPackageDetails :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
439 440
getInstalledPackageDetails pkgstate uid =
    case lookupInstalledPackage pkgstate uid of
Ben Gamari's avatar
Ben Gamari committed
441 442
      Just config -> config
      Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid)
443

444
-- | Get a list of entries from the package database.  NB: be careful with
445 446 447
-- 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
448 449
listUnitInfoMap :: PackageState -> [UnitInfo]
listUnitInfoMap pkgstate = eltsUDFM pkg_map
Edward Z. Yang's avatar
Edward Z. Yang committed
450
  where
Sylvain Henry's avatar
Sylvain Henry committed
451
    UnitInfoMap pkg_map _ = unitInfoMap pkgstate
452

453
-- ----------------------------------------------------------------------------
454
-- Loading the package db files and building up the package state
455

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

484
  (pkg_state, preload, insts)
485 486
        <- mkPackageState dflags pkg_dbs []
  return (dflags{ pkgDatabase = Just read_pkg_dbs,
487 488
                  pkgState = pkg_state,
                  thisUnitIdInsts_ = insts },
489
          preload)
490
  where
491
    forcePkgDb (dflags, _) = unitInfoMap (pkgState dflags) `seq` ()
492 493

-- -----------------------------------------------------------------------------
494 495
-- Reading the package database(s)

496
readPackageDatabases :: DynFlags -> IO [PackageDatabase UnitId]
497
readPackageDatabases dflags = do
498
  conf_refs <- getPackageConfRefs dflags
499 500
  confs     <- liftM catMaybes $ mapM (resolvePackageDatabase dflags) conf_refs
  mapM (readPackageDatabase dflags) confs
501

502

503
getPackageConfRefs :: DynFlags -> IO [PkgDbRef]
504
getPackageConfRefs dflags = do
505
  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
506

507
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
508 509 510
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
511
         | not (null path) && isSearchPathSeparator (last path)
512
         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
513
         | otherwise
514
         -> map PkgDbPath (splitSearchPath path)
515

516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
  -- 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 _ = []

531
  isNotUser UserPkgDb = False
532 533
  isNotUser _ = True

534
  isNotGlobal GlobalPkgDb = False
535
  isNotGlobal _ = True
536

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

552
readPackageDatabase :: DynFlags -> FilePath -> IO (PackageDatabase UnitId)
553
readPackageDatabase dflags conf_file = do
554 555
  isdir <- doesDirectoryExist conf_file

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

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

613 614 615 616 617 618 619 620 621

    -- 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.
622
    tryReadOldFileStyleUnitInfo = do
623 624 625 626 627 628 629
      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)
630
                     liftM Just (readDirStyleUnitInfo conf_dir)
631 632
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
633

634 635
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits pkgs = map distrust pkgs
636
  where
Sylvain Henry's avatar
Sylvain Henry committed
637
    distrust pkg = pkg{ unitIsTrusted = False }
638

639 640 641
mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
642
    mungeDynLibFields
643
  . mungeUnitInfoPaths top_dir pkgroot
644

645
mungeDynLibFields :: UnitInfo -> UnitInfo
646 647
mungeDynLibFields pkg =
    pkg {
Sylvain Henry's avatar
Sylvain Henry committed
648 649 650
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> unitLibraryDirs pkg
         ds -> ds
651 652
    }

653
-- -----------------------------------------------------------------------------
654 655 656 657 658
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
659
   -> PackagePrecedenceIndex
660
   -> UnusablePackages
661
   -> [UnitInfo]
662
   -> TrustFlag
663
   -> IO [UnitInfo]
664
applyTrustFlag dflags prec_map unusable pkgs flag =
665 666 667 668
  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 ->
669
       case selectPackages prec_map (PackageArg str) pkgs unusable of
670 671
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
Sylvain Henry's avatar
Sylvain Henry committed
672
          where trust p = p {unitIsTrusted=True}
673 674

    DistrustPackage str ->
675
       case selectPackages prec_map (PackageArg str) pkgs unusable of
676
         Left ps       -> trustFlagErr dflags flag ps
677
         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
678

Edward Z. Yang's avatar
Edward Z. Yang committed
679 680 681
-- | 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
682
isIndefinite dflags = not (unitIsDefinite (thisPackage dflags))
Edward Z. Yang's avatar
Edward Z. Yang committed
683

684
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
685
   :: DynFlags
686
   -> PackagePrecedenceIndex
687
   -> UnitInfoMap
Ian Lynagh's avatar
Ian Lynagh committed
688
   -> UnusablePackages
689 690
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
691
   -> [UnitInfo]
692
   -> VisibilityMap           -- Initially exposed
693
   -> PackageFlag               -- flag to apply
694
   -> IO VisibilityMap        -- Now exposed
695

696
applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
697
  case flag of
698
    ExposePackage _ arg (ModRenaming b rns) ->
699
       case findPackages prec_map pkg_db arg pkgs unusable of
700
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
701
         Right (p:_) -> return vm'
702 703
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
704 705 706 707 708 709 710 711 712

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

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

762
    HidePackage str ->
763
       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
764 765
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
766
          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
767 768 769 770

-- | 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.
771
findPackages :: PackagePrecedenceIndex
772
             -> UnitInfoMap -> PackageArg -> [UnitInfo]
Edward Z. Yang's avatar
Edward Z. Yang committed
773
             -> UnusablePackages
774 775
             -> Either [(UnitInfo, UnusablePackageReason)]
                [UnitInfo]
776
findPackages prec_map pkg_db arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
777 778 779 780
  = 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))
781
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
782 783
  where
    finder (PackageArg str) p
Sylvain Henry's avatar
Sylvain Henry committed
784
      = if str == unitPackageIdString p || str == unitPackageNameString p
Edward Z. Yang's avatar
Edward Z. Yang committed
785 786 787
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
788 789 790 791 792 793 794 795
      = 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
796

797
selectPackages :: PackagePrecedenceIndex -> PackageArg -> [UnitInfo]
798
               -> UnusablePackages
799 800
               -> Either [(UnitInfo, UnusablePackageReason)]
                  ([UnitInfo], [UnitInfo])
801
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
802 803
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
804 805
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
806
        else Right (sortByPreference prec_map ps, rest)
807

808 809 810
-- | Rename a 'UnitInfo' according to some module instantiation.
renamePackage :: UnitInfoMap -> [(ModuleName, Module)]
              -> UnitInfo -> UnitInfo
Edward Z. Yang's avatar
Edward Z. Yang committed
811 812
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
813
        smod  = renameHoleModule' pkg_map hsubst
Sylvain Henry's avatar
Sylvain Henry committed
814
        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
815
    in conf {
Sylvain Henry's avatar
Sylvain Henry committed
816 817 818
        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
819 820 821
    }


822 823
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
824
matchingStr :: String -> UnitInfo -> Bool
825
matchingStr str p
Sylvain Henry's avatar
Sylvain Henry committed
826 827
        =  str == unitPackageIdString p
        || str == unitPackageNameString p
828

829 830
matchingId :: UnitId -> UnitInfo -> Bool
matchingId uid p = uid == unitId p
831

832
matching :: PackageArg -> UnitInfo -> Bool
833
matching (PackageArg str) = matchingStr str
834
matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
835
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
836

837 838
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
839
sortByPreference :: PackagePrecedenceIndex -> [UnitInfo] -> [UnitInfo]
840 841 842 843 844 845 846 847 848 849 850
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
851
-- in later package database.
852
--
853 854 855 856 857 858
-- 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
859
-- in the @GHC.Builtin.Names@ module.
860 861
compareByPreference
    :: PackagePrecedenceIndex
862 863
    -> UnitInfo
    -> UnitInfo
864
    -> Ordering
865 866 867 868 869 870 871
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
872
  = case comparing unitPackageVersion pkg pkg' of
873 874 875 876 877 878 879 880 881
        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
882

Sylvain Henry's avatar
Sylvain Henry committed
883
  where isIntegerPkg p = unitPackageNameString p `elem`
884 885 886
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
Sylvain Henry's avatar
Sylvain Henry committed
887
          (unitPackageName p /= unitPackageName p')
888

Ian Lynagh's avatar
Ian Lynagh committed
889
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
890 891
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
892 893
packageFlagErr :: DynFlags
               -> PackageFlag
894
               -> [(UnitInfo, UnusablePackageReason)]
895
               -> IO a
896
packageFlagErr dflags flag reasons
897 898 899 900
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
901
             -> [(UnitInfo, UnusablePackageReason)]
902 903 904 905 906 907
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
908
               -> [(UnitInfo, UnusablePackageReason)]
909 910
               -> IO a
packageFlagErr' dflags flag_doc reasons
911
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
912
  where err = text "cannot satisfy " <> flag_doc <>
913
                (if null reasons then Outputable.empty else text ": ") $$
914 915 916
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
917
        ppr_reason (p, reason) =
918
            pprReason (ppr (unitId p) <+> text "is") reason
919

920 921 922
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
923
    ExposePackage doc _ _ -> text doc
924

925 926 927 928 929
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

930
-- -----------------------------------------------------------------------------
931
-- Wired-in units
932
--
933
-- See Note [Wired-in units] in GHC.Unit.Module
934

935
type WiredInUnitId = String
936
type WiredPackagesMap = Map WiredUnitId WiredUnitId
937

938
wired_in_unitids :: [WiredInUnitId]
939
wired_in_unitids = map unitString wiredInUnitIds
940

941 942
findWiredInPackages
   :: DynFlags
943
   -> PackagePrecedenceIndex
944
   -> [UnitInfo]           -- database
945
   -> VisibilityMap             -- info on what packages are visible
946
                                -- for wired in selection
947
   -> IO ([UnitInfo],  -- package database updated for wired in
948
          WiredPackagesMap)