cf181046f0e4586912e1f59d1e6046ee762f34f3
[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 == componentIdString p
606
607 matchingKey :: String -> PackageConfig -> Bool
608 matchingKey str p = str == unitIdString (packageConfigId p)
609
610 matching :: PackageArg -> PackageConfig -> Bool
611 matching (PackageArg str) = matchingStr str
612 matching (PackageIdArg str) = matchingId str
613 matching (UnitIdArg str) = matchingKey str
614
615 sortByVersion :: [PackageConfig] -> [PackageConfig]
616 sortByVersion = sortBy (flip (comparing packageVersion))
617
618 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
619 comparing f a b = f a `compare` f b
620
621 packageFlagErr :: DynFlags
622 -> PackageFlag
623 -> [(PackageConfig, UnusablePackageReason)]
624 -> IO a
625
626 -- for missing DPH package we emit a more helpful error message, because
627 -- this may be the result of using -fdph-par or -fdph-seq.
628 packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
629 | is_dph_package pkg
630 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
631 where dph_err = text "the " <> text pkg <> text " package is not installed."
632 $$ text "To install it: \"cabal install dph\"."
633 is_dph_package pkg = "dph" `isPrefixOf` pkg
634 packageFlagErr dflags flag reasons
635 = packageFlagErr' dflags (pprFlag flag) reasons
636
637 trustFlagErr :: DynFlags
638 -> TrustFlag
639 -> [(PackageConfig, UnusablePackageReason)]
640 -> IO a
641 trustFlagErr dflags flag reasons
642 = packageFlagErr' dflags (pprTrustFlag flag) reasons
643
644 packageFlagErr' :: DynFlags
645 -> SDoc
646 -> [(PackageConfig, UnusablePackageReason)]
647 -> IO a
648 packageFlagErr' dflags flag_doc reasons
649 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
650 where err = text "cannot satisfy " <> flag_doc <>
651 (if null reasons then Outputable.empty else text ": ") $$
652 nest 4 (ppr_reasons $$
653 text "(use -v for more information)")
654 ppr_reasons = vcat (map ppr_reason reasons)
655 ppr_reason (p, reason) =
656 pprReason (ppr (unitId p) <+> text "is") reason
657
658 pprFlag :: PackageFlag -> SDoc
659 pprFlag flag = case flag of
660 HidePackage p -> text "-hide-package " <> text p
661 ExposePackage doc _ _ -> text doc
662
663 pprTrustFlag :: TrustFlag -> SDoc
664 pprTrustFlag flag = case flag of
665 TrustPackage p -> text "-trust " <> text p
666 DistrustPackage p -> text "-distrust " <> text p
667
668 -- -----------------------------------------------------------------------------
669 -- Wired-in packages
670
671 wired_in_pkgids :: [String]
672 wired_in_pkgids = map unitIdString wiredInUnitIds
673
674 type WiredPackagesMap = Map UnitId UnitId
675
676 findWiredInPackages
677 :: DynFlags
678 -> [PackageConfig] -- database
679 -> VisibilityMap -- info on what packages are visible
680 -- for wired in selection
681 -> IO ([PackageConfig], -- package database updated for wired in
682 WiredPackagesMap) -- map from unit id to wired identity
683
684 findWiredInPackages dflags pkgs vis_map = do
685 --
686 -- Now we must find our wired-in packages, and rename them to
687 -- their canonical names (eg. base-1.0 ==> base).
688 --
689 let
690 matches :: PackageConfig -> String -> Bool
691 pc `matches` pid = packageNameString pc == pid
692
693 -- find which package corresponds to each wired-in package
694 -- delete any other packages with the same name
695 -- update the package and any dependencies to point to the new
696 -- one.
697 --
698 -- When choosing which package to map to a wired-in package
699 -- name, we try to pick the latest version of exposed packages.
700 -- However, if there are no exposed wired in packages available
701 -- (e.g. -hide-all-packages was used), we can't bail: we *have*
702 -- to assign a package for the wired-in package: so we try again
703 -- with hidden packages included to (and pick the latest
704 -- version).
705 --
706 -- You can also override the default choice by using -ignore-package:
707 -- this works even when there is no exposed wired in package
708 -- available.
709 --
710 findWiredInPackage :: [PackageConfig] -> String
711 -> IO (Maybe PackageConfig)
712 findWiredInPackage pkgs wired_pkg =
713 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
714 all_exposed_ps =
715 [ p | p <- all_ps
716 , elemUFM (packageConfigId p) vis_map ] in
717 case all_exposed_ps of
718 [] -> case all_ps of
719 [] -> notfound
720 many -> pick (head (sortByVersion many))
721 many -> pick (head (sortByVersion many))
722 where
723 notfound = do
724 debugTraceMsg dflags 2 $
725 text "wired-in package "
726 <> text wired_pkg
727 <> text " not found."
728 return Nothing
729 pick :: PackageConfig
730 -> IO (Maybe PackageConfig)
731 pick pkg = do
732 debugTraceMsg dflags 2 $
733 text "wired-in package "
734 <> text wired_pkg
735 <> text " mapped to "
736 <> ppr (unitId pkg)
737 return (Just pkg)
738
739
740 mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
741 let
742 wired_in_pkgs = catMaybes mb_wired_in_pkgs
743 wired_in_ids = map unitId wired_in_pkgs
744
745 -- this is old: we used to assume that if there were
746 -- multiple versions of wired-in packages installed that
747 -- they were mutually exclusive. Now we're assuming that
748 -- you have one "main" version of each wired-in package
749 -- (the latest version), and the others are backward-compat
750 -- wrappers that depend on this one. e.g. base-4.0 is the
751 -- latest, base-3.0 is a compat wrapper depending on base-4.0.
752 {-
753 deleteOtherWiredInPackages pkgs = filterOut bad pkgs
754 where bad p = any (p `matches`) wired_in_pkgids
755 && package p `notElem` map fst wired_in_ids
756 -}
757
758 wiredInMap :: Map UnitId UnitId
759 wiredInMap = foldl' add_mapping Map.empty pkgs
760 where add_mapping m pkg
761 | let key = unitId pkg
762 , key `elem` wired_in_ids
763 = Map.insert key (stringToUnitId (packageNameString pkg)) m
764 | otherwise = m
765
766 updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
767 where upd_pkg pkg
768 | unitId pkg `elem` wired_in_ids
769 = pkg {
770 unitId = stringToUnitId (packageNameString pkg)
771 }
772 | otherwise
773 = pkg
774 upd_deps pkg = pkg {
775 depends = map upd_wired_in (depends pkg)
776 }
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 -- TODO: signature support
1163 ExposedModule m exposedReexport _exposedSignature <- exposed_mods
1164 let (pk', m', pkg', origin') =
1165 case exposedReexport of
1166 Nothing -> (pk, m, pkg, fromExposedModules e)
1167 Just (OriginalModule pk' m') ->
1168 let pkg' = pkg_lookup pk'
1169 in (pk', m', pkg', fromReexportedModules e pkg')
1170 return (m, sing pk' m' pkg' origin')
1171
1172 esmap :: UniqFM (Map Module ModuleOrigin)
1173 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1174 -- be overwritten
1175
1176 hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
1177
1178 pk = packageConfigId pkg
1179 pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
1180
1181 exposed_mods = exposedModules pkg
1182 hidden_mods = hiddenModules pkg
1183
1184 -- -----------------------------------------------------------------------------
1185 -- Extracting information from the packages in scope
1186
1187 -- Many of these functions take a list of packages: in those cases,
1188 -- the list is expected to contain the "dependent packages",
1189 -- i.e. those packages that were found to be depended on by the
1190 -- current module/program. These can be auto or non-auto packages, it
1191 -- doesn't really matter. The list is always combined with the list
1192 -- of preload (command-line) packages to determine which packages to
1193 -- use.
1194
1195 -- | Find all the include directories in these and the preload packages
1196 getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String]
1197 getPackageIncludePath dflags pkgs =
1198 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1199
1200 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1201 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1202
1203 -- | Find all the library paths in these and the preload packages
1204 getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String]
1205 getPackageLibraryPath dflags pkgs =
1206 collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
1207
1208 collectLibraryPaths :: [PackageConfig] -> [FilePath]
1209 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
1210
1211 -- | Find all the link options in these and the preload packages,
1212 -- returning (package hs lib options, extra library options, other flags)
1213 getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
1214 getPackageLinkOpts dflags pkgs =
1215 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1216
1217 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1218 collectLinkOpts dflags ps =
1219 (
1220 concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1221 concatMap (map ("-l" ++) . extraLibraries) ps,
1222 concatMap ldOptions ps
1223 )
1224
1225 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1226 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1227 where
1228 ways0 = ways dflags
1229
1230 ways1 = filter (/= WayDyn) ways0
1231 -- the name of a shared library is libHSfoo-ghc<version>.so
1232 -- we leave out the _dyn, because it is superfluous
1233
1234 -- debug RTS includes support for -eventlog
1235 ways2 | WayDebug `elem` ways1
1236 = filter (/= WayEventLog) ways1
1237 | otherwise
1238 = ways1
1239
1240 tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
1241 rts_tag = mkBuildTag ways2
1242
1243 mkDynName x
1244 | WayDyn `notElem` ways dflags = x
1245 | "HS" `isPrefixOf` x =
1246 x ++ '-':programName dflags ++ projectVersion dflags
1247 -- For non-Haskell libraries, we use the name "Cfoo". The .a
1248 -- file is libCfoo.a, and the .so is libfoo.so. That way the
1249 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1250 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1251 | Just x' <- stripPrefix "C" x = x'
1252 | otherwise
1253 = panic ("Don't understand library name " ++ x)
1254
1255 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
1256 addSuffix other_lib = other_lib ++ (expandTag tag)
1257
1258 expandTag t | null t = ""
1259 | otherwise = '_':t
1260
1261 -- | Find all the C-compiler options in these and the preload packages
1262 getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
1263 getPackageExtraCcOpts dflags pkgs = do
1264 ps <- getPreloadPackagesAnd dflags pkgs
1265 return (concatMap ccOptions ps)
1266
1267 -- | Find all the package framework paths in these and the preload packages
1268 getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
1269 getPackageFrameworkPath dflags pkgs = do
1270 ps <- getPreloadPackagesAnd dflags pkgs
1271 return (nub (filter notNull (concatMap frameworkDirs ps)))
1272
1273 -- | Find all the package frameworks in these and the preload packages
1274 getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String]
1275 getPackageFrameworks dflags pkgs = do
1276 ps <- getPreloadPackagesAnd dflags pkgs
1277 return (concatMap frameworks ps)
1278
1279 -- -----------------------------------------------------------------------------
1280 -- Package Utils
1281
1282 -- | Takes a 'ModuleName', and if the module is in any package returns
1283 -- list of modules which take that name.
1284 lookupModuleInAllPackages :: DynFlags
1285 -> ModuleName
1286 -> [(Module, PackageConfig)]
1287 lookupModuleInAllPackages dflags m
1288 = case lookupModuleWithSuggestions dflags m Nothing of
1289 LookupFound a b -> [(a,b)]
1290 LookupMultiple rs -> map f rs
1291 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1292 (moduleUnitId m)))
1293 _ -> []
1294
1295 -- | The result of performing a lookup
1296 data LookupResult =
1297 -- | Found the module uniquely, nothing else to do
1298 LookupFound Module PackageConfig
1299 -- | Multiple modules with the same name in scope
1300 | LookupMultiple [(Module, ModuleOrigin)]
1301 -- | No modules found, but there were some hidden ones with
1302 -- an exact name match. First is due to package hidden, second
1303 -- is due to module being hidden
1304 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1305 -- | Nothing found, here are some suggested different names
1306 | LookupNotFound [ModuleSuggestion] -- suggestions
1307
1308 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1309 | SuggestHidden ModuleName Module ModuleOrigin
1310
1311 lookupModuleWithSuggestions :: DynFlags
1312 -> ModuleName
1313 -> Maybe FastString
1314 -> LookupResult
1315 lookupModuleWithSuggestions dflags
1316 = lookupModuleWithSuggestions' dflags
1317 (moduleToPkgConfAll (pkgState dflags))
1318
1319 lookupPluginModuleWithSuggestions :: DynFlags
1320 -> ModuleName
1321 -> Maybe FastString
1322 -> LookupResult
1323 lookupPluginModuleWithSuggestions dflags
1324 = lookupModuleWithSuggestions' dflags
1325 (pluginModuleToPkgConfAll (pkgState dflags))
1326
1327 lookupModuleWithSuggestions' :: DynFlags
1328 -> ModuleToPkgConfAll
1329 -> ModuleName
1330 -> Maybe FastString
1331 -> LookupResult
1332 lookupModuleWithSuggestions' dflags mod_map m mb_pn
1333 = case Map.lookup m mod_map of
1334 Nothing -> LookupNotFound suggestions
1335 Just xs ->
1336 case foldl' classify ([],[],[]) (Map.toList xs) of
1337 ([], [], []) -> LookupNotFound suggestions
1338 (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
1339 (_, _, exposed@(_:_)) -> LookupMultiple exposed
1340 (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
1341 where
1342 classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
1343 let origin = filterOrigin mb_pn (mod_pkg m) origin0
1344 x = (m, origin)
1345 in case origin of
1346 ModHidden -> (hidden_pkg, x:hidden_mod, exposed)
1347 _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed)
1348 | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
1349 | otherwise -> (x:hidden_pkg, hidden_mod, exposed)
1350
1351 pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
1352 mod_pkg = pkg_lookup . moduleUnitId
1353
1354 -- Filters out origins which are not associated with the given package
1355 -- qualifier. No-op if there is no package qualifier. Test if this
1356 -- excluded all origins with 'originEmpty'.
1357 filterOrigin :: Maybe FastString
1358 -> PackageConfig
1359 -> ModuleOrigin
1360 -> ModuleOrigin
1361 filterOrigin Nothing _ o = o
1362 filterOrigin (Just pn) pkg o =
1363 case o of
1364 ModHidden -> if go pkg then ModHidden else mempty
1365 ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1366 fromHiddenReexport = rhs }
1367 -> ModOrigin {
1368 fromOrigPackage = if go pkg then e else Nothing
1369 , fromExposedReexport = filter go res
1370 , fromHiddenReexport = filter go rhs
1371 , fromPackageFlag = False -- always excluded
1372 }
1373 where go pkg = pn == fsPackageName pkg
1374
1375 suggestions
1376 | gopt Opt_HelpfulErrors dflags =
1377 fuzzyLookup (moduleNameString m) all_mods
1378 | otherwise = []
1379
1380 all_mods :: [(String, ModuleSuggestion)] -- All modules
1381 all_mods = sortBy (comparing fst) $
1382 [ (moduleNameString m, suggestion)
1383 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1384 , suggestion <- map (getSuggestion m) (Map.toList e)
1385 ]
1386 getSuggestion name (mod, origin) =
1387 (if originVisible origin then SuggestVisible else SuggestHidden)
1388 name mod origin
1389
1390 listVisibleModuleNames :: DynFlags -> [ModuleName]
1391 listVisibleModuleNames dflags =
1392 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1393 where visible (_, ms) = any originVisible (Map.elems ms)
1394
1395 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1396 -- 'PackageConfig's
1397 getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig]
1398 getPreloadPackagesAnd dflags pkgids =
1399 let
1400 state = pkgState dflags
1401 pkg_map = pkgIdMap state
1402 preload = preloadPackages state
1403 pairs = zip pkgids (repeat Nothing)
1404 in do
1405 all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
1406 return (map (getPackageDetails dflags) all_pkgs)
1407
1408 -- Takes a list of packages, and returns the list with dependencies included,
1409 -- in reverse dependency order (a package appears before those it depends on).
1410 closeDeps :: DynFlags
1411 -> PackageConfigMap
1412 -> [(UnitId, Maybe UnitId)]
1413 -> IO [UnitId]
1414 closeDeps dflags pkg_map ps
1415 = throwErr dflags (closeDepsErr pkg_map ps)
1416
1417 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
1418 throwErr dflags m
1419 = case m of
1420 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
1421 Succeeded r -> return r
1422
1423 closeDepsErr :: PackageConfigMap
1424 -> [(UnitId,Maybe UnitId)]
1425 -> MaybeErr MsgDoc [UnitId]
1426 closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
1427
1428 -- internal helper
1429 add_package :: PackageConfigMap
1430 -> [UnitId]
1431 -> (UnitId,Maybe UnitId)
1432 -> MaybeErr MsgDoc [UnitId]
1433 add_package pkg_db ps (p, mb_parent)
1434 | p `elem` ps = return ps -- Check if we've already added this package
1435 | otherwise =
1436 case lookupPackage' pkg_db p of
1437 Nothing -> Failed (missingPackageMsg p <>
1438 missingDependencyMsg mb_parent)
1439 Just pkg -> do
1440 -- Add the package's dependents also
1441 ps' <- foldM add_unit_key ps (depends pkg)
1442 return (p : ps')
1443 where
1444 add_unit_key ps key
1445 = add_package pkg_db ps (key, Just p)
1446
1447 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
1448 missingPackageMsg p = text "unknown package:" <+> ppr p
1449
1450 missingDependencyMsg :: Maybe UnitId -> SDoc
1451 missingDependencyMsg Nothing = Outputable.empty
1452 missingDependencyMsg (Just parent)
1453 = space <> parens (text "dependency of" <+> ftext (unitIdFS parent))
1454
1455 -- -----------------------------------------------------------------------------
1456
1457 unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
1458 unitIdPackageIdString dflags pkg_key
1459 | pkg_key == mainUnitId = Just "main"
1460 | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
1461
1462 -- | Will the 'Name' come from a dynamically linked library?
1463 isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
1464 -- Despite the "dll", I think this function just means that
1465 -- the symbol comes from another dynamically-linked package,
1466 -- and applies on all platforms, not just Windows
1467 isDllName dflags _this_pkg this_mod name
1468 | WayDyn `notElem` ways dflags = False
1469 | Just mod <- nameModule_maybe name
1470 -- Issue #8696 - when GHC is dynamically linked, it will attempt
1471 -- to load the dynamic dependencies of object files at compile
1472 -- time for things like QuasiQuotes or
1473 -- TemplateHaskell. Unfortunately, this interacts badly with
1474 -- intra-package linking, because we don't generate indirect
1475 -- (dynamic) symbols for intra-package calls. This means that if a
1476 -- module with an intra-package call is loaded without its
1477 -- dependencies, then GHC fails to link. This is the cause of #
1478 --
1479 -- In the mean time, always force dynamic indirections to be
1480 -- generated: when the module name isn't the module being
1481 -- compiled, references are dynamic.
1482 = if mod /= this_mod
1483 then True
1484 else case dllSplit dflags of
1485 Nothing -> False
1486 Just ss ->
1487 let findMod m = let modStr = moduleNameString (moduleName m)
1488 in case find (modStr `Set.member`) ss of
1489 Just i -> i
1490 Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
1491 in findMod mod /= findMod this_mod
1492
1493 | otherwise = False -- no, it is not even an external name
1494
1495 -- -----------------------------------------------------------------------------
1496 -- Displaying packages
1497
1498 -- | Show (very verbose) package info
1499 pprPackages :: DynFlags -> SDoc
1500 pprPackages = pprPackagesWith pprPackageConfig
1501
1502 pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
1503 pprPackagesWith pprIPI dflags =
1504 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
1505
1506 -- | Show simplified package info.
1507 --
1508 -- The idea is to only print package id, and any information that might
1509 -- be different from the package databases (exposure, trust)
1510 pprPackagesSimple :: DynFlags -> SDoc
1511 pprPackagesSimple = pprPackagesWith pprIPI
1512 where pprIPI ipi = let i = unitIdFS (unitId ipi)
1513 e = if exposed ipi then text "E" else text " "
1514 t = if trusted ipi then text "T" else text " "
1515 in e <> t <> text " " <> ftext i
1516
1517 -- | Show the mapping of modules to where they come from.
1518 pprModuleMap :: DynFlags -> SDoc
1519 pprModuleMap dflags =
1520 vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1521 where
1522 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
1523 pprEntry m (m',o)
1524 | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
1525 | otherwise = ppr m' <+> parens (ppr o)
1526
1527 fsPackageName :: PackageConfig -> FastString
1528 fsPackageName = mkFastString . packageNameString