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