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