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