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