44258de70c245d9149aadc5a733d8af1558598ae
[ghc.git] / compiler / main / Packages.hs
1 -- (c) The University of Glasgow, 2006
2
3 {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
4
5 -- | Package manipulation
6 module Packages (
7 module PackageConfig,
8
9 -- * Reading the package config, and processing cmdline args
10 PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext),
11 PackageConfigMap,
12 emptyPackageState,
13 initPackages,
14 readPackageConfigs,
15 getPackageConfRefs,
16 resolvePackageConfig,
17 readPackageConfig,
18 listPackageConfigMap,
19
20 -- * Querying the package config
21 lookupPackage,
22 lookupPackage',
23 lookupInstalledPackage,
24 lookupPackageName,
25 improveUnitId,
26 searchPackageId,
27 getPackageDetails,
28 getInstalledPackageDetails,
29 componentIdString,
30 displayInstalledUnitId,
31 listVisibleModuleNames,
32 lookupModuleInAllPackages,
33 lookupModuleWithSuggestions,
34 lookupPluginModuleWithSuggestions,
35 LookupResult(..),
36 ModuleSuggestion(..),
37 ModuleOrigin(..),
38 UnusablePackageReason(..),
39 pprReason,
40
41 -- * Inspecting the set of packages in scope
42 getPackageIncludePath,
43 getPackageLibraryPath,
44 getPackageLinkOpts,
45 getPackageExtraCcOpts,
46 getPackageFrameworkPath,
47 getPackageFrameworks,
48 getPackageConfigMap,
49 getPreloadPackagesAnd,
50
51 collectArchives,
52 collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
53 packageHsLibs, getLibs,
54
55 -- * Utils
56 unwireUnitId,
57 pprFlag,
58 pprPackages,
59 pprPackagesSimple,
60 pprModuleMap,
61 isIndefinite,
62 isDllName
63 )
64 where
65
66 #include "HsVersions.h"
67
68 import GhcPrelude
69
70 import GHC.PackageDb
71 import PackageConfig
72 import DynFlags
73 import Name ( Name, nameModule_maybe )
74 import UniqFM
75 import UniqDFM
76 import UniqSet
77 import Module
78 import Util
79 import Panic
80 import Platform
81 import Outputable
82 import Maybes
83
84 import System.Environment ( getEnv )
85 import FastString
86 import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn )
87 import Exception
88
89 import System.Directory
90 import System.FilePath as FilePath
91 import qualified System.FilePath.Posix as FilePath.Posix
92 import Control.Monad
93 import Data.Graph (stronglyConnComp, SCC(..))
94 import Data.Char ( toUpper )
95 import Data.List as List
96 import Data.Map (Map)
97 import Data.Set (Set)
98 import Data.Monoid (First(..))
99 import qualified Data.Semigroup as Semigroup
100 import qualified Data.Map as Map
101 import qualified Data.Map.Strict as MapStrict
102 import qualified Data.Set as Set
103 import Data.Version
104
105 -- ---------------------------------------------------------------------------
106 -- The Package state
107
108 -- | Package state is all stored in 'DynFlags', including the details of
109 -- all packages, which packages are exposed, and which modules they
110 -- provide.
111 --
112 -- The package state is computed by 'initPackages', and kept in DynFlags.
113 -- It is influenced by various package flags:
114 --
115 -- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
116 -- If @-hide-all-packages@ was not specified, these commands also cause
117 -- all other packages with the same name to become hidden.
118 --
119 -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
120 --
121 -- * (there are a few more flags, check below for their semantics)
122 --
123 -- The package state has the following properties.
124 --
125 -- * Let @exposedPackages@ be the set of packages thus exposed.
126 -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
127 -- their dependencies.
128 --
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 -- program depends on (the compiler knows this list by the
137 -- 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,
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 -- contain any Haskell modules, and therefore won't be discovered
142 -- by the normal mechanism of dependency tracking.
143
144 -- Notes on DLLs
145 -- ~~~~~~~~~~~~~
146 -- When compiling module A, which imports module B, we need to
147 -- know whether B will be in the same DLL as A.
148 -- If it's in the same DLL, we refer to B_f_closure
149 -- If it isn't, we refer to _imp__B_f_closure
150 -- When compiling A, we record in B's Module value whether it's
151 -- in a different DLL, by setting the DLL flag.
152
153 -- | Given a module name, there may be multiple ways it came into scope,
154 -- possibly simultaneously. This data type tracks all the possible ways
155 -- it could have come into scope. Warning: don't use the record functions,
156 -- they're partial!
157 data ModuleOrigin =
158 -- | Module is hidden, and thus never will be available for import.
159 -- (But maybe the user didn't realize), so we'll still keep track
160 -- of these modules.)
161 ModHidden
162 -- | Module is unavailable because the package is unusable.
163 | ModUnusable UnusablePackageReason
164 -- | Module is public, and could have come from some places.
165 | ModOrigin {
166 -- | @Just False@ means that this module is in
167 -- someone's @exported-modules@ list, but that package is hidden;
168 -- @Just True@ means that it is available; @Nothing@ means neither
169 -- applies.
170 fromOrigPackage :: Maybe Bool
171 -- | Is the module available from a reexport of an exposed package?
172 -- There could be multiple.
173 , fromExposedReexport :: [PackageConfig]
174 -- | Is the module available from a reexport of a hidden package?
175 , fromHiddenReexport :: [PackageConfig]
176 -- | Did the module export come from a package flag? (ToDo: track
177 -- more information.
178 , fromPackageFlag :: Bool
179 }
180
181 instance Outputable ModuleOrigin where
182 ppr ModHidden = text "hidden module"
183 ppr (ModUnusable _) = text "unusable module"
184 ppr (ModOrigin e res rhs f) = sep (punctuate comma (
185 (case e of
186 Nothing -> []
187 Just False -> [text "hidden package"]
188 Just True -> [text "exposed package"]) ++
189 (if null res
190 then []
191 else [text "reexport by" <+>
192 sep (map (ppr . packageConfigId) res)]) ++
193 (if null rhs
194 then []
195 else [text "hidden reexport by" <+>
196 sep (map (ppr . packageConfigId) res)]) ++
197 (if f then [text "package flag"] else [])
198 ))
199
200 -- | Smart constructor for a module which is in @exposed-modules@. Takes
201 -- as an argument whether or not the defining package is exposed.
202 fromExposedModules :: Bool -> ModuleOrigin
203 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 expsed, and
207 -- also its 'PackageConfig'.
208 fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
209 fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
210 fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
211
212 -- | Smart constructor for a module which was bound by a package flag.
213 fromFlag :: ModuleOrigin
214 fromFlag = ModOrigin Nothing [] [] True
215
216 instance Semigroup ModuleOrigin where
217 ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
218 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
219 where g (Just b) (Just b')
220 | b == b' = Just b
221 | otherwise = panic "ModOrigin: package both exposed/hidden"
222 g Nothing x = x
223 g x Nothing = x
224 _x <> _y = panic "ModOrigin: hidden module redefined"
225
226 instance Monoid ModuleOrigin where
227 mempty = ModOrigin Nothing [] [] False
228 mappend = (Semigroup.<>)
229
230 -- | Is the name from the import actually visible? (i.e. does it cause
231 -- ambiguity, or is it only relevant when we're making suggestions?)
232 originVisible :: ModuleOrigin -> Bool
233 originVisible ModHidden = False
234 originVisible (ModUnusable _) = False
235 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
236
237 -- | Are there actually no providers for this module? This will never occur
238 -- except when we're filtering based on package imports.
239 originEmpty :: ModuleOrigin -> Bool
240 originEmpty (ModOrigin Nothing [] [] False) = True
241 originEmpty _ = False
242
243 -- | 'UniqFM' map from 'InstalledUnitId'
244 type InstalledUnitIdMap = UniqDFM
245
246 -- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
247 -- the transitive closure of preload packages.
248 data PackageConfigMap = PackageConfigMap {
249 unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
250 -- | The set of transitively reachable packages according
251 -- to the explicitly provided command line arguments.
252 -- See Note [UnitId to InstalledUnitId improvement]
253 preloadClosure :: UniqSet InstalledUnitId
254 }
255
256 -- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
257 type VisibilityMap = Map UnitId UnitVisibility
258
259 -- | 'UnitVisibility' records the various aspects of visibility of a particular
260 -- 'UnitId'.
261 data UnitVisibility = UnitVisibility
262 { uv_expose_all :: Bool
263 -- ^ Should all modules in exposed-modules should be dumped into scope?
264 , uv_renamings :: [(ModuleName, ModuleName)]
265 -- ^ Any custom renamings that should bring extra 'ModuleName's into
266 -- scope.
267 , uv_package_name :: First FastString
268 -- ^ The package name is associated with the 'UnitId'. This is used
269 -- to implement legacy behavior where @-package foo-0.1@ implicitly
270 -- hides any packages named @foo@
271 , uv_requirements :: Map ModuleName (Set IndefModule)
272 -- ^ The signatures which are contributed to the requirements context
273 -- from this unit ID.
274 , uv_explicit :: Bool
275 -- ^ Whether or not this unit was explicitly brought into scope,
276 -- as opposed to implicitly via the 'exposed' fields in the
277 -- package database (when @-hide-all-packages@ is not passed.)
278 }
279
280 instance Outputable UnitVisibility where
281 ppr (UnitVisibility {
282 uv_expose_all = b,
283 uv_renamings = rns,
284 uv_package_name = First mb_pn,
285 uv_requirements = reqs,
286 uv_explicit = explicit
287 }) = ppr (b, rns, mb_pn, reqs, explicit)
288
289 instance Semigroup UnitVisibility where
290 uv1 <> uv2
291 = UnitVisibility
292 { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
293 , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
294 , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
295 , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
296 , uv_explicit = uv_explicit uv1 || uv_explicit uv2
297 }
298
299 instance Monoid UnitVisibility where
300 mempty = UnitVisibility
301 { uv_expose_all = False
302 , uv_renamings = []
303 , uv_package_name = First Nothing
304 , uv_requirements = Map.empty
305 , uv_explicit = False
306 }
307 mappend = (Semigroup.<>)
308
309 type WiredUnitId = DefUnitId
310 type PreloadUnitId = InstalledUnitId
311
312 -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
313 -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
314 -- (since this is the slow path, we'll just look it up again).
315 type ModuleToPkgConfAll =
316 Map ModuleName (Map Module ModuleOrigin)
317
318 data PackageState = PackageState {
319 -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted
320 -- so that only valid packages are here. 'PackageConfig' reflects
321 -- what was stored *on disk*, except for the 'trusted' flag, which
322 -- is adjusted at runtime. (In particular, some packages in this map
323 -- may have the 'exposed' flag be 'False'.)
324 pkgIdMap :: PackageConfigMap,
325
326 -- | A mapping of 'PackageName' to 'ComponentId'. This is used when
327 -- users refer to packages in Backpack includes.
328 packageNameMap :: Map PackageName ComponentId,
329
330 -- | A mapping from wired in names to the original names from the
331 -- package database.
332 unwireMap :: Map WiredUnitId WiredUnitId,
333
334 -- | The packages we're going to link in eagerly. This list
335 -- should be in reverse dependency order; that is, a package
336 -- is always mentioned before the packages it depends on.
337 preloadPackages :: [PreloadUnitId],
338
339 -- | Packages which we explicitly depend on (from a command line flag).
340 -- We'll use this to generate version macros.
341 explicitPackages :: [UnitId],
342
343 -- | This is a full map from 'ModuleName' to all modules which may possibly
344 -- be providing it. These providers may be hidden (but we'll still want
345 -- to report them in error messages), or it may be an ambiguous import.
346 moduleToPkgConfAll :: !ModuleToPkgConfAll,
347
348 -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
349 pluginModuleToPkgConfAll :: !ModuleToPkgConfAll,
350
351 -- | A map saying, for each requirement, what interfaces must be merged
352 -- together when we use them. For example, if our dependencies
353 -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
354 -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
355 -- and @r[C=<A>]:C@.
356 --
357 -- There's an entry in this map for each hole in our home library.
358 requirementContext :: Map ModuleName [IndefModule]
359 }
360
361 emptyPackageState :: PackageState
362 emptyPackageState = PackageState {
363 pkgIdMap = emptyPackageConfigMap,
364 packageNameMap = Map.empty,
365 unwireMap = Map.empty,
366 preloadPackages = [],
367 explicitPackages = [],
368 moduleToPkgConfAll = Map.empty,
369 pluginModuleToPkgConfAll = Map.empty,
370 requirementContext = Map.empty
371 }
372
373 type InstalledPackageIndex = Map InstalledUnitId PackageConfig
374
375 -- | Empty package configuration map
376 emptyPackageConfigMap :: PackageConfigMap
377 emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet
378
379 -- | Find the package we know about with the given unit id, if any
380 lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
381 lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))
382
383 -- | A more specialized interface, which takes a boolean specifying
384 -- whether or not to look for on-the-fly renamed interfaces, and
385 -- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
386 -- be used while we're initializing 'DynFlags'
387 lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
388 lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
389 lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
390 case splitUnitIdInsts uid of
391 (iuid, Just indef) ->
392 fmap (renamePackage m (indefUnitIdInsts indef))
393 (lookupUDFM pkg_map iuid)
394 (_, Nothing) -> lookupUDFM pkg_map uid
395
396 {-
397 -- | Find the indefinite package for a given 'ComponentId'.
398 -- The way this works is just by fiat'ing that every indefinite package's
399 -- unit key is precisely its component ID; and that they share uniques.
400 lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
401 lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
402 where
403 PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
404 -}
405
406 -- | Find the package we know about with the given package name (e.g. @foo@), if any
407 -- (NB: there might be a locally defined unit name which overrides this)
408 lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
409 lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
410
411 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
412 searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
413 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
414 (listPackageConfigMap dflags)
415
416 -- | Extends the package configuration map with a list of package configs.
417 extendPackageConfigMap
418 :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
419 extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
420 = PackageConfigMap (foldl' add pkg_map new_pkgs) closure
421 -- We also add the expanded version of the packageConfigId, so that
422 -- 'improveUnitId' can find it.
423 where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
424 (installedPackageConfigId p) p
425
426 -- | Looks up the package with the given id in the package state, panicing if it is
427 -- not found
428 getPackageDetails :: DynFlags -> UnitId -> PackageConfig
429 getPackageDetails dflags pid =
430 expectJust "getPackageDetails" (lookupPackage dflags pid)
431
432 lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
433 lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid
434
435 lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
436 lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid
437
438 getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
439 getInstalledPackageDetails dflags uid =
440 expectJust "getInstalledPackageDetails" $
441 lookupInstalledPackage dflags uid
442
443 -- | Get a list of entries from the package database. NB: be careful with
444 -- this function, although all packages in this map are "visible", this
445 -- does not imply that the exposed-modules of the package are available
446 -- (they may have been thinned or renamed).
447 listPackageConfigMap :: DynFlags -> [PackageConfig]
448 listPackageConfigMap dflags = eltsUDFM pkg_map
449 where
450 PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)
451
452 -- ----------------------------------------------------------------------------
453 -- Loading the package db files and building up the package state
454
455 -- | Call this after 'DynFlags.parseDynFlags'. It reads the package
456 -- database files, and sets up various internal tables of package
457 -- information, according to the package-related flags on the
458 -- command-line (@-package@, @-hide-package@ etc.)
459 --
460 -- Returns a list of packages to link in if we're doing dynamic linking.
461 -- This list contains the packages that the user explicitly mentioned with
462 -- @-package@ flags.
463 --
464 -- 'initPackages' can be called again subsequently after updating the
465 -- '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 dflags0 = do
470 dflags <- interpretPackageEnv dflags0
471 pkg_db <-
472 case pkgDatabase dflags of
473 Nothing -> readPackageConfigs dflags
474 Just db -> return $ map (\(p, pkgs)
475 -> (p, setBatchPackageFlags dflags pkgs)) db
476 (pkg_state, preload, insts)
477 <- mkPackageState dflags pkg_db []
478 return (dflags{ pkgDatabase = Just pkg_db,
479 pkgState = pkg_state,
480 thisUnitIdInsts_ = insts },
481 preload)
482
483 -- -----------------------------------------------------------------------------
484 -- Reading the package database(s)
485
486 readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
487 readPackageConfigs dflags = do
488 conf_refs <- getPackageConfRefs dflags
489 confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
490 mapM (readPackageConfig dflags) confs
491
492
493 getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
494 getPackageConfRefs dflags = do
495 let system_conf_refs = [UserPkgConf, GlobalPkgConf]
496
497 e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
498 let base_conf_refs = case e_pkg_path of
499 Left _ -> system_conf_refs
500 Right path
501 | not (null path) && isSearchPathSeparator (last path)
502 -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
503 | otherwise
504 -> map PkgConfFile (splitSearchPath path)
505
506 -- Apply the package DB-related flags from the command line to get the
507 -- final list of package DBs.
508 --
509 -- Notes on ordering:
510 -- * The list of flags is reversed (later ones first)
511 -- * We work with the package DB list in "left shadows right" order
512 -- * and finally reverse it at the end, to get "right shadows left"
513 --
514 return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags))
515 where
516 doFlag (PackageDB p) dbs = p : dbs
517 doFlag NoUserPackageDB dbs = filter isNotUser dbs
518 doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
519 doFlag ClearPackageDBs _ = []
520
521 isNotUser UserPkgConf = False
522 isNotUser _ = True
523
524 isNotGlobal GlobalPkgConf = False
525 isNotGlobal _ = True
526
527 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
528 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
529 -- NB: This logic is reimplemented in Cabal, so if you change it,
530 -- make sure you update Cabal. (Or, better yet, dump it in the
531 -- compiler info so Cabal can use the info.)
532 resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
533 dir <- versionedAppDir dflags
534 let pkgconf = dir </> "package.conf.d"
535 exist <- tryMaybeT $ doesDirectoryExist pkgconf
536 if exist then return pkgconf else mzero
537 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
538
539 readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
540 readPackageConfig dflags conf_file = do
541 isdir <- doesDirectoryExist conf_file
542
543 proto_pkg_configs <-
544 if isdir
545 then readDirStylePackageConfig conf_file
546 else do
547 isfile <- doesFileExist conf_file
548 if isfile
549 then do
550 mpkgs <- tryReadOldFileStylePackageConfig
551 case mpkgs of
552 Just pkgs -> return pkgs
553 Nothing -> throwGhcExceptionIO $ InstallationError $
554 "ghc no longer supports single-file style package " ++
555 "databases (" ++ conf_file ++
556 ") use 'ghc-pkg init' to create the database with " ++
557 "the correct format."
558 else throwGhcExceptionIO $ InstallationError $
559 "can't find a package database at " ++ conf_file
560
561 let
562 top_dir = topDir dflags
563 pkgroot = takeDirectory conf_file
564 pkg_configs1 = map (mungePackageConfig top_dir pkgroot)
565 proto_pkg_configs
566 pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
567 --
568 return (conf_file, pkg_configs2)
569 where
570 readDirStylePackageConfig conf_dir = do
571 let filename = conf_dir </> "package.cache"
572 cache_exists <- doesFileExist filename
573 if cache_exists
574 then do
575 debugTraceMsg dflags 2 $ text "Using binary package database:"
576 <+> text filename
577 readPackageDbForGhc filename
578 else do
579 -- If there is no package.cache file, we check if the database is not
580 -- empty by inspecting if the directory contains any .conf file. If it
581 -- does, something is wrong and we fail. Otherwise we assume that the
582 -- database is empty.
583 debugTraceMsg dflags 2 $ text "There is no package.cache in"
584 <+> text conf_dir
585 <> text ", checking if the database is empty"
586 db_empty <- all (not . isSuffixOf ".conf")
587 <$> getDirectoryContents conf_dir
588 if db_empty
589 then do
590 debugTraceMsg dflags 3 $ text "There are no .conf files in"
591 <+> text conf_dir <> text ", treating"
592 <+> text "package database as empty"
593 return []
594 else do
595 throwGhcExceptionIO $ InstallationError $
596 "there is no package.cache in " ++ conf_dir ++
597 " even though package database is not empty"
598
599
600 -- Single-file style package dbs have been deprecated for some time, but
601 -- it turns out that Cabal was using them in one place. So this is a
602 -- workaround to allow older Cabal versions to use this newer ghc.
603 -- We check if the file db contains just "[]" and if so, we look for a new
604 -- dir-style db in conf_file.d/, ie in a dir next to the given file.
605 -- We cannot just replace the file with a new dir style since Cabal still
606 -- assumes it's a file and tries to overwrite with 'writeFile'.
607 -- ghc-pkg also cooperates with this workaround.
608 tryReadOldFileStylePackageConfig = do
609 content <- readFile conf_file `catchIO` \_ -> return ""
610 if take 2 content == "[]"
611 then do
612 let conf_dir = conf_file <.> "d"
613 direxists <- doesDirectoryExist conf_dir
614 if direxists
615 then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
616 liftM Just (readDirStylePackageConfig conf_dir)
617 else return (Just []) -- ghc-pkg will create it when it's updated
618 else return Nothing
619
620 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
621 setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
622 where
623 maybeDistrustAll pkgs'
624 | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
625 | otherwise = pkgs'
626
627 distrust pkg = pkg{ trusted = False }
628
629 mungePackageConfig :: FilePath -> FilePath
630 -> PackageConfig -> PackageConfig
631 mungePackageConfig top_dir pkgroot =
632 mungeDynLibFields
633 . mungePackagePaths top_dir pkgroot
634
635 mungeDynLibFields :: PackageConfig -> PackageConfig
636 mungeDynLibFields pkg =
637 pkg {
638 libraryDynDirs = libraryDynDirs pkg
639 `orIfNull` libraryDirs pkg
640 }
641 where
642 orIfNull [] flags = flags
643 orIfNull flags _ = flags
644
645 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
646 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
647 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
648 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
649 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
650 -- The "pkgroot" is the directory containing the package database.
651 --
652 -- Also perform a similar substitution for the older GHC-specific
653 -- "$topdir" variable. The "topdir" is the location of the ghc
654 -- installation (obtained from the -B option).
655 mungePackagePaths top_dir pkgroot pkg =
656 pkg {
657 importDirs = munge_paths (importDirs pkg),
658 includeDirs = munge_paths (includeDirs pkg),
659 libraryDirs = munge_paths (libraryDirs pkg),
660 libraryDynDirs = munge_paths (libraryDynDirs pkg),
661 frameworkDirs = munge_paths (frameworkDirs pkg),
662 haddockInterfaces = munge_paths (haddockInterfaces pkg),
663 haddockHTMLs = munge_urls (haddockHTMLs pkg)
664 }
665 where
666 munge_paths = map munge_path
667 munge_urls = map munge_url
668
669 munge_path p
670 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
671 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
672 | otherwise = p
673
674 munge_url p
675 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
676 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
677 | otherwise = p
678
679 toUrlPath r p = "file:///"
680 -- URLs always use posix style '/' separators:
681 ++ FilePath.Posix.joinPath
682 (r : -- We need to drop a leading "/" or "\\"
683 -- if there is one:
684 dropWhile (all isPathSeparator)
685 (FilePath.splitDirectories p))
686
687 -- We could drop the separator here, and then use </> above. However,
688 -- by leaving it in and using ++ we keep the same path separator
689 -- rather than letting FilePath change it to use \ as the separator
690 stripVarPrefix var path = case stripPrefix var path of
691 Just [] -> Just []
692 Just cs@(c : _) | isPathSeparator c -> Just cs
693 _ -> Nothing
694
695
696 -- -----------------------------------------------------------------------------
697 -- Modify our copy of the package database based on trust flags,
698 -- -trust and -distrust.
699
700 applyTrustFlag
701 :: DynFlags
702 -> PackagePrecedenceIndex
703 -> UnusablePackages
704 -> [PackageConfig]
705 -> TrustFlag
706 -> IO [PackageConfig]
707 applyTrustFlag dflags prec_map unusable pkgs flag =
708 case flag of
709 -- we trust all matching packages. Maybe should only trust first one?
710 -- and leave others the same or set them untrusted
711 TrustPackage str ->
712 case selectPackages prec_map (PackageArg str) pkgs unusable of
713 Left ps -> trustFlagErr dflags flag ps
714 Right (ps,qs) -> return (map trust ps ++ qs)
715 where trust p = p {trusted=True}
716
717 DistrustPackage str ->
718 case selectPackages prec_map (PackageArg str) pkgs unusable of
719 Left ps -> trustFlagErr dflags flag ps
720 Right (ps,qs) -> return (map distrust ps ++ qs)
721 where distrust p = p {trusted=False}
722
723 -- | A little utility to tell if the 'thisPackage' is indefinite
724 -- (if it is not, we should never use on-the-fly renaming.)
725 isIndefinite :: DynFlags -> Bool
726 isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))
727
728 applyPackageFlag
729 :: DynFlags
730 -> PackagePrecedenceIndex
731 -> PackageConfigMap
732 -> UnusablePackages
733 -> Bool -- if False, if you expose a package, it implicitly hides
734 -- any previously exposed packages with the same name
735 -> [PackageConfig]
736 -> VisibilityMap -- Initially exposed
737 -> PackageFlag -- flag to apply
738 -> IO VisibilityMap -- Now exposed
739
740 applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
741 case flag of
742 ExposePackage _ arg (ModRenaming b rns) ->
743 case findPackages prec_map pkg_db arg pkgs unusable of
744 Left ps -> packageFlagErr dflags flag ps
745 Right (p:_) -> return vm'
746 where
747 n = fsPackageName p
748
749 -- If a user says @-unit-id p[A=<A>]@, this imposes
750 -- a requirement on us: whatever our signature A is,
751 -- it must fulfill all of p[A=<A>]:A's requirements.
752 -- This method is responsible for computing what our
753 -- inherited requirements are.
754 reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
755 | otherwise = Map.empty
756
757 collectHoles uid = case splitUnitIdInsts uid of
758 (_, Just indef) ->
759 let local = [ Map.singleton
760 (moduleName mod)
761 (Set.singleton $ IndefModule indef mod_name)
762 | (mod_name, mod) <- indefUnitIdInsts indef
763 , isHoleModule mod ]
764 recurse = [ collectHoles (moduleUnitId mod)
765 | (_, mod) <- indefUnitIdInsts indef ]
766 in Map.unionsWith Set.union $ local ++ recurse
767 -- Other types of unit identities don't have holes
768 (_, Nothing) -> Map.empty
769
770
771 uv = UnitVisibility
772 { uv_expose_all = b
773 , uv_renamings = rns
774 , uv_package_name = First (Just n)
775 , uv_requirements = reqs
776 , uv_explicit = True
777 }
778 vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
779 -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
780 -- (or if p-0.1 was registered in the pkgdb as exposed: True),
781 -- the second package flag would override the first one and you
782 -- would only see p-0.2 in exposed modules. This is good for
783 -- usability.
784 --
785 -- However, with thinning and renaming (or Backpack), there might be
786 -- situations where you legitimately want to see two versions of a
787 -- package at the same time, and this behavior would make it
788 -- impossible to do so. So we decided that if you pass
789 -- -hide-all-packages, this should turn OFF the overriding behavior
790 -- where an exposed package hides all other packages with the same
791 -- name. This should not affect Cabal at all, which only ever
792 -- exposes one package at a time.
793 --
794 -- NB: Why a variable no_hide_others? We have to apply this logic to
795 -- -plugin-package too, and it's more consistent if the switch in
796 -- behavior is based off of
797 -- -hide-all-packages/-hide-all-plugin-packages depending on what
798 -- flag is in question.
799 vm_cleared | no_hide_others = vm
800 -- NB: renamings never clear
801 | (_:_) <- rns = vm
802 | otherwise = Map.filterWithKey
803 (\k uv -> k == packageConfigId p
804 || First (Just n) /= uv_package_name uv) vm
805 _ -> panic "applyPackageFlag"
806
807 HidePackage str ->
808 case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
809 Left ps -> packageFlagErr dflags flag ps
810 Right ps -> return vm'
811 where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)
812
813 -- | Like 'selectPackages', but doesn't return a list of unmatched
814 -- packages. Furthermore, any packages it returns are *renamed*
815 -- if the 'UnitArg' has a renaming associated with it.
816 findPackages :: PackagePrecedenceIndex
817 -> PackageConfigMap -> PackageArg -> [PackageConfig]
818 -> UnusablePackages
819 -> Either [(PackageConfig, UnusablePackageReason)]
820 [PackageConfig]
821 findPackages prec_map pkg_db arg pkgs unusable
822 = let ps = mapMaybe (finder arg) pkgs
823 in if null ps
824 then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
825 (Map.elems unusable))
826 else Right (sortByPreference prec_map ps)
827 where
828 finder (PackageArg str) p
829 = if str == sourcePackageIdString p || str == packageNameString p
830 then Just p
831 else Nothing
832 finder (UnitIdArg uid) p
833 = let (iuid, mb_indef) = splitUnitIdInsts uid
834 in if iuid == installedPackageConfigId p
835 then Just (case mb_indef of
836 Nothing -> p
837 Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
838 else Nothing
839
840 selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig]
841 -> UnusablePackages
842 -> Either [(PackageConfig, UnusablePackageReason)]
843 ([PackageConfig], [PackageConfig])
844 selectPackages prec_map arg pkgs unusable
845 = let matches = matching arg
846 (ps,rest) = partition matches pkgs
847 in if null ps
848 then Left (filter (matches.fst) (Map.elems unusable))
849 else Right (sortByPreference prec_map ps, rest)
850
851 -- | Rename a 'PackageConfig' according to some module instantiation.
852 renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
853 -> PackageConfig -> PackageConfig
854 renamePackage pkg_map insts conf =
855 let hsubst = listToUFM insts
856 smod = renameHoleModule' pkg_map hsubst
857 new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
858 in conf {
859 instantiatedWith = new_insts,
860 exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
861 (exposedModules conf)
862 }
863
864
865 -- A package named on the command line can either include the
866 -- version, or just the name if it is unambiguous.
867 matchingStr :: String -> PackageConfig -> Bool
868 matchingStr str p
869 = str == sourcePackageIdString p
870 || str == packageNameString p
871
872 matchingId :: InstalledUnitId -> PackageConfig -> Bool
873 matchingId uid p = uid == installedPackageConfigId p
874
875 matching :: PackageArg -> PackageConfig -> Bool
876 matching (PackageArg str) = matchingStr str
877 matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid
878 matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case
879
880 -- | This sorts a list of packages, putting "preferred" packages first.
881 -- See 'compareByPreference' for the semantics of "preference".
882 sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
883 sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))
884
885 -- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
886 -- which should be "active". Here is the order of preference:
887 --
888 -- 1. First, prefer the latest version
889 -- 2. If the versions are the same, prefer the package that
890 -- came in the latest package database.
891 --
892 -- Pursuant to #12518, we could change this policy to, for example, remove
893 -- the version preference, meaning that we would always prefer the packages
894 -- in later package database.
895 --
896 -- Instead, we use that preference based policy only when one of the packages
897 -- is integer-gmp and the other is integer-simple.
898 -- This currently only happens when we're looking up which concrete
899 -- package to use in place of @integer-wired-in@ and that two different
900 -- package databases supply a different integer library. For more about
901 -- the fake @integer-wired-in@ package, see Note [The integer library]
902 -- in the @PrelNames@ module.
903 compareByPreference
904 :: PackagePrecedenceIndex
905 -> PackageConfig
906 -> PackageConfig
907 -> Ordering
908 compareByPreference prec_map pkg pkg'
909 | Just prec <- Map.lookup (unitId pkg) prec_map
910 , Just prec' <- Map.lookup (unitId pkg') prec_map
911 , differentIntegerPkgs pkg pkg'
912 = compare prec prec'
913
914 | otherwise
915 = case comparing packageVersion pkg pkg' of
916 GT -> GT
917 EQ | Just prec <- Map.lookup (unitId pkg) prec_map
918 , Just prec' <- Map.lookup (unitId pkg') prec_map
919 -- Prefer the package from the later DB flag (i.e., higher
920 -- precedence)
921 -> compare prec prec'
922 | otherwise
923 -> EQ
924 LT -> LT
925
926 where isIntegerPkg p = packageNameString p `elem`
927 ["integer-simple", "integer-gmp"]
928 differentIntegerPkgs p p' =
929 isIntegerPkg p && isIntegerPkg p' &&
930 (packageName p /= packageName p')
931
932 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
933 comparing f a b = f a `compare` f b
934
935 packageFlagErr :: DynFlags
936 -> PackageFlag
937 -> [(PackageConfig, UnusablePackageReason)]
938 -> IO a
939 packageFlagErr dflags flag reasons
940 = packageFlagErr' dflags (pprFlag flag) reasons
941
942 trustFlagErr :: DynFlags
943 -> TrustFlag
944 -> [(PackageConfig, UnusablePackageReason)]
945 -> IO a
946 trustFlagErr dflags flag reasons
947 = packageFlagErr' dflags (pprTrustFlag flag) reasons
948
949 packageFlagErr' :: DynFlags
950 -> SDoc
951 -> [(PackageConfig, UnusablePackageReason)]
952 -> IO a
953 packageFlagErr' dflags flag_doc reasons
954 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
955 where err = text "cannot satisfy " <> flag_doc <>
956 (if null reasons then Outputable.empty else text ": ") $$
957 nest 4 (ppr_reasons $$
958 text "(use -v for more information)")
959 ppr_reasons = vcat (map ppr_reason reasons)
960 ppr_reason (p, reason) =
961 pprReason (ppr (unitId p) <+> text "is") reason
962
963 pprFlag :: PackageFlag -> SDoc
964 pprFlag flag = case flag of
965 HidePackage p -> text "-hide-package " <> text p
966 ExposePackage doc _ _ -> text doc
967
968 pprTrustFlag :: TrustFlag -> SDoc
969 pprTrustFlag flag = case flag of
970 TrustPackage p -> text "-trust " <> text p
971 DistrustPackage p -> text "-distrust " <> text p
972
973 -- -----------------------------------------------------------------------------
974 -- Wired-in packages
975 --
976 -- See Note [Wired-in packages] in Module
977
978 type WiredInUnitId = String
979 type WiredPackagesMap = Map WiredUnitId WiredUnitId
980
981 wired_in_pkgids :: [WiredInUnitId]
982 wired_in_pkgids = map unitIdString wiredInUnitIds
983
984 findWiredInPackages
985 :: DynFlags
986 -> PackagePrecedenceIndex
987 -> [PackageConfig] -- database
988 -> VisibilityMap -- info on what packages are visible
989 -- for wired in selection
990 -> IO ([PackageConfig], -- package database updated for wired in
991 WiredPackagesMap) -- map from unit id to wired identity
992
993 findWiredInPackages dflags prec_map pkgs vis_map = do
994 -- Now we must find our wired-in packages, and rename them to
995 -- their canonical names (eg. base-1.0 ==> base), as described
996 -- in Note [Wired-in packages] in Module
997 let
998 matches :: PackageConfig -> WiredInUnitId -> Bool
999 pc `matches` pid
1000 -- See Note [The integer library] in PrelNames
1001 | pid == unitIdString integerUnitId
1002 = packageNameString pc `elem` ["integer-gmp", "integer-simple"]
1003 pc `matches` pid = packageNameString pc == pid
1004
1005 -- find which package corresponds to each wired-in package
1006 -- delete any other packages with the same name
1007 -- update the package and any dependencies to point to the new
1008 -- one.
1009 --
1010 -- When choosing which package to map to a wired-in package
1011 -- name, we try to pick the latest version of exposed packages.
1012 -- However, if there are no exposed wired in packages available
1013 -- (e.g. -hide-all-packages was used), we can't bail: we *have*
1014 -- to assign a package for the wired-in package: so we try again
1015 -- with hidden packages included to (and pick the latest
1016 -- version).
1017 --
1018 -- You can also override the default choice by using -ignore-package:
1019 -- this works even when there is no exposed wired in package
1020 -- available.
1021 --
1022 findWiredInPackage :: [PackageConfig] -> WiredInUnitId
1023 -> IO (Maybe (WiredInUnitId, PackageConfig))
1024 findWiredInPackage pkgs wired_pkg =
1025 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
1026 all_exposed_ps =
1027 [ p | p <- all_ps
1028 , Map.member (packageConfigId p) vis_map ] in
1029 case all_exposed_ps of
1030 [] -> case all_ps of
1031 [] -> notfound
1032 many -> pick (head (sortByPreference prec_map many))
1033 many -> pick (head (sortByPreference prec_map many))
1034 where
1035 notfound = do
1036 debugTraceMsg dflags 2 $
1037 text "wired-in package "
1038 <> text wired_pkg
1039 <> text " not found."
1040 return Nothing
1041 pick :: PackageConfig
1042 -> IO (Maybe (WiredInUnitId, PackageConfig))
1043 pick pkg = do
1044 debugTraceMsg dflags 2 $
1045 text "wired-in package "
1046 <> text wired_pkg
1047 <> text " mapped to "
1048 <> ppr (unitId pkg)
1049 return (Just (wired_pkg, pkg))
1050
1051
1052 mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
1053 let
1054 wired_in_pkgs = catMaybes mb_wired_in_pkgs
1055
1056 -- this is old: we used to assume that if there were
1057 -- multiple versions of wired-in packages installed that
1058 -- they were mutually exclusive. Now we're assuming that
1059 -- you have one "main" version of each wired-in package
1060 -- (the latest version), and the others are backward-compat
1061 -- wrappers that depend on this one. e.g. base-4.0 is the
1062 -- latest, base-3.0 is a compat wrapper depending on base-4.0.
1063 {-
1064 deleteOtherWiredInPackages pkgs = filterOut bad pkgs
1065 where bad p = any (p `matches`) wired_in_pkgids
1066 && package p `notElem` map fst wired_in_ids
1067 -}
1068
1069 wiredInMap :: Map WiredUnitId WiredUnitId
1070 wiredInMap = Map.fromList
1071 [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId))
1072 | (wiredInUnitId, pkg) <- wired_in_pkgs
1073 , Just key <- pure $ definitePackageConfigId pkg
1074 ]
1075
1076 updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
1077 where upd_pkg pkg
1078 | Just def_uid <- definitePackageConfigId pkg
1079 , Just wiredInUnitId <- Map.lookup def_uid wiredInMap
1080 = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId)
1081 in pkg {
1082 unitId = fsToInstalledUnitId fs,
1083 componentId = ComponentId fs
1084 }
1085 | otherwise
1086 = pkg
1087 upd_deps pkg = pkg {
1088 -- temporary harmless DefUnitId invariant violation
1089 depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg),
1090 exposedModules
1091 = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
1092 (exposedModules pkg)
1093 }
1094
1095
1096 return (updateWiredInDependencies pkgs, wiredInMap)
1097
1098 -- Helper functions for rewiring Module and UnitId. These
1099 -- rewrite UnitIds of modules in wired-in packages to the form known to the
1100 -- compiler, as described in Note [Wired-in packages] in Module.
1101 --
1102 -- For instance, base-4.9.0.0 will be rewritten to just base, to match
1103 -- what appears in PrelNames.
1104
1105 upd_wired_in_mod :: WiredPackagesMap -> Module -> Module
1106 upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
1107
1108 upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId
1109 upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) =
1110 DefiniteUnitId (upd_wired_in wiredInMap def_uid)
1111 upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) =
1112 IndefiniteUnitId $ newIndefUnitId
1113 (indefUnitIdComponentId indef_uid)
1114 (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid))
1115
1116 upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId
1117 upd_wired_in wiredInMap key
1118 | Just key' <- Map.lookup key wiredInMap = key'
1119 | otherwise = key
1120
1121 updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
1122 updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
1123 where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of
1124 Nothing -> vm
1125 Just r -> Map.insert (DefiniteUnitId to) r
1126 (Map.delete (DefiniteUnitId from) vm)
1127
1128
1129 -- ----------------------------------------------------------------------------
1130
1131 -- | The reason why a package is unusable.
1132 data UnusablePackageReason
1133 = -- | We ignored it explicitly using @-ignore-package@.
1134 IgnoredWithFlag
1135 -- | This package transitively depends on a package that was never present
1136 -- in any of the provided databases.
1137 | BrokenDependencies [InstalledUnitId]
1138 -- | This package transitively depends on a package involved in a cycle.
1139 -- Note that the list of 'InstalledUnitId' reports the direct dependencies
1140 -- of this package that (transitively) depended on the cycle, and not
1141 -- the actual cycle itself (which we report separately at high verbosity.)
1142 | CyclicDependencies [InstalledUnitId]
1143 -- | This package transitively depends on a package which was ignored.
1144 | IgnoredDependencies [InstalledUnitId]
1145 -- | This package transitively depends on a package which was
1146 -- shadowed by an ABI-incompatible package.
1147 | ShadowedDependencies [InstalledUnitId]
1148
1149 instance Outputable UnusablePackageReason where
1150 ppr IgnoredWithFlag = text "[ignored with flag]"
1151 ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids)
1152 ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids)
1153 ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids)
1154 ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
1155
1156 type UnusablePackages = Map InstalledUnitId
1157 (PackageConfig, UnusablePackageReason)
1158
1159 pprReason :: SDoc -> UnusablePackageReason -> SDoc
1160 pprReason pref reason = case reason of
1161 IgnoredWithFlag ->
1162 pref <+> text "ignored due to an -ignore-package flag"
1163 BrokenDependencies deps ->
1164 pref <+> text "unusable due to missing dependencies:" $$
1165 nest 2 (hsep (map ppr deps))
1166 CyclicDependencies deps ->
1167 pref <+> text "unusable due to cyclic dependencies:" $$
1168 nest 2 (hsep (map ppr deps))
1169 IgnoredDependencies deps ->
1170 pref <+> text ("unusable because the -ignore-package flag was used to " ++
1171 "ignore at least one of its dependencies:") $$
1172 nest 2 (hsep (map ppr deps))
1173 ShadowedDependencies deps ->
1174 pref <+> text "unusable due to shadowed dependencies:" $$
1175 nest 2 (hsep (map ppr deps))
1176
1177 reportCycles :: DynFlags -> [SCC PackageConfig] -> IO ()
1178 reportCycles dflags sccs = mapM_ report sccs
1179 where
1180 report (AcyclicSCC _) = return ()
1181 report (CyclicSCC vs) =
1182 debugTraceMsg dflags 2 $
1183 text "these packages are involved in a cycle:" $$
1184 nest 2 (hsep (map (ppr . unitId) vs))
1185
1186 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
1187 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
1188 where
1189 report (ipid, (_, reason)) =
1190 debugTraceMsg dflags 2 $
1191 pprReason
1192 (text "package" <+> ppr ipid <+> text "is") reason
1193
1194 -- ----------------------------------------------------------------------------
1195 --
1196 -- Utilities on the database
1197 --
1198
1199 -- | A reverse dependency index, mapping an 'InstalledUnitId' to
1200 -- the 'InstalledUnitId's which have a dependency on it.
1201 type RevIndex = Map InstalledUnitId [InstalledUnitId]
1202
1203 -- | Compute the reverse dependency index of a package database.
1204 reverseDeps :: InstalledPackageIndex -> RevIndex
1205 reverseDeps db = Map.foldl' go Map.empty db
1206 where
1207 go r pkg = foldl' (go' (unitId pkg)) r (depends pkg)
1208 go' from r to = Map.insertWith (++) to [from] r
1209
1210 -- | Given a list of 'InstalledUnitId's to remove, a database,
1211 -- and a reverse dependency index (as computed by 'reverseDeps'),
1212 -- remove those packages, plus any packages which depend on them.
1213 -- Returns the pruned database, as well as a list of 'PackageConfig's
1214 -- that was removed.
1215 removePackages :: [InstalledUnitId] -> RevIndex
1216 -> InstalledPackageIndex
1217 -> (InstalledPackageIndex, [PackageConfig])
1218 removePackages uids index m = go uids (m,[])
1219 where
1220 go [] (m,pkgs) = (m,pkgs)
1221 go (uid:uids) (m,pkgs)
1222 | Just pkg <- Map.lookup uid m
1223 = case Map.lookup uid index of
1224 Nothing -> go uids (Map.delete uid m, pkg:pkgs)
1225 Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)
1226 | otherwise
1227 = go uids (m,pkgs)
1228
1229 -- | Given a 'PackageConfig' from some 'InstalledPackageIndex',
1230 -- return all entries in 'depends' which correspond to packages
1231 -- that do not exist in the index.
1232 depsNotAvailable :: InstalledPackageIndex
1233 -> PackageConfig
1234 -> [InstalledUnitId]
1235 depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg)
1236
1237 -- | Given a 'PackageConfig' from some 'InstalledPackageIndex'
1238 -- return all entries in 'abiDepends' which correspond to packages
1239 -- that do not exist, OR have mismatching ABIs.
1240 depsAbiMismatch :: InstalledPackageIndex
1241 -> PackageConfig
1242 -> [InstalledUnitId]
1243 depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg
1244 where
1245 abiMatch (dep_uid, abi)
1246 | Just dep_pkg <- Map.lookup dep_uid pkg_map
1247 = abiHash dep_pkg == abi
1248 | otherwise
1249 = False
1250
1251 -- -----------------------------------------------------------------------------
1252 -- Ignore packages
1253
1254 ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
1255 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
1256 where
1257 doit (IgnorePackage str) =
1258 case partition (matchingStr str) pkgs of
1259 (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
1260 | p <- ps ]
1261 -- missing package is not an error for -ignore-package,
1262 -- because a common usage is to -ignore-package P as
1263 -- a preventative measure just in case P exists.
1264
1265 -- ----------------------------------------------------------------------------
1266 --
1267 -- Merging databases
1268 --
1269
1270 -- | For each package, a mapping from uid -> i indicates that this
1271 -- package was brought into GHC by the ith @-package-db@ flag on
1272 -- the command line. We use this mapping to make sure we prefer
1273 -- packages that were defined later on the command line, if there
1274 -- is an ambiguity.
1275 type PackagePrecedenceIndex = Map InstalledUnitId Int
1276
1277 -- | Given a list of databases, merge them together, where
1278 -- packages with the same unit id in later databases override
1279 -- earlier ones. This does NOT check if the resulting database
1280 -- makes sense (that's done by 'validateDatabase').
1281 mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])]
1282 -> IO (InstalledPackageIndex, PackagePrecedenceIndex)
1283 mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..]
1284 where
1285 merge (pkg_map, prec_map) (i, (db_path, db)) = do
1286 debugTraceMsg dflags 2 $
1287 text "loading package database" <+> text db_path
1288 forM_ (Set.toList override_set) $ \pkg ->
1289 debugTraceMsg dflags 2 $
1290 text "package" <+> ppr pkg <+>
1291 text "overrides a previously defined package"
1292 return (pkg_map', prec_map')
1293 where
1294 db_map = mk_pkg_map db
1295 mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
1296
1297 -- The set of UnitIds which appear in both db and pkgs. These are the
1298 -- ones that get overridden. Compute this just to give some
1299 -- helpful debug messages at -v2
1300 override_set :: Set InstalledUnitId
1301 override_set = Set.intersection (Map.keysSet db_map)
1302 (Map.keysSet pkg_map)
1303
1304 -- Now merge the sets together (NB: in case of duplicate,
1305 -- first argument preferred)
1306 pkg_map' :: InstalledPackageIndex
1307 pkg_map' = Map.union db_map pkg_map
1308
1309 prec_map' :: PackagePrecedenceIndex
1310 prec_map' = Map.union (Map.map (const i) db_map) prec_map
1311
1312 -- | Validates a database, removing unusable packages from it
1313 -- (this includes removing packages that the user has explicitly
1314 -- ignored.) Our general strategy:
1315 --
1316 -- 1. Remove all broken packages (dangling dependencies)
1317 -- 2. Remove all packages that are cyclic
1318 -- 3. Apply ignore flags
1319 -- 4. Remove all packages which have deps with mismatching ABIs
1320 --
1321 validateDatabase :: DynFlags -> InstalledPackageIndex
1322 -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])
1323 validateDatabase dflags pkg_map1 =
1324 (pkg_map5, unusable, sccs)
1325 where
1326 ignore_flags = reverse (ignorePackageFlags dflags)
1327
1328 -- Compute the reverse dependency index
1329 index = reverseDeps pkg_map1
1330
1331 -- Helper function
1332 mk_unusable mk_err dep_matcher m uids =
1333 Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
1334 | pkg <- uids ]
1335
1336 -- Find broken packages
1337 directly_broken = filter (not . null . depsNotAvailable pkg_map1)
1338 (Map.elems pkg_map1)
1339 (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1
1340 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
1341
1342 -- Find recursive packages
1343 sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg)
1344 | pkg <- Map.elems pkg_map2 ]
1345 getCyclicSCC (CyclicSCC vs) = map unitId vs
1346 getCyclicSCC (AcyclicSCC _) = []
1347 (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2
1348 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
1349
1350 -- Apply ignore flags
1351 directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3)
1352 (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3
1353 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
1354
1355 -- Knock out packages whose dependencies don't agree with ABI
1356 -- (i.e., got invalidated due to shadowing)
1357 directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
1358 (Map.elems pkg_map4)
1359 (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4
1360 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
1361
1362 unusable = directly_ignored `Map.union` unusable_ignored
1363 `Map.union` unusable_broken
1364 `Map.union` unusable_cyclic
1365 `Map.union` unusable_shadowed
1366
1367 -- -----------------------------------------------------------------------------
1368 -- When all the command-line options are in, we can process our package
1369 -- settings and populate the package state.
1370
1371 mkPackageState
1372 :: DynFlags
1373 -- initial databases, in the order they were specified on
1374 -- the command line (later databases shadow earlier ones)
1375 -> [(FilePath, [PackageConfig])]
1376 -> [PreloadUnitId] -- preloaded packages
1377 -> IO (PackageState,
1378 [PreloadUnitId], -- new packages to preload
1379 Maybe [(ModuleName, Module)])
1380
1381 mkPackageState dflags dbs preload0 = do
1382 {-
1383 Plan.
1384
1385 There are two main steps for making the package state:
1386
1387 1. We want to build a single, unified package database based
1388 on all of the input databases, which upholds the invariant that
1389 there is only one package per any UnitId and there are no
1390 dangling dependencies. We'll do this by merging, and
1391 then successively filtering out bad dependencies.
1392
1393 a) Merge all the databases together.
1394 If an input database defines unit ID that is already in
1395 the unified database, that package SHADOWS the existing
1396 package in the current unified database. Note that
1397 order is important: packages defined later in the list of
1398 command line arguments shadow those defined earlier.
1399
1400 b) Remove all packages with missing dependencies, or
1401 mutually recursive dependencies.
1402
1403 b) Remove packages selected by -ignore-package from input database
1404
1405 c) Remove all packages which depended on packages that are now
1406 shadowed by an ABI-incompatible package
1407
1408 d) report (with -v) any packages that were removed by steps 1-3
1409
1410 2. We want to look at the flags controlling package visibility,
1411 and build a mapping of what module names are in scope and
1412 where they live.
1413
1414 a) on the final, unified database, we apply -trust/-distrust
1415 flags directly, modifying the database so that the 'trusted'
1416 field has the correct value.
1417
1418 b) we use the -package/-hide-package flags to compute a
1419 visibility map, stating what packages are "exposed" for
1420 the purposes of computing the module map.
1421 * if any flag refers to a package which was removed by 1-5, then
1422 we can give an error message explaining why
1423 * if -hide-all-packages what not specified, this step also
1424 hides packages which are superseded by later exposed packages
1425 * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
1426 are used
1427
1428 c) based on the visibility map, we pick wired packages and rewrite
1429 them to have the expected unitId.
1430
1431 d) finally, using the visibility map and the package database,
1432 we build a mapping saying what every in scope module name points to.
1433 -}
1434
1435 -- This, and the other reverse's that you will see, are due to the face that
1436 -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
1437 -- than they are on the command line.
1438 let other_flags = reverse (packageFlags dflags)
1439 debugTraceMsg dflags 2 $
1440 text "package flags" <+> ppr other_flags
1441
1442 -- Merge databases together, without checking validity
1443 (pkg_map1, prec_map) <- mergeDatabases dflags dbs
1444
1445 -- Now that we've merged everything together, prune out unusable
1446 -- packages.
1447 let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1
1448
1449 reportCycles dflags sccs
1450 reportUnusable dflags unusable
1451
1452 -- Apply trust flags (these flags apply regardless of whether
1453 -- or not packages are visible or not)
1454 pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable)
1455 (Map.elems pkg_map2) (reverse (trustFlags dflags))
1456 let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1
1457
1458 --
1459 -- Calculate the initial set of packages, prior to any package flags.
1460 -- This set contains the latest version of all valid (not unusable) packages,
1461 -- or is empty if we have -hide-all-packages
1462 --
1463 let preferLater pkg pkg' =
1464 case compareByPreference prec_map pkg pkg' of
1465 GT -> pkg
1466 _ -> pkg'
1467 calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg
1468 initial = if gopt Opt_HideAllPackages dflags
1469 then emptyUDFM
1470 else foldl' calcInitial emptyUDFM pkgs1
1471 vis_map1 = foldUDFM (\p vm ->
1472 -- Note: we NEVER expose indefinite packages by
1473 -- default, because it's almost assuredly not
1474 -- what you want (no mix-in linking has occurred).
1475 if exposed p && unitIdIsDefinite (packageConfigId p)
1476 then Map.insert (packageConfigId p)
1477 UnitVisibility {
1478 uv_expose_all = True,
1479 uv_renamings = [],
1480 uv_package_name = First (Just (fsPackageName p)),
1481 uv_requirements = Map.empty,
1482 uv_explicit = False
1483 }
1484 vm
1485 else vm)
1486 Map.empty initial
1487
1488 --
1489 -- Compute a visibility map according to the command-line flags (-package,
1490 -- -hide-package). This needs to know about the unusable packages, since if a
1491 -- user tries to enable an unusable package, we should let them know.
1492 --
1493 vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable
1494 (gopt Opt_HideAllPackages dflags) pkgs1)
1495 vis_map1 other_flags
1496
1497 --
1498 -- Sort out which packages are wired in. This has to be done last, since
1499 -- it modifies the unit ids of wired in packages, but when we process
1500 -- package arguments we need to key against the old versions.
1501 --
1502 (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2
1503 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
1504
1505 -- Update the visibility map, so we treat wired packages as visible.
1506 let vis_map = updateVisibilityMap wired_map vis_map2
1507
1508 let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags
1509 plugin_vis_map <-
1510 case pluginPackageFlags dflags of
1511 -- common case; try to share the old vis_map
1512 [] | not hide_plugin_pkgs -> return vis_map
1513 | otherwise -> return Map.empty
1514 _ -> do let plugin_vis_map1
1515 | hide_plugin_pkgs = Map.empty
1516 -- Use the vis_map PRIOR to wired in,
1517 -- because otherwise applyPackageFlag
1518 -- won't work.
1519 | otherwise = vis_map2
1520 plugin_vis_map2
1521 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable
1522 (gopt Opt_HideAllPluginPackages dflags) pkgs1)
1523 plugin_vis_map1
1524 (reverse (pluginPackageFlags dflags))
1525 -- Updating based on wired in packages is mostly
1526 -- good hygiene, because it won't matter: no wired in
1527 -- package has a compiler plugin.
1528 -- TODO: If a wired in package had a compiler plugin,
1529 -- and you tried to pick different wired in packages
1530 -- with the plugin flags and the normal flags... what
1531 -- would happen? I don't know! But this doesn't seem
1532 -- likely to actually happen.
1533 return (updateVisibilityMap wired_map plugin_vis_map2)
1534
1535 --
1536 -- Here we build up a set of the packages mentioned in -package
1537 -- flags on the command line; these are called the "preload"
1538 -- packages. we link these packages in eagerly. The preload set
1539 -- should contain at least rts & base, which is why we pretend that
1540 -- the command line contains -package rts & -package base.
1541 --
1542 -- NB: preload IS important even for type-checking, because we
1543 -- need the correct include path to be set.
1544 --
1545 let preload1 = Map.keys (Map.filter uv_explicit vis_map)
1546
1547 let pkgname_map = foldl' add Map.empty pkgs2
1548 where add pn_map p
1549 = Map.insert (packageName p) (componentId p) pn_map
1550
1551 -- The explicitPackages accurately reflects the set of packages we have turned
1552 -- on; as such, it also is the only way one can come up with requirements.
1553 -- The requirement context is directly based off of this: we simply
1554 -- look for nested unit IDs that are directly fed holes: the requirements
1555 -- of those units are precisely the ones we need to track
1556 let explicit_pkgs = Map.keys vis_map
1557 req_ctx = Map.map (Set.toList)
1558 $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
1559
1560
1561 let preload2 = preload1
1562
1563 let
1564 -- add base & rts to the preload packages
1565 basicLinkedPackages
1566 | gopt Opt_AutoLinkPackages dflags
1567 = filter (flip elemUDFM (unPackageConfigMap pkg_db))
1568 [baseUnitId, rtsUnitId]
1569 | otherwise = []
1570 -- but in any case remove the current package from the set of
1571 -- preloaded packages so that base/rts does not end up in the
1572 -- set up preloaded package when we are just building it
1573 -- (NB: since this is only relevant for base/rts it doesn't matter
1574 -- that thisUnitIdInsts_ is not wired yet)
1575 --
1576 preload3 = nub $ filter (/= thisPackage dflags)
1577 $ (basicLinkedPackages ++ preload2)
1578
1579 -- Close the preload packages with their dependencies
1580 dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))
1581 let new_dep_preload = filter (`notElem` preload0) dep_preload
1582
1583 let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map
1584 mod_map2 = mkUnusableModuleToPkgConfAll unusable
1585 mod_map = Map.union mod_map1 mod_map2
1586
1587 dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map"
1588 (pprModuleMap mod_map)
1589
1590 -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
1591 let !pstate = PackageState{
1592 preloadPackages = dep_preload,
1593 explicitPackages = explicit_pkgs,
1594 pkgIdMap = pkg_db,
1595 moduleToPkgConfAll = mod_map,
1596 pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map,
1597 packageNameMap = pkgname_map,
1598 unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],
1599 requirementContext = req_ctx
1600 }
1601 let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags)
1602 return (pstate, new_dep_preload, new_insts)
1603
1604 -- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
1605 -- that it was recorded as in the package database.
1606 unwireUnitId :: DynFlags -> UnitId -> UnitId
1607 unwireUnitId dflags uid@(DefiniteUnitId def_uid) =
1608 maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags)))
1609 unwireUnitId _ uid = uid
1610
1611 -- -----------------------------------------------------------------------------
1612 -- | Makes the mapping from module to package info
1613
1614 -- Slight irritation: we proceed by leafing through everything
1615 -- in the installed package database, which makes handling indefinite
1616 -- packages a bit bothersome.
1617
1618 mkModuleToPkgConfAll
1619 :: DynFlags
1620 -> PackageConfigMap
1621 -> VisibilityMap
1622 -> ModuleToPkgConfAll
1623 mkModuleToPkgConfAll dflags pkg_db vis_map =
1624 -- What should we fold on? Both situations are awkward:
1625 --
1626 -- * Folding on the visibility map means that we won't create
1627 -- entries for packages that aren't mentioned in vis_map
1628 -- (e.g., hidden packages, causing #14717)
1629 --
1630 -- * Folding on pkg_db is awkward because if we have an
1631 -- Backpack instantiation, we need to possibly add a
1632 -- package from pkg_db multiple times to the actual
1633 -- ModuleToPkgConfAll. Also, we don't really want
1634 -- definite package instantiations to show up in the
1635 -- list of possibilities.
1636 --
1637 -- So what will we do instead? We'll extend vis_map with
1638 -- entries for every definite (for non-Backpack) and
1639 -- indefinite (for Backpack) package, so that we get the
1640 -- hidden entries we need.
1641 Map.foldlWithKey extend_modmap emptyMap vis_map_extended
1642 where
1643 vis_map_extended = Map.union vis_map {- preferred -} default_vis
1644
1645 default_vis = Map.fromList
1646 [ (packageConfigId pkg, mempty)
1647 | pkg <- eltsUDFM (unPackageConfigMap pkg_db)
1648 -- Exclude specific instantiations of an indefinite
1649 -- package
1650 , indefinite pkg || null (instantiatedWith pkg)
1651 ]
1652
1653 emptyMap = Map.empty
1654 setOrigins m os = fmap (const os) m
1655 extend_modmap modmap uid
1656 UnitVisibility { uv_expose_all = b, uv_renamings = rns }
1657 = addListTo modmap theBindings
1658 where
1659 pkg = pkg_lookup uid
1660
1661 theBindings :: [(ModuleName, Map Module ModuleOrigin)]
1662 theBindings = newBindings b rns
1663
1664 newBindings :: Bool
1665 -> [(ModuleName, ModuleName)]
1666 -> [(ModuleName, Map Module ModuleOrigin)]
1667 newBindings e rns = es e ++ hiddens ++ map rnBinding rns
1668
1669 rnBinding :: (ModuleName, ModuleName)
1670 -> (ModuleName, Map Module ModuleOrigin)
1671 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1672 where origEntry = case lookupUFM esmap orig of
1673 Just r -> r
1674 Nothing -> throwGhcException (CmdLineError (showSDoc dflags
1675 (text "package flag: could not find module name" <+>
1676 ppr orig <+> text "in package" <+> ppr pk)))
1677
1678 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
1679 es e = do
1680 (m, exposedReexport) <- exposed_mods
1681 let (pk', m', origin') =
1682 case exposedReexport of
1683 Nothing -> (pk, m, fromExposedModules e)
1684 Just (Module pk' m') ->
1685 let pkg' = pkg_lookup pk'
1686 in (pk', m', fromReexportedModules e pkg')
1687 return (m, mkModMap pk' m' origin')
1688
1689 esmap :: UniqFM (Map Module ModuleOrigin)
1690 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1691 -- be overwritten
1692
1693 hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
1694
1695 pk = packageConfigId pkg
1696 pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
1697 `orElse` pprPanic "pkg_lookup" (ppr uid)
1698
1699 exposed_mods = exposedModules pkg
1700 hidden_mods = hiddenModules pkg
1701
1702 -- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages.
1703 mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll
1704 mkUnusableModuleToPkgConfAll unusables =
1705 Map.foldl' extend_modmap Map.empty unusables
1706 where
1707 extend_modmap modmap (pkg, reason) = addListTo modmap bindings
1708 where bindings :: [(ModuleName, Map Module ModuleOrigin)]
1709 bindings = exposed ++ hidden
1710
1711 origin = ModUnusable reason
1712 pkg_id = packageConfigId pkg
1713
1714 exposed = map get_exposed exposed_mods
1715 hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
1716
1717 get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
1718 get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin)
1719
1720 exposed_mods = exposedModules pkg
1721 hidden_mods = hiddenModules pkg
1722
1723 -- | Add a list of key/value pairs to a nested map.
1724 --
1725 -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
1726 -- when reloading modules in GHCi (see Trac #4029). This ensures that each
1727 -- value is forced before installing into the map.
1728 addListTo :: (Monoid a, Ord k1, Ord k2)
1729 => Map k1 (Map k2 a)
1730 -> [(k1, Map k2 a)]
1731 -> Map k1 (Map k2 a)
1732 addListTo = foldl' merge
1733 where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
1734
1735 -- | Create a singleton module mapping
1736 mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
1737 mkModMap pkg mod = Map.singleton (mkModule pkg mod)
1738
1739 -- -----------------------------------------------------------------------------
1740 -- Extracting information from the packages in scope
1741
1742 -- Many of these functions take a list of packages: in those cases,
1743 -- the list is expected to contain the "dependent packages",
1744 -- i.e. those packages that were found to be depended on by the
1745 -- current module/program. These can be auto or non-auto packages, it
1746 -- doesn't really matter. The list is always combined with the list
1747 -- of preload (command-line) packages to determine which packages to
1748 -- use.
1749
1750 -- | Find all the include directories in these and the preload packages
1751 getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String]
1752 getPackageIncludePath dflags pkgs =
1753 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1754
1755 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1756 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1757
1758 -- | Find all the library paths in these and the preload packages
1759 getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String]
1760 getPackageLibraryPath dflags pkgs =
1761 collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs
1762
1763 collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath]
1764 collectLibraryPaths dflags = nub . filter notNull
1765 . concatMap (libraryDirsForWay dflags)
1766
1767 -- | Find all the link options in these and the preload packages,
1768 -- returning (package hs lib options, extra library options, other flags)
1769 getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String])
1770 getPackageLinkOpts dflags pkgs =
1771 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1772
1773 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1774 collectLinkOpts dflags ps =
1775 (
1776 concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1777 concatMap (map ("-l" ++) . extraLibraries) ps,
1778 concatMap ldOptions ps
1779 )
1780 collectArchives :: DynFlags -> PackageConfig -> IO [FilePath]
1781 collectArchives dflags pc =
1782 filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
1783 | searchPath <- searchPaths
1784 , lib <- libs ]
1785 where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc
1786 libs = packageHsLibs dflags pc ++ extraLibraries pc
1787
1788 getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)]
1789 getLibs dflags pkgs = do
1790 ps <- getPreloadPackagesAnd dflags pkgs
1791 fmap concat . forM ps $ \p -> do
1792 let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p]
1793 , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]
1794 filterM (doesFileExist . fst) candidates
1795
1796 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1797 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1798 where
1799 ways0 = ways dflags
1800
1801 ways1 = filter (/= WayDyn) ways0
1802 -- the name of a shared library is libHSfoo-ghc<version>.so
1803 -- we leave out the _dyn, because it is superfluous
1804
1805 -- debug and profiled RTSs include support for -eventlog
1806 ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1
1807 = filter (/= WayEventLog) ways1
1808 | otherwise
1809 = ways1
1810
1811 tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
1812 rts_tag = mkBuildTag ways2
1813
1814 mkDynName x
1815 | WayDyn `notElem` ways dflags = x
1816 | "HS" `isPrefixOf` x =
1817 x ++ '-':programName dflags ++ projectVersion dflags
1818 -- For non-Haskell libraries, we use the name "Cfoo". The .a
1819 -- file is libCfoo.a, and the .so is libfoo.so. That way the
1820 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1821 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1822 | Just x' <- stripPrefix "C" x = x'
1823 | otherwise
1824 = panic ("Don't understand library name " ++ x)
1825
1826 -- Add _thr and other rts suffixes to packages named
1827 -- `rts` or `rts-1.0`. Why both? Traditionally the rts
1828 -- package is called `rts` only. However the tooling
1829 -- usually expects a package name to have a version.
1830 -- As such we will gradually move towards the `rts-1.0`
1831 -- package name, at which point the `rts` package name
1832 -- will eventually be unused.
1833 --
1834 -- This change elevates the need to add custom hooks
1835 -- and handling specifically for the `rts` package for
1836 -- example in ghc-cabal.
1837 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
1838 addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag)
1839 addSuffix other_lib = other_lib ++ (expandTag tag)
1840
1841 expandTag t | null t = ""
1842 | otherwise = '_':t
1843
1844 -- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way.
1845 libraryDirsForWay :: DynFlags -> PackageConfig -> [String]
1846 libraryDirsForWay dflags
1847 | WayDyn `elem` ways dflags = libraryDynDirs
1848 | otherwise = libraryDirs
1849
1850 -- | Find all the C-compiler options in these and the preload packages
1851 getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String]
1852 getPackageExtraCcOpts dflags pkgs = do
1853 ps <- getPreloadPackagesAnd dflags pkgs
1854 return (concatMap ccOptions ps)
1855
1856 -- | Find all the package framework paths in these and the preload packages
1857 getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String]
1858 getPackageFrameworkPath dflags pkgs = do
1859 ps <- getPreloadPackagesAnd dflags pkgs
1860 return (nub (filter notNull (concatMap frameworkDirs ps)))
1861
1862 -- | Find all the package frameworks in these and the preload packages
1863 getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String]
1864 getPackageFrameworks dflags pkgs = do
1865 ps <- getPreloadPackagesAnd dflags pkgs
1866 return (concatMap frameworks ps)
1867
1868 -- -----------------------------------------------------------------------------
1869 -- Package Utils
1870
1871 -- | Takes a 'ModuleName', and if the module is in any package returns
1872 -- list of modules which take that name.
1873 lookupModuleInAllPackages :: DynFlags
1874 -> ModuleName
1875 -> [(Module, PackageConfig)]
1876 lookupModuleInAllPackages dflags m
1877 = case lookupModuleWithSuggestions dflags m Nothing of
1878 LookupFound a b -> [(a,b)]
1879 LookupMultiple rs -> map f rs
1880 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1881 (moduleUnitId m)))
1882 _ -> []
1883
1884 -- | The result of performing a lookup
1885 data LookupResult =
1886 -- | Found the module uniquely, nothing else to do
1887 LookupFound Module PackageConfig
1888 -- | Multiple modules with the same name in scope
1889 | LookupMultiple [(Module, ModuleOrigin)]
1890 -- | No modules found, but there were some hidden ones with
1891 -- an exact name match. First is due to package hidden, second
1892 -- is due to module being hidden
1893 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1894 -- | No modules found, but there were some unusable ones with
1895 -- an exact name match
1896 | LookupUnusable [(Module, ModuleOrigin)]
1897 -- | Nothing found, here are some suggested different names
1898 | LookupNotFound [ModuleSuggestion] -- suggestions
1899
1900 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1901 | SuggestHidden ModuleName Module ModuleOrigin
1902
1903 lookupModuleWithSuggestions :: DynFlags
1904 -> ModuleName
1905 -> Maybe FastString
1906 -> LookupResult
1907 lookupModuleWithSuggestions dflags
1908 = lookupModuleWithSuggestions' dflags
1909 (moduleToPkgConfAll (pkgState dflags))
1910
1911 lookupPluginModuleWithSuggestions :: DynFlags
1912 -> ModuleName
1913 -> Maybe FastString
1914 -> LookupResult
1915 lookupPluginModuleWithSuggestions dflags
1916 = lookupModuleWithSuggestions' dflags
1917 (pluginModuleToPkgConfAll (pkgState dflags))
1918
1919 lookupModuleWithSuggestions' :: DynFlags
1920 -> ModuleToPkgConfAll
1921 -> ModuleName
1922 -> Maybe FastString
1923 -> LookupResult
1924 lookupModuleWithSuggestions' dflags mod_map m mb_pn
1925 = case Map.lookup m mod_map of
1926 Nothing -> LookupNotFound suggestions
1927 Just xs ->
1928 case foldl' classify ([],[],[], []) (Map.toList xs) of
1929 ([], [], [], []) -> LookupNotFound suggestions
1930 (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m)
1931 (_, _, _, exposed@(_:_)) -> LookupMultiple exposed
1932 ([], [], unusable@(_:_), []) -> LookupUnusable unusable
1933 (hidden_pkg, hidden_mod, _, []) ->
1934 LookupHidden hidden_pkg hidden_mod
1935 where
1936 classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) =
1937 let origin = filterOrigin mb_pn (mod_pkg m) origin0
1938 x = (m, origin)
1939 in case origin of
1940 ModHidden
1941 -> (hidden_pkg, x:hidden_mod, unusable, exposed)
1942 ModUnusable _
1943 -> (hidden_pkg, hidden_mod, x:unusable, exposed)
1944 _ | originEmpty origin
1945 -> (hidden_pkg, hidden_mod, unusable, exposed)
1946 | originVisible origin
1947 -> (hidden_pkg, hidden_mod, unusable, x:exposed)
1948 | otherwise
1949 -> (x:hidden_pkg, hidden_mod, unusable, exposed)
1950
1951 pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
1952 mod_pkg = pkg_lookup . moduleUnitId
1953
1954 -- Filters out origins which are not associated with the given package
1955 -- qualifier. No-op if there is no package qualifier. Test if this
1956 -- excluded all origins with 'originEmpty'.
1957 filterOrigin :: Maybe FastString
1958 -> PackageConfig
1959 -> ModuleOrigin
1960 -> ModuleOrigin
1961 filterOrigin Nothing _ o = o
1962 filterOrigin (Just pn) pkg o =
1963 case o of
1964 ModHidden -> if go pkg then ModHidden else mempty
1965 (ModUnusable _) -> if go pkg then o else mempty
1966 ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1967 fromHiddenReexport = rhs }
1968 -> ModOrigin {
1969 fromOrigPackage = if go pkg then e else Nothing
1970 , fromExposedReexport = filter go res
1971 , fromHiddenReexport = filter go rhs
1972 , fromPackageFlag = False -- always excluded
1973 }
1974 where go pkg = pn == fsPackageName pkg
1975
1976 suggestions
1977 | gopt Opt_HelpfulErrors dflags =
1978 fuzzyLookup (moduleNameString m) all_mods
1979 | otherwise = []
1980
1981 all_mods :: [(String, ModuleSuggestion)] -- All modules
1982 all_mods = sortBy (comparing fst) $
1983 [ (moduleNameString m, suggestion)
1984 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1985 , suggestion <- map (getSuggestion m) (Map.toList e)
1986 ]
1987 getSuggestion name (mod, origin) =
1988 (if originVisible origin then SuggestVisible else SuggestHidden)
1989 name mod origin
1990
1991 listVisibleModuleNames :: DynFlags -> [ModuleName]
1992 listVisibleModuleNames dflags =
1993 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1994 where visible (_, ms) = any originVisible (Map.elems ms)
1995
1996 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1997 -- 'PackageConfig's
1998 getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]
1999 getPreloadPackagesAnd dflags pkgids0 =
2000 let
2001 pkgids = pkgids0 ++
2002 -- An indefinite package will have insts to HOLE,
2003 -- which is not a real package. Don't look it up.
2004 -- Fixes #14525
2005 if isIndefinite dflags
2006 then []
2007 else map (toInstalledUnitId . moduleUnitId . snd)
2008 (thisUnitIdInsts dflags)
2009 state = pkgState dflags
2010 pkg_map = pkgIdMap state
2011 preload = preloadPackages state
2012 pairs = zip pkgids (repeat Nothing)
2013 in do
2014 all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
2015 return (map (getInstalledPackageDetails dflags) all_pkgs)
2016
2017 -- Takes a list of packages, and returns the list with dependencies included,
2018 -- in reverse dependency order (a package appears before those it depends on).
2019 closeDeps :: DynFlags
2020 -> PackageConfigMap
2021 -> [(InstalledUnitId, Maybe InstalledUnitId)]
2022 -> IO [InstalledUnitId]
2023 closeDeps dflags pkg_map ps
2024 = throwErr dflags (closeDepsErr dflags pkg_map ps)
2025
2026 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
2027 throwErr dflags m
2028 = case m of
2029 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
2030 Succeeded r -> return r
2031
2032 closeDepsErr :: DynFlags
2033 -> PackageConfigMap
2034 -> [(InstalledUnitId,Maybe InstalledUnitId)]
2035 -> MaybeErr MsgDoc [InstalledUnitId]
2036 closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps
2037
2038 -- internal helper
2039 add_package :: DynFlags
2040 -> PackageConfigMap
2041 -> [PreloadUnitId]
2042 -> (PreloadUnitId,Maybe PreloadUnitId)
2043 -> MaybeErr MsgDoc [PreloadUnitId]
2044 add_package dflags pkg_db ps (p, mb_parent)
2045 | p `elem` ps = return ps -- Check if we've already added this package
2046 | otherwise =
2047 case lookupInstalledPackage' pkg_db p of
2048 Nothing -> Failed (missingPackageMsg p <>
2049 missingDependencyMsg mb_parent)
2050 Just pkg -> do
2051 -- Add the package's dependents also
2052 ps' <- foldM add_unit_key ps (depends pkg)
2053 return (p : ps')
2054 where
2055 add_unit_key ps key
2056 = add_package dflags pkg_db ps (key, Just p)
2057
2058 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
2059 missingPackageMsg p = text "unknown package:" <+> ppr p
2060
2061 missingDependencyMsg :: Maybe InstalledUnitId -> SDoc
2062 missingDependencyMsg Nothing = Outputable.empty
2063 missingDependencyMsg (Just parent)
2064 = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent))
2065
2066 -- -----------------------------------------------------------------------------
2067
2068 componentIdString :: DynFlags -> ComponentId -> Maybe String
2069 componentIdString dflags cid = do
2070 conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid)
2071 return $
2072 case sourceLibName conf of
2073 Nothing -> sourcePackageIdString conf
2074 Just (PackageName libname) ->
2075 packageNameString conf
2076 ++ "-" ++ showVersion (packageVersion conf)
2077 ++ ":" ++ unpackFS libname
2078
2079 displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
2080 displayInstalledUnitId dflags uid =
2081 fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
2082
2083 -- | Will the 'Name' come from a dynamically linked library?
2084 isDllName :: DynFlags -> Module -> Name -> Bool
2085 -- Despite the "dll", I think this function just means that
2086 -- the symbol comes from another dynamically-linked package,
2087 -- and applies on all platforms, not just Windows
2088 isDllName dflags this_mod name
2089 | not (gopt Opt_ExternalDynamicRefs dflags) = False
2090 | Just mod <- nameModule_maybe name
2091 -- Issue #8696 - when GHC is dynamically linked, it will attempt
2092 -- to load the dynamic dependencies of object files at compile
2093 -- time for things like QuasiQuotes or
2094 -- TemplateHaskell. Unfortunately, this interacts badly with
2095 -- intra-package linking, because we don't generate indirect
2096 -- (dynamic) symbols for intra-package calls. This means that if a
2097 -- module with an intra-package call is loaded without its
2098 -- dependencies, then GHC fails to link. This is the cause of #
2099 --
2100 -- In the mean time, always force dynamic indirections to be
2101 -- generated: when the module name isn't the module being
2102 -- compiled, references are dynamic.
2103 = case platformOS $ targetPlatform dflags of
2104 -- On Windows the hack for #8696 makes it unlinkable.
2105 -- As the entire setup of the code from Cmm down to the RTS expects
2106 -- the use of trampolines for the imported functions only when
2107 -- doing intra-package linking, e.g. refering to a symbol defined in the same
2108 -- package should not use a trampoline.
2109 -- I much rather have dynamic TH not supported than the entire Dynamic linking
2110 -- not due to a hack.
2111 -- Also not sure this would break on Windows anyway.
2112 OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod
2113
2114 -- For the other platforms, still perform the hack
2115 _ -> mod /= this_mod
2116
2117 | otherwise = False -- no, it is not even an external name
2118
2119 -- -----------------------------------------------------------------------------
2120 -- Displaying packages
2121
2122 -- | Show (very verbose) package info
2123 pprPackages :: DynFlags -> SDoc
2124 pprPackages = pprPackagesWith pprPackageConfig
2125
2126 pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
2127 pprPackagesWith pprIPI dflags =
2128 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
2129
2130 -- | Show simplified package info.
2131 --
2132 -- The idea is to only print package id, and any information that might
2133 -- be different from the package databases (exposure, trust)
2134 pprPackagesSimple :: DynFlags -> SDoc
2135 pprPackagesSimple = pprPackagesWith pprIPI
2136 where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)
2137 e = if exposed ipi then text "E" else text " "
2138 t = if trusted ipi then text "T" else text " "
2139 in e <> t <> text " " <> ftext i
2140
2141 -- | Show the mapping of modules to where they come from.
2142 pprModuleMap :: ModuleToPkgConfAll -> SDoc
2143 pprModuleMap mod_map =
2144 vcat (map pprLine (Map.toList mod_map))
2145 where
2146 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
2147 pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
2148 pprEntry m (m',o)
2149 | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
2150 | otherwise = ppr m' <+> parens (ppr o)
2151
2152 fsPackageName :: PackageConfig -> FastString
2153 fsPackageName = mkFastString . packageNameString
2154
2155 -- | Given a fully instantiated 'UnitId', improve it into a
2156 -- 'InstalledUnitId' if we can find it in the package database.
2157 improveUnitId :: PackageConfigMap -> UnitId -> UnitId
2158 improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit
2159 improveUnitId pkg_map uid =
2160 -- Do NOT lookup indefinite ones, they won't be useful!
2161 case lookupPackage' False pkg_map uid of
2162 Nothing -> uid
2163 Just pkg ->
2164 -- Do NOT improve if the indefinite unit id is not
2165 -- part of the closure unique set. See
2166 -- Note [UnitId to InstalledUnitId improvement]
2167 if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map
2168 then packageConfigId pkg
2169 else uid
2170
2171 -- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
2172 -- in the @hs-boot@ loop-breaker.
2173 getPackageConfigMap :: DynFlags -> PackageConfigMap
2174 getPackageConfigMap = pkgIdMap . pkgState