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