Revert "Revert "Revert "Support for multiple signature files in scope."""
[ghc.git] / compiler / main / Packages.hs
1 -- (c) The University of Glasgow, 2006
2
3 {-# LANGUAGE CPP, ScopedTypeVariables #-}
4
5 -- | Package manipulation
6 module Packages (
7 module PackageConfig,
8
9 -- * Reading the package config, and processing cmdline args
10 PackageState(preloadPackages),
11 emptyPackageState,
12 initPackages,
13 readPackageConfigs,
14 getPackageConfRefs,
15 resolvePackageConfig,
16 readPackageConfig,
17 listPackageConfigMap,
18
19 -- * Querying the package config
20 lookupPackage,
21 resolveInstalledPackageId,
22 searchPackageId,
23 getPackageDetails,
24 listVisibleModuleNames,
25 lookupModuleInAllPackages,
26 lookupModuleWithSuggestions,
27 LookupResult(..),
28 ModuleSuggestion(..),
29 ModuleOrigin(..),
30
31 -- * Inspecting the set of packages in scope
32 getPackageIncludePath,
33 getPackageLibraryPath,
34 getPackageLinkOpts,
35 getPackageExtraCcOpts,
36 getPackageFrameworkPath,
37 getPackageFrameworks,
38 getPreloadPackagesAnd,
39
40 collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
41 packageHsLibs,
42
43 -- * Utils
44 packageKeyPackageIdString,
45 pprFlag,
46 pprPackages,
47 pprPackagesSimple,
48 pprModuleMap,
49 isDllName
50 )
51 where
52
53 #include "HsVersions.h"
54
55 import GHC.PackageDb
56 import PackageConfig
57 import DynFlags
58 import Name ( Name, nameModule_maybe )
59 import UniqFM
60 import Module
61 import Util
62 import Panic
63 import Outputable
64 import Maybes
65
66 import System.Environment ( getEnv )
67 import FastString
68 import ErrUtils ( debugTraceMsg, MsgDoc )
69 import Exception
70 import Unique
71
72 import System.Directory
73 import System.FilePath as FilePath
74 import qualified System.FilePath.Posix as FilePath.Posix
75 import Control.Monad
76 import Data.Char ( toUpper )
77 import Data.List as List
78 import Data.Map (Map)
79 #if __GLASGOW_HASKELL__ < 709
80 import Data.Monoid hiding ((<>))
81 #endif
82 import qualified Data.Map as Map
83 import qualified FiniteMap as Map
84 import qualified Data.Set as Set
85
86 -- ---------------------------------------------------------------------------
87 -- The Package state
88
89 -- | Package state is all stored in 'DynFlags', including the details of
90 -- all packages, which packages are exposed, and which modules they
91 -- provide.
92 --
93 -- The package state is computed by 'initPackages', and kept in DynFlags.
94 -- It is influenced by various package flags:
95 --
96 -- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
97 -- If @-hide-all-packages@ was not specified, these commands also cause
98 -- all other packages with the same name to become hidden.
99 --
100 -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
101 --
102 -- * (there are a few more flags, check below for their semantics)
103 --
104 -- The package state has the following properties.
105 --
106 -- * Let @exposedPackages@ be the set of packages thus exposed.
107 -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
108 -- their dependencies.
109 --
110 -- * When searching for a module from an preload import declaration,
111 -- only the exposed modules in @exposedPackages@ are valid.
112 --
113 -- * When searching for a module from an implicit import, all modules
114 -- from @depExposedPackages@ are valid.
115 --
116 -- * When linking in a compilation manager mode, we link in packages the
117 -- program depends on (the compiler knows this list by the
118 -- time it gets to the link step). Also, we link in all packages
119 -- which were mentioned with preload @-package@ flags on the command-line,
120 -- or are a transitive dependency of same, or are \"base\"\/\"rts\".
121 -- The reason for this is that we might need packages which don't
122 -- contain any Haskell modules, and therefore won't be discovered
123 -- by the normal mechanism of dependency tracking.
124
125 -- Notes on DLLs
126 -- ~~~~~~~~~~~~~
127 -- When compiling module A, which imports module B, we need to
128 -- know whether B will be in the same DLL as A.
129 -- If it's in the same DLL, we refer to B_f_closure
130 -- If it isn't, we refer to _imp__B_f_closure
131 -- When compiling A, we record in B's Module value whether it's
132 -- in a different DLL, by setting the DLL flag.
133
134 -- | Given a module name, there may be multiple ways it came into scope,
135 -- possibly simultaneously. This data type tracks all the possible ways
136 -- it could have come into scope. Warning: don't use the record functions,
137 -- they're partial!
138 data ModuleOrigin =
139 -- | Module is hidden, and thus never will be available for import.
140 -- (But maybe the user didn't realize), so we'll still keep track
141 -- of these modules.)
142 ModHidden
143 -- | Module is public, and could have come from some places.
144 | ModOrigin {
145 -- | @Just False@ means that this module is in
146 -- someone's @exported-modules@ list, but that package is hidden;
147 -- @Just True@ means that it is available; @Nothing@ means neither
148 -- applies.
149 fromOrigPackage :: Maybe Bool
150 -- | Is the module available from a reexport of an exposed package?
151 -- There could be multiple.
152 , fromExposedReexport :: [PackageConfig]
153 -- | Is the module available from a reexport of a hidden package?
154 , fromHiddenReexport :: [PackageConfig]
155 -- | Did the module export come from a package flag? (ToDo: track
156 -- more information.
157 , fromPackageFlag :: Bool
158 }
159
160 instance Outputable ModuleOrigin where
161 ppr ModHidden = text "hidden module"
162 ppr (ModOrigin e res rhs f) = sep (punctuate comma (
163 (case e of
164 Nothing -> []
165 Just False -> [text "hidden package"]
166 Just True -> [text "exposed package"]) ++
167 (if null res
168 then []
169 else [text "reexport by" <+>
170 sep (map (ppr . packageConfigId) res)]) ++
171 (if null rhs
172 then []
173 else [text "hidden reexport by" <+>
174 sep (map (ppr . packageConfigId) res)]) ++
175 (if f then [text "package flag"] else [])
176 ))
177
178 -- | Smart constructor for a module which is in @exposed-modules@. Takes
179 -- as an argument whether or not the defining package is exposed.
180 fromExposedModules :: Bool -> ModuleOrigin
181 fromExposedModules e = ModOrigin (Just e) [] [] False
182
183 -- | Smart constructor for a module which is in @reexported-modules@. Takes
184 -- as an argument whether or not the reexporting package is expsed, and
185 -- also its 'PackageConfig'.
186 fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
187 fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
188 fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
189
190 -- | Smart constructor for a module which was bound by a package flag.
191 fromFlag :: ModuleOrigin
192 fromFlag = ModOrigin Nothing [] [] True
193
194 instance Monoid ModuleOrigin where
195 mempty = ModOrigin Nothing [] [] False
196 mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
197 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
198 where g (Just b) (Just b')
199 | b == b' = Just b
200 | otherwise = panic "ModOrigin: package both exposed/hidden"
201 g Nothing x = x
202 g x Nothing = x
203 mappend _ _ = panic "ModOrigin: hidden module redefined"
204
205 -- | Is the name from the import actually visible? (i.e. does it cause
206 -- ambiguity, or is it only relevant when we're making suggestions?)
207 originVisible :: ModuleOrigin -> Bool
208 originVisible ModHidden = False
209 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
210
211 -- | Are there actually no providers for this module? This will never occur
212 -- except when we're filtering based on package imports.
213 originEmpty :: ModuleOrigin -> Bool
214 originEmpty (ModOrigin Nothing [] [] False) = True
215 originEmpty _ = False
216
217 -- | 'UniqFM' map from 'PackageKey'
218 type PackageKeyMap = UniqFM
219
220 -- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
221 type PackageConfigMap = PackageKeyMap PackageConfig
222
223 -- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
224 -- are exposed should be dumped into scope, (2) any custom renamings that
225 -- should also be apply, and (3) what package name is associated with the
226 -- key, if it might be hidden
227 type VisibilityMap =
228 PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)
229
230 -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
231 -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
232 -- (since this is the slow path, we'll just look it up again).
233 type ModuleToPkgConfAll =
234 Map ModuleName (Map Module ModuleOrigin)
235
236 data PackageState = PackageState {
237 -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted
238 -- so that only valid packages are here. 'PackageConfig' reflects
239 -- what was stored *on disk*, except for the 'trusted' flag, which
240 -- is adjusted at runtime. (In particular, some packages in this map
241 -- may have the 'exposed' flag be 'False'.)
242 pkgIdMap :: PackageConfigMap,
243
244 -- | The packages we're going to link in eagerly. This list
245 -- should be in reverse dependency order; that is, a package
246 -- is always mentioned before the packages it depends on.
247 preloadPackages :: [PackageKey],
248
249 -- | This is a full map from 'ModuleName' to all modules which may possibly
250 -- be providing it. These providers may be hidden (but we'll still want
251 -- to report them in error messages), or it may be an ambiguous import.
252 moduleToPkgConfAll :: ModuleToPkgConfAll,
253
254 -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
255 -- internally deals in package keys but the database may refer to installed
256 -- package IDs.
257 installedPackageIdMap :: InstalledPackageIdMap
258 }
259
260 emptyPackageState :: PackageState
261 emptyPackageState = PackageState {
262 pkgIdMap = emptyUFM,
263 preloadPackages = [],
264 moduleToPkgConfAll = Map.empty,
265 installedPackageIdMap = Map.empty
266 }
267
268 type InstalledPackageIdMap = Map InstalledPackageId PackageKey
269 type InstalledPackageIndex = Map InstalledPackageId PackageConfig
270
271 -- | Empty package configuration map
272 emptyPackageConfigMap :: PackageConfigMap
273 emptyPackageConfigMap = emptyUFM
274
275 -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
276 lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
277 lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
278
279 lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
280 lookupPackage' = lookupUFM
281
282 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
283 searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
284 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
285 (listPackageConfigMap dflags)
286
287 -- | Extends the package configuration map with a list of package configs.
288 extendPackageConfigMap
289 :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
290 extendPackageConfigMap pkg_map new_pkgs
291 = foldl add pkg_map new_pkgs
292 where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
293
294 -- | Looks up the package with the given id in the package state, panicing if it is
295 -- not found
296 getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
297 getPackageDetails dflags pid =
298 expectJust "getPackageDetails" (lookupPackage dflags pid)
299
300 -- | Get a list of entries from the package database. NB: be careful with
301 -- this function, although all packages in this map are "visible", this
302 -- does not imply that the exposed-modules of the package are available
303 -- (they may have been thinned or renamed).
304 listPackageConfigMap :: DynFlags -> [PackageConfig]
305 listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
306
307 -- | Looks up a 'PackageKey' given an 'InstalledPackageId'
308 resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
309 resolveInstalledPackageId dflags ipid =
310 expectJust "resolveInstalledPackageId"
311 (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
312
313 -- ----------------------------------------------------------------------------
314 -- Loading the package db files and building up the package state
315
316 -- | Call this after 'DynFlags.parseDynFlags'. It reads the package
317 -- database files, and sets up various internal tables of package
318 -- information, according to the package-related flags on the
319 -- command-line (@-package@, @-hide-package@ etc.)
320 --
321 -- Returns a list of packages to link in if we're doing dynamic linking.
322 -- This list contains the packages that the user explicitly mentioned with
323 -- @-package@ flags.
324 --
325 -- 'initPackages' can be called again subsequently after updating the
326 -- 'packageFlags' field of the 'DynFlags', and it will update the
327 -- 'pkgState' in 'DynFlags' and return a list of packages to
328 -- link in.
329 initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
330 initPackages dflags = do
331 pkg_db <- case pkgDatabase dflags of
332 Nothing -> readPackageConfigs dflags
333 Just db -> return $ setBatchPackageFlags dflags db
334 (pkg_state, preload, this_pkg)
335 <- mkPackageState dflags pkg_db []
336 return (dflags{ pkgDatabase = Just pkg_db,
337 pkgState = pkg_state,
338 thisPackage = this_pkg },
339 preload)
340
341 -- -----------------------------------------------------------------------------
342 -- Reading the package database(s)
343
344 readPackageConfigs :: DynFlags -> IO [PackageConfig]
345 readPackageConfigs dflags = do
346 conf_refs <- getPackageConfRefs dflags
347 confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
348 liftM concat $ mapM (readPackageConfig dflags) confs
349
350 getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
351 getPackageConfRefs dflags = do
352 let system_conf_refs = [UserPkgConf, GlobalPkgConf]
353
354 e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
355 let base_conf_refs = case e_pkg_path of
356 Left _ -> system_conf_refs
357 Right path
358 | not (null path) && isSearchPathSeparator (last path)
359 -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
360 | otherwise
361 -> map PkgConfFile (splitSearchPath path)
362
363 return $ reverse (extraPkgConfs dflags base_conf_refs)
364 -- later packages shadow earlier ones. extraPkgConfs
365 -- is in the opposite order to the flags on the
366 -- command line.
367
368 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
369 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
370 resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
371 dir <- versionedAppDir dflags
372 let pkgconf = dir </> "package.conf.d"
373 exist <- doesDirectoryExist pkgconf
374 return $ if exist then Just pkgconf else Nothing
375 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
376
377 readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
378 readPackageConfig dflags conf_file = do
379 isdir <- doesDirectoryExist conf_file
380
381 proto_pkg_configs <-
382 if isdir
383 then readDirStylePackageConfig conf_file
384 else do
385 isfile <- doesFileExist conf_file
386 if isfile
387 then do
388 mpkgs <- tryReadOldFileStylePackageConfig
389 case mpkgs of
390 Just pkgs -> return pkgs
391 Nothing -> throwGhcExceptionIO $ InstallationError $
392 "ghc no longer supports single-file style package " ++
393 "databases (" ++ conf_file ++
394 ") use 'ghc-pkg init' to create the database with " ++
395 "the correct format."
396 else throwGhcExceptionIO $ InstallationError $
397 "can't find a package database at " ++ conf_file
398
399 let
400 top_dir = topDir dflags
401 pkgroot = takeDirectory conf_file
402 pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
403 pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
404 --
405 return pkg_configs2
406 where
407 readDirStylePackageConfig conf_dir = do
408 let filename = conf_dir </> "package.cache"
409 debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
410 readPackageDbForGhc filename
411
412 -- Single-file style package dbs have been deprecated for some time, but
413 -- it turns out that Cabal was using them in one place. So this is a
414 -- workaround to allow older Cabal versions to use this newer ghc.
415 -- We check if the file db contains just "[]" and if so, we look for a new
416 -- dir-style db in conf_file.d/, ie in a dir next to the given file.
417 -- We cannot just replace the file with a new dir style since Cabal still
418 -- assumes it's a file and tries to overwrite with 'writeFile'.
419 -- ghc-pkg also cooperates with this workaround.
420 tryReadOldFileStylePackageConfig = do
421 content <- readFile conf_file `catchIO` \_ -> return ""
422 if take 2 content == "[]"
423 then do
424 let conf_dir = conf_file <.> "d"
425 direxists <- doesDirectoryExist conf_dir
426 if direxists
427 then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
428 liftM Just (readDirStylePackageConfig conf_dir)
429 else return (Just []) -- ghc-pkg will create it when it's updated
430 else return Nothing
431
432 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
433 setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
434 where
435 maybeDistrustAll pkgs'
436 | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
437 | otherwise = pkgs'
438
439 distrust pkg = pkg{ trusted = False }
440
441 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
442 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
443 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
444 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
445 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
446 -- The "pkgroot" is the directory containing the package database.
447 --
448 -- Also perform a similar substitution for the older GHC-specific
449 -- "$topdir" variable. The "topdir" is the location of the ghc
450 -- installation (obtained from the -B option).
451 mungePackagePaths top_dir pkgroot pkg =
452 pkg {
453 importDirs = munge_paths (importDirs pkg),
454 includeDirs = munge_paths (includeDirs pkg),
455 libraryDirs = munge_paths (libraryDirs pkg),
456 frameworkDirs = munge_paths (frameworkDirs pkg),
457 haddockInterfaces = munge_paths (haddockInterfaces pkg),
458 haddockHTMLs = munge_urls (haddockHTMLs pkg)
459 }
460 where
461 munge_paths = map munge_path
462 munge_urls = map munge_url
463
464 munge_path p
465 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
466 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
467 | otherwise = p
468
469 munge_url p
470 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
471 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
472 | otherwise = p
473
474 toUrlPath r p = "file:///"
475 -- URLs always use posix style '/' separators:
476 ++ FilePath.Posix.joinPath
477 (r : -- We need to drop a leading "/" or "\\"
478 -- if there is one:
479 dropWhile (all isPathSeparator)
480 (FilePath.splitDirectories p))
481
482 -- We could drop the separator here, and then use </> above. However,
483 -- by leaving it in and using ++ we keep the same path separator
484 -- rather than letting FilePath change it to use \ as the separator
485 stripVarPrefix var path = case stripPrefix var path of
486 Just [] -> Just []
487 Just cs@(c : _) | isPathSeparator c -> Just cs
488 _ -> Nothing
489
490
491 -- -----------------------------------------------------------------------------
492 -- Modify our copy of the package database based on a package flag
493 -- (-package, -hide-package, -ignore-package).
494
495 applyPackageFlag
496 :: DynFlags
497 -> UnusablePackages
498 -> ([PackageConfig], VisibilityMap) -- Initial database
499 -> PackageFlag -- flag to apply
500 -> IO ([PackageConfig], VisibilityMap) -- new database
501
502 -- ToDo: Unfortunately, we still have to plumb the package config through,
503 -- because Safe Haskell trust is still implemented by modifying the database.
504 -- Eventually, track that separately and then axe @[PackageConfig]@ from
505 -- this fold entirely
506
507 applyPackageFlag dflags unusable (pkgs, vm) flag =
508 case flag of
509 ExposePackage arg (ModRenaming b rns) ->
510 case selectPackages (matching arg) pkgs unusable of
511 Left ps -> packageFlagErr dflags flag ps
512 Right (p:_,_) -> return (pkgs, vm')
513 where
514 n = fsPackageName p
515 vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
516 edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
517 -- ToDo: ATM, -hide-all-packages implicitly triggers change in
518 -- behavior, maybe eventually make it toggleable with a separate
519 -- flag
520 vm_cleared | gopt Opt_HideAllPackages dflags = vm
521 | otherwise = filterUFM_Directly
522 (\k (_,_,n') -> k == getUnique (packageConfigId p)
523 || n /= n') vm
524 _ -> panic "applyPackageFlag"
525
526 HidePackage str ->
527 case selectPackages (matchingStr str) pkgs unusable of
528 Left ps -> packageFlagErr dflags flag ps
529 Right (ps,_) -> return (pkgs, vm')
530 where vm' = delListFromUFM vm (map packageConfigId ps)
531
532 -- we trust all matching packages. Maybe should only trust first one?
533 -- and leave others the same or set them untrusted
534 TrustPackage str ->
535 case selectPackages (matchingStr str) pkgs unusable of
536 Left ps -> packageFlagErr dflags flag ps
537 Right (ps,qs) -> return (map trust ps ++ qs, vm)
538 where trust p = p {trusted=True}
539
540 DistrustPackage str ->
541 case selectPackages (matchingStr str) pkgs unusable of
542 Left ps -> packageFlagErr dflags flag ps
543 Right (ps,qs) -> return (map distrust ps ++ qs, vm)
544 where distrust p = p {trusted=False}
545
546 IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
547
548 selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
549 -> UnusablePackages
550 -> Either [(PackageConfig, UnusablePackageReason)]
551 ([PackageConfig], [PackageConfig])
552 selectPackages matches pkgs unusable
553 = let (ps,rest) = partition matches pkgs
554 in if null ps
555 then Left (filter (matches.fst) (Map.elems unusable))
556 else Right (sortByVersion ps, rest)
557
558 -- A package named on the command line can either include the
559 -- version, or just the name if it is unambiguous.
560 matchingStr :: String -> PackageConfig -> Bool
561 matchingStr str p
562 = str == sourcePackageIdString p
563 || str == packageNameString p
564
565 matchingId :: String -> PackageConfig -> Bool
566 matchingId str p = str == installedPackageIdString p
567
568 matchingKey :: String -> PackageConfig -> Bool
569 matchingKey str p = str == packageKeyString (packageConfigId p)
570
571 matching :: PackageArg -> PackageConfig -> Bool
572 matching (PackageArg str) = matchingStr str
573 matching (PackageIdArg str) = matchingId str
574 matching (PackageKeyArg str) = matchingKey str
575
576 sortByVersion :: [PackageConfig] -> [PackageConfig]
577 sortByVersion = sortBy (flip (comparing packageVersion))
578
579 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
580 comparing f a b = f a `compare` f b
581
582 packageFlagErr :: DynFlags
583 -> PackageFlag
584 -> [(PackageConfig, UnusablePackageReason)]
585 -> IO a
586
587 -- for missing DPH package we emit a more helpful error message, because
588 -- this may be the result of using -fdph-par or -fdph-seq.
589 packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
590 | is_dph_package pkg
591 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
592 where dph_err = text "the " <> text pkg <> text " package is not installed."
593 $$ text "To install it: \"cabal install dph\"."
594 is_dph_package pkg = "dph" `isPrefixOf` pkg
595
596 packageFlagErr dflags flag reasons
597 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
598 where err = text "cannot satisfy " <> pprFlag flag <>
599 (if null reasons then Outputable.empty else text ": ") $$
600 nest 4 (ppr_reasons $$
601 -- ToDo: this admonition seems a bit dodgy
602 text "(use -v for more information)")
603 ppr_reasons = vcat (map ppr_reason reasons)
604 ppr_reason (p, reason) =
605 pprReason (ppr (installedPackageId p) <+> text "is") reason
606
607 pprFlag :: PackageFlag -> SDoc
608 pprFlag flag = case flag of
609 IgnorePackage p -> text "-ignore-package " <> text p
610 HidePackage p -> text "-hide-package " <> text p
611 ExposePackage a rns -> ppr_arg a <> ppr_rns rns
612 TrustPackage p -> text "-trust " <> text p
613 DistrustPackage p -> text "-distrust " <> text p
614 where ppr_arg arg = case arg of
615 PackageArg p -> text "-package " <> text p
616 PackageIdArg p -> text "-package-id " <> text p
617 PackageKeyArg p -> text "-package-key " <> text p
618 ppr_rns (ModRenaming True []) = Outputable.empty
619 ppr_rns (ModRenaming b rns) =
620 if b then text "with" else Outputable.empty <+>
621 char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')'
622 ppr_rn (orig, new) | orig == new = ppr orig
623 | otherwise = ppr orig <+> text "as" <+> ppr new
624
625 -- -----------------------------------------------------------------------------
626 -- Wired-in packages
627
628 wired_in_pkgids :: [String]
629 wired_in_pkgids = map packageKeyString wiredInPackageKeys
630
631 findWiredInPackages
632 :: DynFlags
633 -> [PackageConfig] -- database
634 -> VisibilityMap -- info on what packages are visible
635 -> IO ([PackageConfig], VisibilityMap)
636
637 findWiredInPackages dflags pkgs vis_map = do
638 --
639 -- Now we must find our wired-in packages, and rename them to
640 -- their canonical names (eg. base-1.0 ==> base).
641 --
642 let
643 matches :: PackageConfig -> String -> Bool
644 pc `matches` pid = packageNameString pc == pid
645
646 -- find which package corresponds to each wired-in package
647 -- delete any other packages with the same name
648 -- update the package and any dependencies to point to the new
649 -- one.
650 --
651 -- When choosing which package to map to a wired-in package
652 -- name, we try to pick the latest version of exposed packages.
653 -- However, if there are no exposed wired in packages available
654 -- (e.g. -hide-all-packages was used), we can't bail: we *have*
655 -- to assign a package for the wired-in package: so we try again
656 -- with hidden packages included to (and pick the latest
657 -- version).
658 --
659 -- You can also override the default choice by using -ignore-package:
660 -- this works even when there is no exposed wired in package
661 -- available.
662 --
663 findWiredInPackage :: [PackageConfig] -> String
664 -> IO (Maybe PackageConfig)
665 findWiredInPackage pkgs wired_pkg =
666 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
667 all_exposed_ps =
668 [ p | p <- all_ps
669 , elemUFM (packageConfigId p) vis_map ] in
670 case all_exposed_ps of
671 [] -> case all_ps of
672 [] -> notfound
673 many -> pick (head (sortByVersion many))
674 many -> pick (head (sortByVersion many))
675 where
676 notfound = do
677 debugTraceMsg dflags 2 $
678 ptext (sLit "wired-in package ")
679 <> text wired_pkg
680 <> ptext (sLit " not found.")
681 return Nothing
682 pick :: PackageConfig
683 -> IO (Maybe PackageConfig)
684 pick pkg = do
685 debugTraceMsg dflags 2 $
686 ptext (sLit "wired-in package ")
687 <> text wired_pkg
688 <> ptext (sLit " mapped to ")
689 <> ppr (installedPackageId pkg)
690 return (Just pkg)
691
692
693 mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
694 let
695 wired_in_pkgs = catMaybes mb_wired_in_pkgs
696 wired_in_ids = map installedPackageId wired_in_pkgs
697
698 -- this is old: we used to assume that if there were
699 -- multiple versions of wired-in packages installed that
700 -- they were mutually exclusive. Now we're assuming that
701 -- you have one "main" version of each wired-in package
702 -- (the latest version), and the others are backward-compat
703 -- wrappers that depend on this one. e.g. base-4.0 is the
704 -- latest, base-3.0 is a compat wrapper depending on base-4.0.
705 {-
706 deleteOtherWiredInPackages pkgs = filterOut bad pkgs
707 where bad p = any (p `matches`) wired_in_pkgids
708 && package p `notElem` map fst wired_in_ids
709 -}
710
711 updateWiredInDependencies pkgs = map upd_pkg pkgs
712 where upd_pkg pkg
713 | installedPackageId pkg `elem` wired_in_ids
714 = pkg {
715 packageKey = stringToPackageKey (packageNameString pkg)
716 }
717 | otherwise
718 = pkg
719
720 updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
721 where f vm p = case lookupUFM vis_map (packageConfigId p) of
722 Nothing -> vm
723 Just r -> addToUFM vm (stringToPackageKey
724 (packageNameString p)) r
725
726
727 return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map)
728
729 -- ----------------------------------------------------------------------------
730
731 data UnusablePackageReason
732 = IgnoredWithFlag
733 | MissingDependencies [InstalledPackageId]
734 | ShadowedBy InstalledPackageId
735
736 type UnusablePackages = Map InstalledPackageId
737 (PackageConfig, UnusablePackageReason)
738
739 pprReason :: SDoc -> UnusablePackageReason -> SDoc
740 pprReason pref reason = case reason of
741 IgnoredWithFlag ->
742 pref <+> ptext (sLit "ignored due to an -ignore-package flag")
743 MissingDependencies deps ->
744 pref <+>
745 ptext (sLit "unusable due to missing or recursive dependencies:") $$
746 nest 2 (hsep (map ppr deps))
747 ShadowedBy ipid ->
748 pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
749
750 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
751 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
752 where
753 report (ipid, (_, reason)) =
754 debugTraceMsg dflags 2 $
755 pprReason
756 (ptext (sLit "package") <+>
757 ppr ipid <+> text "is") reason
758
759 -- ----------------------------------------------------------------------------
760 --
761 -- Detect any packages that have missing dependencies, and also any
762 -- mutually-recursive groups of packages (loops in the package graph
763 -- are not allowed). We do this by taking the least fixpoint of the
764 -- dependency graph, repeatedly adding packages whose dependencies are
765 -- satisfied until no more can be added.
766 --
767 findBroken :: [PackageConfig] -> UnusablePackages
768 findBroken pkgs = go [] Map.empty pkgs
769 where
770 go avail ipids not_avail =
771 case partitionWith (depsAvailable ipids) not_avail of
772 ([], not_avail) ->
773 Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
774 | (p,deps) <- not_avail ]
775 (new_avail, not_avail) ->
776 go (new_avail ++ avail) new_ipids (map fst not_avail)
777 where new_ipids = Map.insertList
778 [ (installedPackageId p, p) | p <- new_avail ]
779 ipids
780
781 depsAvailable :: InstalledPackageIndex
782 -> PackageConfig
783 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
784 depsAvailable ipids pkg
785 | null dangling = Left pkg
786 | otherwise = Right (pkg, dangling)
787 where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
788
789 -- -----------------------------------------------------------------------------
790 -- Eliminate shadowed packages, giving the user some feedback
791
792 -- later packages in the list should shadow earlier ones with the same
793 -- package name/version. Additionally, a package may be preferred if
794 -- it is in the transitive closure of packages selected using -package-id
795 -- flags.
796 type UnusablePackage = (PackageConfig, UnusablePackageReason)
797 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
798 shadowPackages pkgs preferred
799 = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
800 in Map.fromList shadowed
801 where
802 check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
803 -> PackageConfig
804 -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
805 check (shadowed,pkgmap) pkg
806 | Just oldpkg <- lookupUFM pkgmap pkgid
807 , let
808 ipid_new = installedPackageId pkg
809 ipid_old = installedPackageId oldpkg
810 --
811 , ipid_old /= ipid_new
812 = if ipid_old `elem` preferred
813 then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
814 else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
815 | otherwise
816 = (shadowed, pkgmap')
817 where
818 pkgid = packageKeyFS (packageKey pkg)
819 pkgmap' = addToUFM pkgmap pkgid pkg
820
821 -- -----------------------------------------------------------------------------
822
823 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
824 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
825 where
826 doit (IgnorePackage str) =
827 case partition (matchingStr str) pkgs of
828 (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
829 | p <- ps ]
830 -- missing package is not an error for -ignore-package,
831 -- because a common usage is to -ignore-package P as
832 -- a preventative measure just in case P exists.
833 doit _ = panic "ignorePackages"
834
835 -- -----------------------------------------------------------------------------
836
837 depClosure :: InstalledPackageIndex
838 -> [InstalledPackageId]
839 -> [InstalledPackageId]
840 depClosure index ipids = closure Map.empty ipids
841 where
842 closure set [] = Map.keys set
843 closure set (ipid : ipids)
844 | ipid `Map.member` set = closure set ipids
845 | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
846 (depends p ++ ipids)
847 | otherwise = closure set ipids
848
849 -- -----------------------------------------------------------------------------
850 -- When all the command-line options are in, we can process our package
851 -- settings and populate the package state.
852
853 mkPackageState
854 :: DynFlags
855 -> [PackageConfig] -- initial database
856 -> [PackageKey] -- preloaded packages
857 -> IO (PackageState,
858 [PackageKey], -- new packages to preload
859 PackageKey) -- this package, might be modified if the current
860 -- package is a wired-in package.
861
862 mkPackageState dflags0 pkgs0 preload0 = do
863 dflags <- interpretPackageEnv dflags0
864
865 -- Compute the package key
866 let this_package = thisPackage dflags
867
868 {-
869 Plan.
870
871 1. P = transitive closure of packages selected by -package-id
872
873 2. Apply shadowing. When there are multiple packages with the same
874 packageKey,
875 * if one is in P, use that one
876 * otherwise, use the one highest in the package stack
877 [
878 rationale: we cannot use two packages with the same packageKey
879 in the same program, because packageKey is the symbol prefix.
880 Hence we must select a consistent set of packages to use. We have
881 a default algorithm for doing this: packages higher in the stack
882 shadow those lower down. This default algorithm can be overriden
883 by giving explicit -package-id flags; then we have to take these
884 preferences into account when selecting which other packages are
885 made available.
886
887 Our simple algorithm throws away some solutions: there may be other
888 consistent sets that would satisfy the -package flags, but it's
889 not GHC's job to be doing constraint solving.
890 ]
891
892 3. remove packages selected by -ignore-package
893
894 4. remove any packages with missing dependencies, or mutually recursive
895 dependencies.
896
897 5. report (with -v) any packages that were removed by steps 2-4
898
899 6. apply flags to set exposed/hidden on the resulting packages
900 - if any flag refers to a package which was removed by 2-4, then
901 we can give an error message explaining why
902
903 7. hide any packages which are superseded by later exposed packages
904 -}
905
906 let
907 flags = reverse (packageFlags dflags)
908
909 -- pkgs0 with duplicate packages filtered out. This is
910 -- important: it is possible for a package in the global package
911 -- DB to have the same IPID as a package in the user DB, and
912 -- we want the latter to take precedence. This is not the same
913 -- as shadowing (below), since in this case the two packages
914 -- have the same ABI and are interchangeable.
915 --
916 -- #4072: note that we must retain the ordering of the list here
917 -- so that shadowing behaves as expected when we apply it later.
918 pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
919 where del p (s,ps)
920 | pid `Set.member` s = (s,ps)
921 | otherwise = (Set.insert pid s, p:ps)
922 where pid = installedPackageId p
923 -- XXX this is just a variant of nub
924
925 ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
926
927 ipid_selected = depClosure ipid_map
928 [ InstalledPackageId (mkFastString i)
929 | ExposePackage (PackageIdArg i) _ <- flags ]
930
931 (ignore_flags, other_flags) = partition is_ignore flags
932 is_ignore IgnorePackage{} = True
933 is_ignore _ = False
934
935 shadowed = shadowPackages pkgs0_unique ipid_selected
936 ignored = ignorePackages ignore_flags pkgs0_unique
937
938 isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
939 pkgs0' = filter (not . isBroken) pkgs0_unique
940
941 broken = findBroken pkgs0'
942
943 unusable = shadowed `Map.union` ignored `Map.union` broken
944 pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'
945
946 reportUnusable dflags unusable
947
948 --
949 -- Calculate the initial set of packages, prior to any package flags.
950 -- This set contains the latest version of all valid (not unusable) packages,
951 -- or is empty if we have -hide-all-packages
952 --
953 let preferLater pkg pkg' =
954 case comparing packageVersion pkg pkg' of
955 GT -> pkg
956 _ -> pkg'
957 calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
958 initial = if gopt Opt_HideAllPackages dflags
959 then emptyUFM
960 else foldl' calcInitial emptyUFM pkgs1
961 vis_map1 = foldUFM (\p vm ->
962 if exposed p
963 then addToUFM vm (packageConfigId p)
964 (True, [], fsPackageName p)
965 else vm)
966 emptyUFM initial
967
968 --
969 -- Modify the package database according to the command-line flags
970 -- (-package, -hide-package, -ignore-package, -hide-all-packages).
971 -- This needs to know about the unusable packages, since if a user tries
972 -- to enable an unusable package, we should let them know.
973 --
974 (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
975 (pkgs1, vis_map1) other_flags
976
977 --
978 -- Sort out which packages are wired in. This has to be done last, since
979 -- it modifies the package keys of wired in packages, but when we process
980 -- package arguments we need to key against the old versions. We also
981 -- have to update the visibility map in the process.
982 --
983 (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2
984
985 --
986 -- Here we build up a set of the packages mentioned in -package
987 -- flags on the command line; these are called the "preload"
988 -- packages. we link these packages in eagerly. The preload set
989 -- should contain at least rts & base, which is why we pretend that
990 -- the command line contains -package rts & -package base.
991 --
992 let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
993
994 get_exposed (ExposePackage a _) = take 1 . sortByVersion
995 . filter (matching a)
996 $ pkgs2
997 get_exposed _ = []
998
999 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
1000
1001 ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
1002 | p <- pkgs3 ]
1003
1004 lookupIPID ipid
1005 | Just pid <- Map.lookup ipid ipid_map = return pid
1006 | otherwise = missingPackageErr dflags ipid
1007
1008 preload2 <- mapM lookupIPID preload1
1009
1010 let
1011 -- add base & rts to the preload packages
1012 basicLinkedPackages
1013 | gopt Opt_AutoLinkPackages dflags
1014 = filter (flip elemUFM pkg_db)
1015 [basePackageKey, rtsPackageKey]
1016 | otherwise = []
1017 -- but in any case remove the current package from the set of
1018 -- preloaded packages so that base/rts does not end up in the
1019 -- set up preloaded package when we are just building it
1020 preload3 = nub $ filter (/= this_package)
1021 $ (basicLinkedPackages ++ preload2)
1022
1023 -- Close the preload packages with their dependencies
1024 dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
1025 let new_dep_preload = filter (`notElem` preload0) dep_preload
1026
1027 let pstate = PackageState{
1028 preloadPackages = dep_preload,
1029 pkgIdMap = pkg_db,
1030 moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
1031 installedPackageIdMap = ipid_map
1032 }
1033 return (pstate, new_dep_preload, this_package)
1034
1035
1036 -- -----------------------------------------------------------------------------
1037 -- | Makes the mapping from module to package info
1038
1039 mkModuleToPkgConfAll
1040 :: DynFlags
1041 -> PackageConfigMap
1042 -> InstalledPackageIdMap
1043 -> VisibilityMap
1044 -> ModuleToPkgConfAll
1045 mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
1046 foldl' extend_modmap emptyMap (eltsUFM pkg_db)
1047 where
1048 emptyMap = Map.empty
1049 sing pk m _ = Map.singleton (mkModule pk m)
1050 addListTo = foldl' merge
1051 merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
1052 setOrigins m os = fmap (const os) m
1053 extend_modmap modmap pkg = addListTo modmap theBindings
1054 where
1055 theBindings :: [(ModuleName, Map Module ModuleOrigin)]
1056 theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
1057 = newBindings b rns
1058 | otherwise = newBindings False []
1059
1060 newBindings :: Bool
1061 -> [(ModuleName, ModuleName)]
1062 -> [(ModuleName, Map Module ModuleOrigin)]
1063 newBindings e rns = es e ++ hiddens ++ map rnBinding rns
1064
1065 rnBinding :: (ModuleName, ModuleName)
1066 -> (ModuleName, Map Module ModuleOrigin)
1067 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1068 where origEntry = case lookupUFM esmap orig of
1069 Just r -> r
1070 Nothing -> throwGhcException (CmdLineError (showSDoc dflags
1071 (text "package flag: could not find module name" <+>
1072 ppr orig <+> text "in package" <+> ppr pk)))
1073
1074 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
1075 es e = do
1076 -- TODO: signature support
1077 ExposedModule m exposedReexport _exposedSignature <- exposed_mods
1078 let (pk', m', pkg', origin') =
1079 case exposedReexport of
1080 Nothing -> (pk, m, pkg, fromExposedModules e)
1081 Just (OriginalModule ipid' m') ->
1082 let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
1083 pkg' = pkg_lookup pk'
1084 in (pk', m', pkg', fromReexportedModules e pkg')
1085 return (m, sing pk' m' pkg' origin')
1086
1087 esmap :: UniqFM (Map Module ModuleOrigin)
1088 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1089 -- be overwritten
1090
1091 hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
1092
1093 pk = packageConfigId pkg
1094 pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
1095
1096 exposed_mods = exposedModules pkg
1097 hidden_mods = hiddenModules pkg
1098
1099 -- -----------------------------------------------------------------------------
1100 -- Extracting information from the packages in scope
1101
1102 -- Many of these functions take a list of packages: in those cases,
1103 -- the list is expected to contain the "dependent packages",
1104 -- i.e. those packages that were found to be depended on by the
1105 -- current module/program. These can be auto or non-auto packages, it
1106 -- doesn't really matter. The list is always combined with the list
1107 -- of preload (command-line) packages to determine which packages to
1108 -- use.
1109
1110 -- | Find all the include directories in these and the preload packages
1111 getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String]
1112 getPackageIncludePath dflags pkgs =
1113 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1114
1115 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1116 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1117
1118 -- | Find all the library paths in these and the preload packages
1119 getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String]
1120 getPackageLibraryPath dflags pkgs =
1121 collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
1122
1123 collectLibraryPaths :: [PackageConfig] -> [FilePath]
1124 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
1125
1126 -- | Find all the link options in these and the preload packages,
1127 -- returning (package hs lib options, extra library options, other flags)
1128 getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String])
1129 getPackageLinkOpts dflags pkgs =
1130 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1131
1132 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1133 collectLinkOpts dflags ps =
1134 (
1135 concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1136 concatMap (map ("-l" ++) . extraLibraries) ps,
1137 concatMap ldOptions ps
1138 )
1139
1140 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1141 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1142 where
1143 ways0 = ways dflags
1144
1145 ways1 = filter (/= WayDyn) ways0
1146 -- the name of a shared library is libHSfoo-ghc<version>.so
1147 -- we leave out the _dyn, because it is superfluous
1148
1149 -- debug RTS includes support for -eventlog
1150 ways2 | WayDebug `elem` ways1
1151 = filter (/= WayEventLog) ways1
1152 | otherwise
1153 = ways1
1154
1155 tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
1156 rts_tag = mkBuildTag ways2
1157
1158 mkDynName x
1159 | gopt Opt_Static dflags = x
1160 | "HS" `isPrefixOf` x =
1161 x ++ '-':programName dflags ++ projectVersion dflags
1162 -- For non-Haskell libraries, we use the name "Cfoo". The .a
1163 -- file is libCfoo.a, and the .so is libfoo.so. That way the
1164 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1165 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1166 | Just x' <- stripPrefix "C" x = x'
1167 | otherwise
1168 = panic ("Don't understand library name " ++ x)
1169
1170 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
1171 addSuffix other_lib = other_lib ++ (expandTag tag)
1172
1173 expandTag t | null t = ""
1174 | otherwise = '_':t
1175
1176 -- | Find all the C-compiler options in these and the preload packages
1177 getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String]
1178 getPackageExtraCcOpts dflags pkgs = do
1179 ps <- getPreloadPackagesAnd dflags pkgs
1180 return (concatMap ccOptions ps)
1181
1182 -- | Find all the package framework paths in these and the preload packages
1183 getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String]
1184 getPackageFrameworkPath dflags pkgs = do
1185 ps <- getPreloadPackagesAnd dflags pkgs
1186 return (nub (filter notNull (concatMap frameworkDirs ps)))
1187
1188 -- | Find all the package frameworks in these and the preload packages
1189 getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String]
1190 getPackageFrameworks dflags pkgs = do
1191 ps <- getPreloadPackagesAnd dflags pkgs
1192 return (concatMap frameworks ps)
1193
1194 -- -----------------------------------------------------------------------------
1195 -- Package Utils
1196
1197 -- | Takes a 'ModuleName', and if the module is in any package returns
1198 -- list of modules which take that name.
1199 lookupModuleInAllPackages :: DynFlags
1200 -> ModuleName
1201 -> [(Module, PackageConfig)]
1202 lookupModuleInAllPackages dflags m
1203 = case lookupModuleWithSuggestions dflags m Nothing of
1204 LookupFound a b -> [(a,b)]
1205 LookupMultiple rs -> map f rs
1206 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1207 (modulePackageKey m)))
1208 _ -> []
1209
1210 -- | The result of performing a lookup
1211 data LookupResult =
1212 -- | Found the module uniquely, nothing else to do
1213 LookupFound Module PackageConfig
1214 -- | Multiple modules with the same name in scope
1215 | LookupMultiple [(Module, ModuleOrigin)]
1216 -- | No modules found, but there were some hidden ones with
1217 -- an exact name match. First is due to package hidden, second
1218 -- is due to module being hidden
1219 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1220 -- | Nothing found, here are some suggested different names
1221 | LookupNotFound [ModuleSuggestion] -- suggestions
1222
1223 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1224 | SuggestHidden ModuleName Module ModuleOrigin
1225
1226 lookupModuleWithSuggestions :: DynFlags
1227 -> ModuleName
1228 -> Maybe FastString
1229 -> LookupResult
1230 lookupModuleWithSuggestions dflags m mb_pn
1231 = case Map.lookup m (moduleToPkgConfAll pkg_state) of
1232 Nothing -> LookupNotFound suggestions
1233 Just xs ->
1234 case foldl' classify ([],[],[]) (Map.toList xs) of
1235 ([], [], []) -> LookupNotFound suggestions
1236 (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
1237 (_, _, exposed@(_:_)) -> LookupMultiple exposed
1238 (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
1239 where
1240 classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
1241 let origin = filterOrigin mb_pn (mod_pkg m) origin0
1242 x = (m, origin)
1243 in case origin of
1244 ModHidden -> (hidden_pkg, x:hidden_mod, exposed)
1245 _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed)
1246 | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
1247 | otherwise -> (x:hidden_pkg, hidden_mod, exposed)
1248
1249 pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
1250 pkg_state = pkgState dflags
1251 mod_pkg = pkg_lookup . modulePackageKey
1252
1253 -- Filters out origins which are not associated with the given package
1254 -- qualifier. No-op if there is no package qualifier. Test if this
1255 -- excluded all origins with 'originEmpty'.
1256 filterOrigin :: Maybe FastString
1257 -> PackageConfig
1258 -> ModuleOrigin
1259 -> ModuleOrigin
1260 filterOrigin Nothing _ o = o
1261 filterOrigin (Just pn) pkg o =
1262 case o of
1263 ModHidden -> if go pkg then ModHidden else mempty
1264 ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1265 fromHiddenReexport = rhs }
1266 -> ModOrigin {
1267 fromOrigPackage = if go pkg then e else Nothing
1268 , fromExposedReexport = filter go res
1269 , fromHiddenReexport = filter go rhs
1270 , fromPackageFlag = False -- always excluded
1271 }
1272 where go pkg = pn == fsPackageName pkg
1273
1274 suggestions
1275 | gopt Opt_HelpfulErrors dflags =
1276 fuzzyLookup (moduleNameString m) all_mods
1277 | otherwise = []
1278
1279 all_mods :: [(String, ModuleSuggestion)] -- All modules
1280 all_mods = sortBy (comparing fst) $
1281 [ (moduleNameString m, suggestion)
1282 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1283 , suggestion <- map (getSuggestion m) (Map.toList e)
1284 ]
1285 getSuggestion name (mod, origin) =
1286 (if originVisible origin then SuggestVisible else SuggestHidden)
1287 name mod origin
1288
1289 listVisibleModuleNames :: DynFlags -> [ModuleName]
1290 listVisibleModuleNames dflags =
1291 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1292 where visible (_, ms) = any originVisible (Map.elems ms)
1293
1294 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1295 -- 'PackageConfig's
1296 getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig]
1297 getPreloadPackagesAnd dflags pkgids =
1298 let
1299 state = pkgState dflags
1300 pkg_map = pkgIdMap state
1301 ipid_map = installedPackageIdMap state
1302 preload = preloadPackages state
1303 pairs = zip pkgids (repeat Nothing)
1304 in do
1305 all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
1306 return (map (getPackageDetails dflags) all_pkgs)
1307
1308 -- Takes a list of packages, and returns the list with dependencies included,
1309 -- in reverse dependency order (a package appears before those it depends on).
1310 closeDeps :: DynFlags
1311 -> PackageConfigMap
1312 -> Map InstalledPackageId PackageKey
1313 -> [(PackageKey, Maybe PackageKey)]
1314 -> IO [PackageKey]
1315 closeDeps dflags pkg_map ipid_map ps
1316 = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
1317
1318 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
1319 throwErr dflags m
1320 = case m of
1321 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
1322 Succeeded r -> return r
1323
1324 closeDepsErr :: PackageConfigMap
1325 -> Map InstalledPackageId PackageKey
1326 -> [(PackageKey,Maybe PackageKey)]
1327 -> MaybeErr MsgDoc [PackageKey]
1328 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
1329
1330 -- internal helper
1331 add_package :: PackageConfigMap
1332 -> Map InstalledPackageId PackageKey
1333 -> [PackageKey]
1334 -> (PackageKey,Maybe PackageKey)
1335 -> MaybeErr MsgDoc [PackageKey]
1336 add_package pkg_db ipid_map ps (p, mb_parent)
1337 | p `elem` ps = return ps -- Check if we've already added this package
1338 | otherwise =
1339 case lookupPackage' pkg_db p of
1340 Nothing -> Failed (missingPackageMsg p <>
1341 missingDependencyMsg mb_parent)
1342 Just pkg -> do
1343 -- Add the package's dependents also
1344 ps' <- foldM add_package_ipid ps (depends pkg)
1345 return (p : ps')
1346 where
1347 add_package_ipid ps ipid
1348 | Just pid <- Map.lookup ipid ipid_map
1349 = add_package pkg_db ipid_map ps (pid, Just p)
1350 | otherwise
1351 = Failed (missingPackageMsg ipid
1352 <> missingDependencyMsg mb_parent)
1353
1354 missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a
1355 missingPackageErr dflags p
1356 = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
1357
1358 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
1359 missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
1360
1361 missingDependencyMsg :: Maybe PackageKey -> SDoc
1362 missingDependencyMsg Nothing = Outputable.empty
1363 missingDependencyMsg (Just parent)
1364 = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
1365
1366 -- -----------------------------------------------------------------------------
1367
1368 packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String
1369 packageKeyPackageIdString dflags pkg_key
1370 | pkg_key == mainPackageKey = Just "main"
1371 | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
1372
1373 -- | Will the 'Name' come from a dynamically linked library?
1374 isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
1375 -- Despite the "dll", I think this function just means that
1376 -- the synbol comes from another dynamically-linked package,
1377 -- and applies on all platforms, not just Windows
1378 isDllName dflags _this_pkg this_mod name
1379 | gopt Opt_Static dflags = False
1380 | Just mod <- nameModule_maybe name
1381 -- Issue #8696 - when GHC is dynamically linked, it will attempt
1382 -- to load the dynamic dependencies of object files at compile
1383 -- time for things like QuasiQuotes or
1384 -- TemplateHaskell. Unfortunately, this interacts badly with
1385 -- intra-package linking, because we don't generate indirect
1386 -- (dynamic) symbols for intra-package calls. This means that if a
1387 -- module with an intra-package call is loaded without its
1388 -- dependencies, then GHC fails to link. This is the cause of #
1389 --
1390 -- In the mean time, always force dynamic indirections to be
1391 -- generated: when the module name isn't the module being
1392 -- compiled, references are dynamic.
1393 = if mod /= this_mod
1394 then True
1395 else case dllSplit dflags of
1396 Nothing -> False
1397 Just ss ->
1398 let findMod m = let modStr = moduleNameString (moduleName m)
1399 in case find (modStr `Set.member`) ss of
1400 Just i -> i
1401 Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
1402 in findMod mod /= findMod this_mod
1403
1404 | otherwise = False -- no, it is not even an external name
1405
1406 -- -----------------------------------------------------------------------------
1407 -- Displaying packages
1408
1409 -- | Show (very verbose) package info
1410 pprPackages :: DynFlags -> SDoc
1411 pprPackages = pprPackagesWith pprPackageConfig
1412
1413 pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
1414 pprPackagesWith pprIPI dflags =
1415 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
1416
1417 -- | Show simplified package info.
1418 --
1419 -- The idea is to only print package id, and any information that might
1420 -- be different from the package databases (exposure, trust)
1421 pprPackagesSimple :: DynFlags -> SDoc
1422 pprPackagesSimple = pprPackagesWith pprIPI
1423 where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi
1424 e = if exposed ipi then text "E" else text " "
1425 t = if trusted ipi then text "T" else text " "
1426 in e <> t <> text " " <> ftext i
1427
1428 -- | Show the mapping of modules to where they come from.
1429 pprModuleMap :: DynFlags -> SDoc
1430 pprModuleMap dflags =
1431 vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1432 where
1433 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
1434 pprEntry m (m',o)
1435 | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o)
1436 | otherwise = ppr m' <+> parens (ppr o)
1437
1438 fsPackageName :: PackageConfig -> FastString
1439 fsPackageName = mkFastString . packageNameString