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