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

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

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

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

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

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

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

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

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

#include "HsVersions.h"
78

79
import GHC.Prelude
80

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

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

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

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

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

-- Notes on DLLs
-- ~~~~~~~~~~~~~
157 158 159 160
-- 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
161 162 163
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

164
-- | Given a module name, there may be multiple ways it came into scope,
165 166 167
-- 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!
168
data ModuleOrigin =
169 170 171 172
    -- | 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
173
    -- | Module is unavailable because the package is unusable.
Sylvain Henry's avatar
Sylvain Henry committed
174
  | ModUnusable UnusableUnitReason
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.
Sylvain Henry's avatar
Sylvain Henry committed
181
        fromOrigUnit :: Maybe Bool
182 183
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
184
      , fromExposedReexport :: [UnitInfo]
185
        -- | Is the module available from a reexport of a hidden package?
186
      , fromHiddenReexport :: [UnitInfo]
187 188 189 190 191 192
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
193
    ppr ModHidden = text "hidden module"
194
    ppr (ModUnusable _) = text "unusable module"
195 196 197 198 199 200 201 202
    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" <+>
203
                    sep (map (ppr . mkUnit) res)]) ++
204 205 206
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
207
                    sep (map (ppr . mkUnit) res)]) ++
208 209 210
        (if f then [text "package flag"] else [])
        ))

211 212 213 214
-- | 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
215

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

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

227 228 229 230 231 232 233 234 235 236
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"

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

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
243 244
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
245
originVisible (ModUnusable _) = False
246 247 248 249 250 251 252
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
253

254 255
type PreloadUnitClosure = UniqSet UnitId

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

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

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

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

309 310 311 312 313 314
-- | 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 =
315
    Map ModuleName (Map Module ModuleOrigin)
316

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

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

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

336 337 338 339
  -- | A mapping from database unit keys to wired in unit ids.
  wireMap :: Map UnitId UnitId,

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

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

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

351 352 353
  -- | 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.
354
  moduleNameProvidersMap    :: !ModuleNameProvidersMap,
355

356 357
  -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
  pluginModuleNameProvidersMap    :: !ModuleNameProvidersMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
358 359 360 361 362 363 364 365

  -- | 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.
366 367 368 369 370 371 372
  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
373 374
  }

Sylvain Henry's avatar
Sylvain Henry committed
375 376
emptyUnitState :: UnitState
emptyUnitState = UnitState {
Sylvain Henry's avatar
Sylvain Henry committed
377 378
    unitInfoMap = Map.empty,
    preloadClosure = emptyUniqSet,
Edward Z. Yang's avatar
Edward Z. Yang committed
379
    packageNameMap = Map.empty,
380
    wireMap   = Map.empty,
Edward Z. Yang's avatar
Edward Z. Yang committed
381
    unwireMap = Map.empty,
Sylvain Henry's avatar
Sylvain Henry committed
382 383
    preloadUnits = [],
    explicitUnits = [],
384 385
    moduleNameProvidersMap = Map.empty,
    pluginModuleNameProvidersMap = Map.empty,
386 387
    requirementContext = Map.empty,
    allowVirtualUnits = False
388 389
    }

Sylvain Henry's avatar
Sylvain Henry committed
390 391 392 393
-- | Unit database
data UnitDatabase unit = UnitDatabase
   { unitDatabasePath  :: FilePath
   , unitDatabaseUnits :: [GenUnitInfo unit]
394 395
   }

Sylvain Henry's avatar
Sylvain Henry committed
396
type UnitInfoMap = Map UnitId UnitInfo
397

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

Sylvain Henry's avatar
Sylvain Henry committed
402
-- | A more specialized interface, which doesn't require a 'UnitState' (so it
Sylvain Henry's avatar
Sylvain Henry committed
403 404 405 406 407 408 409 410
-- can be used while we're initializing 'DynFlags')
--
-- Parameters:
--    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
--    * a 'UnitInfoMap'
--    * a 'PreloadUnitClosure'
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of
411
   HoleUnit   -> error "Hole unit"
412 413 414 415 416
   RealUnit i -> Map.lookup (unDefinite i) pkg_map
   VirtUnit i
      | allowOnTheFlyInst
      -> -- lookup UnitInfo of the indefinite unit to be instantiated and
         -- instantiate it on-the-fly
Sylvain Henry's avatar
Sylvain Henry committed
417
         fmap (renameUnitInfo pkg_map closure (instUnitInsts i))
418 419 420 421 422 423 424 425
           (Map.lookup (indefUnit (instUnitInstanceOf i)) pkg_map)

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

Sylvain Henry's avatar
Sylvain Henry committed
427
-- | Find the unit we know about with the given unit id, if any
Sylvain Henry's avatar
Sylvain Henry committed
428
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
429 430 431
lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid

-- | Find the unit we know about with the given unit id, if any
Sylvain Henry's avatar
Sylvain Henry committed
432 433
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' db uid = Map.lookup uid db
Sylvain Henry's avatar
Sylvain Henry committed
434 435 436


-- | Looks up the given unit in the package state, panicing if it is not found
Sylvain Henry's avatar
Sylvain Henry committed
437
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
438 439 440 441 442
unsafeLookupUnit state u = case lookupUnit state u of
   Just info -> info
   Nothing   -> pprPanic "unsafeLookupUnit" (ppr u)

-- | Looks up the given unit id in the package state, panicing if it is not found
Sylvain Henry's avatar
Sylvain Henry committed
443
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
Sylvain Henry's avatar
Sylvain Henry committed
444 445 446 447 448
unsafeLookupUnitId state uid = case lookupUnitId state uid of
   Just info -> info
   Nothing   -> pprPanic "unsafeLookupUnitId" (ppr uid)


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

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

459 460 461 462 463 464 465 466 467
-- | Create a Map UnitId UnitInfo
--
-- For each instantiated unit, we add two map keys:
--    * the real unit id
--    * the virtual unit id made from its instantiation
--
-- We do the same thing for fully indefinite units (which are "instantiated"
-- with module holes).
--
Sylvain Henry's avatar
Sylvain Henry committed
468 469
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap infos = foldl' add Map.empty infos
Sylvain Henry's avatar
Sylvain Henry committed
470
  where
471
   mkVirt      p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))
472 473
   add pkg_map p
      | not (null (unitInstantiations p))
474 475 476
      = Map.insert (mkVirt p) p
         $ Map.insert (unitId p) p
         $ pkg_map
477
      | otherwise
478
      = Map.insert (unitId p) p pkg_map
479

480
-- | Get a list of entries from the package database.  NB: be careful with
481 482 483
-- 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
484
listUnitInfo :: UnitState -> [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
485
listUnitInfo state = Map.elems (unitInfoMap state)
486

487
-- ----------------------------------------------------------------------------
488
-- Loading the package db files and building up the package state
489

490 491
-- | Read the package database files, and sets up various internal tables of
-- package information, according to the package-related flags on the
492
-- command-line (@-package@, @-hide-package@ etc.)
493 494 495
--
-- 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
496
-- @-package@ flags.
497
--
Sylvain Henry's avatar
Sylvain Henry committed
498
-- 'initUnits' can be called again subsequently after updating the
499
-- 'packageFlags' field of the 'DynFlags', and it will update the
Sylvain Henry's avatar
Sylvain Henry committed
500
-- 'unitState' in 'DynFlags' and return a list of packages to
501
-- link in.
Sylvain Henry's avatar
Sylvain Henry committed
502 503
initUnits :: DynFlags -> IO (DynFlags, [UnitId])
initUnits dflags = withTiming dflags
504 505
                                  (text "initializing package database")
                                  forcePkgDb $ do
506
  read_pkg_dbs <-
Sylvain Henry's avatar
Sylvain Henry committed
507 508
    case unitDatabases dflags of
        Nothing  -> readUnitDatabases dflags
509 510 511
        Just dbs -> return dbs

  let
Sylvain Henry's avatar
Sylvain Henry committed
512
      distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
513 514 515 516 517

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

518
  (state, preload) <- mkUnitState dflags pkg_dbs []
519 520 521 522 523

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

524 525 526 527 528 529
  -- Some wired units can be used to instantiate the home unit. We need to
  -- replace their unit key by their wired unit id.
  let wiringMap    = wireMap state
      unwiredInsts = homeUnitInstantiations dflags
      wiredInsts   = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts

530 531
  return (dflags{ unitDatabases          = Just read_pkg_dbs,
                  unitState              = state,
532
                  homeUnitInstantiations = wiredInsts },
533
          preload)
534
  where
Sylvain Henry's avatar
Sylvain Henry committed
535
    forcePkgDb (dflags, _) = unitInfoMap (unitState dflags) `seq` ()
536 537

-- -----------------------------------------------------------------------------
Sylvain Henry's avatar
Sylvain Henry committed
538
-- Reading the unit database(s)
539

Sylvain Henry's avatar
Sylvain Henry committed
540 541
readUnitDatabases :: DynFlags -> IO [UnitDatabase UnitId]
readUnitDatabases dflags = do
Sylvain Henry's avatar
Sylvain Henry committed
542
  conf_refs <- getUnitDbRefs dflags
Sylvain Henry's avatar
Sylvain Henry committed
543 544
  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase dflags) conf_refs
  mapM (readUnitDatabase dflags) confs
545

546

Sylvain Henry's avatar
Sylvain Henry committed
547 548
getUnitDbRefs :: DynFlags -> IO [PkgDbRef]
getUnitDbRefs dflags = do
549
  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
550

551
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
552 553 554
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
555
         | not (null path) && isSearchPathSeparator (last path)
556
         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
557
         | otherwise
558
         -> map PkgDbPath (splitSearchPath path)
559

560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
  -- 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 _ = []

575
  isNotUser UserPkgDb = False
576 577
  isNotUser _ = True

578
  isNotGlobal GlobalPkgDb = False
579
  isNotGlobal _ = True
580

581 582 583
-- | 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.
--
584
-- NB: This logic is reimplemented in Cabal, so if you change it,
585
-- make sure you update Cabal. (Or, better yet, dump it in the
586
-- compiler info so Cabal can use the info.)
Sylvain Henry's avatar
Sylvain Henry committed
587 588 589
resolveUnitDatabase :: DynFlags -> PkgDbRef -> IO (Maybe FilePath)
resolveUnitDatabase dflags GlobalPkgDb = return $ Just (globalPackageDatabasePath dflags)
resolveUnitDatabase dflags UserPkgDb = runMaybeT $ do
590
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
591
  let pkgconf = dir </> "package.conf.d"
592 593
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
Sylvain Henry's avatar
Sylvain Henry committed
594
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
595

Sylvain Henry's avatar
Sylvain Henry committed
596 597
readUnitDatabase :: DynFlags -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase dflags conf_file = do
598 599
  isdir <- doesDirectoryExist conf_file

600
  proto_pkg_configs <-
601
    if isdir
602
       then readDirStyleUnitInfo conf_file
603
       else do
604
            isfile <- doesFileExist conf_file
605
            if isfile
606
               then do
607
                 mpkgs <- tryReadOldFileStyleUnitInfo
608 609 610
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
611 612 613 614
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
615 616
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
617

618
  let
619
      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
620
      conf_file' = dropTrailingPathSeparator conf_file
621
      top_dir = topDir dflags
622
      pkgroot = takeDirectory conf_file'
623
      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo)
624
                         proto_pkg_configs
625
  --
Sylvain Henry's avatar
Sylvain Henry committed
626
  return $ UnitDatabase conf_file' pkg_configs1
627
  where
628
    readDirStyleUnitInfo conf_dir = do
629
      let filename = conf_dir </> "package.cache"
630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656
      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"

657 658 659 660 661 662 663 664 665

    -- 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.
666
    tryReadOldFileStyleUnitInfo = do
667 668 669 670 671 672 673
      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)
674
                     liftM Just (readDirStyleUnitInfo conf_dir)
675 676
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
677

678 679
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits pkgs = map distrust pkgs
680
  where
Sylvain Henry's avatar
Sylvain Henry committed
681
    distrust pkg = pkg{ unitIsTrusted = False }
682

683 684 685
mungeUnitInfo :: FilePath -> FilePath
                   -> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
686
    mungeDynLibFields
687
  . mungeUnitInfoPaths top_dir pkgroot
688

689
mungeDynLibFields :: UnitInfo -> UnitInfo
690 691
mungeDynLibFields pkg =
    pkg {
Sylvain Henry's avatar
Sylvain Henry committed
692 693 694
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> unitLibraryDirs pkg
         ds -> ds
695 696
    }

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

applyTrustFlag
   :: DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
703 704
   -> UnitPrecedenceMap
   -> UnusableUnits
705
   -> [UnitInfo]
706
   -> TrustFlag
707
   -> IO [UnitInfo]
708
applyTrustFlag dflags prec_map unusable pkgs flag =
709 710 711 712
  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 ->
713
       case selectPackages prec_map (PackageArg str) pkgs unusable of
714 715
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
Sylvain Henry's avatar
Sylvain Henry committed
716
          where trust p = p {unitIsTrusted=True}
717 718

    DistrustPackage str ->
719
       case selectPackages prec_map (PackageArg str) pkgs unusable of
720
         Left ps       -> trustFlagErr dflags flag ps
721
         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
722

Sylvain Henry's avatar
Sylvain Henry committed
723
-- | A little utility to tell if the home unit is indefinite
Edward Z. Yang's avatar
Edward Z. Yang committed
724
-- (if it is not, we should never use on-the-fly renaming.)
Sylvain Henry's avatar
Sylvain Henry committed
725 726 727 728 729 730 731
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
732

733
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
734
   :: DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
735
   -> UnitPrecedenceMap
Sylvain Henry's avatar
Sylvain Henry committed
736 737
   -> UnitInfoMap
   -> PreloadUnitClosure
Sylvain Henry's avatar
Sylvain Henry committed
738
   -> UnusableUnits
739 740
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
741
   -> [UnitInfo]
742
   -> VisibilityMap           -- Initially exposed
743
   -> PackageFlag               -- flag to apply
744
   -> IO VisibilityMap        -- Now exposed
745

Sylvain Henry's avatar
Sylvain Henry committed
746
applyPackageFlag dflags prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
747
  case flag of
748
    ExposePackage _ arg (ModRenaming b rns) ->
Sylvain Henry's avatar
Sylvain Henry committed
749
       case findPackages prec_map pkg_map closure arg pkgs unusable of
750
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
751
         Right (p:_) -> return vm'
752 753
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
754 755 756 757 758 759 760 761 762

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

763 764 765 766
           collectHoles uid = case uid of
             HoleUnit       -> Map.empty
             RealUnit {}    -> Map.empty -- definite units don't have holes
             VirtUnit indef ->
767
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
768
                                  (moduleName mod)
769 770
                                  (Set.singleton $ Module indef mod_name)
                              | (mod_name, mod) <- instUnitInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
771
                              , isHoleModule mod ]
772 773
                      recurse = [ collectHoles (moduleUnit mod)
                                | (_, mod) <- instUnitInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
774 775 776 777 778 779 780 781 782
                  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
                }
783
           vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804
           -- 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
805 806 807
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
808
                            (\k uv -> k == mkUnit p
Edward Z. Yang's avatar
Edward Z. Yang committed
809
                                   || First (Just n) /= uv_package_name uv) vm
810 811
         _ -> panic "applyPackageFlag"

812
    HidePackage str ->
Sylvain Henry's avatar
Sylvain Henry committed
813
       case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
814 815
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
816
          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
817 818 819 820

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
Sylvain Henry's avatar
Sylvain Henry committed
821
findPackages :: UnitPrecedenceMap
Sylvain Henry's avatar
Sylvain Henry committed
822 823 824
             -> UnitInfoMap
             -> PreloadUnitClosure
             -> PackageArg -> [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
825 826
             -> UnusableUnits
             -> Either [(UnitInfo, UnusableUnitReason)]
827
                [UnitInfo]
Sylvain Henry's avatar
Sylvain Henry committed
828
findPackages prec_map pkg_map closure arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
829 830 831 832
  = 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))
833
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
834 835
  where
    finder (PackageArg str) p
Sylvain Henry's avatar
Sylvain Henry committed
836
      = if str == unitPackageIdString p || str == unitPackageNameString p
Edward Z. Yang's avatar
Edward Z. Yang committed
837 838 839
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
840 841 842 843 844 845
      = case uid of
          RealUnit (Definite iuid)
            | iuid == unitId p
            -> Just p
          VirtUnit inst
            | indefUnit (instUnitInstanceOf inst) == unitId p
Sylvain Henry's avatar
Sylvain Henry committed
846
            -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p)
847
          _ -> Nothing
Edward Z. Yang's avatar
Edward Z. Yang committed
848

Sylvain Henry's avatar
Sylvain Henry committed
849 850 851
selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
               -> UnusableUnits
               -> Either [(UnitInfo, UnusableUnitReason)]
852
                  ([UnitInfo], [UnitInfo])
853
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
854 855
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
856 857
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
858
        else Right (sortByPreference prec_map ps, rest)
859

860
-- | Rename a 'UnitInfo' according to some module instantiation.
Sylvain Henry's avatar
Sylvain Henry committed
861 862
renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo pkg_map closure insts conf =
Edward Z. Yang's avatar
Edward Z. Yang committed
863
    let hsubst = listToUFM insts
Sylvain Henry's avatar
Sylvain Henry committed
864
        smod  = renameHoleModule' pkg_map closure hsubst
Sylvain Henry's avatar
Sylvain Henry committed
865
        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
866
    in conf {
Sylvain Henry's avatar
Sylvain Henry committed
867 868 869
        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
870 871 872
    }


873 874
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
875
matchingStr :: String -> UnitInfo -> Bool
876
matchingStr str p
Sylvain Henry's avatar
Sylvain Henry committed
877 878
        =  str == unitPackageIdString p
        || str == unitPackageNameString p
879

880 881
matchingId :: UnitId -> UnitInfo -> Bool
matchingId uid p = uid == unitId p
882

883
matching :: PackageArg -> UnitInfo -> Bool
884
matching (PackageArg str) = matchingStr str
885
matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
886
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
887

888 889
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
Sylvain Henry's avatar
Sylvain Henry committed
890
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
891 892 893 894 895 896 897 898 899 900 901
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
902
-- in later package database.
903
--
904 905 906 907 908 909
-- 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
910
-- in the @GHC.Builtin.Names@ module.
911
compareByPreference
Sylvain Henry's avatar
Sylvain Henry committed
912
    :: UnitPrecedenceMap
913 914
    -> UnitInfo
    -> UnitInfo
915
    -> Ordering
916 917 918 919 920 921 922
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
923
  = case comparing unitPackageVersion pkg pkg' of
924 925 926 927 928 929 930 931 932
        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
933

Sylvain Henry's avatar
Sylvain Henry committed
934
  where isIntegerPkg p = unitPackageNameString p `elem`
935 936 937
          ["integer-simple", "integer-gmp"]
        differentIntegerPkgs p p' =
          isIntegerPkg p && isIntegerPkg p' &&
Sylvain Henry's avatar
Sylvain Henry committed
938
          (unitPackageName p /= unitPackageName p')
939

Ian Lynagh's avatar
Ian Lynagh committed
940
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
941 942
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
943 944
packageFlagErr :: DynFlags
               -> PackageFlag
Sylvain Henry's avatar
Sylvain Henry committed
945
               -> [(UnitInfo, UnusableUnitReason)]
946
               -> IO a
947
packageFlagErr dflags flag reasons
948 949 950 951
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
Sylvain Henry's avatar
Sylvain Henry committed
952
             -> [(UnitInfo, UnusableUnitReason)]
953 954 955 956 957 958
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
Sylvain Henry's avatar
Sylvain Henry committed
959
               -> [(UnitInfo, UnusableUnitReason)]
960 961
               -> IO a
packageFlagErr' dflags flag_doc reasons
962
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
963
  where err = text "cannot satisfy " <> flag_doc <>
964
                (if null reasons then Outputable.empty else text ": ") $$
965 966 967
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
968
        ppr_reason (p, reason) =
969
            pprReason (ppr (unitId p) <+> text "is") reason
970

971 972 973
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
974
    ExposePackage doc _ _ -> text doc
975

976 977 978 979 980
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

981
-- -----------------------------------------------------------------------------
982
-- Wired-in units
983
--
984
-- See Note [Wired-in units] in GHC.Unit.Module
985

Sylvain Henry's avatar
Sylvain Henry committed
986
type WiringMap = Map UnitId UnitId