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