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