Support for abi-depends for computing shadowing.
[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.Graph (stronglyConnComp, SCC(..))
87 import Data.Char ( toUpper )
88 import Data.List as List
89 import Data.Map (Map)
90 import Data.Set (Set)
91 import Data.Maybe (mapMaybe)
92 import Data.Monoid (First(..))
93 #if __GLASGOW_HASKELL__ > 710
94 import Data.Semigroup ( Semigroup )
95 import qualified Data.Semigroup as Semigroup
96 #endif
97 import qualified Data.Map as Map
98 import qualified Data.Map.Strict as MapStrict
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 -- | The reason why a package is unusable.
1028 data UnusablePackageReason
1029 = -- | We ignored it explicitly using @-ignore-package@.
1030 IgnoredWithFlag
1031 -- | This package transitively depends on a package that was never present
1032 -- in any of the provided databases.
1033 | BrokenDependencies [InstalledUnitId]
1034 -- | This package transitively depends on a package involved in a cycle.
1035 -- Note that the list of 'InstalledUnitId' reports the direct dependencies
1036 -- of this package that (transitively) depended on the cycle, and not
1037 -- the actual cycle itself (which we report separately at high verbosity.)
1038 | CyclicDependencies [InstalledUnitId]
1039 -- | This package transitively depends on a package which was ignored.
1040 | IgnoredDependencies [InstalledUnitId]
1041 -- | This package transitively depends on a package which was
1042 -- shadowed by an ABI-incompatible package.
1043 | ShadowedDependencies [InstalledUnitId]
1044
1045 instance Outputable UnusablePackageReason where
1046 ppr IgnoredWithFlag = text "[ignored with flag]"
1047 ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids)
1048 ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids)
1049 ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids)
1050 ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
1051
1052 type UnusablePackages = Map InstalledUnitId
1053 (PackageConfig, UnusablePackageReason)
1054
1055 pprReason :: SDoc -> UnusablePackageReason -> SDoc
1056 pprReason pref reason = case reason of
1057 IgnoredWithFlag ->
1058 pref <+> text "ignored due to an -ignore-package flag"
1059 BrokenDependencies deps ->
1060 pref <+> text "unusable due to missing dependencies:" $$
1061 nest 2 (hsep (map ppr deps))
1062 CyclicDependencies deps ->
1063 pref <+> text "unusable due to cyclic dependencies:" $$
1064 nest 2 (hsep (map ppr deps))
1065 IgnoredDependencies deps ->
1066 pref <+> text "unusable due to ignored dependencies:" $$
1067 nest 2 (hsep (map ppr deps))
1068 ShadowedDependencies deps ->
1069 pref <+> text "unusable due to shadowed dependencies:" $$
1070 nest 2 (hsep (map ppr deps))
1071
1072 reportCycles :: DynFlags -> [SCC PackageConfig] -> IO ()
1073 reportCycles dflags sccs = mapM_ report sccs
1074 where
1075 report (AcyclicSCC _) = return ()
1076 report (CyclicSCC vs) =
1077 debugTraceMsg dflags 2 $
1078 text "these packages are involved in a cycle:" $$
1079 nest 2 (hsep (map (ppr . unitId) vs))
1080
1081 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
1082 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
1083 where
1084 report (ipid, (_, reason)) =
1085 debugTraceMsg dflags 2 $
1086 pprReason
1087 (text "package" <+> ppr ipid <+> text "is") reason
1088
1089 -- ----------------------------------------------------------------------------
1090 --
1091 -- Utilities on the database
1092 --
1093
1094 -- | A reverse dependency index, mapping an 'InstalledUnitId' to
1095 -- the 'InstalledUnitId's which have a dependency on it.
1096 type RevIndex = Map InstalledUnitId [InstalledUnitId]
1097
1098 -- | Compute the reverse dependency index of a package database.
1099 reverseDeps :: InstalledPackageIndex -> RevIndex
1100 reverseDeps db = Map.foldl' go Map.empty db
1101 where
1102 go r pkg = foldl' (go' (unitId pkg)) r (depends pkg)
1103 go' from r to = Map.insertWith (++) to [from] r
1104
1105 -- | Given a list of 'InstalledUnitId's to remove, a database,
1106 -- and a reverse dependency index (as computed by 'reverseDeps'),
1107 -- remove those packages, plus any packages which depend on them.
1108 -- Returns the pruned database, as well as a list of 'PackageConfig's
1109 -- that was removed.
1110 removePackages :: [InstalledUnitId] -> RevIndex
1111 -> InstalledPackageIndex
1112 -> (InstalledPackageIndex, [PackageConfig])
1113 removePackages uids index m = go uids (m,[])
1114 where
1115 go [] (m,pkgs) = (m,pkgs)
1116 go (uid:uids) (m,pkgs)
1117 | Just pkg <- Map.lookup uid m
1118 = case Map.lookup uid index of
1119 Nothing -> go uids (Map.delete uid m, pkg:pkgs)
1120 Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)
1121 | otherwise
1122 = go uids (m,pkgs)
1123
1124 -- | Given a 'PackageConfig' from some 'InstalledPackageIndex',
1125 -- return all entries in 'depends' which correspond to packages
1126 -- that do not exist in the index.
1127 depsNotAvailable :: InstalledPackageIndex
1128 -> PackageConfig
1129 -> [InstalledUnitId]
1130 depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg)
1131
1132 -- | Given a 'PackageConfig' from some 'InstalledPackageIndex'
1133 -- return all entries in 'abiDepends' which correspond to packages
1134 -- that do not exist, OR have mismatching ABIs.
1135 depsAbiMismatch :: InstalledPackageIndex
1136 -> PackageConfig
1137 -> [InstalledUnitId]
1138 depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg
1139 where
1140 abiMatch (dep_uid, abi)
1141 | Just dep_pkg <- Map.lookup dep_uid pkg_map
1142 = abiHash dep_pkg == abi
1143 | otherwise
1144 = False
1145
1146 -- -----------------------------------------------------------------------------
1147 -- Ignore packages
1148
1149 ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
1150 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
1151 where
1152 doit (IgnorePackage str) =
1153 case partition (matchingStr str) pkgs of
1154 (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
1155 | p <- ps ]
1156 -- missing package is not an error for -ignore-package,
1157 -- because a common usage is to -ignore-package P as
1158 -- a preventative measure just in case P exists.
1159
1160 -- ----------------------------------------------------------------------------
1161 --
1162 -- Merging databases
1163 --
1164
1165 -- | Given a list of databases, merge them together, where
1166 -- packages with the same unit id in later databases override
1167 -- earlier ones. This does NOT check if the resulting database
1168 -- makes sense (that's done by 'validateDatabase').
1169 mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])]
1170 -> IO InstalledPackageIndex
1171 mergeDatabases dflags = foldM merge Map.empty
1172 where
1173 merge pkg_map (db_path, db) = do
1174 debugTraceMsg dflags 2 $
1175 text "loading package database" <+> text db_path
1176 forM_ (Set.toList override_set) $ \pkg ->
1177 debugTraceMsg dflags 2 $
1178 text "package" <+> ppr pkg <+>
1179 text "overrides a previously defined package"
1180 return pkg_map'
1181 where
1182 db_map = mk_pkg_map db
1183 mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
1184
1185 -- The set of UnitIds which appear in both db and pkgs. These are the
1186 -- ones that get overridden. Compute this just to give some
1187 -- helpful debug messages at -v2
1188 override_set :: Set InstalledUnitId
1189 override_set = Set.intersection (Map.keysSet db_map)
1190 (Map.keysSet pkg_map)
1191
1192 -- Now merge the sets together (NB: in case of duplicate,
1193 -- first argument preferred)
1194 pkg_map' :: InstalledPackageIndex
1195 pkg_map' = Map.union db_map pkg_map
1196
1197 -- | Validates a database, removing unusable packages from it
1198 -- (this includes removing packages that the user has explicitly
1199 -- ignored.) Our general strategy:
1200 --
1201 -- 1. Remove all broken packages (dangling dependencies)
1202 -- 2. Remove all packages that are cyclic
1203 -- 3. Apply ignore flags
1204 -- 4. Remove all packages which have deps with mismatching ABIs
1205 --
1206 validateDatabase :: DynFlags -> InstalledPackageIndex
1207 -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])
1208 validateDatabase dflags pkg_map1 =
1209 (pkg_map5, unusable, sccs)
1210 where
1211 ignore_flags = reverse (ignorePackageFlags dflags)
1212
1213 -- Compute the reverse dependency index
1214 index = reverseDeps pkg_map1
1215
1216 -- Helper function
1217 mk_unusable mk_err dep_matcher m uids =
1218 Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
1219 | pkg <- uids ]
1220
1221 -- Find broken packages
1222 directly_broken = filter (not . null . depsNotAvailable pkg_map1)
1223 (Map.elems pkg_map1)
1224 (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1
1225 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
1226
1227 -- Find recursive packages
1228 sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg)
1229 | pkg <- Map.elems pkg_map2 ]
1230 getCyclicSCC (CyclicSCC vs) = map unitId vs
1231 getCyclicSCC (AcyclicSCC _) = []
1232 (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2
1233 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
1234
1235 -- Apply ignore flags
1236 directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3)
1237 (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3
1238 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
1239
1240 -- Knock out packages whose dependencies don't agree with ABI
1241 -- (i.e., got invalidated due to shadowing)
1242 directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
1243 (Map.elems pkg_map4)
1244 (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4
1245 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
1246
1247 unusable = directly_ignored `Map.union` unusable_ignored
1248 `Map.union` unusable_broken
1249 `Map.union` unusable_cyclic
1250 `Map.union` unusable_shadowed
1251
1252 -- -----------------------------------------------------------------------------
1253 -- When all the command-line options are in, we can process our package
1254 -- settings and populate the package state.
1255
1256 mkPackageState
1257 :: DynFlags
1258 -> [(FilePath, [PackageConfig])] -- initial databases
1259 -> [PreloadUnitId] -- preloaded packages
1260 -> IO (PackageState,
1261 [PreloadUnitId]) -- new packages to preload
1262
1263 mkPackageState dflags dbs preload0 = do
1264 -- Compute the unit id
1265 let this_package = thisPackage dflags
1266
1267 {-
1268 Plan.
1269
1270 There are two main steps for making the package state:
1271
1272 1. We want to build a single, unified package database based
1273 on all of the input databases, which upholds the invariant that
1274 there is only one package per any UnitId and there are no
1275 dangling dependencies. We'll do this by merging, and
1276 then successively filtering out bad dependencies.
1277
1278 a) Merge all the databases together.
1279 If an input database defines unit ID that is already in
1280 the unified database, that package SHADOWS the existing
1281 package in the current unified database.
1282
1283 b) Remove all packages with missing dependencies, or
1284 mutually recursive dependencies.
1285
1286 b) Remove packages selected by -ignore-package from input database
1287
1288 c) Remove all packages which depended on packages that are now
1289 shadowed by an ABI-incompatible package
1290
1291 d) report (with -v) any packages that were removed by steps 1-3
1292
1293 2. We want to look at the flags controlling package visibility,
1294 and build a mapping of what module names are in scope and
1295 where they live.
1296
1297 a) on the final, unified database, we apply -trust/-distrust
1298 flags directly, modifying the database so that the 'trusted'
1299 field has the correct value.
1300
1301 b) we use the -package/-hide-package flags to compute a
1302 visibility map, stating what packages are "exposed" for
1303 the purposes of computing the module map.
1304 * if any flag refers to a package which was removed by 1-5, then
1305 we can give an error message explaining why
1306 * if -hide-all-packages what not specified, this step also
1307 hides packages which are superseded by later exposed packages
1308 * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
1309 are used
1310
1311 c) based on the visibility map, we pick wired packages and rewrite
1312 them to have the expected unitId.
1313
1314 d) finally, using the visibility map and the package database,
1315 we build a mapping saying what every in scope module name points to.
1316 -}
1317
1318 let other_flags = reverse (packageFlags dflags)
1319 debugTraceMsg dflags 2 $
1320 text "package flags" <+> ppr other_flags
1321
1322 -- Merge databases together, without checking validity
1323 pkg_map1 <- mergeDatabases dflags dbs
1324
1325 -- Now that we've merged everything together, prune out unusable
1326 -- packages.
1327 let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1
1328
1329 reportCycles dflags sccs
1330 reportUnusable dflags unusable
1331
1332 -- Apply trust flags (these flags apply regardless of whether
1333 -- or not packages are visible or not)
1334 pkgs1 <- foldM (applyTrustFlag dflags unusable)
1335 (Map.elems pkg_map2) (reverse (trustFlags dflags))
1336 let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1
1337
1338 --
1339 -- Calculate the initial set of packages, prior to any package flags.
1340 -- This set contains the latest version of all valid (not unusable) packages,
1341 -- or is empty if we have -hide-all-packages
1342 --
1343 let preferLater pkg pkg' =
1344 case comparing packageVersion pkg pkg' of
1345 GT -> pkg
1346 _ -> pkg'
1347 calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg
1348 initial = if gopt Opt_HideAllPackages dflags
1349 then emptyUDFM
1350 else foldl' calcInitial emptyUDFM pkgs1
1351 vis_map1 = foldUDFM (\p vm ->
1352 -- Note: we NEVER expose indefinite packages by
1353 -- default, because it's almost assuredly not
1354 -- what you want (no mix-in linking has occurred).
1355 if exposed p && unitIdIsDefinite (packageConfigId p)
1356 then Map.insert (packageConfigId p)
1357 UnitVisibility {
1358 uv_expose_all = True,
1359 uv_renamings = [],
1360 uv_package_name = First (Just (fsPackageName p)),
1361 uv_requirements = Map.empty,
1362 uv_explicit = False
1363 }
1364 vm
1365 else vm)
1366 Map.empty initial
1367
1368 --
1369 -- Compute a visibility map according to the command-line flags (-package,
1370 -- -hide-package). This needs to know about the unusable packages, since if a
1371 -- user tries to enable an unusable package, we should let them know.
1372 --
1373 vis_map2 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
1374 (gopt Opt_HideAllPackages dflags) pkgs1)
1375 vis_map1 other_flags
1376
1377 --
1378 -- Sort out which packages are wired in. This has to be done last, since
1379 -- it modifies the unit ids of wired in packages, but when we process
1380 -- package arguments we need to key against the old versions.
1381 --
1382 (pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
1383 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
1384
1385 -- Update the visibility map, so we treat wired packages as visible.
1386 let vis_map = updateVisibilityMap wired_map vis_map2
1387
1388 let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags
1389 plugin_vis_map <-
1390 case pluginPackageFlags dflags of
1391 -- common case; try to share the old vis_map
1392 [] | not hide_plugin_pkgs -> return vis_map
1393 | otherwise -> return Map.empty
1394 _ -> do let plugin_vis_map1
1395 | hide_plugin_pkgs = Map.empty
1396 -- Use the vis_map PRIOR to wired in,
1397 -- because otherwise applyPackageFlag
1398 -- won't work.
1399 | otherwise = vis_map2
1400 plugin_vis_map2
1401 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
1402 (gopt Opt_HideAllPluginPackages dflags) pkgs1)
1403 plugin_vis_map1
1404 (reverse (pluginPackageFlags dflags))
1405 -- Updating based on wired in packages is mostly
1406 -- good hygiene, because it won't matter: no wired in
1407 -- package has a compiler plugin.
1408 -- TODO: If a wired in package had a compiler plugin,
1409 -- and you tried to pick different wired in packages
1410 -- with the plugin flags and the normal flags... what
1411 -- would happen? I don't know! But this doesn't seem
1412 -- likely to actually happen.
1413 return (updateVisibilityMap wired_map plugin_vis_map2)
1414
1415 --
1416 -- Here we build up a set of the packages mentioned in -package
1417 -- flags on the command line; these are called the "preload"
1418 -- packages. we link these packages in eagerly. The preload set
1419 -- should contain at least rts & base, which is why we pretend that
1420 -- the command line contains -package rts & -package base.
1421 --
1422 -- NB: preload IS important even for type-checking, because we
1423 -- need the correct include path to be set.
1424 --
1425 let preload1 = Map.keys (Map.filter uv_explicit vis_map)
1426
1427 let pkgname_map = foldl add Map.empty pkgs2
1428 where add pn_map p
1429 = Map.insert (packageName p) (componentId p) pn_map
1430
1431 -- The explicitPackages accurately reflects the set of packages we have turned
1432 -- on; as such, it also is the only way one can come up with requirements.
1433 -- The requirement context is directly based off of this: we simply
1434 -- look for nested unit IDs that are directly fed holes: the requirements
1435 -- of those units are precisely the ones we need to track
1436 let explicit_pkgs = Map.keys vis_map
1437 req_ctx = Map.map (Set.toList)
1438 $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
1439
1440
1441 let preload2 = preload1
1442
1443 let
1444 -- add base & rts to the preload packages
1445 basicLinkedPackages
1446 | gopt Opt_AutoLinkPackages dflags
1447 = filter (flip elemUDFM (unPackageConfigMap pkg_db))
1448 [baseUnitId, rtsUnitId]
1449 | otherwise = []
1450 -- but in any case remove the current package from the set of
1451 -- preloaded packages so that base/rts does not end up in the
1452 -- set up preloaded package when we are just building it
1453 preload3 = nub $ filter (/= this_package)
1454 $ (basicLinkedPackages ++ preload2)
1455
1456 -- Close the preload packages with their dependencies
1457 dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))
1458 let new_dep_preload = filter (`notElem` preload0) dep_preload
1459
1460 let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
1461 when (dopt Opt_D_dump_mod_map dflags) $
1462 printInfoForUser (dflags { pprCols = 200 })
1463 alwaysQualify (pprModuleMap mod_map)
1464
1465 -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
1466 let !pstate = PackageState{
1467 preloadPackages = dep_preload,
1468 explicitPackages = explicit_pkgs,
1469 pkgIdMap = pkg_db,
1470 moduleToPkgConfAll = mod_map,
1471 pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map,
1472 packageNameMap = pkgname_map,
1473 unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],
1474 requirementContext = req_ctx
1475 }
1476 return (pstate, new_dep_preload)
1477
1478 -- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
1479 -- that it was recorded as in the package database.
1480 unwireUnitId :: DynFlags -> UnitId -> UnitId
1481 unwireUnitId dflags uid@(DefiniteUnitId def_uid) =
1482 maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags)))
1483 unwireUnitId _ uid = uid
1484
1485 -- -----------------------------------------------------------------------------
1486 -- | Makes the mapping from module to package info
1487
1488 -- Slight irritation: we proceed by leafing through everything
1489 -- in the installed package database, which makes handling indefinite
1490 -- packages a bit bothersome.
1491
1492 mkModuleToPkgConfAll
1493 :: DynFlags
1494 -> PackageConfigMap
1495 -> VisibilityMap
1496 -> ModuleToPkgConfAll
1497 mkModuleToPkgConfAll dflags pkg_db vis_map =
1498 Map.foldlWithKey extend_modmap emptyMap vis_map
1499 where
1500 emptyMap = Map.empty
1501 sing pk m _ = Map.singleton (mkModule pk m)
1502 addListTo = foldl' merge
1503 merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
1504 setOrigins m os = fmap (const os) m
1505 extend_modmap modmap uid
1506 UnitVisibility { uv_expose_all = b, uv_renamings = rns }
1507 = addListTo modmap theBindings
1508 where
1509 pkg = pkg_lookup uid
1510
1511 theBindings :: [(ModuleName, Map Module ModuleOrigin)]
1512 theBindings = newBindings b rns
1513
1514 newBindings :: Bool
1515 -> [(ModuleName, ModuleName)]
1516 -> [(ModuleName, Map Module ModuleOrigin)]
1517 newBindings e rns = es e ++ hiddens ++ map rnBinding rns
1518
1519 rnBinding :: (ModuleName, ModuleName)
1520 -> (ModuleName, Map Module ModuleOrigin)
1521 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1522 where origEntry = case lookupUFM esmap orig of
1523 Just r -> r
1524 Nothing -> throwGhcException (CmdLineError (showSDoc dflags
1525 (text "package flag: could not find module name" <+>
1526 ppr orig <+> text "in package" <+> ppr pk)))
1527
1528 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
1529 es e = do
1530 (m, exposedReexport) <- exposed_mods
1531 let (pk', m', pkg', origin') =
1532 case exposedReexport of
1533 Nothing -> (pk, m, pkg, fromExposedModules e)
1534 Just (Module pk' m') ->
1535 let pkg' = pkg_lookup pk'
1536 in (pk', m', pkg', fromReexportedModules e pkg')
1537 return (m, sing pk' m' pkg' origin')
1538
1539 esmap :: UniqFM (Map Module ModuleOrigin)
1540 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1541 -- be overwritten
1542
1543 hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
1544
1545 pk = packageConfigId pkg
1546 pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
1547 `orElse` pprPanic "pkg_lookup" (ppr uid)
1548
1549 exposed_mods = exposedModules pkg
1550 hidden_mods = hiddenModules pkg
1551
1552 -- -----------------------------------------------------------------------------
1553 -- Extracting information from the packages in scope
1554
1555 -- Many of these functions take a list of packages: in those cases,
1556 -- the list is expected to contain the "dependent packages",
1557 -- i.e. those packages that were found to be depended on by the
1558 -- current module/program. These can be auto or non-auto packages, it
1559 -- doesn't really matter. The list is always combined with the list
1560 -- of preload (command-line) packages to determine which packages to
1561 -- use.
1562
1563 -- | Find all the include directories in these and the preload packages
1564 getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String]
1565 getPackageIncludePath dflags pkgs =
1566 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1567
1568 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1569 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1570
1571 -- | Find all the library paths in these and the preload packages
1572 getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String]
1573 getPackageLibraryPath dflags pkgs =
1574 collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs
1575
1576 collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath]
1577 collectLibraryPaths dflags = nub . filter notNull
1578 . concatMap (libraryDirsForWay dflags)
1579
1580 -- | Find all the link options in these and the preload packages,
1581 -- returning (package hs lib options, extra library options, other flags)
1582 getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String])
1583 getPackageLinkOpts dflags pkgs =
1584 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1585
1586 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1587 collectLinkOpts dflags ps =
1588 (
1589 concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1590 concatMap (map ("-l" ++) . extraLibraries) ps,
1591 concatMap ldOptions ps
1592 )
1593
1594 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1595 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1596 where
1597 ways0 = ways dflags
1598
1599 ways1 = filter (/= WayDyn) ways0
1600 -- the name of a shared library is libHSfoo-ghc<version>.so
1601 -- we leave out the _dyn, because it is superfluous
1602
1603 -- debug and profiled RTSs include support for -eventlog
1604 ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1
1605 = filter (/= WayEventLog) ways1
1606 | otherwise
1607 = ways1
1608
1609 tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
1610 rts_tag = mkBuildTag ways2
1611
1612 mkDynName x
1613 | WayDyn `notElem` ways dflags = x
1614 | "HS" `isPrefixOf` x =
1615 x ++ '-':programName dflags ++ projectVersion dflags
1616 -- For non-Haskell libraries, we use the name "Cfoo". The .a
1617 -- file is libCfoo.a, and the .so is libfoo.so. That way the
1618 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1619 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1620 | Just x' <- stripPrefix "C" x = x'
1621 | otherwise
1622 = panic ("Don't understand library name " ++ x)
1623
1624 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
1625 addSuffix other_lib = other_lib ++ (expandTag tag)
1626
1627 expandTag t | null t = ""
1628 | otherwise = '_':t
1629
1630 -- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way.
1631 libraryDirsForWay :: DynFlags -> PackageConfig -> [String]
1632 libraryDirsForWay dflags
1633 | WayDyn `elem` ways dflags = libraryDynDirs
1634 | otherwise = libraryDirs
1635
1636 -- | Find all the C-compiler options in these and the preload packages
1637 getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String]
1638 getPackageExtraCcOpts dflags pkgs = do
1639 ps <- getPreloadPackagesAnd dflags pkgs
1640 return (concatMap ccOptions ps)
1641
1642 -- | Find all the package framework paths in these and the preload packages
1643 getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String]
1644 getPackageFrameworkPath dflags pkgs = do
1645 ps <- getPreloadPackagesAnd dflags pkgs
1646 return (nub (filter notNull (concatMap frameworkDirs ps)))
1647
1648 -- | Find all the package frameworks in these and the preload packages
1649 getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String]
1650 getPackageFrameworks dflags pkgs = do
1651 ps <- getPreloadPackagesAnd dflags pkgs
1652 return (concatMap frameworks ps)
1653
1654 -- -----------------------------------------------------------------------------
1655 -- Package Utils
1656
1657 -- | Takes a 'ModuleName', and if the module is in any package returns
1658 -- list of modules which take that name.
1659 lookupModuleInAllPackages :: DynFlags
1660 -> ModuleName
1661 -> [(Module, PackageConfig)]
1662 lookupModuleInAllPackages dflags m
1663 = case lookupModuleWithSuggestions dflags m Nothing of
1664 LookupFound a b -> [(a,b)]
1665 LookupMultiple rs -> map f rs
1666 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1667 (moduleUnitId m)))
1668 _ -> []
1669
1670 -- | The result of performing a lookup
1671 data LookupResult =
1672 -- | Found the module uniquely, nothing else to do
1673 LookupFound Module PackageConfig
1674 -- | Multiple modules with the same name in scope
1675 | LookupMultiple [(Module, ModuleOrigin)]
1676 -- | No modules found, but there were some hidden ones with
1677 -- an exact name match. First is due to package hidden, second
1678 -- is due to module being hidden
1679 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1680 -- | Nothing found, here are some suggested different names
1681 | LookupNotFound [ModuleSuggestion] -- suggestions
1682
1683 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1684 | SuggestHidden ModuleName Module ModuleOrigin
1685
1686 lookupModuleWithSuggestions :: DynFlags
1687 -> ModuleName
1688 -> Maybe FastString
1689 -> LookupResult
1690 lookupModuleWithSuggestions dflags
1691 = lookupModuleWithSuggestions' dflags
1692 (moduleToPkgConfAll (pkgState dflags))
1693
1694 lookupPluginModuleWithSuggestions :: DynFlags
1695 -> ModuleName
1696 -> Maybe FastString
1697 -> LookupResult
1698 lookupPluginModuleWithSuggestions dflags
1699 = lookupModuleWithSuggestions' dflags
1700 (pluginModuleToPkgConfAll (pkgState dflags))
1701
1702 lookupModuleWithSuggestions' :: DynFlags
1703 -> ModuleToPkgConfAll
1704 -> ModuleName
1705 -> Maybe FastString
1706 -> LookupResult
1707 lookupModuleWithSuggestions' dflags mod_map m mb_pn
1708 = case Map.lookup m mod_map of
1709 Nothing -> LookupNotFound suggestions
1710 Just xs ->
1711 case foldl' classify ([],[],[]) (Map.toList xs) of
1712 ([], [], []) -> LookupNotFound suggestions
1713 (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
1714 (_, _, exposed@(_:_)) -> LookupMultiple exposed
1715 (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
1716 where
1717 classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
1718 let origin = filterOrigin mb_pn (mod_pkg m) origin0
1719 x = (m, origin)
1720 in case origin of
1721 ModHidden -> (hidden_pkg, x:hidden_mod, exposed)
1722 _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed)
1723 | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
1724 | otherwise -> (x:hidden_pkg, hidden_mod, exposed)
1725
1726 pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
1727 mod_pkg = pkg_lookup . moduleUnitId
1728
1729 -- Filters out origins which are not associated with the given package
1730 -- qualifier. No-op if there is no package qualifier. Test if this
1731 -- excluded all origins with 'originEmpty'.
1732 filterOrigin :: Maybe FastString
1733 -> PackageConfig
1734 -> ModuleOrigin
1735 -> ModuleOrigin
1736 filterOrigin Nothing _ o = o
1737 filterOrigin (Just pn) pkg o =
1738 case o of
1739 ModHidden -> if go pkg then ModHidden else mempty
1740 ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1741 fromHiddenReexport = rhs }
1742 -> ModOrigin {
1743 fromOrigPackage = if go pkg then e else Nothing
1744 , fromExposedReexport = filter go res
1745 , fromHiddenReexport = filter go rhs
1746 , fromPackageFlag = False -- always excluded
1747 }
1748 where go pkg = pn == fsPackageName pkg
1749
1750 suggestions
1751 | gopt Opt_HelpfulErrors dflags =
1752 fuzzyLookup (moduleNameString m) all_mods
1753 | otherwise = []
1754
1755 all_mods :: [(String, ModuleSuggestion)] -- All modules
1756 all_mods = sortBy (comparing fst) $
1757 [ (moduleNameString m, suggestion)
1758 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1759 , suggestion <- map (getSuggestion m) (Map.toList e)
1760 ]
1761 getSuggestion name (mod, origin) =
1762 (if originVisible origin then SuggestVisible else SuggestHidden)
1763 name mod origin
1764
1765 listVisibleModuleNames :: DynFlags -> [ModuleName]
1766 listVisibleModuleNames dflags =
1767 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1768 where visible (_, ms) = any originVisible (Map.elems ms)
1769
1770 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1771 -- 'PackageConfig's
1772 getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]
1773 getPreloadPackagesAnd dflags pkgids =
1774 let
1775 state = pkgState dflags
1776 pkg_map = pkgIdMap state
1777 preload = preloadPackages state
1778 pairs = zip pkgids (repeat Nothing)
1779 in do
1780 all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
1781 return (map (getInstalledPackageDetails dflags) all_pkgs)
1782
1783 -- Takes a list of packages, and returns the list with dependencies included,
1784 -- in reverse dependency order (a package appears before those it depends on).
1785 closeDeps :: DynFlags
1786 -> PackageConfigMap
1787 -> [(InstalledUnitId, Maybe InstalledUnitId)]
1788 -> IO [InstalledUnitId]
1789 closeDeps dflags pkg_map ps
1790 = throwErr dflags (closeDepsErr dflags pkg_map ps)
1791
1792 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
1793 throwErr dflags m
1794 = case m of
1795 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
1796 Succeeded r -> return r
1797
1798 closeDepsErr :: DynFlags
1799 -> PackageConfigMap
1800 -> [(InstalledUnitId,Maybe InstalledUnitId)]
1801 -> MaybeErr MsgDoc [InstalledUnitId]
1802 closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps
1803
1804 -- internal helper
1805 add_package :: DynFlags
1806 -> PackageConfigMap
1807 -> [PreloadUnitId]
1808 -> (PreloadUnitId,Maybe PreloadUnitId)
1809 -> MaybeErr MsgDoc [PreloadUnitId]
1810 add_package dflags pkg_db ps (p, mb_parent)
1811 | p `elem` ps = return ps -- Check if we've already added this package
1812 | otherwise =
1813 case lookupInstalledPackage' pkg_db p of
1814 Nothing -> Failed (missingPackageMsg p <>
1815 missingDependencyMsg mb_parent)
1816 Just pkg -> do
1817 -- Add the package's dependents also
1818 ps' <- foldM add_unit_key ps (depends pkg)
1819 return (p : ps')
1820 where
1821 add_unit_key ps key
1822 = add_package dflags pkg_db ps (key, Just p)
1823
1824 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
1825 missingPackageMsg p = text "unknown package:" <+> ppr p
1826
1827 missingDependencyMsg :: Maybe InstalledUnitId -> SDoc
1828 missingDependencyMsg Nothing = Outputable.empty
1829 missingDependencyMsg (Just parent)
1830 = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent))
1831
1832 -- -----------------------------------------------------------------------------
1833
1834 componentIdString :: DynFlags -> ComponentId -> Maybe String
1835 componentIdString dflags cid =
1836 fmap sourcePackageIdString (lookupInstalledPackage dflags
1837 (componentIdToInstalledUnitId cid))
1838
1839 displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
1840 displayInstalledUnitId dflags uid =
1841 fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
1842
1843 -- | Will the 'Name' come from a dynamically linked library?
1844 isDllName :: DynFlags -> Module -> Name -> Bool
1845 -- Despite the "dll", I think this function just means that
1846 -- the symbol comes from another dynamically-linked package,
1847 -- and applies on all platforms, not just Windows
1848 isDllName dflags this_mod name
1849 | WayDyn `notElem` ways dflags = False
1850 | Just mod <- nameModule_maybe name
1851 -- Issue #8696 - when GHC is dynamically linked, it will attempt
1852 -- to load the dynamic dependencies of object files at compile
1853 -- time for things like QuasiQuotes or
1854 -- TemplateHaskell. Unfortunately, this interacts badly with
1855 -- intra-package linking, because we don't generate indirect
1856 -- (dynamic) symbols for intra-package calls. This means that if a
1857 -- module with an intra-package call is loaded without its
1858 -- dependencies, then GHC fails to link. This is the cause of #
1859 --
1860 -- In the mean time, always force dynamic indirections to be
1861 -- generated: when the module name isn't the module being
1862 -- compiled, references are dynamic.
1863 = if mod /= this_mod
1864 then True
1865 else case dllSplit dflags of
1866 Nothing -> False
1867 Just ss ->
1868 let findMod m = let modStr = moduleNameString (moduleName m)
1869 in case find (modStr `Set.member`) ss of
1870 Just i -> i
1871 Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
1872 in findMod mod /= findMod this_mod
1873
1874 | otherwise = False -- no, it is not even an external name
1875
1876 -- -----------------------------------------------------------------------------
1877 -- Displaying packages
1878
1879 -- | Show (very verbose) package info
1880 pprPackages :: DynFlags -> SDoc
1881 pprPackages = pprPackagesWith pprPackageConfig
1882
1883 pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
1884 pprPackagesWith pprIPI dflags =
1885 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
1886
1887 -- | Show simplified package info.
1888 --
1889 -- The idea is to only print package id, and any information that might
1890 -- be different from the package databases (exposure, trust)
1891 pprPackagesSimple :: DynFlags -> SDoc
1892 pprPackagesSimple = pprPackagesWith pprIPI
1893 where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)
1894 e = if exposed ipi then text "E" else text " "
1895 t = if trusted ipi then text "T" else text " "
1896 in e <> t <> text " " <> ftext i
1897
1898 -- | Show the mapping of modules to where they come from.
1899 pprModuleMap :: ModuleToPkgConfAll -> SDoc
1900 pprModuleMap mod_map =
1901 vcat (map pprLine (Map.toList mod_map))
1902 where
1903 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
1904 pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
1905 pprEntry m (m',o)
1906 | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
1907 | otherwise = ppr m' <+> parens (ppr o)
1908
1909 fsPackageName :: PackageConfig -> FastString
1910 fsPackageName = mkFastString . packageNameString
1911
1912 -- | Given a fully instantiated 'UnitId', improve it into a
1913 -- 'InstalledUnitId' if we can find it in the package database.
1914 improveUnitId :: PackageConfigMap -> UnitId -> UnitId
1915 improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit
1916 improveUnitId pkg_map uid =
1917 -- Do NOT lookup indefinite ones, they won't be useful!
1918 case lookupPackage' False pkg_map uid of
1919 Nothing -> uid
1920 Just pkg ->
1921 -- Do NOT improve if the indefinite unit id is not
1922 -- part of the closure unique set. See
1923 -- Note [UnitId to InstalledUnitId improvement]
1924 if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map
1925 then packageConfigId pkg
1926 else uid
1927
1928 -- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
1929 -- in the @hs-boot@ loop-breaker.
1930 getPackageConfigMap :: DynFlags -> PackageConfigMap
1931 getPackageConfigMap = pkgIdMap . pkgState