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