never executed always true always false
1 -- (c) The University of Glasgow, 2006
2
3 {-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
4 {-# LANGUAGE LambdaCase #-}
5 {-# LANGUAGE NamedFieldPuns #-}
6
7 -- | Unit manipulation
8 module GHC.Unit.State (
9 module GHC.Unit.Info,
10
11 -- * Reading the package config, and processing cmdline args
12 UnitState(..),
13 PreloadUnitClosure,
14 UnitDatabase (..),
15 UnitErr (..),
16 emptyUnitState,
17 initUnits,
18 readUnitDatabases,
19 readUnitDatabase,
20 getUnitDbRefs,
21 resolveUnitDatabase,
22 listUnitInfo,
23
24 -- * Querying the package config
25 UnitInfoMap,
26 lookupUnit,
27 lookupUnit',
28 unsafeLookupUnit,
29 lookupUnitId,
30 lookupUnitId',
31 unsafeLookupUnitId,
32
33 lookupPackageName,
34 improveUnit,
35 searchPackageId,
36 listVisibleModuleNames,
37 lookupModuleInAllUnits,
38 lookupModuleWithSuggestions,
39 lookupModulePackage,
40 lookupPluginModuleWithSuggestions,
41 requirementMerges,
42 LookupResult(..),
43 ModuleSuggestion(..),
44 ModuleOrigin(..),
45 UnusableUnitReason(..),
46 pprReason,
47
48 closeUnitDeps,
49 closeUnitDeps',
50 mayThrowUnitErr,
51
52 -- * Module hole substitution
53 ShHoleSubst,
54 renameHoleUnit,
55 renameHoleModule,
56 renameHoleUnit',
57 renameHoleModule',
58 instUnitToUnit,
59 instModuleToModule,
60
61 -- * Pretty-printing
62 pprFlag,
63 pprUnits,
64 pprUnitsSimple,
65 pprUnitIdForUser,
66 pprUnitInfoForUser,
67 pprModuleMap,
68 pprWithUnitState,
69
70 -- * Utils
71 unwireUnit,
72 implicitPackageDeps)
73 where
74
75 import GHC.Prelude
76
77 import GHC.Driver.Session
78
79 import GHC.Platform
80 import GHC.Platform.Ways
81
82 import GHC.Unit.Database
83 import GHC.Unit.Info
84 import GHC.Unit.Ppr
85 import GHC.Unit.Types
86 import GHC.Unit.Module
87 import GHC.Unit.Home
88
89 import GHC.Types.Unique.FM
90 import GHC.Types.Unique.DFM
91 import GHC.Types.Unique.Set
92 import GHC.Types.Unique.DSet
93 import GHC.Types.PkgQual
94
95 import GHC.Utils.Misc
96 import GHC.Utils.Panic
97 import GHC.Utils.Outputable as Outputable
98 import GHC.Data.Maybe
99
100 import System.Environment ( getEnv )
101 import GHC.Data.FastString
102 import qualified GHC.Data.ShortText as ST
103 import GHC.Utils.Logger
104 import GHC.Utils.Error
105 import GHC.Utils.Exception
106
107 import System.Directory
108 import System.FilePath as FilePath
109 import Control.Monad
110 import Data.Graph (stronglyConnComp, SCC(..))
111 import Data.Char ( toUpper )
112 import Data.List ( intersperse, partition, sortBy, isSuffixOf )
113 import Data.Map (Map)
114 import Data.Set (Set)
115 import Data.Monoid (First(..))
116 import qualified Data.Semigroup as Semigroup
117 import qualified Data.Map as Map
118 import qualified Data.Map.Strict as MapStrict
119 import qualified Data.Set as Set
120 import GHC.LanguageExtensions
121
122 -- ---------------------------------------------------------------------------
123 -- The Unit state
124
125 -- The unit state is computed by 'initUnits', and kept in HscEnv.
126 -- It is influenced by various command-line flags:
127 --
128 -- * @-package \<pkg>@ and @-package-id \<pkg>@ cause @\<pkg>@ to become exposed.
129 -- If @-hide-all-packages@ was not specified, these commands also cause
130 -- all other packages with the same name to become hidden.
131 --
132 -- * @-hide-package \<pkg>@ causes @\<pkg>@ to become hidden.
133 --
134 -- * (there are a few more flags, check below for their semantics)
135 --
136 -- The unit state has the following properties.
137 --
138 -- * Let @exposedUnits@ be the set of packages thus exposed.
139 -- Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of
140 -- their dependencies.
141 --
142 -- * When searching for a module from a preload import declaration,
143 -- only the exposed modules in @exposedUnits@ are valid.
144 --
145 -- * When searching for a module from an implicit import, all modules
146 -- from @depExposedUnits@ are valid.
147 --
148 -- * When linking in a compilation manager mode, we link in packages the
149 -- program depends on (the compiler knows this list by the
150 -- time it gets to the link step). Also, we link in all packages
151 -- which were mentioned with preload @-package@ flags on the command-line,
152 -- or are a transitive dependency of same, or are \"base\"\/\"rts\".
153 -- The reason for this is that we might need packages which don't
154 -- contain any Haskell modules, and therefore won't be discovered
155 -- by the normal mechanism of dependency tracking.
156
157 -- Notes on DLLs
158 -- ~~~~~~~~~~~~~
159 -- When compiling module A, which imports module B, we need to
160 -- know whether B will be in the same DLL as A.
161 -- If it's in the same DLL, we refer to B_f_closure
162 -- If it isn't, we refer to _imp__B_f_closure
163 -- When compiling A, we record in B's Module value whether it's
164 -- in a different DLL, by setting the DLL flag.
165
166 -- | Given a module name, there may be multiple ways it came into scope,
167 -- possibly simultaneously. This data type tracks all the possible ways
168 -- it could have come into scope. Warning: don't use the record functions,
169 -- they're partial!
170 data ModuleOrigin =
171 -- | Module is hidden, and thus never will be available for import.
172 -- (But maybe the user didn't realize), so we'll still keep track
173 -- of these modules.)
174 ModHidden
175 -- | Module is unavailable because the package is unusable.
176 | ModUnusable UnusableUnitReason
177 -- | Module is public, and could have come from some places.
178 | ModOrigin {
179 -- | @Just False@ means that this module is in
180 -- someone's @exported-modules@ list, but that package is hidden;
181 -- @Just True@ means that it is available; @Nothing@ means neither
182 -- applies.
183 fromOrigUnit :: Maybe Bool
184 -- | Is the module available from a reexport of an exposed package?
185 -- There could be multiple.
186 , fromExposedReexport :: [UnitInfo]
187 -- | Is the module available from a reexport of a hidden package?
188 , fromHiddenReexport :: [UnitInfo]
189 -- | Did the module export come from a package flag? (ToDo: track
190 -- more information.
191 , fromPackageFlag :: Bool
192 }
193
194 instance Outputable ModuleOrigin where
195 ppr ModHidden = text "hidden module"
196 ppr (ModUnusable _) = text "unusable module"
197 ppr (ModOrigin e res rhs f) = sep (punctuate comma (
198 (case e of
199 Nothing -> []
200 Just False -> [text "hidden package"]
201 Just True -> [text "exposed package"]) ++
202 (if null res
203 then []
204 else [text "reexport by" <+>
205 sep (map (ppr . mkUnit) res)]) ++
206 (if null rhs
207 then []
208 else [text "hidden reexport by" <+>
209 sep (map (ppr . mkUnit) res)]) ++
210 (if f then [text "package flag"] else [])
211 ))
212
213 -- | Smart constructor for a module which is in @exposed-modules@. Takes
214 -- as an argument whether or not the defining package is exposed.
215 fromExposedModules :: Bool -> ModuleOrigin
216 fromExposedModules e = ModOrigin (Just e) [] [] False
217
218 -- | Smart constructor for a module which is in @reexported-modules@. Takes
219 -- as an argument whether or not the reexporting package is exposed, and
220 -- also its 'UnitInfo'.
221 fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
222 fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
223 fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
224
225 -- | Smart constructor for a module which was bound by a package flag.
226 fromFlag :: ModuleOrigin
227 fromFlag = ModOrigin Nothing [] [] True
228
229 instance Semigroup ModuleOrigin where
230 x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =
231 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
232 where g (Just b) (Just b')
233 | b == b' = Just b
234 | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $
235 text "x: " <> ppr x $$ text "y: " <> ppr y
236 g Nothing x = x
237 g x Nothing = x
238 x <> y = pprPanic "ModOrigin: hidden module redefined" $
239 text "x: " <> ppr x $$ text "y: " <> ppr y
240
241 instance Monoid ModuleOrigin where
242 mempty = ModOrigin Nothing [] [] False
243 mappend = (Semigroup.<>)
244
245 -- | Is the name from the import actually visible? (i.e. does it cause
246 -- ambiguity, or is it only relevant when we're making suggestions?)
247 originVisible :: ModuleOrigin -> Bool
248 originVisible ModHidden = False
249 originVisible (ModUnusable _) = False
250 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
251
252 -- | Are there actually no providers for this module? This will never occur
253 -- except when we're filtering based on package imports.
254 originEmpty :: ModuleOrigin -> Bool
255 originEmpty (ModOrigin Nothing [] [] False) = True
256 originEmpty _ = False
257
258 type PreloadUnitClosure = UniqSet UnitId
259
260 -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
261 type VisibilityMap = Map Unit UnitVisibility
262
263 -- | 'UnitVisibility' records the various aspects of visibility of a particular
264 -- 'Unit'.
265 data UnitVisibility = UnitVisibility
266 { uv_expose_all :: Bool
267 -- ^ Should all modules in exposed-modules should be dumped into scope?
268 , uv_renamings :: [(ModuleName, ModuleName)]
269 -- ^ Any custom renamings that should bring extra 'ModuleName's into
270 -- scope.
271 , uv_package_name :: First FastString
272 -- ^ The package name associated with the 'Unit'. This is used
273 -- to implement legacy behavior where @-package foo-0.1@ implicitly
274 -- hides any packages named @foo@
275 , uv_requirements :: Map ModuleName (Set InstantiatedModule)
276 -- ^ The signatures which are contributed to the requirements context
277 -- from this unit ID.
278 , uv_explicit :: Bool
279 -- ^ Whether or not this unit was explicitly brought into scope,
280 -- as opposed to implicitly via the 'exposed' fields in the
281 -- package database (when @-hide-all-packages@ is not passed.)
282 }
283
284 instance Outputable UnitVisibility where
285 ppr (UnitVisibility {
286 uv_expose_all = b,
287 uv_renamings = rns,
288 uv_package_name = First mb_pn,
289 uv_requirements = reqs,
290 uv_explicit = explicit
291 }) = ppr (b, rns, mb_pn, reqs, explicit)
292
293 instance Semigroup UnitVisibility where
294 uv1 <> uv2
295 = UnitVisibility
296 { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
297 , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
298 , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
299 , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
300 , uv_explicit = uv_explicit uv1 || uv_explicit uv2
301 }
302
303 instance Monoid UnitVisibility where
304 mempty = UnitVisibility
305 { uv_expose_all = False
306 , uv_renamings = []
307 , uv_package_name = First Nothing
308 , uv_requirements = Map.empty
309 , uv_explicit = False
310 }
311 mappend = (Semigroup.<>)
312
313
314 -- | Unit configuration
315 data UnitConfig = UnitConfig
316 { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS
317 , unitConfigWays :: !Ways -- ^ Ways to use
318
319 , unitConfigAllowVirtual :: !Bool -- ^ Allow virtual units
320 -- ^ Do we allow the use of virtual units instantiated on-the-fly (see Note
321 -- [About units] in GHC.Unit). This should only be true when we are
322 -- type-checking an indefinite unit (not producing any code).
323
324 , unitConfigProgramName :: !String
325 -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
326 -- variables such as "GHC[JS]_PACKAGE_PATH".
327
328 , unitConfigGlobalDB :: !FilePath -- ^ Path to global DB
329 , unitConfigGHCDir :: !FilePath -- ^ Main GHC dir: contains settings, etc.
330 , unitConfigDBName :: !String -- ^ User DB name (e.g. "package.conf.d")
331
332 , unitConfigAutoLink :: ![UnitId] -- ^ Units to link automatically (e.g. base, rts)
333 , unitConfigDistrustAll :: !Bool -- ^ Distrust all units by default
334 , unitConfigHideAll :: !Bool -- ^ Hide all units by default
335 , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default
336
337 , unitConfigDBCache :: Maybe [UnitDatabase UnitId]
338 -- ^ Cache of databases to use, in the order they were specified on the
339 -- command line (later databases shadow earlier ones).
340 -- If Nothing, databases will be found using `unitConfigFlagsDB`.
341
342 -- command-line flags
343 , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags
344 , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units
345 , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units
346 , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units
347 , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units
348 }
349
350 initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig
351 initUnitConfig dflags cached_dbs =
352 let !hu_id = homeUnitId_ dflags
353 !hu_instanceof = homeUnitInstanceOf_ dflags
354 !hu_instantiations = homeUnitInstantiations_ dflags
355
356 autoLink
357 | not (gopt Opt_AutoLinkPackages dflags) = []
358 -- By default we add base & rts to the preload units (when they are
359 -- found in the unit database) except when we are building them
360 | otherwise = filter (hu_id /=) [baseUnitId, rtsUnitId]
361
362 -- if the home unit is indefinite, it means we are type-checking it only
363 -- (not producing any code). Hence we can use virtual units instantiated
364 -- on-the-fly. See Note [About units] in GHC.Unit
365 allow_virtual_units = case (hu_instanceof, hu_instantiations) of
366 (Just u, is) -> u == hu_id && any (isHoleModule . snd) is
367 _ -> False
368
369 in UnitConfig
370 { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags)
371 , unitConfigProgramName = programName dflags
372 , unitConfigWays = ways dflags
373 , unitConfigAllowVirtual = allow_virtual_units
374
375 , unitConfigGlobalDB = globalPackageDatabasePath dflags
376 , unitConfigGHCDir = topDir dflags
377 , unitConfigDBName = "package.conf.d"
378
379 , unitConfigAutoLink = autoLink
380 , unitConfigDistrustAll = gopt Opt_DistrustAllPackages dflags
381 , unitConfigHideAll = gopt Opt_HideAllPackages dflags
382 , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags
383
384 , unitConfigDBCache = cached_dbs
385 , unitConfigFlagsDB = packageDBFlags dflags
386 , unitConfigFlagsExposed = packageFlags dflags
387 , unitConfigFlagsIgnored = ignorePackageFlags dflags
388 , unitConfigFlagsTrusted = trustFlags dflags
389 , unitConfigFlagsPlugins = pluginPackageFlags dflags
390
391 }
392
393 -- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
394 -- its 'ModuleOrigin').
395 --
396 -- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
397 -- origin for a given 'Module'
398 type ModuleNameProvidersMap =
399 Map ModuleName (Map Module ModuleOrigin)
400
401 data UnitState = UnitState {
402 -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted
403 -- so that only valid units are here. 'UnitInfo' reflects
404 -- what was stored *on disk*, except for the 'trusted' flag, which
405 -- is adjusted at runtime. (In particular, some units in this map
406 -- may have the 'exposed' flag be 'False'.)
407 unitInfoMap :: UnitInfoMap,
408
409 -- | The set of transitively reachable units according
410 -- to the explicitly provided command line arguments.
411 -- A fully instantiated VirtUnit may only be replaced by a RealUnit from
412 -- this set.
413 -- See Note [VirtUnit to RealUnit improvement]
414 preloadClosure :: PreloadUnitClosure,
415
416 -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
417 -- package name (e.g. different instantiations), then we return one of them...
418 -- This is used when users refer to packages in Backpack includes.
419 -- And also to resolve package qualifiers with the PackageImports extension.
420 packageNameMap :: UniqFM PackageName UnitId,
421
422 -- | A mapping from database unit keys to wired in unit ids.
423 wireMap :: Map UnitId UnitId,
424
425 -- | A mapping from wired in unit ids to unit keys from the database.
426 unwireMap :: Map UnitId UnitId,
427
428 -- | The units we're going to link in eagerly. This list
429 -- should be in reverse dependency order; that is, a unit
430 -- is always mentioned before the units it depends on.
431 preloadUnits :: [UnitId],
432
433 -- | Units which we explicitly depend on (from a command line flag).
434 -- We'll use this to generate version macros.
435 explicitUnits :: [Unit],
436
437 -- | This is a full map from 'ModuleName' to all modules which may possibly
438 -- be providing it. These providers may be hidden (but we'll still want
439 -- to report them in error messages), or it may be an ambiguous import.
440 moduleNameProvidersMap :: !ModuleNameProvidersMap,
441
442 -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility.
443 pluginModuleNameProvidersMap :: !ModuleNameProvidersMap,
444
445 -- | A map saying, for each requirement, what interfaces must be merged
446 -- together when we use them. For example, if our dependencies
447 -- are @p[A=\<A>]@ and @q[A=\<A>,B=r[C=\<A>]:B]@, then the interfaces
448 -- to merge for A are @p[A=\<A>]:A@, @q[A=\<A>,B=r[C=\<A>]:B]:A@
449 -- and @r[C=\<A>]:C@.
450 --
451 -- There's an entry in this map for each hole in our home library.
452 requirementContext :: Map ModuleName [InstantiatedModule],
453
454 -- | Indicate if we can instantiate units on-the-fly.
455 --
456 -- This should only be true when we are type-checking an indefinite unit.
457 -- See Note [About units] in GHC.Unit.
458 allowVirtualUnits :: !Bool
459 }
460
461 emptyUnitState :: UnitState
462 emptyUnitState = UnitState {
463 unitInfoMap = Map.empty,
464 preloadClosure = emptyUniqSet,
465 packageNameMap = emptyUFM,
466 wireMap = Map.empty,
467 unwireMap = Map.empty,
468 preloadUnits = [],
469 explicitUnits = [],
470 moduleNameProvidersMap = Map.empty,
471 pluginModuleNameProvidersMap = Map.empty,
472 requirementContext = Map.empty,
473 allowVirtualUnits = False
474 }
475
476 -- | Unit database
477 data UnitDatabase unit = UnitDatabase
478 { unitDatabasePath :: FilePath
479 , unitDatabaseUnits :: [GenUnitInfo unit]
480 }
481
482 type UnitInfoMap = Map UnitId UnitInfo
483
484 -- | Find the unit we know about with the given unit, if any
485 lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
486 lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs)
487
488 -- | A more specialized interface, which doesn't require a 'UnitState' (so it
489 -- can be used while we're initializing 'DynFlags')
490 --
491 -- Parameters:
492 -- * a boolean specifying whether or not to look for on-the-fly renamed interfaces
493 -- * a 'UnitInfoMap'
494 -- * a 'PreloadUnitClosure'
495 lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
496 lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of
497 HoleUnit -> error "Hole unit"
498 RealUnit i -> Map.lookup (unDefinite i) pkg_map
499 VirtUnit i
500 | allowOnTheFlyInst
501 -> -- lookup UnitInfo of the indefinite unit to be instantiated and
502 -- instantiate it on-the-fly
503 fmap (renameUnitInfo pkg_map closure (instUnitInsts i))
504 (Map.lookup (instUnitInstanceOf i) pkg_map)
505
506 | otherwise
507 -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
508 -- units. Even if they are real, installed units, they can't use the
509 -- `RealUnit` constructor (it is reserved for definite units) so we use
510 -- the `VirtUnit` constructor.
511 Map.lookup (virtualUnitId i) pkg_map
512
513 -- | Find the unit we know about with the given unit id, if any
514 lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
515 lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid
516
517 -- | Find the unit we know about with the given unit id, if any
518 lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
519 lookupUnitId' db uid = Map.lookup uid db
520
521
522 -- | Looks up the given unit in the unit state, panicing if it is not found
523 unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
524 unsafeLookupUnit state u = case lookupUnit state u of
525 Just info -> info
526 Nothing -> pprPanic "unsafeLookupUnit" (ppr u)
527
528 -- | Looks up the given unit id in the unit state, panicing if it is not found
529 unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
530 unsafeLookupUnitId state uid = case lookupUnitId state uid of
531 Just info -> info
532 Nothing -> pprPanic "unsafeLookupUnitId" (ppr uid)
533
534
535 -- | Find the unit we know about with the given package name (e.g. @foo@), if any
536 -- (NB: there might be a locally defined unit name which overrides this)
537 lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
538 lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n
539
540 -- | Search for units with a given package ID (e.g. \"foo-0.1\")
541 searchPackageId :: UnitState -> PackageId -> [UnitInfo]
542 searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
543 (listUnitInfo pkgstate)
544
545 -- | Create a Map UnitId UnitInfo
546 --
547 -- For each instantiated unit, we add two map keys:
548 -- * the real unit id
549 -- * the virtual unit id made from its instantiation
550 --
551 -- We do the same thing for fully indefinite units (which are "instantiated"
552 -- with module holes).
553 --
554 mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
555 mkUnitInfoMap infos = foldl' add Map.empty infos
556 where
557 mkVirt p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))
558 add pkg_map p
559 | not (null (unitInstantiations p))
560 = Map.insert (mkVirt p) p
561 $ Map.insert (unitId p) p
562 $ pkg_map
563 | otherwise
564 = Map.insert (unitId p) p pkg_map
565
566 -- | Get a list of entries from the unit database. NB: be careful with
567 -- this function, although all units in this map are "visible", this
568 -- does not imply that the exposed-modules of the unit are available
569 -- (they may have been thinned or renamed).
570 listUnitInfo :: UnitState -> [UnitInfo]
571 listUnitInfo state = Map.elems (unitInfoMap state)
572
573 -- ----------------------------------------------------------------------------
574 -- Loading the unit db files and building up the unit state
575
576 -- | Read the unit database files, and sets up various internal tables of
577 -- unit information, according to the unit-related flags on the
578 -- command-line (@-package@, @-hide-package@ etc.)
579 --
580 -- 'initUnits' can be called again subsequently after updating the
581 -- 'packageFlags' field of the 'DynFlags', and it will update the
582 -- 'unitState' in 'DynFlags'.
583 initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
584 initUnits logger dflags cached_dbs = do
585
586 let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
587
588 (unit_state,dbs) <- withTiming logger (text "initializing unit database")
589 forceUnitInfoMap
590 $ mkUnitState logger (initUnitConfig dflags cached_dbs)
591
592 putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
593 FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
594 $ pprModuleMap (moduleNameProvidersMap unit_state))
595
596 let home_unit = mkHomeUnit unit_state
597 (homeUnitId_ dflags)
598 (homeUnitInstanceOf_ dflags)
599 (homeUnitInstantiations_ dflags)
600
601 -- Try to find platform constants
602 --
603 -- See Note [Platform constants] in GHC.Platform
604 mconstants <- if homeUnitId_ dflags == rtsUnitId
605 then do
606 -- we're building the RTS! Lookup DerivedConstants.h in the include paths
607 lookupPlatformConstants (includePathsGlobal (includePaths dflags))
608 else
609 -- lookup the DerivedConstants.h header bundled with the RTS unit. We
610 -- don't fail if we can't find the RTS unit as it can be a valid (but
611 -- uncommon) case, e.g. building a C utility program (not depending on the
612 -- RTS) before building the RTS. In any case, we will fail later on if we
613 -- really need to use the platform constants but they have not been loaded.
614 case lookupUnitId unit_state rtsUnitId of
615 Nothing -> return Nothing
616 Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info))
617
618 return (dbs,unit_state,home_unit,mconstants)
619
620 mkHomeUnit
621 :: UnitState
622 -> UnitId -- ^ Home unit id
623 -> Maybe UnitId -- ^ Home unit instance of
624 -> [(ModuleName, Module)] -- ^ Home unit instantiations
625 -> HomeUnit
626 mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
627 let
628 -- Some wired units can be used to instantiate the home unit. We need to
629 -- replace their unit keys with their wired unit ids.
630 wmap = wireMap unit_state
631 hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_
632 in case (hu_instanceof, hu_instantiations) of
633 (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
634 (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
635 (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")
636 (Just u, is)
637 -- detect fully indefinite units: all their instantiations are hole
638 -- modules and the home unit id is the same as the instantiating unit
639 -- id (see Note [About units] in GHC.Unit)
640 | all (isHoleModule . snd) is && u == hu_id
641 -> IndefiniteHomeUnit u is
642 -- otherwise it must be that we (fully) instantiate an indefinite unit
643 -- to make it definite.
644 -- TODO: error when the unit is partially instantiated??
645 | otherwise
646 -> DefiniteHomeUnit hu_id (Just (u, is))
647
648 -- -----------------------------------------------------------------------------
649 -- Reading the unit database(s)
650
651 readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
652 readUnitDatabases logger cfg = do
653 conf_refs <- getUnitDbRefs cfg
654 confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
655 mapM (readUnitDatabase logger cfg) confs
656
657
658 getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
659 getUnitDbRefs cfg = do
660 let system_conf_refs = [UserPkgDb, GlobalPkgDb]
661
662 e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH")
663 let base_conf_refs = case e_pkg_path of
664 Left _ -> system_conf_refs
665 Right path
666 | not (null path) && isSearchPathSeparator (last path)
667 -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
668 | otherwise
669 -> map PkgDbPath (splitSearchPath path)
670
671 -- Apply the package DB-related flags from the command line to get the
672 -- final list of package DBs.
673 --
674 -- Notes on ordering:
675 -- * The list of flags is reversed (later ones first)
676 -- * We work with the package DB list in "left shadows right" order
677 -- * and finally reverse it at the end, to get "right shadows left"
678 --
679 return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg))
680 where
681 doFlag (PackageDB p) dbs = p : dbs
682 doFlag NoUserPackageDB dbs = filter isNotUser dbs
683 doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
684 doFlag ClearPackageDBs _ = []
685
686 isNotUser UserPkgDb = False
687 isNotUser _ = True
688
689 isNotGlobal GlobalPkgDb = False
690 isNotGlobal _ = True
691
692 -- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
693 -- when the user database filepath is expected but the latter doesn't exist.
694 --
695 -- NB: This logic is reimplemented in Cabal, so if you change it,
696 -- make sure you update Cabal. (Or, better yet, dump it in the
697 -- compiler info so Cabal can use the info.)
698 resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
699 resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
700 resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
701 dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
702 let pkgconf = dir </> unitConfigDBName cfg
703 exist <- tryMaybeT $ doesDirectoryExist pkgconf
704 if exist then return pkgconf else mzero
705 resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
706
707 readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
708 readUnitDatabase logger cfg conf_file = do
709 isdir <- doesDirectoryExist conf_file
710
711 proto_pkg_configs <-
712 if isdir
713 then readDirStyleUnitInfo conf_file
714 else do
715 isfile <- doesFileExist conf_file
716 if isfile
717 then do
718 mpkgs <- tryReadOldFileStyleUnitInfo
719 case mpkgs of
720 Just pkgs -> return pkgs
721 Nothing -> throwGhcExceptionIO $ InstallationError $
722 "ghc no longer supports single-file style package " ++
723 "databases (" ++ conf_file ++
724 ") use 'ghc-pkg init' to create the database with " ++
725 "the correct format."
726 else throwGhcExceptionIO $ InstallationError $
727 "can't find a package database at " ++ conf_file
728
729 let
730 -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
731 conf_file' = dropTrailingPathSeparator conf_file
732 top_dir = unitConfigGHCDir cfg
733 pkgroot = takeDirectory conf_file'
734 pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
735 proto_pkg_configs
736 --
737 return $ UnitDatabase conf_file' pkg_configs1
738 where
739 readDirStyleUnitInfo conf_dir = do
740 let filename = conf_dir </> "package.cache"
741 cache_exists <- doesFileExist filename
742 if cache_exists
743 then do
744 debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
745 readPackageDbForGhc filename
746 else do
747 -- If there is no package.cache file, we check if the database is not
748 -- empty by inspecting if the directory contains any .conf file. If it
749 -- does, something is wrong and we fail. Otherwise we assume that the
750 -- database is empty.
751 debugTraceMsg logger 2 $ text "There is no package.cache in"
752 <+> text conf_dir
753 <> text ", checking if the database is empty"
754 db_empty <- all (not . isSuffixOf ".conf")
755 <$> getDirectoryContents conf_dir
756 if db_empty
757 then do
758 debugTraceMsg logger 3 $ text "There are no .conf files in"
759 <+> text conf_dir <> text ", treating"
760 <+> text "package database as empty"
761 return []
762 else
763 throwGhcExceptionIO $ InstallationError $
764 "there is no package.cache in " ++ conf_dir ++
765 " even though package database is not empty"
766
767
768 -- Single-file style package dbs have been deprecated for some time, but
769 -- it turns out that Cabal was using them in one place. So this is a
770 -- workaround to allow older Cabal versions to use this newer ghc.
771 -- We check if the file db contains just "[]" and if so, we look for a new
772 -- dir-style db in conf_file.d/, ie in a dir next to the given file.
773 -- We cannot just replace the file with a new dir style since Cabal still
774 -- assumes it's a file and tries to overwrite with 'writeFile'.
775 -- ghc-pkg also cooperates with this workaround.
776 tryReadOldFileStyleUnitInfo = do
777 content <- readFile conf_file `catchIO` \_ -> return ""
778 if take 2 content == "[]"
779 then do
780 let conf_dir = conf_file <.> "d"
781 direxists <- doesDirectoryExist conf_dir
782 if direxists
783 then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
784 liftM Just (readDirStyleUnitInfo conf_dir)
785 else return (Just []) -- ghc-pkg will create it when it's updated
786 else return Nothing
787
788 distrustAllUnits :: [UnitInfo] -> [UnitInfo]
789 distrustAllUnits pkgs = map distrust pkgs
790 where
791 distrust pkg = pkg{ unitIsTrusted = False }
792
793 mungeUnitInfo :: FilePath -> FilePath
794 -> UnitInfo -> UnitInfo
795 mungeUnitInfo top_dir pkgroot =
796 mungeDynLibFields
797 . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
798
799 mungeDynLibFields :: UnitInfo -> UnitInfo
800 mungeDynLibFields pkg =
801 pkg {
802 unitLibraryDynDirs = case unitLibraryDynDirs pkg of
803 [] -> unitLibraryDirs pkg
804 ds -> ds
805 }
806
807 -- -----------------------------------------------------------------------------
808 -- Modify our copy of the unit database based on trust flags,
809 -- -trust and -distrust.
810
811 applyTrustFlag
812 :: UnitPrecedenceMap
813 -> UnusableUnits
814 -> [UnitInfo]
815 -> TrustFlag
816 -> MaybeErr UnitErr [UnitInfo]
817 applyTrustFlag prec_map unusable pkgs flag =
818 case flag of
819 -- we trust all matching packages. Maybe should only trust first one?
820 -- and leave others the same or set them untrusted
821 TrustPackage str ->
822 case selectPackages prec_map (PackageArg str) pkgs unusable of
823 Left ps -> Failed (TrustFlagErr flag ps)
824 Right (ps,qs) -> Succeeded (map trust ps ++ qs)
825 where trust p = p {unitIsTrusted=True}
826
827 DistrustPackage str ->
828 case selectPackages prec_map (PackageArg str) pkgs unusable of
829 Left ps -> Failed (TrustFlagErr flag ps)
830 Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)
831
832 applyPackageFlag
833 :: UnitPrecedenceMap
834 -> UnitInfoMap
835 -> PreloadUnitClosure
836 -> UnusableUnits
837 -> Bool -- if False, if you expose a package, it implicitly hides
838 -- any previously exposed packages with the same name
839 -> [UnitInfo]
840 -> VisibilityMap -- Initially exposed
841 -> PackageFlag -- flag to apply
842 -> MaybeErr UnitErr VisibilityMap -- Now exposed
843
844 applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
845 case flag of
846 ExposePackage _ arg (ModRenaming b rns) ->
847 case findPackages prec_map pkg_map closure arg pkgs unusable of
848 Left ps -> Failed (PackageFlagErr flag ps)
849 Right (p:_) -> Succeeded vm'
850 where
851 n = fsPackageName p
852
853 -- If a user says @-unit-id p[A=<A>]@, this imposes
854 -- a requirement on us: whatever our signature A is,
855 -- it must fulfill all of p[A=<A>]:A's requirements.
856 -- This method is responsible for computing what our
857 -- inherited requirements are.
858 reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
859 | otherwise = Map.empty
860
861 collectHoles uid = case uid of
862 HoleUnit -> Map.empty
863 RealUnit {} -> Map.empty -- definite units don't have holes
864 VirtUnit indef ->
865 let local = [ Map.singleton
866 (moduleName mod)
867 (Set.singleton $ Module indef mod_name)
868 | (mod_name, mod) <- instUnitInsts indef
869 , isHoleModule mod ]
870 recurse = [ collectHoles (moduleUnit mod)
871 | (_, mod) <- instUnitInsts indef ]
872 in Map.unionsWith Set.union $ local ++ recurse
873
874 uv = UnitVisibility
875 { uv_expose_all = b
876 , uv_renamings = rns
877 , uv_package_name = First (Just n)
878 , uv_requirements = reqs
879 , uv_explicit = True
880 }
881 vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
882 -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
883 -- (or if p-0.1 was registered in the pkgdb as exposed: True),
884 -- the second package flag would override the first one and you
885 -- would only see p-0.2 in exposed modules. This is good for
886 -- usability.
887 --
888 -- However, with thinning and renaming (or Backpack), there might be
889 -- situations where you legitimately want to see two versions of a
890 -- package at the same time, and this behavior would make it
891 -- impossible to do so. So we decided that if you pass
892 -- -hide-all-packages, this should turn OFF the overriding behavior
893 -- where an exposed package hides all other packages with the same
894 -- name. This should not affect Cabal at all, which only ever
895 -- exposes one package at a time.
896 --
897 -- NB: Why a variable no_hide_others? We have to apply this logic to
898 -- -plugin-package too, and it's more consistent if the switch in
899 -- behavior is based off of
900 -- -hide-all-packages/-hide-all-plugin-packages depending on what
901 -- flag is in question.
902 vm_cleared | no_hide_others = vm
903 -- NB: renamings never clear
904 | (_:_) <- rns = vm
905 | otherwise = Map.filterWithKey
906 (\k uv -> k == mkUnit p
907 || First (Just n) /= uv_package_name uv) vm
908 _ -> panic "applyPackageFlag"
909
910 HidePackage str ->
911 case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
912 Left ps -> Failed (PackageFlagErr flag ps)
913 Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)
914
915 -- | Like 'selectPackages', but doesn't return a list of unmatched
916 -- packages. Furthermore, any packages it returns are *renamed*
917 -- if the 'UnitArg' has a renaming associated with it.
918 findPackages :: UnitPrecedenceMap
919 -> UnitInfoMap
920 -> PreloadUnitClosure
921 -> PackageArg -> [UnitInfo]
922 -> UnusableUnits
923 -> Either [(UnitInfo, UnusableUnitReason)]
924 [UnitInfo]
925 findPackages prec_map pkg_map closure arg pkgs unusable
926 = let ps = mapMaybe (finder arg) pkgs
927 in if null ps
928 then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
929 (Map.elems unusable))
930 else Right (sortByPreference prec_map ps)
931 where
932 finder (PackageArg str) p
933 = if matchingStr str p
934 then Just p
935 else Nothing
936 finder (UnitIdArg uid) p
937 = case uid of
938 RealUnit (Definite iuid)
939 | iuid == unitId p
940 -> Just p
941 VirtUnit inst
942 | instUnitInstanceOf inst == unitId p
943 -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p)
944 _ -> Nothing
945
946 selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
947 -> UnusableUnits
948 -> Either [(UnitInfo, UnusableUnitReason)]
949 ([UnitInfo], [UnitInfo])
950 selectPackages prec_map arg pkgs unusable
951 = let matches = matching arg
952 (ps,rest) = partition matches pkgs
953 in if null ps
954 then Left (filter (matches.fst) (Map.elems unusable))
955 else Right (sortByPreference prec_map ps, rest)
956
957 -- | Rename a 'UnitInfo' according to some module instantiation.
958 renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
959 renameUnitInfo pkg_map closure insts conf =
960 let hsubst = listToUFM insts
961 smod = renameHoleModule' pkg_map closure hsubst
962 new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
963 in conf {
964 unitInstantiations = new_insts,
965 unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
966 (unitExposedModules conf)
967 }
968
969
970 -- A package named on the command line can either include the
971 -- version, or just the name if it is unambiguous.
972 matchingStr :: String -> UnitInfo -> Bool
973 matchingStr str p
974 = str == unitPackageIdString p
975 || str == unitPackageNameString p
976
977 matchingId :: UnitId -> UnitInfo -> Bool
978 matchingId uid p = uid == unitId p
979
980 matching :: PackageArg -> UnitInfo -> Bool
981 matching (PackageArg str) = matchingStr str
982 matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
983 matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case
984
985 -- | This sorts a list of packages, putting "preferred" packages first.
986 -- See 'compareByPreference' for the semantics of "preference".
987 sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
988 sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))
989
990 -- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
991 -- which should be "active". Here is the order of preference:
992 --
993 -- 1. First, prefer the latest version
994 -- 2. If the versions are the same, prefer the package that
995 -- came in the latest package database.
996 --
997 -- Pursuant to #12518, we could change this policy to, for example, remove
998 -- the version preference, meaning that we would always prefer the units
999 -- in later unit database.
1000 compareByPreference
1001 :: UnitPrecedenceMap
1002 -> UnitInfo
1003 -> UnitInfo
1004 -> Ordering
1005 compareByPreference prec_map pkg pkg'
1006 = case comparing unitPackageVersion pkg pkg' of
1007 GT -> GT
1008 EQ | Just prec <- Map.lookup (unitId pkg) prec_map
1009 , Just prec' <- Map.lookup (unitId pkg') prec_map
1010 -- Prefer the unit from the later DB flag (i.e., higher
1011 -- precedence)
1012 -> compare prec prec'
1013 | otherwise
1014 -> EQ
1015 LT -> LT
1016
1017 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
1018 comparing f a b = f a `compare` f b
1019
1020 pprFlag :: PackageFlag -> SDoc
1021 pprFlag flag = case flag of
1022 HidePackage p -> text "-hide-package " <> text p
1023 ExposePackage doc _ _ -> text doc
1024
1025 pprTrustFlag :: TrustFlag -> SDoc
1026 pprTrustFlag flag = case flag of
1027 TrustPackage p -> text "-trust " <> text p
1028 DistrustPackage p -> text "-distrust " <> text p
1029
1030 -- -----------------------------------------------------------------------------
1031 -- Wired-in units
1032 --
1033 -- See Note [Wired-in units] in GHC.Unit.Module
1034
1035 type WiringMap = Map UnitId UnitId
1036
1037 findWiredInUnits
1038 :: Logger
1039 -> UnitPrecedenceMap
1040 -> [UnitInfo] -- database
1041 -> VisibilityMap -- info on what units are visible
1042 -- for wired in selection
1043 -> IO ([UnitInfo], -- unit database updated for wired in
1044 WiringMap) -- map from unit id to wired identity
1045
1046 findWiredInUnits logger prec_map pkgs vis_map = do
1047 -- Now we must find our wired-in units, and rename them to
1048 -- their canonical names (eg. base-1.0 ==> base), as described
1049 -- in Note [Wired-in units] in GHC.Unit.Module
1050 let
1051 matches :: UnitInfo -> UnitId -> Bool
1052 pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
1053
1054 -- find which package corresponds to each wired-in package
1055 -- delete any other packages with the same name
1056 -- update the package and any dependencies to point to the new
1057 -- one.
1058 --
1059 -- When choosing which package to map to a wired-in package
1060 -- name, we try to pick the latest version of exposed packages.
1061 -- However, if there are no exposed wired in packages available
1062 -- (e.g. -hide-all-packages was used), we can't bail: we *have*
1063 -- to assign a package for the wired-in package: so we try again
1064 -- with hidden packages included to (and pick the latest
1065 -- version).
1066 --
1067 -- You can also override the default choice by using -ignore-package:
1068 -- this works even when there is no exposed wired in package
1069 -- available.
1070 --
1071 findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
1072 findWiredInUnit pkgs wired_pkg =
1073 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
1074 all_exposed_ps =
1075 [ p | p <- all_ps
1076 , Map.member (mkUnit p) vis_map ] in
1077 case all_exposed_ps of
1078 [] -> case all_ps of
1079 [] -> notfound
1080 many -> pick (head (sortByPreference prec_map many))
1081 many -> pick (head (sortByPreference prec_map many))
1082 where
1083 notfound = do
1084 debugTraceMsg logger 2 $
1085 text "wired-in package "
1086 <> ftext (unitIdFS wired_pkg)
1087 <> text " not found."
1088 return Nothing
1089 pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
1090 pick pkg = do
1091 debugTraceMsg logger 2 $
1092 text "wired-in package "
1093 <> ftext (unitIdFS wired_pkg)
1094 <> text " mapped to "
1095 <> ppr (unitId pkg)
1096 return (Just (wired_pkg, pkg))
1097
1098
1099 mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
1100 let
1101 wired_in_pkgs = catMaybes mb_wired_in_pkgs
1102
1103 wiredInMap :: Map UnitId UnitId
1104 wiredInMap = Map.fromList
1105 [ (unitId realUnitInfo, wiredInUnitId)
1106 | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
1107 , not (unitIsIndefinite realUnitInfo)
1108 ]
1109
1110 updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
1111 where upd_pkg pkg
1112 | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap
1113 = pkg { unitId = wiredInUnitId
1114 , unitInstanceOf = wiredInUnitId
1115 -- every non instantiated unit is an instance of
1116 -- itself (required by Backpack...)
1117 --
1118 -- See Note [About Units] in GHC.Unit
1119 }
1120 | otherwise
1121 = pkg
1122 upd_deps pkg = pkg {
1123 unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
1124 unitExposedModules
1125 = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
1126 (unitExposedModules pkg)
1127 }
1128
1129
1130 return (updateWiredInDependencies pkgs, wiredInMap)
1131
1132 -- Helper functions for rewiring Module and Unit. These
1133 -- rewrite Units of modules in wired-in packages to the form known to the
1134 -- compiler, as described in Note [Wired-in units] in GHC.Unit.Module.
1135 --
1136 -- For instance, base-4.9.0.0 will be rewritten to just base, to match
1137 -- what appears in GHC.Builtin.Names.
1138
1139 upd_wired_in_mod :: WiringMap -> Module -> Module
1140 upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
1141
1142 upd_wired_in_uid :: WiringMap -> Unit -> Unit
1143 upd_wired_in_uid wiredInMap u = case u of
1144 HoleUnit -> HoleUnit
1145 RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
1146 VirtUnit indef_uid ->
1147 VirtUnit $ mkInstantiatedUnit
1148 (instUnitInstanceOf indef_uid)
1149 (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid))
1150
1151 upd_wired_in :: WiringMap -> UnitId -> UnitId
1152 upd_wired_in wiredInMap key
1153 | Just key' <- Map.lookup key wiredInMap = key'
1154 | otherwise = key
1155
1156 updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
1157 updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
1158 where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of
1159 Nothing -> vm
1160 Just r -> Map.insert (RealUnit (Definite to)) r
1161 (Map.delete (RealUnit (Definite from)) vm)
1162
1163
1164 -- ----------------------------------------------------------------------------
1165
1166 -- | The reason why a unit is unusable.
1167 data UnusableUnitReason
1168 = -- | We ignored it explicitly using @-ignore-package@.
1169 IgnoredWithFlag
1170 -- | This unit transitively depends on a unit that was never present
1171 -- in any of the provided databases.
1172 | BrokenDependencies [UnitId]
1173 -- | This unit transitively depends on a unit involved in a cycle.
1174 -- Note that the list of 'UnitId' reports the direct dependencies
1175 -- of this unit that (transitively) depended on the cycle, and not
1176 -- the actual cycle itself (which we report separately at high verbosity.)
1177 | CyclicDependencies [UnitId]
1178 -- | This unit transitively depends on a unit which was ignored.
1179 | IgnoredDependencies [UnitId]
1180 -- | This unit transitively depends on a unit which was
1181 -- shadowed by an ABI-incompatible unit.
1182 | ShadowedDependencies [UnitId]
1183
1184 instance Outputable UnusableUnitReason where
1185 ppr IgnoredWithFlag = text "[ignored with flag]"
1186 ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids)
1187 ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids)
1188 ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids)
1189 ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
1190
1191 type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason)
1192
1193 pprReason :: SDoc -> UnusableUnitReason -> SDoc
1194 pprReason pref reason = case reason of
1195 IgnoredWithFlag ->
1196 pref <+> text "ignored due to an -ignore-package flag"
1197 BrokenDependencies deps ->
1198 pref <+> text "unusable due to missing dependencies:" $$
1199 nest 2 (hsep (map ppr deps))
1200 CyclicDependencies deps ->
1201 pref <+> text "unusable due to cyclic dependencies:" $$
1202 nest 2 (hsep (map ppr deps))
1203 IgnoredDependencies deps ->
1204 pref <+> text ("unusable because the -ignore-package flag was used to " ++
1205 "ignore at least one of its dependencies:") $$
1206 nest 2 (hsep (map ppr deps))
1207 ShadowedDependencies deps ->
1208 pref <+> text "unusable due to shadowed dependencies:" $$
1209 nest 2 (hsep (map ppr deps))
1210
1211 reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
1212 reportCycles logger sccs = mapM_ report sccs
1213 where
1214 report (AcyclicSCC _) = return ()
1215 report (CyclicSCC vs) =
1216 debugTraceMsg logger 2 $
1217 text "these packages are involved in a cycle:" $$
1218 nest 2 (hsep (map (ppr . unitId) vs))
1219
1220 reportUnusable :: Logger -> UnusableUnits -> IO ()
1221 reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)
1222 where
1223 report (ipid, (_, reason)) =
1224 debugTraceMsg logger 2 $
1225 pprReason
1226 (text "package" <+> ppr ipid <+> text "is") reason
1227
1228 -- ----------------------------------------------------------------------------
1229 --
1230 -- Utilities on the database
1231 --
1232
1233 -- | A reverse dependency index, mapping an 'UnitId' to
1234 -- the 'UnitId's which have a dependency on it.
1235 type RevIndex = Map UnitId [UnitId]
1236
1237 -- | Compute the reverse dependency index of a unit database.
1238 reverseDeps :: UnitInfoMap -> RevIndex
1239 reverseDeps db = Map.foldl' go Map.empty db
1240 where
1241 go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg)
1242 go' from r to = Map.insertWith (++) to [from] r
1243
1244 -- | Given a list of 'UnitId's to remove, a database,
1245 -- and a reverse dependency index (as computed by 'reverseDeps'),
1246 -- remove those units, plus any units which depend on them.
1247 -- Returns the pruned database, as well as a list of 'UnitInfo's
1248 -- that was removed.
1249 removeUnits :: [UnitId] -> RevIndex
1250 -> UnitInfoMap
1251 -> (UnitInfoMap, [UnitInfo])
1252 removeUnits uids index m = go uids (m,[])
1253 where
1254 go [] (m,pkgs) = (m,pkgs)
1255 go (uid:uids) (m,pkgs)
1256 | Just pkg <- Map.lookup uid m
1257 = case Map.lookup uid index of
1258 Nothing -> go uids (Map.delete uid m, pkg:pkgs)
1259 Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)
1260 | otherwise
1261 = go uids (m,pkgs)
1262
1263 -- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
1264 -- which correspond to units that do not exist in the index.
1265 depsNotAvailable :: UnitInfoMap
1266 -> UnitInfo
1267 -> [UnitId]
1268 depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg)
1269
1270 -- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
1271 -- 'unitAbiDepends' which correspond to units that do not exist, OR have
1272 -- mismatching ABIs.
1273 depsAbiMismatch :: UnitInfoMap
1274 -> UnitInfo
1275 -> [UnitId]
1276 depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg
1277 where
1278 abiMatch (dep_uid, abi)
1279 | Just dep_pkg <- Map.lookup dep_uid pkg_map
1280 = unitAbiHash dep_pkg == abi
1281 | otherwise
1282 = False
1283
1284 -- -----------------------------------------------------------------------------
1285 -- Ignore units
1286
1287 ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
1288 ignoreUnits flags pkgs = Map.fromList (concatMap doit flags)
1289 where
1290 doit (IgnorePackage str) =
1291 case partition (matchingStr str) pkgs of
1292 (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
1293 | p <- ps ]
1294 -- missing unit is not an error for -ignore-package,
1295 -- because a common usage is to -ignore-package P as
1296 -- a preventative measure just in case P exists.
1297
1298 -- ----------------------------------------------------------------------------
1299 --
1300 -- Merging databases
1301 --
1302
1303 -- | For each unit, a mapping from uid -> i indicates that this
1304 -- unit was brought into GHC by the ith @-package-db@ flag on
1305 -- the command line. We use this mapping to make sure we prefer
1306 -- units that were defined later on the command line, if there
1307 -- is an ambiguity.
1308 type UnitPrecedenceMap = Map UnitId Int
1309
1310 -- | Given a list of databases, merge them together, where
1311 -- units with the same unit id in later databases override
1312 -- earlier ones. This does NOT check if the resulting database
1313 -- makes sense (that's done by 'validateDatabase').
1314 mergeDatabases :: Logger -> [UnitDatabase UnitId]
1315 -> IO (UnitInfoMap, UnitPrecedenceMap)
1316 mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]
1317 where
1318 merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
1319 debugTraceMsg logger 2 $
1320 text "loading package database" <+> text db_path
1321 forM_ (Set.toList override_set) $ \pkg ->
1322 debugTraceMsg logger 2 $
1323 text "package" <+> ppr pkg <+>
1324 text "overrides a previously defined package"
1325 return (pkg_map', prec_map')
1326 where
1327 db_map = mk_pkg_map db
1328 mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
1329
1330 -- The set of UnitIds which appear in both db and pkgs. These are the
1331 -- ones that get overridden. Compute this just to give some
1332 -- helpful debug messages at -v2
1333 override_set :: Set UnitId
1334 override_set = Set.intersection (Map.keysSet db_map)
1335 (Map.keysSet pkg_map)
1336
1337 -- Now merge the sets together (NB: in case of duplicate,
1338 -- first argument preferred)
1339 pkg_map' :: UnitInfoMap
1340 pkg_map' = Map.union db_map pkg_map
1341
1342 prec_map' :: UnitPrecedenceMap
1343 prec_map' = Map.union (Map.map (const i) db_map) prec_map
1344
1345 -- | Validates a database, removing unusable units from it
1346 -- (this includes removing units that the user has explicitly
1347 -- ignored.) Our general strategy:
1348 --
1349 -- 1. Remove all broken units (dangling dependencies)
1350 -- 2. Remove all units that are cyclic
1351 -- 3. Apply ignore flags
1352 -- 4. Remove all units which have deps with mismatching ABIs
1353 --
1354 validateDatabase :: UnitConfig -> UnitInfoMap
1355 -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
1356 validateDatabase cfg pkg_map1 =
1357 (pkg_map5, unusable, sccs)
1358 where
1359 ignore_flags = reverse (unitConfigFlagsIgnored cfg)
1360
1361 -- Compute the reverse dependency index
1362 index = reverseDeps pkg_map1
1363
1364 -- Helper function
1365 mk_unusable mk_err dep_matcher m uids =
1366 Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
1367 | pkg <- uids ]
1368
1369 -- Find broken units
1370 directly_broken = filter (not . null . depsNotAvailable pkg_map1)
1371 (Map.elems pkg_map1)
1372 (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1
1373 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
1374
1375 -- Find recursive units
1376 sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
1377 | pkg <- Map.elems pkg_map2 ]
1378 getCyclicSCC (CyclicSCC vs) = map unitId vs
1379 getCyclicSCC (AcyclicSCC _) = []
1380 (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
1381 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
1382
1383 -- Apply ignore flags
1384 directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3)
1385 (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3
1386 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
1387
1388 -- Knock out units whose dependencies don't agree with ABI
1389 -- (i.e., got invalidated due to shadowing)
1390 directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
1391 (Map.elems pkg_map4)
1392 (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4
1393 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
1394
1395 unusable = directly_ignored `Map.union` unusable_ignored
1396 `Map.union` unusable_broken
1397 `Map.union` unusable_cyclic
1398 `Map.union` unusable_shadowed
1399
1400 -- -----------------------------------------------------------------------------
1401 -- When all the command-line options are in, we can process our unit
1402 -- settings and populate the unit state.
1403
1404 mkUnitState
1405 :: Logger
1406 -> UnitConfig
1407 -> IO (UnitState,[UnitDatabase UnitId])
1408 mkUnitState logger cfg = do
1409 {-
1410 Plan.
1411
1412 There are two main steps for making the package state:
1413
1414 1. We want to build a single, unified package database based
1415 on all of the input databases, which upholds the invariant that
1416 there is only one package per any UnitId and there are no
1417 dangling dependencies. We'll do this by merging, and
1418 then successively filtering out bad dependencies.
1419
1420 a) Merge all the databases together.
1421 If an input database defines unit ID that is already in
1422 the unified database, that package SHADOWS the existing
1423 package in the current unified database. Note that
1424 order is important: packages defined later in the list of
1425 command line arguments shadow those defined earlier.
1426
1427 b) Remove all packages with missing dependencies, or
1428 mutually recursive dependencies.
1429
1430 b) Remove packages selected by -ignore-package from input database
1431
1432 c) Remove all packages which depended on packages that are now
1433 shadowed by an ABI-incompatible package
1434
1435 d) report (with -v) any packages that were removed by steps 1-3
1436
1437 2. We want to look at the flags controlling package visibility,
1438 and build a mapping of what module names are in scope and
1439 where they live.
1440
1441 a) on the final, unified database, we apply -trust/-distrust
1442 flags directly, modifying the database so that the 'trusted'
1443 field has the correct value.
1444
1445 b) we use the -package/-hide-package flags to compute a
1446 visibility map, stating what packages are "exposed" for
1447 the purposes of computing the module map.
1448 * if any flag refers to a package which was removed by 1-5, then
1449 we can give an error message explaining why
1450 * if -hide-all-packages was not specified, this step also
1451 hides packages which are superseded by later exposed packages
1452 * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
1453 are used
1454
1455 c) based on the visibility map, we pick wired packages and rewrite
1456 them to have the expected unitId.
1457
1458 d) finally, using the visibility map and the package database,
1459 we build a mapping saying what every in scope module name points to.
1460 -}
1461
1462 -- if databases have not been provided, read the database flags
1463 raw_dbs <- case unitConfigDBCache cfg of
1464 Nothing -> readUnitDatabases logger cfg
1465 Just dbs -> return dbs
1466
1467 -- distrust all units if the flag is set
1468 let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
1469 dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
1470 | otherwise = raw_dbs
1471
1472
1473 -- This, and the other reverse's that you will see, are due to the fact that
1474 -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
1475 -- than they are on the command line.
1476 let other_flags = reverse (unitConfigFlagsExposed cfg)
1477 debugTraceMsg logger 2 $
1478 text "package flags" <+> ppr other_flags
1479
1480 -- Merge databases together, without checking validity
1481 (pkg_map1, prec_map) <- mergeDatabases logger dbs
1482
1483 -- Now that we've merged everything together, prune out unusable
1484 -- packages.
1485 let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
1486
1487 reportCycles logger sccs
1488 reportUnusable logger unusable
1489
1490 -- Apply trust flags (these flags apply regardless of whether
1491 -- or not packages are visible or not)
1492 pkgs1 <- mayThrowUnitErr
1493 $ foldM (applyTrustFlag prec_map unusable)
1494 (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
1495 let prelim_pkg_db = mkUnitInfoMap pkgs1
1496
1497 --
1498 -- Calculate the initial set of units from package databases, prior to any package flags.
1499 --
1500 -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
1501 -- (not units). This is empty if we have -hide-all-packages.
1502 --
1503 -- Then we create an initial visibility map with default visibilities for all
1504 -- exposed, definite units which belong to the latest valid packages.
1505 --
1506 let preferLater unit unit' =
1507 case compareByPreference prec_map unit unit' of
1508 GT -> unit
1509 _ -> unit'
1510 addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
1511 -- This is the set of maximally preferable packages. In fact, it is a set of
1512 -- most preferable *units* keyed by package name, which act as stand-ins in
1513 -- for "a package in a database". We use units here because we don't have
1514 -- "a package in a database" as a type currently.
1515 mostPreferablePackageReps = if unitConfigHideAll cfg
1516 then emptyUDFM
1517 else foldl' addIfMorePreferable emptyUDFM pkgs1
1518 -- When exposing units, we want to consider all of those in the most preferable
1519 -- packages. We can implement that by looking for units that are equi-preferable
1520 -- with the most preferable unit for package. Being equi-preferable means that
1521 -- they must be in the same database, with the same version, and the same package name.
1522 --
1523 -- We must take care to consider all these units and not just the most
1524 -- preferable one, otherwise we can end up with problems like #16228.
1525 mostPreferable u =
1526 case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
1527 Nothing -> False
1528 Just u' -> compareByPreference prec_map u u' == EQ
1529 vis_map1 = foldl' (\vm p ->
1530 -- Note: we NEVER expose indefinite packages by
1531 -- default, because it's almost assuredly not
1532 -- what you want (no mix-in linking has occurred).
1533 if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
1534 then Map.insert (mkUnit p)
1535 UnitVisibility {
1536 uv_expose_all = True,
1537 uv_renamings = [],
1538 uv_package_name = First (Just (fsPackageName p)),
1539 uv_requirements = Map.empty,
1540 uv_explicit = False
1541 }
1542 vm
1543 else vm)
1544 Map.empty pkgs1
1545
1546 --
1547 -- Compute a visibility map according to the command-line flags (-package,
1548 -- -hide-package). This needs to know about the unusable packages, since if a
1549 -- user tries to enable an unusable package, we should let them know.
1550 --
1551 vis_map2 <- mayThrowUnitErr
1552 $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
1553 (unitConfigHideAll cfg) pkgs1)
1554 vis_map1 other_flags
1555
1556 --
1557 -- Sort out which packages are wired in. This has to be done last, since
1558 -- it modifies the unit ids of wired in packages, but when we process
1559 -- package arguments we need to key against the old versions.
1560 --
1561 (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
1562 let pkg_db = mkUnitInfoMap pkgs2
1563
1564 -- Update the visibility map, so we treat wired packages as visible.
1565 let vis_map = updateVisibilityMap wired_map vis_map2
1566
1567 let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
1568 plugin_vis_map <-
1569 case unitConfigFlagsPlugins cfg of
1570 -- common case; try to share the old vis_map
1571 [] | not hide_plugin_pkgs -> return vis_map
1572 | otherwise -> return Map.empty
1573 _ -> do let plugin_vis_map1
1574 | hide_plugin_pkgs = Map.empty
1575 -- Use the vis_map PRIOR to wired in,
1576 -- because otherwise applyPackageFlag
1577 -- won't work.
1578 | otherwise = vis_map2
1579 plugin_vis_map2
1580 <- mayThrowUnitErr
1581 $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
1582 hide_plugin_pkgs pkgs1)
1583 plugin_vis_map1
1584 (reverse (unitConfigFlagsPlugins cfg))
1585 -- Updating based on wired in packages is mostly
1586 -- good hygiene, because it won't matter: no wired in
1587 -- package has a compiler plugin.
1588 -- TODO: If a wired in package had a compiler plugin,
1589 -- and you tried to pick different wired in packages
1590 -- with the plugin flags and the normal flags... what
1591 -- would happen? I don't know! But this doesn't seem
1592 -- likely to actually happen.
1593 return (updateVisibilityMap wired_map plugin_vis_map2)
1594
1595 let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
1596 | p <- pkgs2
1597 ]
1598 -- The explicitUnits accurately reflects the set of units we have turned
1599 -- on; as such, it also is the only way one can come up with requirements.
1600 -- The requirement context is directly based off of this: we simply
1601 -- look for nested unit IDs that are directly fed holes: the requirements
1602 -- of those units are precisely the ones we need to track
1603 let explicit_pkgs = Map.keys vis_map
1604 req_ctx = Map.map (Set.toList)
1605 $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
1606
1607
1608 --
1609 -- Here we build up a set of the packages mentioned in -package
1610 -- flags on the command line; these are called the "preload"
1611 -- packages. we link these packages in eagerly. The preload set
1612 -- should contain at least rts & base, which is why we pretend that
1613 -- the command line contains -package rts & -package base.
1614 --
1615 -- NB: preload IS important even for type-checking, because we
1616 -- need the correct include path to be set.
1617 --
1618 let preload1 = Map.keys (Map.filter uv_explicit vis_map)
1619
1620 -- add default preload units if they can be found in the db
1621 basicLinkedUnits = fmap (RealUnit . Definite)
1622 $ filter (flip Map.member pkg_db)
1623 $ unitConfigAutoLink cfg
1624 preload3 = ordNub $ (basicLinkedUnits ++ preload1)
1625
1626 -- Close the preload packages with their dependencies
1627 dep_preload <- mayThrowUnitErr
1628 $ closeUnitDeps pkg_db
1629 $ zip (map toUnitId preload3) (repeat Nothing)
1630
1631 let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
1632 mod_map2 = mkUnusableModuleNameProvidersMap unusable
1633 mod_map = Map.union mod_map1 mod_map2
1634
1635 -- Force the result to avoid leaking input parameters
1636 let !state = UnitState
1637 { preloadUnits = dep_preload
1638 , explicitUnits = explicit_pkgs
1639 , unitInfoMap = pkg_db
1640 , preloadClosure = emptyUniqSet
1641 , moduleNameProvidersMap = mod_map
1642 , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
1643 , packageNameMap = pkgname_map
1644 , wireMap = wired_map
1645 , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
1646 , requirementContext = req_ctx
1647 , allowVirtualUnits = unitConfigAllowVirtual cfg
1648 }
1649 return (state, raw_dbs)
1650
1651 -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
1652 -- that it was recorded as in the package database.
1653 unwireUnit :: UnitState -> Unit -> Unit
1654 unwireUnit state uid@(RealUnit (Definite def_uid)) =
1655 maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))
1656 unwireUnit _ uid = uid
1657
1658 -- -----------------------------------------------------------------------------
1659 -- | Makes the mapping from ModuleName to package info
1660
1661 -- Slight irritation: we proceed by leafing through everything
1662 -- in the installed package database, which makes handling indefinite
1663 -- packages a bit bothersome.
1664
1665 mkModuleNameProvidersMap
1666 :: Logger
1667 -> UnitConfig
1668 -> UnitInfoMap
1669 -> PreloadUnitClosure
1670 -> VisibilityMap
1671 -> ModuleNameProvidersMap
1672 mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
1673 -- What should we fold on? Both situations are awkward:
1674 --
1675 -- * Folding on the visibility map means that we won't create
1676 -- entries for packages that aren't mentioned in vis_map
1677 -- (e.g., hidden packages, causing #14717)
1678 --
1679 -- * Folding on pkg_map is awkward because if we have an
1680 -- Backpack instantiation, we need to possibly add a
1681 -- package from pkg_map multiple times to the actual
1682 -- ModuleNameProvidersMap. Also, we don't really want
1683 -- definite package instantiations to show up in the
1684 -- list of possibilities.
1685 --
1686 -- So what will we do instead? We'll extend vis_map with
1687 -- entries for every definite (for non-Backpack) and
1688 -- indefinite (for Backpack) package, so that we get the
1689 -- hidden entries we need.
1690 Map.foldlWithKey extend_modmap emptyMap vis_map_extended
1691 where
1692 vis_map_extended = Map.union vis_map {- preferred -} default_vis
1693
1694 default_vis = Map.fromList
1695 [ (mkUnit pkg, mempty)
1696 | pkg <- Map.elems pkg_map
1697 -- Exclude specific instantiations of an indefinite
1698 -- package
1699 , unitIsIndefinite pkg || null (unitInstantiations pkg)
1700 ]
1701
1702 emptyMap = Map.empty
1703 setOrigins m os = fmap (const os) m
1704 extend_modmap modmap uid
1705 UnitVisibility { uv_expose_all = b, uv_renamings = rns }
1706 = addListTo modmap theBindings
1707 where
1708 pkg = unit_lookup uid
1709
1710 theBindings :: [(ModuleName, Map Module ModuleOrigin)]
1711 theBindings = newBindings b rns
1712
1713 newBindings :: Bool
1714 -> [(ModuleName, ModuleName)]
1715 -> [(ModuleName, Map Module ModuleOrigin)]
1716 newBindings e rns = es e ++ hiddens ++ map rnBinding rns
1717
1718 rnBinding :: (ModuleName, ModuleName)
1719 -> (ModuleName, Map Module ModuleOrigin)
1720 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1721 where origEntry = case lookupUFM esmap orig of
1722 Just r -> r
1723 Nothing -> throwGhcException (CmdLineError (renderWithContext
1724 (log_default_user_context (logFlags logger))
1725 (text "package flag: could not find module name" <+>
1726 ppr orig <+> text "in package" <+> ppr pk)))
1727
1728 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
1729 es e = do
1730 (m, exposedReexport) <- exposed_mods
1731 let (pk', m', origin') =
1732 case exposedReexport of
1733 Nothing -> (pk, m, fromExposedModules e)
1734 Just (Module pk' m') ->
1735 (pk', m', fromReexportedModules e pkg)
1736 return (m, mkModMap pk' m' origin')
1737
1738 esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
1739 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1740 -- be overwritten
1741
1742 hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
1743
1744 pk = mkUnit pkg
1745 unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid
1746 `orElse` pprPanic "unit_lookup" (ppr uid)
1747
1748 exposed_mods = unitExposedModules pkg
1749 hidden_mods = unitHiddenModules pkg
1750
1751 -- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
1752 mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
1753 mkUnusableModuleNameProvidersMap unusables =
1754 Map.foldl' extend_modmap Map.empty unusables
1755 where
1756 extend_modmap modmap (pkg, reason) = addListTo modmap bindings
1757 where bindings :: [(ModuleName, Map Module ModuleOrigin)]
1758 bindings = exposed ++ hidden
1759
1760 origin = ModUnusable reason
1761 pkg_id = mkUnit pkg
1762
1763 exposed = map get_exposed exposed_mods
1764 hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
1765
1766 get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
1767 get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin)
1768
1769 exposed_mods = unitExposedModules pkg
1770 hidden_mods = unitHiddenModules pkg
1771
1772 -- | Add a list of key/value pairs to a nested map.
1773 --
1774 -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
1775 -- when reloading modules in GHCi (see #4029). This ensures that each
1776 -- value is forced before installing into the map.
1777 addListTo :: (Monoid a, Ord k1, Ord k2)
1778 => Map k1 (Map k2 a)
1779 -> [(k1, Map k2 a)]
1780 -> Map k1 (Map k2 a)
1781 addListTo = foldl' merge
1782 where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
1783
1784 -- | Create a singleton module mapping
1785 mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
1786 mkModMap pkg mod = Map.singleton (mkModule pkg mod)
1787
1788
1789 -- -----------------------------------------------------------------------------
1790 -- Package Utils
1791
1792 -- | Takes a 'ModuleName', and if the module is in any package returns
1793 -- list of modules which take that name.
1794 lookupModuleInAllUnits :: UnitState
1795 -> ModuleName
1796 -> [(Module, UnitInfo)]
1797 lookupModuleInAllUnits pkgs m
1798 = case lookupModuleWithSuggestions pkgs m NoPkgQual of
1799 LookupFound a b -> [(a,fst b)]
1800 LookupMultiple rs -> map f rs
1801 where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
1802 (moduleUnit m)))
1803 _ -> []
1804
1805 -- | The result of performing a lookup
1806 data LookupResult =
1807 -- | Found the module uniquely, nothing else to do
1808 LookupFound Module (UnitInfo, ModuleOrigin)
1809 -- | Multiple modules with the same name in scope
1810 | LookupMultiple [(Module, ModuleOrigin)]
1811 -- | No modules found, but there were some hidden ones with
1812 -- an exact name match. First is due to package hidden, second
1813 -- is due to module being hidden
1814 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1815 -- | No modules found, but there were some unusable ones with
1816 -- an exact name match
1817 | LookupUnusable [(Module, ModuleOrigin)]
1818 -- | Nothing found, here are some suggested different names
1819 | LookupNotFound [ModuleSuggestion] -- suggestions
1820
1821 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1822 | SuggestHidden ModuleName Module ModuleOrigin
1823
1824 lookupModuleWithSuggestions :: UnitState
1825 -> ModuleName
1826 -> PkgQual
1827 -> LookupResult
1828 lookupModuleWithSuggestions pkgs
1829 = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
1830
1831 -- | The package which the module **appears** to come from, this could be
1832 -- the one which reexports the module from it's original package. This function
1833 -- is currently only used for -Wunused-packages
1834 lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
1835 lookupModulePackage pkgs mn mfs =
1836 case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
1837 LookupFound _ (orig_unit, origin) ->
1838 case origin of
1839 ModOrigin {fromOrigUnit, fromExposedReexport} ->
1840 case fromOrigUnit of
1841 -- Just True means, the import is available from its original location
1842 Just True ->
1843 pure [orig_unit]
1844 -- Otherwise, it must be available from a reexport
1845 _ -> pure fromExposedReexport
1846
1847 _ -> Nothing
1848
1849 _ -> Nothing
1850
1851 lookupPluginModuleWithSuggestions :: UnitState
1852 -> ModuleName
1853 -> PkgQual
1854 -> LookupResult
1855 lookupPluginModuleWithSuggestions pkgs
1856 = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
1857
1858 lookupModuleWithSuggestions' :: UnitState
1859 -> ModuleNameProvidersMap
1860 -> ModuleName
1861 -> PkgQual
1862 -> LookupResult
1863 lookupModuleWithSuggestions' pkgs mod_map m mb_pn
1864 = case Map.lookup m mod_map of
1865 Nothing -> LookupNotFound suggestions
1866 Just xs ->
1867 case foldl' classify ([],[],[], []) (Map.toList xs) of
1868 ([], [], [], []) -> LookupNotFound suggestions
1869 (_, _, _, [(m, o)]) -> LookupFound m (mod_unit m, o)
1870 (_, _, _, exposed@(_:_)) -> LookupMultiple exposed
1871 ([], [], unusable@(_:_), []) -> LookupUnusable unusable
1872 (hidden_pkg, hidden_mod, _, []) ->
1873 LookupHidden hidden_pkg hidden_mod
1874 where
1875 classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) =
1876 let origin = filterOrigin mb_pn (mod_unit m) origin0
1877 x = (m, origin)
1878 in case origin of
1879 ModHidden
1880 -> (hidden_pkg, x:hidden_mod, unusable, exposed)
1881 ModUnusable _
1882 -> (hidden_pkg, hidden_mod, x:unusable, exposed)
1883 _ | originEmpty origin
1884 -> (hidden_pkg, hidden_mod, unusable, exposed)
1885 | originVisible origin
1886 -> (hidden_pkg, hidden_mod, unusable, x:exposed)
1887 | otherwise
1888 -> (x:hidden_pkg, hidden_mod, unusable, exposed)
1889
1890 unit_lookup p = lookupUnit pkgs p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
1891 mod_unit = unit_lookup . moduleUnit
1892
1893 -- Filters out origins which are not associated with the given package
1894 -- qualifier. No-op if there is no package qualifier. Test if this
1895 -- excluded all origins with 'originEmpty'.
1896 filterOrigin :: PkgQual
1897 -> UnitInfo
1898 -> ModuleOrigin
1899 -> ModuleOrigin
1900 filterOrigin NoPkgQual _ o = o
1901 filterOrigin (ThisPkg _) _ o = o
1902 filterOrigin (OtherPkg u) pkg o =
1903 let match_pkg p = u == unitId p
1904 in case o of
1905 ModHidden
1906 | match_pkg pkg -> ModHidden
1907 | otherwise -> mempty
1908 ModUnusable _
1909 | match_pkg pkg -> o
1910 | otherwise -> mempty
1911 ModOrigin { fromOrigUnit = e, fromExposedReexport = res,
1912 fromHiddenReexport = rhs }
1913 -> ModOrigin
1914 { fromOrigUnit = if match_pkg pkg then e else Nothing
1915 , fromExposedReexport = filter match_pkg res
1916 , fromHiddenReexport = filter match_pkg rhs
1917 , fromPackageFlag = False -- always excluded
1918 }
1919
1920 suggestions = fuzzyLookup (moduleNameString m) all_mods
1921
1922 all_mods :: [(String, ModuleSuggestion)] -- All modules
1923 all_mods = sortBy (comparing fst) $
1924 [ (moduleNameString m, suggestion)
1925 | (m, e) <- Map.toList (moduleNameProvidersMap pkgs)
1926 , suggestion <- map (getSuggestion m) (Map.toList e)
1927 ]
1928 getSuggestion name (mod, origin) =
1929 (if originVisible origin then SuggestVisible else SuggestHidden)
1930 name mod origin
1931
1932 listVisibleModuleNames :: UnitState -> [ModuleName]
1933 listVisibleModuleNames state =
1934 map fst (filter visible (Map.toList (moduleNameProvidersMap state)))
1935 where visible (_, ms) = any originVisible (Map.elems ms)
1936
1937 -- | Takes a list of UnitIds (and their "parent" dependency, used for error
1938 -- messages), and returns the list with dependencies included, in reverse
1939 -- dependency order (a units appears before those it depends on).
1940 closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
1941 closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
1942
1943 -- | Similar to closeUnitDeps but takes a list of already loaded units as an
1944 -- additional argument.
1945 closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
1946 closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
1947
1948 -- | Add a UnitId and those it depends on (recursively) to the given list of
1949 -- UnitIds if they are not already in it. Return a list in reverse dependency
1950 -- order (a unit appears before those it depends on).
1951 --
1952 -- The UnitId is looked up in the given UnitInfoMap (to find its dependencies).
1953 -- It it's not found, the optional parent unit is used to return a more precise
1954 -- error message ("dependency of <PARENT>").
1955 add_unit :: UnitInfoMap
1956 -> [UnitId]
1957 -> (UnitId,Maybe UnitId)
1958 -> MaybeErr UnitErr [UnitId]
1959 add_unit pkg_map ps (p, mb_parent)
1960 | p `elem` ps = return ps -- Check if we've already added this unit
1961 | otherwise = case lookupUnitId' pkg_map p of
1962 Nothing -> Failed (CloseUnitErr p mb_parent)
1963 Just info -> do
1964 -- Add the unit's dependents also
1965 ps' <- foldM add_unit_key ps (unitDepends info)
1966 return (p : ps')
1967 where
1968 add_unit_key ps key
1969 = add_unit pkg_map ps (key, Just p)
1970
1971 data UnitErr
1972 = CloseUnitErr !UnitId !(Maybe UnitId)
1973 | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
1974 | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)]
1975
1976 mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
1977 mayThrowUnitErr = \case
1978 Failed e -> throwGhcExceptionIO
1979 $ CmdLineError
1980 $ renderWithContext defaultSDocContext
1981 $ withPprStyle defaultUserStyle
1982 $ ppr e
1983 Succeeded a -> return a
1984
1985 instance Outputable UnitErr where
1986 ppr = \case
1987 CloseUnitErr p mb_parent
1988 -> (ftext (fsLit "unknown unit:") <+> ppr p)
1989 <> case mb_parent of
1990 Nothing -> Outputable.empty
1991 Just parent -> space <> parens (text "dependency of"
1992 <+> ftext (unitIdFS parent))
1993 PackageFlagErr flag reasons
1994 -> flag_err (pprFlag flag) reasons
1995
1996 TrustFlagErr flag reasons
1997 -> flag_err (pprTrustFlag flag) reasons
1998 where
1999 flag_err flag_doc reasons =
2000 text "cannot satisfy "
2001 <> flag_doc
2002 <> (if null reasons then Outputable.empty else text ": ")
2003 $$ nest 4 (vcat (map ppr_reason reasons) $$
2004 text "(use -v for more information)")
2005
2006 ppr_reason (p, reason) =
2007 pprReason (ppr (unitId p) <+> text "is") reason
2008
2009 -- | Return this list of requirement interfaces that need to be merged
2010 -- to form @mod_name@, or @[]@ if this is not a requirement.
2011 requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
2012 requirementMerges pkgstate mod_name =
2013 fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
2014
2015 -- -----------------------------------------------------------------------------
2016
2017 -- | Pretty-print a UnitId for the user.
2018 --
2019 -- Cabal packages may contain several components (programs, libraries, etc.).
2020 -- As far as GHC is concerned, installed package components ("units") are
2021 -- identified by an opaque UnitId string provided by Cabal. As the string
2022 -- contains a hash, we don't want to display it to users so GHC queries the
2023 -- database to retrieve some infos about the original source package (name,
2024 -- version, component name).
2025 --
2026 -- Instead we want to display: packagename-version[:componentname]
2027 --
2028 -- Component name is only displayed if it isn't the default library
2029 --
2030 -- To do this we need to query a unit database.
2031 pprUnitIdForUser :: UnitState -> UnitId -> SDoc
2032 pprUnitIdForUser state uid@(UnitId fs) =
2033 case lookupUnitPprInfo state uid of
2034 Nothing -> ftext fs -- we didn't find the unit at all
2035 Just i -> ppr i
2036
2037 pprUnitInfoForUser :: UnitInfo -> SDoc
2038 pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info)
2039
2040 lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
2041 lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid)
2042
2043 -- -----------------------------------------------------------------------------
2044 -- Displaying packages
2045
2046 -- | Show (very verbose) package info
2047 pprUnits :: UnitState -> SDoc
2048 pprUnits = pprUnitsWith pprUnitInfo
2049
2050 pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
2051 pprUnitsWith pprIPI pkgstate =
2052 vcat (intersperse (text "---") (map pprIPI (listUnitInfo pkgstate)))
2053
2054 -- | Show simplified unit info.
2055 --
2056 -- The idea is to only print package id, and any information that might
2057 -- be different from the package databases (exposure, trust)
2058 pprUnitsSimple :: UnitState -> SDoc
2059 pprUnitsSimple = pprUnitsWith pprIPI
2060 where pprIPI ipi = let i = unitIdFS (unitId ipi)
2061 e = if unitIsExposed ipi then text "E" else text " "
2062 t = if unitIsTrusted ipi then text "T" else text " "
2063 in e <> t <> text " " <> ftext i
2064
2065 -- | Show the mapping of modules to where they come from.
2066 pprModuleMap :: ModuleNameProvidersMap -> SDoc
2067 pprModuleMap mod_map =
2068 vcat (map pprLine (Map.toList mod_map))
2069 where
2070 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
2071 pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
2072 pprEntry m (m',o)
2073 | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)
2074 | otherwise = ppr m' <+> parens (ppr o)
2075
2076 fsPackageName :: UnitInfo -> FastString
2077 fsPackageName info = fs
2078 where
2079 PackageName fs = unitPackageName info
2080
2081
2082 -- | Given a fully instantiated 'InstantiatedUnit', improve it into a
2083 -- 'RealUnit' if we can find it in the package database.
2084 improveUnit :: UnitState -> Unit -> Unit
2085 improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u
2086
2087 -- | Given a fully instantiated 'InstantiatedUnit', improve it into a
2088 -- 'RealUnit' if we can find it in the package database.
2089 improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
2090 improveUnit' _ _ uid@(RealUnit _) = uid -- short circuit
2091 improveUnit' pkg_map closure uid =
2092 -- Do NOT lookup indefinite ones, they won't be useful!
2093 case lookupUnit' False pkg_map closure uid of
2094 Nothing -> uid
2095 Just pkg ->
2096 -- Do NOT improve if the indefinite unit id is not
2097 -- part of the closure unique set. See
2098 -- Note [VirtUnit to RealUnit improvement]
2099 if unitId pkg `elementOfUniqSet` closure
2100 then mkUnit pkg
2101 else uid
2102
2103 -- | Check the database to see if we already have an installed unit that
2104 -- corresponds to the given 'InstantiatedUnit'.
2105 --
2106 -- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or
2107 -- references a matching installed unit.
2108 --
2109 -- See Note [VirtUnit to RealUnit improvement]
2110 instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit
2111 instUnitToUnit state iuid =
2112 -- NB: suppose that we want to compare the instantiated
2113 -- unit p[H=impl:H] against p+abcd (where p+abcd
2114 -- happens to be the existing, installed version of
2115 -- p[H=impl:H]. If we *only* wrap in p[H=impl:H]
2116 -- VirtUnit, they won't compare equal; only
2117 -- after improvement will the equality hold.
2118 improveUnit state $ VirtUnit iuid
2119
2120
2121 -- | Substitution on module variables, mapping module names to module
2122 -- identifiers.
2123 type ShHoleSubst = ModuleNameEnv Module
2124
2125 -- | Substitutes holes in a 'Module'. NOT suitable for being called
2126 -- directly on a 'nameModule', see Note [Representation of module/name variable].
2127 -- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
2128 -- similarly, @\<A>@ maps to @q():A@.
2129 renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module
2130 renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state)
2131
2132 -- | Substitutes holes in a 'Unit', suitable for renaming when
2133 -- an include occurs; see Note [Representation of module/name variable].
2134 --
2135 -- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@.
2136 renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
2137 renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state)
2138
2139 -- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap'
2140 -- so it can be used by "GHC.Unit.State".
2141 renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module
2142 renameHoleModule' pkg_map closure env m
2143 | not (isHoleModule m) =
2144 let uid = renameHoleUnit' pkg_map closure env (moduleUnit m)
2145 in mkModule uid (moduleName m)
2146 | Just m' <- lookupUFM env (moduleName m) = m'
2147 -- NB m = <Blah>, that's what's in scope.
2148 | otherwise = m
2149
2150 -- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap'
2151 -- so it can be used by "GHC.Unit.State".
2152 renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit
2153 renameHoleUnit' pkg_map closure env uid =
2154 case uid of
2155 (VirtUnit
2156 InstantiatedUnit{ instUnitInstanceOf = cid
2157 , instUnitInsts = insts
2158 , instUnitHoles = fh })
2159 -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
2160 then uid
2161 -- Functorially apply the substitution to the instantiation,
2162 -- then check the 'ClosureUnitInfoMap' to see if there is
2163 -- a compiled version of this 'InstantiatedUnit' we can improve to.
2164 -- See Note [VirtUnit to RealUnit improvement]
2165 else improveUnit' pkg_map closure $
2166 mkVirtUnit cid
2167 (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts)
2168 _ -> uid
2169
2170 -- | Injects an 'InstantiatedModule' to 'Module' (see also
2171 -- 'instUnitToUnit'.
2172 instModuleToModule :: UnitState -> InstantiatedModule -> Module
2173 instModuleToModule pkgstate (Module iuid mod_name) =
2174 mkModule (instUnitToUnit pkgstate iuid) mod_name
2175
2176 -- | Print unit-ids with UnitInfo found in the given UnitState
2177 pprWithUnitState :: UnitState -> SDoc -> SDoc
2178 pprWithUnitState state = updSDocContext (\ctx -> ctx
2179 { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
2180 })
2181
2182 -- | Add package dependencies on the wired-in packages we use
2183 implicitPackageDeps :: DynFlags -> [UnitId]
2184 implicitPackageDeps dflags
2185 = [thUnitId | xopt TemplateHaskellQuotes dflags]
2186 -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but
2187 -- it is possible to not depend on base (for example, see `ghc-prim`)
2188