summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.lhs8
-rw-r--r--compiler/main/DriverPipeline.hs33
-rw-r--r--compiler/main/DynFlags.hs173
-rw-r--r--compiler/main/ErrUtils.lhs35
-rw-r--r--compiler/main/Finder.lhs154
-rw-r--r--compiler/main/GHC.hs32
-rw-r--r--compiler/main/GhcMake.hs16
-rw-r--r--compiler/main/HscMain.hs82
-rw-r--r--compiler/main/HscTypes.lhs113
-rw-r--r--compiler/main/InteractiveEval.hs2
-rw-r--r--compiler/main/PackageConfig.hs35
-rw-r--r--compiler/main/Packages.lhs840
-rw-r--r--compiler/main/Packages.lhs-boot4
-rw-r--r--compiler/main/PprTyThing.hs23
-rw-r--r--compiler/main/SysTools.lhs66
-rw-r--r--compiler/main/TidyPgm.lhs4
16 files changed, 1107 insertions, 513 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index c0a609ba2e..7a554f4d20 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -50,7 +50,7 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
- -> [PackageId]
+ -> [PackageKey]
-> Stream IO RawCmmGroup () -- Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}))
@@ -100,7 +100,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
- -> [PackageId]
+ -> [PackageKey]
-> IO ()
outputC dflags filenm cmm_stream packages
@@ -115,7 +115,7 @@ outputC dflags filenm cmm_stream packages
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
- let rts = getPackageDetails (pkgState dflags) rtsPackageId
+ let rts = getPackageDetails dflags rtsPackageKey
let cc_injects = unlines (map mk_include (includes rts))
mk_include h_file =
@@ -210,7 +210,7 @@ outputForeignStubs dflags mod location stubs
-- we need the #includes from the rts package for the stub files
let rts_includes =
- let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
+ let rts_pkg = getPackageDetails dflags rtsPackageKey in
concatMap mk_include (includes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 11427e27cf..f7b5eb8782 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -390,7 +390,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
-linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageId] -> IO Bool
+linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool
linkingNeeded dflags staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
@@ -411,9 +411,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- next, check libraries. XXX this only checks Haskell libraries,
-- not extra_libraries or -l things from the command line.
- let pkg_map = pkgIdMap (pkgState dflags)
- pkg_hslibs = [ (libraryDirs c, lib)
- | Just c <- map (lookupPackage pkg_map) pkg_deps,
+ let pkg_hslibs = [ (libraryDirs c, lib)
+ | Just c <- map (lookupPackage dflags) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
@@ -427,7 +426,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
-checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool
+checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool
checkLinkInfo dflags pkg_deps exe_file
| not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
-- ToDo: Windows and OS X do not use the ELF binary format, so
@@ -1113,7 +1112,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
++ (if platformOS platform == OSMinGW32 &&
- thisPackage dflags == basePackageId
+ thisPackage dflags == basePackageKey
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
@@ -1559,7 +1558,7 @@ mkExtraObj dflags extn xs
= do cFile <- newTempName dflags extn
oFile <- newTempName dflags "o"
writeFile cFile xs
- let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
+ let rtsDetails = getPackageDetails dflags rtsPackageKey
SysTools.runCc dflags
([Option "-c",
FileOption "" cFile,
@@ -1608,7 +1607,7 @@ mkExtraObjToLinkIntoBinary dflags = do
-- this was included as inline assembly in the main.c file but this
-- is pretty fragile. gas gets upset trying to calculate relative offsets
-- that span the .note section (notably .text) when debug info is present
-mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
@@ -1649,7 +1648,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
-- link. We save this information in the binary, and the next time we
-- link, if nothing else has changed, we use the link info stored in
-- the existing binary to decide whether to re-link or not.
-getLinkInfo :: DynFlags -> [PackageId] -> IO String
+getLinkInfo :: DynFlags -> [PackageKey] -> IO String
getLinkInfo dflags dep_packages = do
package_link_opts <- getPackageLinkOpts dflags dep_packages
pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
@@ -1727,13 +1726,13 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
-getHCFilePackages :: FilePath -> IO [PackageId]
+getHCFilePackages :: FilePath -> IO [PackageKey]
getHCFilePackages filename =
Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
l <- hGetLine h
case l of
'/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
- return (map stringToPackageId (words rest))
+ return (map stringToPackageKey (words rest))
_other ->
return []
@@ -1750,10 +1749,10 @@ getHCFilePackages filename =
-- read any interface files), so the user must explicitly specify all
-- the packages.
-linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
+linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO ()
linkBinary = linkBinary' False
-linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO ()
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO ()
linkBinary' staticLink dflags o_files dep_packages = do
let platform = targetPlatform dflags
mySettings = settings dflags
@@ -2027,7 +2026,7 @@ maybeCreateManifest dflags exe_filename
| otherwise = return []
-linkDynLibCheck :: DynFlags -> [String] -> [PackageId] -> IO ()
+linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
@@ -2037,7 +2036,7 @@ linkDynLibCheck dflags o_files dep_packages
linkDynLib dflags o_files dep_packages
-linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO ()
+linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
linkStaticLibCheck dflags o_files dep_packages
= do
when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
@@ -2166,7 +2165,9 @@ joinObjectFiles dflags o_files output_fn = do
if ldIsGnuLd
then do
script <- newTempName dflags "ldscript"
- writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
+ cwd <- getCurrentDirectory
+ let o_files_abs = map (cwd </>) o_files
+ writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
ld_r [SysTools.FileOption "" script] ccInfo
else if sLdSupportsFilelist mySettings
then do
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 122eafff19..74bd1397b8 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -43,7 +43,7 @@ module DynFlags (
targetRetainsAllBindings,
GhcMode(..), isOneShot,
GhcLink(..), isNoLink,
- PackageFlag(..),
+ PackageFlag(..), PackageArg(..), ModRenaming,
PkgConfRef(..),
Option(..), showOpt,
DynLibLoader(..),
@@ -61,7 +61,7 @@ module DynFlags (
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
packageTrustOn,
safeDirectImpsReq, safeImplicitImpsReq,
- unsafeFlags,
+ unsafeFlags, unsafeFlagsForInfer,
-- ** System tool settings and locations
Settings(..),
@@ -90,7 +90,7 @@ module DynFlags (
getVerbFlags,
updOptLevel,
setTmpDir,
- setPackageName,
+ setPackageKey,
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
@@ -190,6 +190,8 @@ import Data.Word
import System.FilePath
import System.IO
import System.IO.Error
+import Text.ParserCombinators.ReadP hiding (char)
+import Text.ParserCombinators.ReadP as R
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
@@ -269,6 +271,7 @@ data DumpFlag
| Opt_D_dump_hi
| Opt_D_dump_hi_diffs
| Opt_D_dump_mod_cycles
+ | Opt_D_dump_mod_map
| Opt_D_dump_view_pattern_commoning
| Opt_D_verbose_core2core
@@ -480,7 +483,6 @@ data SafeHaskellMode
| Sf_Unsafe
| Sf_Trustworthy
| Sf_Safe
- | Sf_SafeInferred
deriving (Eq)
instance Show SafeHaskellMode where
@@ -488,7 +490,6 @@ instance Show SafeHaskellMode where
show Sf_Unsafe = "Unsafe"
show Sf_Trustworthy = "Trustworthy"
show Sf_Safe = "Safe"
- show Sf_SafeInferred = "Safe-Inferred"
instance Outputable SafeHaskellMode where
ppr = text . show
@@ -630,7 +631,7 @@ data DynFlags = DynFlags {
ctxtStkDepth :: Int, -- ^ Typechecker context stack depth
tyFunStkDepth :: Int, -- ^ Typechecker type function stack depth
- thisPackage :: PackageId, -- ^ name of package currently being compiled
+ thisPackage :: PackageKey, -- ^ name of package currently being compiled
-- ways
ways :: [Way], -- ^ Way flags from the command line
@@ -737,11 +738,14 @@ data DynFlags = DynFlags {
language :: Maybe Language,
-- | Safe Haskell mode
safeHaskell :: SafeHaskellMode,
+ safeInfer :: Bool,
+ safeInferred :: Bool,
-- We store the location of where some extension and flags were turned on so
-- we can produce accurate error messages when Safe Haskell fails due to
-- them.
thOnLoc :: SrcSpan,
newDerivOnLoc :: SrcSpan,
+ overlapInstLoc :: SrcSpan,
pkgTrustOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
@@ -1019,9 +1023,15 @@ isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
isNoLink _ = False
+data PackageArg = PackageArg String
+ | PackageIdArg String
+ | PackageKeyArg String
+ deriving (Eq, Show)
+
+type ModRenaming = Maybe [(String, String)]
+
data PackageFlag
- = ExposePackage String
- | ExposePackageId String
+ = ExposePackage PackageArg ModRenaming
| HidePackage String
| IgnorePackage String
| TrustPackage String
@@ -1215,7 +1225,6 @@ wayOptl platform WayThreaded =
-- the problems are our fault or theirs, but it seems that using the
-- alternative 1:1 threading library libthr works around it:
OSFreeBSD -> ["-lthr"]
- OSSolaris2 -> ["-lrt"]
OSOpenBSD -> ["-pthread"]
OSNetBSD -> ["-pthread"]
_ -> []
@@ -1352,7 +1361,7 @@ defaultDynFlags mySettings =
ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH,
- thisPackage = mainPackageId,
+ thisPackage = mainPackageKey,
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -1417,9 +1426,12 @@ defaultDynFlags mySettings =
warningFlags = IntSet.fromList (map fromEnum standardWarnings),
ghciScripts = [],
language = Nothing,
- safeHaskell = Sf_SafeInferred,
+ safeHaskell = Sf_None,
+ safeInfer = True,
+ safeInferred = True,
thOnLoc = noSrcSpan,
newDerivOnLoc = noSrcSpan,
+ overlapInstLoc = noSrcSpan,
pkgTrustOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
@@ -1626,6 +1638,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
enableIfVerbose Opt_D_dump_ticked = False
enableIfVerbose Opt_D_dump_view_pattern_commoning = False
enableIfVerbose Opt_D_dump_mod_cycles = False
+ enableIfVerbose Opt_D_dump_mod_map = False
enableIfVerbose _ = True
-- | Set a 'DumpFlag'
@@ -1702,7 +1715,7 @@ packageTrustOn = gopt Opt_PackageTrust
-- | Is Safe Haskell on in some way (including inference mode)
safeHaskellOn :: DynFlags -> Bool
-safeHaskellOn dflags = safeHaskell dflags /= Sf_None
+safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags
-- | Is the Safe Haskell safe language in use
safeLanguageOn :: DynFlags -> Bool
@@ -1710,7 +1723,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
-- | Is the Safe Haskell safe inference mode active
safeInferOn :: DynFlags -> Bool
-safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred
+safeInferOn = safeInfer
-- | Test if Safe Imports are on in some form
safeImportsOn :: DynFlags -> Bool
@@ -1724,7 +1737,11 @@ setSafeHaskell s = updM f
where f dfs = do
let sf = safeHaskell dfs
safeM <- combineSafeFlags sf s
- return $ dfs { safeHaskell = safeM }
+ return $ case (s == Sf_Safe || s == Sf_Unsafe) of
+ True -> dfs { safeHaskell = safeM, safeInfer = False }
+ -- leave safe inferrence on in Trustworthy mode so we can warn
+ -- if it could have been inferred safe.
+ False -> dfs { safeHaskell = safeM }
-- | Are all direct imports required to be safe for this Safe Haskell mode?
-- Direct imports are when the code explicitly imports a module
@@ -1741,9 +1758,7 @@ safeImplicitImpsReq d = safeLanguageOn d
-- want to export this functionality from the module but do want to export the
-- type constructors.
combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode
-combineSafeFlags a b | a == Sf_SafeInferred = return b
- | b == Sf_SafeInferred = return a
- | a == Sf_None = return b
+combineSafeFlags a b | a == Sf_None = return b
| b == Sf_None = return a
| a == b = return a
| otherwise = addErr errm >> return (panic errm)
@@ -1755,13 +1770,19 @@ combineSafeFlags a b | a == Sf_SafeInferred = return b
-- * function to get srcspan that enabled the flag
-- * function to test if the flag is on
-- * function to turn the flag off
-unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
+unsafeFlags, unsafeFlagsForInfer
+ :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
xopt Opt_GeneralizedNewtypeDeriving,
flip xopt_unset Opt_GeneralizedNewtypeDeriving),
("-XTemplateHaskell", thOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)]
+unsafeFlagsForInfer = unsafeFlags ++
+ -- TODO: Can we do better than this for inference?
+ [("-XOverlappingInstances", overlapInstLoc,
+ xopt Opt_OverlappingInstances,
+ flip xopt_unset Opt_OverlappingInstances)]
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
@@ -2043,43 +2064,41 @@ updateWays dflags
-- The bool is to indicate if we are parsing command line flags (false means
-- file pragma). This allows us to generate better warnings.
safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
-safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags)
- = (dflags, [])
-
--- safe or safe-infer ON
-safeFlagCheck cmdl dflags =
- case safeLanguageOn dflags of
- True -> (dflags', warns)
+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)
+ where
+ -- Handle illegal flags under safe language.
+ (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags
- -- throw error if -fpackage-trust by itself with no safe haskell flag
- False | not cmdl && packageTrustOn dflags
- -> (gopt_unset dflags' Opt_PackageTrust,
- [L (pkgTrustOnLoc dflags') $
- "-fpackage-trust ignored;" ++
- " must be specified with a Safe Haskell flag"]
- )
+ check_method (df, warns) (str,loc,test,fix)
+ | test df = (fix df, warns ++ safeFailure (loc df) str)
+ | otherwise = (df, warns)
- False | null warns && safeInfOk
- -> (dflags', [])
+ safeFailure loc str
+ = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "
+ ++ str]
- | otherwise
- -> (dflags' { safeHaskell = Sf_None }, [])
- -- Have we inferred Unsafe?
- -- See Note [HscMain . Safe Haskell Inference]
- where
- -- TODO: Can we do better than this for inference?
- safeInfOk = not $ xopt Opt_OverlappingInstances dflags
+safeFlagCheck cmdl dflags =
+ case (safeInferOn dflags) of
+ True | safeFlags -> (dflags', warn)
+ True -> (dflags' { safeInferred = False }, warn)
+ False -> (dflags', warn)
- (dflags', warns) = foldl check_method (dflags, []) unsafeFlags
+ where
+ -- dynflags and warn for when -fpackage-trust by itself with no safe
+ -- haskell flag
+ (dflags', warn)
+ | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags
+ = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)
+ | otherwise = (dflags, [])
- check_method (df, warns) (str,loc,test,fix)
- | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str)
- | otherwise = (df, warns)
+ pkgWarnMsg = [L (pkgTrustOnLoc dflags') $
+ "-fpackage-trust ignored;" ++
+ " must be specified with a Safe Haskell flag"]
- apFix f = if safeInferOn dflags then id else f
+ safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer
+ -- Have we inferred Unsafe?
+ -- See Note [HscMain . Safe Haskell Inference]
- safeFailure loc str
- = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str]
{- **********************************************************************
%* *
@@ -2364,6 +2383,7 @@ dynamic_flags = [
, Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat
, Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked)
, Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles)
+ , Flag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map)
, Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning)
, Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile))
, Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs)
@@ -2478,7 +2498,7 @@ dynamic_flags = [
------ Safe Haskell flags -------------------------------------------
, Flag "fpackage-trust" (NoArg setPackageTrust)
- , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
+ , Flag "fno-safe-infer" (noArg (\d -> d { safeInfer = False } ))
, Flag "fPIC" (NoArg (setGeneralFlag Opt_PIC))
, Flag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC))
]
@@ -2517,9 +2537,13 @@ package_flags = [
removeUserPkgConf
deprecate "Use -no-user-package-db instead")
- , Flag "package-name" (hasArg setPackageName)
+ , Flag "package-name" (HasArg $ \name -> do
+ upd (setPackageKey name)
+ deprecate "Use -this-package-key instead")
+ , Flag "this-package-key" (hasArg setPackageKey)
, Flag "package-id" (HasArg exposePackageId)
, Flag "package" (HasArg exposePackage)
+ , Flag "package-key" (HasArg exposePackageKey)
, Flag "hide-package" (HasArg hidePackage)
, Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages))
, Flag "ignore-package" (HasArg ignorePackage)
@@ -2872,7 +2896,9 @@ xFlags = [
deprecatedForExtension "MultiParamTypeClasses" ),
( "FunctionalDependencies", Opt_FunctionalDependencies, nop ),
( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, setGenDeriving ),
- ( "OverlappingInstances", Opt_OverlappingInstances, nop ),
+ ( "OverlappingInstances", Opt_OverlappingInstances,
+ \ turn_on -> when turn_on
+ $ deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" ),
( "UndecidableInstances", Opt_UndecidableInstances, nop ),
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "PackageImports", Opt_PackageImports, nop ),
@@ -3327,11 +3353,39 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
-exposePackage, exposePackageId, hidePackage, ignorePackage,
+parsePackageFlag :: (String -> PackageArg) -- type of argument
+ -> String -- string to parse
+ -> PackageFlag
+parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of
+ [(r, "")] -> r
+ _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)
+ where parse = do
+ pkg <- munch1 (\c -> isAlphaNum c || c `elem` ":-_.")
+ (do _ <- tok $ R.char '('
+ rns <- tok $ sepBy parseItem (tok $ R.char ',')
+ _ <- tok $ R.char ')'
+ return (ExposePackage (constr pkg) (Just rns))
+ +++
+ return (ExposePackage (constr pkg) Nothing))
+ parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".")
+ parseItem = do
+ orig <- tok $ parseMod
+ (do _ <- tok $ string "as"
+ new <- tok $ parseMod
+ return (orig, new)
+ +++
+ return (orig, orig))
+ tok m = skipSpaces >> m
+
+exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP ()
exposePackage p = upd (exposePackage' p)
exposePackageId p =
- upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s })
+ upd (\s -> s{ packageFlags =
+ parsePackageFlag PackageIdArg p : packageFlags s })
+exposePackageKey p =
+ upd (\s -> s{ packageFlags =
+ parsePackageFlag PackageKeyArg p : packageFlags s })
hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
@@ -3343,10 +3397,11 @@ distrustPackage p = exposePackage p >>
exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
- = dflags { packageFlags = ExposePackage p : packageFlags dflags }
+ = dflags { packageFlags =
+ parsePackageFlag PackageArg p : packageFlags dflags }
-setPackageName :: String -> DynFlags -> DynFlags
-setPackageName p s = s{ thisPackage = stringToPackageId p }
+setPackageKey :: String -> DynFlags -> DynFlags
+setPackageKey p s = s{ thisPackage = stringToPackageKey p }
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
@@ -3398,10 +3453,10 @@ setMainIs arg
| not (null main_fn) && isLower (head main_fn)
-- The arg looked like "Foo.Bar.baz"
= upd $ \d -> d{ mainFunIs = Just main_fn,
- mainModIs = mkModule mainPackageId (mkModuleName main_mod) }
+ mainModIs = mkModule mainPackageKey (mkModuleName main_mod) }
| isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"
- = upd $ \d -> d{ mainModIs = mkModule mainPackageId (mkModuleName arg) }
+ = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) }
| otherwise -- The arg looked like "baz"
= upd $ \d -> d{ mainFunIs = Just arg }
@@ -3588,6 +3643,8 @@ compilerInfo dflags
("RTS ways", cGhcRTSWays),
("Support dynamic-too", if isWindows then "NO" else "YES"),
("Support parallel --make", "YES"),
+ ("Support reexported-modules", "YES"),
+ ("Uses package keys", "YES"),
("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags
then "YES" else "NO"),
("GHC Dynamic", if dynamicGhc
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 02f731d3c2..c43064e7f1 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -7,15 +7,18 @@
{-# LANGUAGE CPP #-}
module ErrUtils (
+ MsgDoc,
+ Validity(..), andValid, allValid, isValid, getInvalids,
+
ErrMsg, WarnMsg, Severity(..),
Messages, ErrorMessages, WarningMessages,
errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
- MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
+ mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
pprLocErrMsg, makeIntoWarning,
-
+
errorsFound, emptyMessages, isEmptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
- printBagOfErrors,
+ printBagOfErrors,
warnIsErrorMsg, mkLongWarnMsg,
ghcExit,
@@ -46,7 +49,7 @@ import DynFlags
import System.Directory
import System.Exit ( ExitCode(..), exitWith )
-import System.FilePath
+import System.FilePath ( takeDirectory, (</>) )
import Data.List
import qualified Data.Set as Set
import Data.IORef
@@ -56,6 +59,29 @@ import Control.Monad
import Control.Monad.IO.Class
import System.IO
+-------------------------
+type MsgDoc = SDoc
+
+-------------------------
+data Validity
+ = IsValid -- Everything is fine
+ | NotValid MsgDoc -- A problem, and some indication of why
+
+isValid :: Validity -> Bool
+isValid IsValid = True
+isValid (NotValid {}) = False
+
+andValid :: Validity -> Validity -> Validity
+andValid IsValid v = v
+andValid v _ = v
+
+allValid :: [Validity] -> Validity -- If they aren't all valid, return the first
+allValid [] = IsValid
+allValid (v : vs) = v `andValid` allValid vs
+
+getInvalids :: [Validity] -> [MsgDoc]
+getInvalids vs = [d | NotValid d <- vs]
+
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.
@@ -74,7 +100,6 @@ data ErrMsg = ErrMsg {
-- The SrcSpan is used for sorting errors into line-number order
type WarnMsg = ErrMsg
-type MsgDoc = SDoc
data Severity
= SevOutput
diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index cbfd4e4f1c..f9c7e2eee0 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -43,13 +43,12 @@ import Maybes ( expectJust )
import Exception ( evaluate )
import Distribution.Text
-import Distribution.Package hiding (PackageId)
import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef )
import System.Directory
import System.FilePath
import Control.Monad
-import Data.List ( partition )
import Data.Time
+import Data.List ( foldl' )
type FileExt = String -- Filename extension
@@ -80,12 +79,12 @@ flushFinderCaches hsc_env = do
fc_ref = hsc_FC hsc_env
mlc_ref = hsc_MLC hsc_env
-flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO ()
+flushModLocationCache :: PackageKey -> IORef ModLocationCache -> IO ()
flushModLocationCache this_pkg ref = do
atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ())
_ <- evaluate =<< readIORef ref
return ()
- where is_ext mod _ | modulePackageId mod /= this_pkg = True
+ where is_ext mod _ | modulePackageKey mod /= this_pkg = True
| otherwise = False
addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO ()
@@ -148,7 +147,7 @@ findImportedModule hsc_env mod_name mb_pkg =
findExactModule :: HscEnv -> Module -> IO FindResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
- in if modulePackageId mod == thisPackage dflags
+ in if modulePackageKey mod == thisPackage dflags
then findHomeModule hsc_env (moduleName mod)
else findPackageModule hsc_env mod
@@ -190,41 +189,21 @@ homeSearchCache hsc_env mod_name do_this = do
findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
-> IO FindResult
findExposedPackageModule hsc_env mod_name mb_pkg
- -- not found in any package:
- = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name of
- Left suggest -> return (NotFound { fr_paths = [], fr_pkg = Nothing
- , fr_pkgs_hidden = []
- , fr_mods_hidden = []
- , fr_suggestions = suggest })
- Right found
- | null found_exposed -- Found, but with no exposed copies
- -> return (NotFound { fr_paths = [], fr_pkg = Nothing
- , fr_pkgs_hidden = pkg_hiddens
- , fr_mods_hidden = mod_hiddens
- , fr_suggestions = [] })
-
- | [(pkg_conf,_)] <- found_exposed -- Found uniquely
- -> let pkgid = packageConfigId pkg_conf in
- findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf
-
- | otherwise -- Found in more than one place
- -> return (FoundMultiple (map (packageConfigId.fst) found_exposed))
- where
- for_this_pkg = case mb_pkg of
- Nothing -> found
- Just p -> filter ((`matches` p) . fst) found
- found_exposed = filter is_exposed for_this_pkg
- is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod
-
- mod_hiddens = [ packageConfigId pkg_conf
- | (pkg_conf,False) <- found ]
-
- pkg_hiddens = [ packageConfigId pkg_conf
- | (pkg_conf,_) <- found, not (exposed pkg_conf) ]
-
- pkg_conf `matches` pkg
- = case packageName pkg_conf of
- PackageName n -> pkg == mkFastString n
+ = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of
+ LookupFound m pkg_conf ->
+ findPackageModule_ hsc_env m pkg_conf
+ LookupMultiple rs ->
+ return (FoundMultiple rs)
+ LookupHidden pkg_hiddens mod_hiddens ->
+ return (NotFound{ fr_paths = [], fr_pkg = Nothing
+ , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens
+ , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens
+ , fr_suggestions = [] })
+ LookupNotFound suggest ->
+ return (NotFound{ fr_paths = [], fr_pkg = Nothing
+ , fr_pkgs_hidden = []
+ , fr_mods_hidden = []
+ , fr_suggestions = suggest })
modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
modLocationCache hsc_env mod do_this = do
@@ -295,15 +274,22 @@ findPackageModule :: HscEnv -> Module -> IO FindResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
- pkg_id = modulePackageId mod
- pkg_map = pkgIdMap (pkgState dflags)
+ pkg_id = modulePackageKey mod
--
- case lookupPackage pkg_map pkg_id of
+ case lookupPackage dflags pkg_id of
Nothing -> return (NoPackage pkg_id)
Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
+-- | Look up the interface file associated with module @mod@. This function
+-- requires a few invariants to be upheld: (1) the 'Module' in question must
+-- be the module identifier of the *original* implementation of a module,
+-- not a reexport (this invariant is upheld by @Packages.lhs@) and (2)
+-- the 'PackageConfig' must be consistent with the package key in the 'Module'.
+-- The redundancy is to avoid an extra lookup in the package state
+-- for the appropriate config.
findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
findPackageModule_ hsc_env mod pkg_conf =
+ ASSERT( modulePackageKey mod == packageConfigId pkg_conf )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
@@ -373,7 +359,7 @@ searchPathExts paths mod exts
]
search [] = return (NotFound { fr_paths = map fst to_search
- , fr_pkg = Just (modulePackageId mod)
+ , fr_pkg = Just (modulePackageKey mod)
, fr_mods_hidden = [], fr_pkgs_hidden = []
, fr_suggestions = [] })
@@ -548,18 +534,38 @@ cannotFindInterface = cantFindErr (sLit "Failed to load interface for")
cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult
-> SDoc
-cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs)
+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
+ | Just pkgs <- unambiguousPackages
= hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
sep [ptext (sLit "it was found in multiple packages:"),
- hsep (map (text.packageIdString) pkgs)]
+ hsep (map ppr pkgs) ]
)
+ | otherwise
+ = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
+ vcat (map pprMod mods)
+ )
+ where
+ unambiguousPackages = foldl' unambiguousPackage (Just []) mods
+ unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
+ = Just (modulePackageKey m : xs)
+ unambiguousPackage _ _ = Nothing
+
+ pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+>
+ ptext (sLit "by") <+> pprOrigin m o
+ pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
+ pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
+ if e == Just True
+ then [ptext (sLit "package") <+> ppr (modulePackageKey m)]
+ else [] ++
+ map ((ptext (sLit "a reexport in package") <+>)
+ .ppr.packageConfigId) res ++
+ if f then [ptext (sLit "a package flag")] else []
+ )
+
cantFindErr cannot_find _ dflags mod_name find_result
= ptext cannot_find <+> quotes (ppr mod_name)
$$ more_info
where
- pkg_map :: PackageConfigMap
- pkg_map = pkgIdMap (pkgState dflags)
-
more_info
= case find_result of
NoPackage pkg
@@ -615,7 +621,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
<> dot $$ cabal_pkg_hidden_hint pkg
cabal_pkg_hidden_hint pkg
| gopt Opt_BuildingCabalPackage dflags
- = case simpleParse (packageIdString pkg) of
+ = case simpleParse (packageKeyString pkg) of
Just pid ->
ptext (sLit "Perhaps you need to add") <+>
quotes (text (display (pkgName pid))) <+>
@@ -626,22 +632,40 @@ cantFindErr cannot_find _ dflags mod_name find_result
mod_hidden pkg =
ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg)
- pp_suggestions :: [Module] -> SDoc
+ pp_suggestions :: [ModuleSuggestion] -> SDoc
pp_suggestions sugs
| null sugs = empty
| otherwise = hang (ptext (sLit "Perhaps you meant"))
- 2 (vcat [ vcat (map pp_exp exposed_sugs)
- , vcat (map pp_hid hidden_sugs) ])
- where
- (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs
-
- from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of
- Just pkg_config -> exposed pkg_config
- Nothing -> WARN( True, ppr m ) -- Should not happen
- False
-
- pp_exp mod = ppr (moduleName mod)
- <+> parens (ptext (sLit "from") <+> ppr (modulePackageId mod))
- pp_hid mod = ppr (moduleName mod)
- <+> parens (ptext (sLit "needs flag -package") <+> ppr (modulePackageId mod))
+ 2 (vcat (map pp_sugg sugs))
+
+ -- NB: Prefer the *original* location, and then reexports, and then
+ -- package flags when making suggestions. ToDo: if the original package
+ -- also has a reexport, prefer that one
+ pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
+ where provenance ModHidden = empty
+ provenance (ModOrigin{ fromOrigPackage = e,
+ fromExposedReexport = res,
+ fromPackageFlag = f })
+ | Just True <- e
+ = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod))
+ | f && moduleName mod == m
+ = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod))
+ | (pkg:_) <- res
+ = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg)
+ <> comma <+> ptext (sLit "reexporting") <+> ppr mod)
+ | f
+ = parens (ptext (sLit "defined via package flags to be")
+ <+> ppr mod)
+ | otherwise = empty
+ pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
+ where provenance ModHidden = empty
+ provenance (ModOrigin{ fromOrigPackage = e,
+ fromHiddenReexport = rhs })
+ | Just False <- e
+ = parens (ptext (sLit "needs flag -package-key")
+ <+> ppr (modulePackageKey mod))
+ | (pkg:_) <- rhs
+ = parens (ptext (sLit "needs flag -package-key")
+ <+> ppr (packageConfigId pkg))
+ | otherwise = empty
\end{code}
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 13d4f87009..9ab52ebf1d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -81,7 +81,7 @@ module GHC (
SafeHaskellMode(..),
-- * Querying the environment
- packageDbModules,
+ -- packageDbModules,
-- * Printing
PrintUnqualified, alwaysQualify,
@@ -133,10 +133,10 @@ module GHC (
-- * Abstract syntax elements
-- ** Packages
- PackageId,
+ PackageKey,
-- ** Modules
- Module, mkModule, pprModule, moduleName, modulePackageId,
+ Module, mkModule, pprModule, moduleName, modulePackageKey,
ModuleName, mkModuleName, moduleNameString,
-- ** Names
@@ -534,7 +534,7 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
-setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
setSessionDynFlags dflags = do
(dflags', preload) <- liftIO $ initPackages dflags
modifySession $ \h -> h{ hsc_dflags = dflags'
@@ -543,7 +543,7 @@ setSessionDynFlags dflags = do
return preload
-- | Sets the program 'DynFlags'.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
+setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
setProgramDynFlags dflags = do
(dflags', preload) <- liftIO $ initPackages dflags
modifySession $ \h -> h{ hsc_dflags = dflags' }
@@ -1167,9 +1167,10 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
-- -----------------------------------------------------------------------------
+{- ToDo: Move the primary logic here to compiler/main/Packages.lhs
-- | Return all /external/ modules available in the package database.
-- Modules from the current session (i.e., from the 'HomePackageTable') are
--- not included.
+-- not included. This includes module names which are reexported by packages.
packageDbModules :: GhcMonad m =>
Bool -- ^ Only consider exposed packages.
-> m [Module]
@@ -1177,10 +1178,13 @@ packageDbModules only_exposed = do
dflags <- getSessionDynFlags
let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
return $
- [ mkModule pid modname | p <- pkgs
- , not only_exposed || exposed p
- , let pid = packageConfigId p
- , modname <- exposedModules p ]
+ [ mkModule pid modname
+ | p <- pkgs
+ , not only_exposed || exposed p
+ , let pid = packageConfigId p
+ , modname <- exposedModules p
+ ++ map exportName (reexportedModules p) ]
+ -}
-- -----------------------------------------------------------------------------
-- Misc exported utils
@@ -1301,7 +1305,7 @@ showRichTokenStream ts = go startLoc ts ""
-- -----------------------------------------------------------------------------
-- Interactive evaluation
--- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
+-- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
@@ -1311,7 +1315,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
this_pkg = thisPackage dflags
--
case maybe_pkg of
- Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+ Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
@@ -1323,7 +1327,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
- Found loc m | modulePackageId m /= this_pkg -> return m
+ Found loc m | modulePackageKey m /= this_pkg -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
@@ -1368,7 +1372,7 @@ isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId])
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 694778115d..0c63203d4c 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -63,6 +63,7 @@ import qualified Data.Set as Set
import qualified FiniteMap as Map ( insertListWith )
import Control.Concurrent ( forkIOWithUnmask, killThread )
+import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
@@ -80,6 +81,11 @@ import System.IO.Error ( isDoesNotExistError )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
+label_self :: String -> IO ()
+label_self thread_name = do
+ self_tid <- CC.myThreadId
+ CC.labelThread self_tid thread_name
+
-- -----------------------------------------------------------------------------
-- Loading the program
@@ -744,10 +750,18 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
| ((ms,mvar,_),idx) <- comp_graph_w_idx ]
+ liftIO $ label_self "main --make thread"
-- For each module in the module graph, spawn a worker thread that will
-- compile this module.
let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
forkIOWithUnmask $ \unmask -> do
+ liftIO $ label_self $ unwords
+ [ "worker --make thread"
+ , "for module"
+ , show (moduleNameString (ms_mod_name mod))
+ , "number"
+ , show mod_idx
+ ]
-- Replace the default log_action with one that writes each
-- message to the module's log_queue. The main thread will
-- deal with synchronously printing these messages.
@@ -1786,7 +1800,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
just_found location mod
| otherwise ->
-- Drop external-pkg
- ASSERT(modulePackageId mod /= thisPackage dflags)
+ ASSERT(modulePackageKey mod /= thisPackage dflags)
return Nothing
err -> return $ Just $ Left $ noModError dflags loc wanted_mod err
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index aef6007fb7..15d67fc882 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -407,19 +407,20 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res)
dflags <- getDynFlags
+ let allSafeOK = safeInferred dflags && tcSafeOK
- -- end of the Safe Haskell line, how to respond to user?
- if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
- -- if safe haskell off or safe infer failed, wipe trust
- then wipeTrust tcg_res emptyBag
+ -- end of the safe haskell line, how to respond to user?
+ if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
+ -- if safe Haskell off or safe infer failed, mark unsafe
+ then markUnsafe tcg_res emptyBag
- -- module safe, throw warning if needed
+ -- module (could be) safe, throw warning if needed
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
when (safe && wopt Opt_WarnSafe dflags)
- (logWarnings $ unitBag $
- mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res')
+ (logWarnings $ unitBag $ mkPlainWarnMsg dflags
+ (warnSafeOnLoc dflags) $ errSafe tcg_res')
return tcg_res'
where
pprMod t = ppr $ moduleName $ tcg_mod t
@@ -773,16 +774,15 @@ hscCheckSafeImports tcg_env = do
tcg_env' <- checkSafeImports dflags tcg_env
case safeLanguageOn dflags of
True -> do
- -- we nuke user written RULES in -XSafe
+ -- XSafe: we nuke user written RULES
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
- -- user defined RULES, so not safe or already unsafe
- | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
- safeHaskell dflags == Sf_None
- -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env')
+ -- SafeInferred: user defined RULES, so not safe
+ | safeInferOn dflags && not (null $ tcg_rules tcg_env')
+ -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env')
- -- trustworthy OR safe inferred with no RULES
+ -- Trustworthy OR SafeInferred: with no RULES
| otherwise
-> return tcg_env'
@@ -828,7 +828,7 @@ checkSafeImports dflags tcg_env
True ->
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
- True -> wipeTrust tcg_env errs
+ True -> markUnsafe tcg_env errs
False -> liftIO . throwIO . mkSrcErr $ errs
-- All good matey!
@@ -842,14 +842,16 @@ checkSafeImports dflags tcg_env
imp_info = tcg_imports tcg_env -- ImportAvails
imports = imp_mods imp_info -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
- pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
+ pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
-- we turn all imports into safe ones when
-- inference mode is on.
- let s' = if safeInferOn dflags then True else s
+ let s' = if safeInferOn dflags &&
+ safeHaskell dflags == Sf_None
+ then True else s
return (m, l, s')
-- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
@@ -879,7 +881,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId])
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey])
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
@@ -893,15 +895,15 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
-hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey])
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomePkg m -> return (Nothing, pkgs)
- | otherwise -> return (Just $ modulePackageId m, pkgs)
+ | otherwise -> return (Just $ modulePackageKey m, pkgs)
where
- isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
+ isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey])
isModSafe m l = do
iface <- lookup' m
case iface of
@@ -915,7 +917,7 @@ hscCheckSafe' dflags m l = do
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
-- check module is trusted
- safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy]
+ safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
@@ -930,13 +932,13 @@ hscCheckSafe' dflags m l = do
return (trust == Sf_Trustworthy, pkgRs)
where
- pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $
+ pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
- , text "The package (" <> ppr (modulePackageId m)
+ , text "The package (" <> ppr (modulePackageKey m)
<> text ") the module resides in isn't trusted."
]
- modTrustErr = unitBag $ mkPlainErrMsg dflags l $
+ modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
@@ -951,11 +953,9 @@ hscCheckSafe' dflags m l = do
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True
- packageTrusted Sf_SafeInferred False _ = True
packageTrusted _ _ m
| isHomePkg m = True
- | otherwise = trusted $ getPackageDetails (pkgState dflags)
- (modulePackageId m)
+ | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
@@ -979,11 +979,11 @@ hscCheckSafe' dflags m l = do
isHomePkg :: Module -> Bool
isHomePkg m
- | thisPackage dflags == modulePackageId m = True
+ | thisPackage dflags == modulePackageKey m = True
| otherwise = False
-- | Check the list of packages are trusted.
-checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
+checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
@@ -991,19 +991,20 @@ checkPkgTrust dflags pkgs =
where
errors = catMaybes $ map go pkgs
go pkg
- | trusted $ getPackageDetails (pkgState dflags) pkg
+ | trusted $ getPackageDetails dflags pkg
= Nothing
| otherwise
- = Just $ mkPlainErrMsg dflags noSrcSpan
+ = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
--- | Set module to unsafe and wipe trust information.
+-- | Set module to unsafe and (potentially) wipe trust information.
--
-- Make sure to call this method to set a module to inferred unsafe,
--- it should be a central and single failure method.
-wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
-wipeTrust tcg_env whyUnsafe = do
+-- it should be a central and single failure method. We only wipe the trust
+-- information when we aren't in a specific Safe Haskell mode.
+markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+markUnsafe tcg_env whyUnsafe = do
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
@@ -1011,7 +1012,12 @@ wipeTrust tcg_env whyUnsafe = do
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) False
- return $ tcg_env { tcg_imports = wiped_trust }
+ -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
+ -- times inference may be on but we are in Trustworthy mode -- so we want
+ -- to record safe-inference failed but not wipe the trust dependencies.
+ case safeHaskell dflags == Sf_None of
+ True -> return $ tcg_env { tcg_imports = wiped_trust }
+ False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
@@ -1021,7 +1027,7 @@ wipeTrust tcg_env whyUnsafe = do
, nest 4 $ (vcat $ badFlags df) $+$
(vcat $ pprErrMsgBagWithLoc whyUnsafe)
]
- badFlags df = concat $ map (badFlag df) unsafeFlags
+ badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
badFlag df (str,loc,on,_)
| on df = [mkLocMessage SevOutput (loc df) $
text str <+> text "is not allowed in Safe Haskell"]
@@ -1368,7 +1374,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
handleWarnings
-- Then code-gen, and link it
- -- It's important NOT to have package 'interactive' as thisPackageId
+ -- It's important NOT to have package 'interactive' as thisPackageKey
-- for linking, else we try to link 'main' and can't find it.
-- Whereas the linker already knows to ignore 'interactive'
let src_span = srcLocSpan interactiveSrcLoc
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 9738f590b6..123b0777fc 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -54,6 +54,7 @@ module HscTypes (
setInteractivePrintName, icInteractiveModule,
InteractiveImport(..), setInteractivePackage,
mkPrintUnqualified, pprModulePrefix,
+ mkQualPackage, mkQualModule, pkgQual,
-- * Interfaces
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
@@ -443,7 +444,7 @@ instance Outputable TargetId where
-- | Helps us find information about modules in the home package
type HomePackageTable = ModuleNameEnv HomeModInfo
-- Domain = modules in the home package that have been fully compiled
- -- "home" package name cached here for convenience
+ -- "home" package key cached here for convenience
-- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface
@@ -634,26 +635,26 @@ type FinderCache = ModuleNameEnv FindResult
data FindResult
= Found ModLocation Module
-- ^ The module was found
- | NoPackage PackageId
+ | NoPackage PackageKey
-- ^ The requested package was not found
- | FoundMultiple [PackageId]
+ | FoundMultiple [(Module, ModuleOrigin)]
-- ^ _Error_: both in multiple packages
-- | Not found
| NotFound
{ fr_paths :: [FilePath] -- Places where I looked
- , fr_pkg :: Maybe PackageId -- Just p => module is in this package's
+ , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's
-- manifest, but couldn't find
-- the .hi file
- , fr_mods_hidden :: [PackageId] -- Module is in these packages,
+ , fr_mods_hidden :: [PackageKey] -- Module is in these packages,
-- but the *module* is hidden
- , fr_pkgs_hidden :: [PackageId] -- Module is in these packages,
+ , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages,
-- but the *package* is hidden
- , fr_suggestions :: [Module] -- Possible mis-spelled modules
+ , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules
}
-- | Cache that remembers where we found a particular module. Contains both
@@ -995,8 +996,8 @@ data ModGuts
mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment
-- These fields all describe the things **declared in this module**
- mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module
- -- ToDo: I'm unconvinced this is actually used anywhere
+ mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module.
+ -- Used for creating interface files.
mg_tcs :: ![TyCon], -- ^ TyCons declared in this module
-- (includes TyCons for classes)
mg_insts :: ![ClsInst], -- ^ Class instances declared in this module
@@ -1067,7 +1068,7 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
- cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to
+ cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
cg_modBreaks :: !ModBreaks -- ^ Module breakpoints
@@ -1100,13 +1101,13 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
Note [The interactive package]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Type and class declarations at the command prompt are treated as if
-they were defined in modules
+Type, class, and value declarations at the command prompt are treated
+as if they were defined in modules
interactive:Ghci1
interactive:Ghci2
...etc...
with each bunch of declarations using a new module, all sharing a
-common package 'interactive' (see Module.interactivePackageId, and
+common package 'interactive' (see Module.interactivePackageKey, and
PrelNames.mkInteractiveModule).
This scheme deals well with shadowing. For example:
@@ -1138,7 +1139,7 @@ The details are a bit tricky though:
extend the HPT.
* The 'thisPackage' field of DynFlags is *not* set to 'interactive'.
- It stays as 'main' (or whatever -package-name says), and is the
+ It stays as 'main' (or whatever -this-package-key says), and is the
package to which :load'ed modules are added to.
* So how do we arrange that declarations at the command prompt get
@@ -1148,14 +1149,15 @@ The details are a bit tricky though:
turn get the module from it 'icInteractiveModule' field of the
interactive context.
- The 'thisPackage' field stays as 'main' (or whatever -package-name says.
+ The 'thisPackage' field stays as 'main' (or whatever -this-package-key says.
* The main trickiness is that the type environment (tcg_type_env and
- fixity envt (tcg_fix_env) now contains entities from all the
- GhciN modules together, rather than just a single module as is usually
- the case. So you can't use "nameIsLocalOrFrom" to decide whether
- to look in the TcGblEnv vs the HPT/PTE. This is a change, but not
- a problem provided you know.
+ fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts)
+ now contains entities from all the interactive-package modules
+ (Ghci1, Ghci2, ...) together, rather than just a single module as
+ is usually the case. So you can't use "nameIsLocalOrFrom" to
+ decide whether to look in the TcGblEnv vs the HPT/PTE. This is a
+ change, but not a problem provided you know.
Note [Interactively-bound Ids in GHCi]
@@ -1341,7 +1343,7 @@ extendInteractiveContext ictxt new_tythings
setInteractivePackage :: HscEnv -> HscEnv
-- Set the 'thisPackage' DynFlag to 'interactive'
setInteractivePackage hsc_env
- = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageId } }
+ = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
@@ -1408,11 +1410,28 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix
+Note [Printing package keys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the old days, original names were tied to PackageIds, which directly
+corresponded to the entities that users wrote in Cabal files, and were perfectly
+suitable for printing when we need to disambiguate packages. However, with
+PackageKey, the situation is different. First, the key is not a human readable
+at all, so we need to consult the package database to find the appropriate
+PackageId to display. Second, there may be multiple copies of a library visible
+with the same PackageId, in which case we need to disambiguate. For now,
+we just emit the actual package key (which the user can go look up); however,
+another scheme is to (recursively) say which dependencies are different.
+
+NB: When we extend package keys to also have holes, we will have to disambiguate
+those as well.
+
\begin{code}
-- | Creates some functions that work out the best ways to format
--- names for the user according to a set of heuristics
+-- names for the user according to a set of heuristics.
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
-mkPrintUnqualified dflags env = (qual_name, qual_mod)
+mkPrintUnqualified dflags env = QueryQualify qual_name
+ (mkQualModule dflags)
+ (mkQualPackage dflags)
where
qual_name mod occ
| [gre] <- unqual_gres
@@ -1445,18 +1464,48 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
-- "import M" would resolve unambiguously to P:M. (if P is the
-- current package we can just assume it is unqualified).
- qual_mod mod
- | modulePackageId mod == thisPackage dflags = False
+-- | Creates a function for formatting modules based on two heuristics:
+-- (1) if the module is the current module, don't qualify, and (2) if there
+-- is only one exposed package which exports this module, don't qualify.
+mkQualModule :: DynFlags -> QueryQualifyModule
+mkQualModule dflags mod
+ | modulePackageKey mod == thisPackage dflags = False
- | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup,
- exposed pkg && exposed_module],
- packageConfigId pkgconfig == modulePackageId mod
+ | [(_, pkgconfig)] <- lookup,
+ packageConfigId pkgconfig == modulePackageKey mod
-- this says: we are given a module P:M, is there just one exposed package
-- that exposes a module M, and is it package P?
= False
| otherwise = True
where lookup = lookupModuleInAllPackages dflags (moduleName mod)
+
+-- | Creates a function for formatting packages based on two heuristics:
+-- (1) don't qualify if the package in question is "main", and (2) only qualify
+-- with a package key if the package ID would be ambiguous.
+mkQualPackage :: DynFlags -> QueryQualifyPackage
+mkQualPackage dflags pkg_key
+ | pkg_key == mainPackageKey
+ -- Skip the lookup if it's main, since it won't be in the package
+ -- database!
+ = False
+ | searchPackageId dflags pkgid `lengthIs` 1
+ -- this says: we are given a package pkg-0.1@MMM, are there only one
+ -- exposed packages whose package ID is pkg-0.1?
+ = False
+ | otherwise
+ = True
+ where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key)))
+ (lookupPackage dflags pkg_key)
+ pkgid = sourcePackageId pkg
+
+-- | A function which only qualifies package names if necessary; but
+-- qualifies all other identifiers.
+pkgQual :: DynFlags -> PrintUnqualified
+pkgQual dflags = alwaysQualify {
+ queryQualifyPackage = mkQualPackage dflags
+ }
+
\end{code}
@@ -1904,7 +1953,7 @@ data Dependencies
-- I.e. modules that this one imports, or that are in the
-- dep_mods of those directly-imported modules
- , dep_pkgs :: [(PackageId, Bool)]
+ , dep_pkgs :: [(PackageKey, Bool)]
-- ^ All packages transitively below this module
-- I.e. packages to which this module's direct imports belong,
-- or that are in the dep_pkgs of those modules
@@ -2493,14 +2542,15 @@ trustInfoToNum it
Sf_Unsafe -> 1
Sf_Trustworthy -> 2
Sf_Safe -> 3
- Sf_SafeInferred -> 4
numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo 0 = setSafeMode Sf_None
numToTrustInfo 1 = setSafeMode Sf_Unsafe
numToTrustInfo 2 = setSafeMode Sf_Trustworthy
numToTrustInfo 3 = setSafeMode Sf_Safe
-numToTrustInfo 4 = setSafeMode Sf_SafeInferred
+numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used
+ -- to be Sf_SafeInfered but we no longer
+ -- differentiate.
numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"
instance Outputable IfaceTrustInfo where
@@ -2508,7 +2558,6 @@ instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe"
ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy"
ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe"
- ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred"
instance Binary IfaceTrustInfo where
put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index cfcc076235..d60cf56eba 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -879,7 +879,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
-- its full top-level scope available.
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
- if modulePackageId modl /= thisPackage (hsc_dflags h)
+ if modulePackageKey modl /= thisPackage (hsc_dflags h)
then return False
else case lookupUFM (hsc_HPT h) (moduleName modl) of
Just details -> return (isJust (mi_globals (hm_iface details)))
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 514a2e004f..864980be9d 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -9,8 +9,8 @@
module PackageConfig (
-- $package_naming
- -- * PackageId
- mkPackageId, packageConfigId,
+ -- * PackageKey
+ mkPackageKey, packageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
@@ -26,7 +26,8 @@ module PackageConfig (
import Distribution.InstalledPackageInfo
import Distribution.ModuleName
-import Distribution.Package hiding (PackageId)
+import Distribution.Package hiding (PackageKey, mkPackageKey)
+import qualified Distribution.Package as Cabal
import Distribution.Text
import Distribution.Version
@@ -43,31 +44,33 @@ defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
-- -----------------------------------------------------------------------------
--- PackageId (package names with versions)
+-- PackageKey (package names, versions and dep hash)
-- $package_naming
-- #package_naming#
--- Mostly the compiler deals in terms of 'PackageId's, which have the
--- form @<pkg>-<version>@. You're expected to pass in the version for
--- the @-package-name@ flag. However, for wired-in packages like @base@
--- & @rts@, we don't necessarily know what the version is, so these are
--- handled specially; see #wired_in_packages#.
+-- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes
+-- of a package ID, keys of its dependencies, and Cabal flags. You're expected
+-- to pass in the package key in the @-this-package-key@ flag. However, for
+-- wired-in packages like @base@ & @rts@, we don't necessarily know what the
+-- version is, so these are handled specially; see #wired_in_packages#.
--- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageId'
-mkPackageId :: PackageIdentifier -> PackageId
-mkPackageId = stringToPackageId . display
+-- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey'
+mkPackageKey :: Cabal.PackageKey -> PackageKey
+mkPackageKey = stringToPackageKey . display
--- | Get the GHC 'PackageId' right out of a Cabalish 'PackageConfig'
-packageConfigId :: PackageConfig -> PackageId
-packageConfigId = mkPackageId . sourcePackageId
+-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
+packageConfigId :: PackageConfig -> PackageKey
+packageConfigId = mkPackageKey . packageKey
-- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
-- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo
packageConfigToInstalledPackageInfo
(pkgconf@(InstalledPackageInfo { exposedModules = e,
+ reexportedModules = r,
hiddenModules = h })) =
pkgconf{ exposedModules = map convert e,
+ reexportedModules = map (fmap convert) r,
hiddenModules = map convert h }
where convert :: Module.ModuleName -> Distribution.ModuleName.ModuleName
convert = (expectJust "packageConfigToInstalledPackageInfo") . simpleParse . moduleNameString
@@ -77,7 +80,9 @@ packageConfigToInstalledPackageInfo
installedPackageInfoToPackageConfig :: InstalledPackageInfo_ String -> PackageConfig
installedPackageInfoToPackageConfig
(pkgconf@(InstalledPackageInfo { exposedModules = e,
+ reexportedModules = r,
hiddenModules = h })) =
pkgconf{ exposedModules = map mkModuleName e,
+ reexportedModules = map (fmap mkModuleName) r,
hiddenModules = map mkModuleName h }
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index bb2e048cc3..78c8059046 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -2,21 +2,29 @@
% (c) The University of Glasgow, 2006
%
\begin{code}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
-- | Package manipulation
module Packages (
module PackageConfig,
- -- * The PackageConfigMap
- PackageConfigMap, emptyPackageConfigMap, lookupPackage,
- extendPackageConfigMap, dumpPackages, simpleDumpPackages,
-
-- * Reading the package config, and processing cmdline args
- PackageState(..),
+ PackageState(preloadPackages),
initPackages,
+
+ -- * Querying the package config
+ lookupPackage,
+ resolveInstalledPackageId,
+ searchPackageId,
+ dumpPackages,
+ simpleDumpPackages,
getPackageDetails,
- lookupModuleInAllPackages, lookupModuleWithSuggestions,
+ listVisibleModuleNames,
+ lookupModuleInAllPackages,
+ lookupModuleWithSuggestions,
+ LookupResult(..),
+ ModuleSuggestion(..),
+ ModuleOrigin(..),
-- * Inspecting the set of packages in scope
getPackageIncludePath,
@@ -29,8 +37,12 @@ module Packages (
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs,
+ ModuleExport(..),
-- * Utils
+ packageKeyPackageIdString,
+ pprFlag,
+ pprModuleMap,
isDllName
)
where
@@ -51,10 +63,12 @@ import Maybes
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.InstalledPackageInfo.Binary
-import Distribution.Package hiding (PackageId,depends)
+import Distribution.Package hiding (depends, PackageKey, mkPackageKey)
+import Distribution.ModuleExport
import FastString
import ErrUtils ( debugTraceMsg, putMsg, MsgDoc )
import Exception
+import Unique
import System.Directory
import System.FilePath as FilePath
@@ -63,6 +77,7 @@ import Control.Monad
import Data.Char (isSpace)
import Data.List as List
import Data.Map (Map)
+import Data.Monoid hiding ((<>))
import qualified Data.Map as Map
import qualified FiniteMap as Map
import qualified Data.Set as Set
@@ -75,12 +90,18 @@ import qualified Data.Set as Set
-- provide.
--
-- The package state is computed by 'initPackages', and kept in DynFlags.
+-- It is influenced by various package flags:
--
--- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages
--- with the same name to become hidden.
+-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
+-- If @-hide-all-packages@ was not specified, these commands also cause
+-- all other packages with the same name to become hidden.
--
-- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
--
+-- * (there are a few more flags, check below for their semantics)
+--
+-- The package state has the following properties.
+--
-- * Let @exposedPackages@ be the set of packages thus exposed.
-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
-- their dependencies.
@@ -109,39 +130,166 @@ import qualified Data.Set as Set
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.
-data PackageState = PackageState {
- pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig
- -- The exposed flags are adjusted according to -package and
- -- -hide-package flags, and -ignore-package removes packages.
-
- preloadPackages :: [PackageId],
- -- The packages we're going to link in eagerly. This list
- -- should be in reverse dependency order; that is, a package
- -- is always mentioned before the packages it depends on.
-
- moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
- -- Derived from pkgIdMap.
- -- Maps Module to (pkgconf,exposed), where pkgconf is the
- -- PackageConfig for the package containing the module, and
- -- exposed is True if the package exposes that module.
+-- | Given a module name, there may be multiple ways it came into scope,
+-- possibly simultaneously. This data type tracks all the possible ways
+-- it could have come into scope. Warning: don't use the record functions,
+-- they're partial!
+data ModuleOrigin =
+ -- | Module is hidden, and thus never will be available for import.
+ -- (But maybe the user didn't realize), so we'll still keep track
+ -- of these modules.)
+ ModHidden
+ -- | Module is public, and could have come from some places.
+ | ModOrigin {
+ -- | @Just False@ means that this module is in
+ -- someone's @exported-modules@ list, but that package is hidden;
+ -- @Just True@ means that it is available; @Nothing@ means neither
+ -- applies.
+ fromOrigPackage :: Maybe Bool
+ -- | Is the module available from a reexport of an exposed package?
+ -- There could be multiple.
+ , fromExposedReexport :: [PackageConfig]
+ -- | Is the module available from a reexport of a hidden package?
+ , fromHiddenReexport :: [PackageConfig]
+ -- | Did the module export come from a package flag? (ToDo: track
+ -- more information.
+ , fromPackageFlag :: Bool
+ }
+
+instance Outputable ModuleOrigin where
+ ppr ModHidden = text "hidden module"
+ ppr (ModOrigin e res rhs f) = sep (punctuate comma (
+ (case e of
+ Nothing -> []
+ Just False -> [text "hidden package"]
+ Just True -> [text "exposed package"]) ++
+ (if null res
+ then []
+ else [text "reexport by" <+>
+ sep (map (ppr . packageConfigId) res)]) ++
+ (if null rhs
+ then []
+ else [text "hidden reexport by" <+>
+ sep (map (ppr . packageConfigId) res)]) ++
+ (if f then [text "package flag"] else [])
+ ))
+
+-- | Smart constructor for a module which is in @exposed-modules@. Takes
+-- as an argument whether or not the defining package is exposed.
+fromExposedModules :: Bool -> ModuleOrigin
+fromExposedModules e = ModOrigin (Just e) [] [] False
+
+-- | Smart constructor for a module which is in @reexported-modules@. Takes
+-- as an argument whether or not the reexporting package is expsed, and
+-- also its 'PackageConfig'.
+fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
+fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
+fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
+
+-- | Smart constructor for a module which was bound by a package flag.
+fromFlag :: ModuleOrigin
+fromFlag = ModOrigin Nothing [] [] True
+
+instance Monoid ModuleOrigin where
+ mempty = ModOrigin Nothing [] [] False
+ mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
+ ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
+ where g (Just b) (Just b')
+ | b == b' = Just b
+ | otherwise = panic "ModOrigin: package both exposed/hidden"
+ g Nothing x = x
+ g x Nothing = x
+ mappend _ _ = panic "ModOrigin: hidden module redefined"
+
+-- | Is the name from the import actually visible? (i.e. does it cause
+-- ambiguity, or is it only relevant when we're making suggestions?)
+originVisible :: ModuleOrigin -> Bool
+originVisible ModHidden = False
+originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
+
+-- | Are there actually no providers for this module? This will never occur
+-- except when we're filtering based on package imports.
+originEmpty :: ModuleOrigin -> Bool
+originEmpty (ModOrigin Nothing [] [] False) = True
+originEmpty _ = False
+
+-- | When we do a plain lookup (e.g. for an import), initially, all we want
+-- to know is if we can find it or not (and if we do and it's a reexport,
+-- what the real name is). If the find fails, we'll want to investigate more
+-- to give a good error message.
+data SimpleModuleConf =
+ SModConf Module PackageConfig ModuleOrigin
+ | SModConfAmbiguous
+
+-- | 'UniqFM' map from 'ModuleName'
+type ModuleNameMap = UniqFM
+
+-- | 'UniqFM' map from 'PackageKey'
+type PackageKeyMap = UniqFM
+
+-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
+type PackageConfigMap = PackageKeyMap PackageConfig
+
+-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
+-- are exposed should be dumped into scope, (2) any custom renamings that
+-- should also be apply, and (3) what package name is associated with the
+-- key, if it might be hidden
+type VisibilityMap =
+ PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)
+
+-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
+-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
+-- (since this is the slow path, we'll just look it up again).
+type ModuleToPkgConfAll =
+ Map ModuleName (Map Module ModuleOrigin)
+data PackageState = PackageState {
+ -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted
+ -- so that only valid packages are here. Currently, we also flip the
+ -- exposed/trusted bits based on package flags; however, the hope is to
+ -- stop doing that.
+ pkgIdMap :: PackageConfigMap,
+
+ -- | The packages we're going to link in eagerly. This list
+ -- should be in reverse dependency order; that is, a package
+ -- is always mentioned before the packages it depends on.
+ preloadPackages :: [PackageKey],
+
+ -- | This is a simplified map from 'ModuleName' to original 'Module' and
+ -- package configuration providing it.
+ moduleToPkgConf :: ModuleNameMap SimpleModuleConf,
+
+ -- | This is a full map from 'ModuleName' to all modules which may possibly
+ -- be providing it. These providers may be hidden (but we'll still want
+ -- to report them in error messages), or it may be an ambiguous import.
+ moduleToPkgConfAll :: ModuleToPkgConfAll,
+
+ -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
+ -- internally deals in package keys but the database may refer to installed
+ -- package IDs.
installedPackageIdMap :: InstalledPackageIdMap
}
--- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
-type PackageConfigMap = UniqFM PackageConfig
-
-type InstalledPackageIdMap = Map InstalledPackageId PackageId
-
+type InstalledPackageIdMap = Map InstalledPackageId PackageKey
type InstalledPackageIndex = Map InstalledPackageId PackageConfig
+-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
--- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any
-lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig
-lookupPackage = lookupUFM
+-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
+lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
+lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
+
+lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
+lookupPackage' = lookupUFM
+
+-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
+searchPackageId :: DynFlags -> PackageId -> [PackageConfig]
+searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
+ (listPackageConfigMap dflags)
+-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap pkg_map new_pkgs
@@ -150,8 +298,20 @@ extendPackageConfigMap pkg_map new_pkgs
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
-getPackageDetails :: PackageState -> PackageId -> PackageConfig
-getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
+getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
+getPackageDetails dflags pid =
+ expectJust "getPackageDetails" (lookupPackage dflags pid)
+
+-- | Get a list of entries from the package database. NB: be careful with
+-- this function, it may not do what you expect it to.
+listPackageConfigMap :: DynFlags -> [PackageConfig]
+listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
+
+-- | Looks up a 'PackageKey' given an 'InstalledPackageId'
+resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
+resolveInstalledPackageId dflags ipid =
+ expectJust "resolveInstalledPackageId"
+ (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state
@@ -169,7 +329,7 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'pkgState' in 'DynFlags' and return a list of packages to
-- link in.
-initPackages :: DynFlags -> IO (DynFlags, [PackageId])
+initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
initPackages dflags = do
pkg_db <- case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags
@@ -251,17 +411,12 @@ readPackageConfig dflags conf_file = do
return pkg_configs2
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
-setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs
+setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
where
- maybeHideAll pkgs'
- | gopt Opt_HideAllPackages dflags = map hide pkgs'
- | otherwise = pkgs'
-
maybeDistrustAll pkgs'
| gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
| otherwise = pkgs'
- hide pkg = pkg{ exposed = False }
distrust pkg = pkg{ trusted = False }
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
@@ -318,75 +473,88 @@ mungePackagePaths top_dir pkgroot pkg =
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).
+-- | A horrible hack, the problem is the package key we'll turn
+-- up here is going to get edited when we select the wired in
+-- packages, so preemptively pick up the right one. Also, this elem
+-- test is slow. The alternative is to change wired in packages first, but
+-- then we are no longer able to match against package keys e.g. from when
+-- a user passes in a package flag.
+calcKey :: PackageConfig -> PackageKey
+calcKey p | pk <- display (pkgName (sourcePackageId p))
+ , pk `elem` wired_in_pkgids
+ = stringToPackageKey pk
+ | otherwise = packageConfigId p
+
applyPackageFlag
:: DynFlags
-> UnusablePackages
- -> [PackageConfig] -- Initial database
+ -> ([PackageConfig], VisibilityMap) -- Initial database
-> PackageFlag -- flag to apply
- -> IO [PackageConfig] -- new database
+ -> IO ([PackageConfig], VisibilityMap) -- new database
-applyPackageFlag dflags unusable pkgs flag =
- case flag of
- ExposePackage str ->
- case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr dflags flag ps
- Right (p:ps,qs) -> return (p':ps')
- where p' = p {exposed=True}
- ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
- _ -> panic "applyPackageFlag"
+-- ToDo: Unfortunately, we still have to plumb the package config through,
+-- because Safe Haskell trust is still implemented by modifying the database.
+-- Eventually, track that separately and then axe @[PackageConfig]@ from
+-- this fold entirely
- ExposePackageId str ->
- case selectPackages (matchingId str) pkgs unusable of
+applyPackageFlag dflags unusable (pkgs, vm) flag =
+ case flag of
+ ExposePackage arg m_rns ->
+ case selectPackages (matching arg) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
- Right (p:ps,qs) -> return (p':ps')
- where p' = p {exposed=True}
- ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
+ Right (p:_,_) -> return (pkgs, vm')
+ where
+ n = fsPackageName p
+ vm' = addToUFM_C edit vm_cleared (calcKey p)
+ (case m_rns of
+ Nothing -> (True, [], n)
+ Just rns' -> (False, map convRn rns', n))
+ edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
+ convRn (a,b) = (mkModuleName a, mkModuleName b)
+ -- ToDo: ATM, -hide-all-packages implicitly triggers change in
+ -- behavior, maybe eventually make it toggleable with a separate
+ -- flag
+ vm_cleared | gopt Opt_HideAllPackages dflags = vm
+ -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide
+ -- other versions of foo. Presence of renaming means
+ -- user probably wanted both.
+ | Just _ <- m_rns = vm
+ | otherwise = filterUFM_Directly
+ (\k (_,_,n') -> k == getUnique (calcKey p)
+ || n /= n') vm
_ -> panic "applyPackageFlag"
HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
- Right (ps,qs) -> return (map hide ps ++ qs)
- where hide p = p {exposed=False}
+ Right (ps,_) -> return (pkgs, vm')
+ where vm' = delListFromUFM vm (map calcKey ps)
-- we trust all matching packages. Maybe should only trust first one?
-- and leave others the same or set them untrusted
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
- Right (ps,qs) -> return (map trust ps ++ qs)
+ Right (ps,qs) -> return (map trust ps ++ qs, vm)
where trust p = p {trusted=True}
DistrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
- Right (ps,qs) -> return (map distrust ps ++ qs)
+ Right (ps,qs) -> return (map distrust ps ++ qs, vm)
where distrust p = p {trusted=False}
- _ -> panic "applyPackageFlag"
-
- where
- -- When a package is requested to be exposed, we hide all other
- -- packages with the same name.
- hideAll name ps = map maybe_hide ps
- where maybe_hide p
- | pkgName (sourcePackageId p) == name = p {exposed=False}
- | otherwise = p
-
+ IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)]
([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
- = let
- (ps,rest) = partition matches pkgs
- reasons = [ (p, Map.lookup (installedPackageId p) unusable)
- | p <- ps ]
- in
- if all (isJust.snd) reasons
- then Left [ (p, reason) | (p,Just reason) <- reasons ]
- else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest)
+ = let (ps,rest) = partition matches pkgs
+ in if null ps
+ then Left (filter (matches.fst) (Map.elems unusable))
+ else Right (sortByVersion ps, rest)
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
@@ -398,6 +566,14 @@ matchingStr str p
matchingId :: String -> PackageConfig -> Bool
matchingId str p = InstalledPackageId str == installedPackageId p
+matchingKey :: String -> PackageConfig -> Bool
+matchingKey str p = str == display (packageKey p)
+
+matching :: PackageArg -> PackageConfig -> Bool
+matching (PackageArg str) = matchingStr str
+matching (PackageIdArg str) = matchingId str
+matching (PackageKeyArg str) = matchingKey str
+
sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
@@ -411,7 +587,8 @@ packageFlagErr :: DynFlags
-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
-packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
+packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
+ | is_dph_package pkg
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
where dph_err = text "the " <> text pkg <> text " package is not installed."
$$ text "To install it: \"cabal install dph\"."
@@ -419,50 +596,37 @@ packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
packageFlagErr dflags flag reasons
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
- where err = text "cannot satisfy " <> ppr_flag <>
+ where err = text "cannot satisfy " <> pprFlag flag <>
(if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$
+ -- ToDo: this admonition seems a bit dodgy
text "(use -v for more information)")
- ppr_flag = case flag of
- IgnorePackage p -> text "-ignore-package " <> text p
- HidePackage p -> text "-hide-package " <> text p
- ExposePackage p -> text "-package " <> text p
- ExposePackageId p -> text "-package-id " <> text p
- TrustPackage p -> text "-trust " <> text p
- DistrustPackage p -> text "-distrust " <> text p
ppr_reasons = vcat (map ppr_reason reasons)
ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
--- -----------------------------------------------------------------------------
--- Hide old versions of packages
-
---
--- hide all packages for which there is also a later version
--- that is already exposed. This just makes it non-fatal to have two
--- versions of a package exposed, which can happen if you install a
--- later version of a package in the user database, for example.
---
-hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig]
-hideOldPackages dflags pkgs = mapM maybe_hide pkgs
- where maybe_hide p
- | not (exposed p) = return p
- | (p' : _) <- later_versions = do
- debugTraceMsg dflags 2 $
- (ptext (sLit "hiding package") <+> pprSPkg p <+>
- ptext (sLit "to avoid conflict with later version") <+>
- pprSPkg p')
- return (p {exposed=False})
- | otherwise = return p
- where myname = pkgName (sourcePackageId p)
- myversion = pkgVersion (sourcePackageId p)
- later_versions = [ p | p <- pkgs, exposed p,
- let pkg = sourcePackageId p,
- pkgName pkg == myname,
- pkgVersion pkg > myversion ]
+pprFlag :: PackageFlag -> SDoc
+pprFlag flag = case flag of
+ IgnorePackage p -> text "-ignore-package " <> text p
+ HidePackage p -> text "-hide-package " <> text p
+ ExposePackage a rns -> ppr_arg a <> ppr_rns rns
+ TrustPackage p -> text "-trust " <> text p
+ DistrustPackage p -> text "-distrust " <> text p
+ where ppr_arg arg = case arg of
+ PackageArg p -> text "-package " <> text p
+ PackageIdArg p -> text "-package-id " <> text p
+ PackageKeyArg p -> text "-package-key " <> text p
+ ppr_rns Nothing = empty
+ ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns))
+ <> char ')'
+ ppr_rn (orig, new) | orig == new = text orig
+ | otherwise = text orig <+> text "as" <+> text new
-- -----------------------------------------------------------------------------
-- Wired-in packages
+wired_in_pkgids :: [String]
+wired_in_pkgids = map packageKeyString wiredInPackageKeys
+
findWiredInPackages
:: DynFlags
-> [PackageConfig] -- database
@@ -474,16 +638,6 @@ findWiredInPackages dflags pkgs = do
-- their canonical names (eg. base-1.0 ==> base).
--
let
- wired_in_pkgids :: [String]
- wired_in_pkgids = map packageIdString
- [ primPackageId,
- integerPackageId,
- basePackageId,
- rtsPackageId,
- thPackageId,
- dphSeqPackageId,
- dphParPackageId ]
-
matches :: PackageConfig -> String -> Bool
pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
@@ -493,9 +647,10 @@ findWiredInPackages dflags pkgs = do
-- one.
--
-- When choosing which package to map to a wired-in package
- -- name, we prefer exposed packages, and pick the latest
- -- version. To override the default choice, -hide-package
- -- could be used to hide newer versions.
+ -- name, we pick the latest version (modern Cabal makes it difficult
+ -- to install multiple versions of wired-in packages, however!)
+ -- To override the default choice, -ignore-package could be used to
+ -- hide newer versions.
--
findWiredInPackage :: [PackageConfig] -> String
-> IO (Maybe InstalledPackageId)
@@ -542,7 +697,9 @@ findWiredInPackages dflags pkgs = do
updateWiredInDependencies pkgs = map upd_pkg pkgs
where upd_pkg p
| installedPackageId p `elem` wired_in_ids
- = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
+ = let pid = (sourcePackageId p) { pkgVersion = Version [] [] }
+ in p { sourcePackageId = pid
+ , packageKey = OldPackageKey pid }
| otherwise
= p
@@ -555,7 +712,8 @@ data UnusablePackageReason
| MissingDependencies [InstalledPackageId]
| ShadowedBy InstalledPackageId
-type UnusablePackages = Map InstalledPackageId UnusablePackageReason
+type UnusablePackages = Map InstalledPackageId
+ (PackageConfig, UnusablePackageReason)
pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
@@ -571,7 +729,7 @@ pprReason pref reason = case reason of
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
where
- report (ipid, reason) =
+ report (ipid, (_, reason)) =
debugTraceMsg dflags 2 $
pprReason
(ptext (sLit "package") <+>
@@ -591,7 +749,7 @@ findBroken pkgs = go [] Map.empty pkgs
go avail ipids not_avail =
case partitionWith (depsAvailable ipids) not_avail of
([], not_avail) ->
- Map.fromList [ (installedPackageId p, MissingDependencies deps)
+ Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
| (p,deps) <- not_avail ]
(new_avail, not_avail) ->
go (new_avail ++ avail) new_ipids (map fst not_avail)
@@ -620,19 +778,20 @@ shadowPackages pkgs preferred
in Map.fromList shadowed
where
check (shadowed,pkgmap) pkg
- | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
+ | Just oldpkg <- lookupUFM pkgmap pkgid
, let
ipid_new = installedPackageId pkg
ipid_old = installedPackageId oldpkg
--
, ipid_old /= ipid_new
= if ipid_old `elem` preferred
- then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
- else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
+ then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
+ else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
| otherwise
= (shadowed, pkgmap')
where
- pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
+ pkgid = mkFastString (display (sourcePackageId pkg))
+ pkgmap' = addToUFM pkgmap pkgid pkg
-- -----------------------------------------------------------------------------
@@ -641,7 +800,7 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
- (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
+ (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
| p <- ps ]
-- missing package is not an error for -ignore-package,
-- because a common usage is to -ignore-package P as
@@ -669,11 +828,11 @@ depClosure index ipids = closure Map.empty ipids
mkPackageState
:: DynFlags
-> [PackageConfig] -- initial database
- -> [PackageId] -- preloaded packages
- -> PackageId -- this package
+ -> [PackageKey] -- preloaded packages
+ -> PackageKey -- this package
-> IO (PackageState,
- [PackageId], -- new packages to preload
- PackageId) -- this package, might be modified if the current
+ [PackageKey], -- new packages to preload
+ PackageKey) -- this package, might be modified if the current
-- package is a wired-in package.
mkPackageState dflags pkgs0 preload0 this_package = do
@@ -684,12 +843,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do
1. P = transitive closure of packages selected by -package-id
2. Apply shadowing. When there are multiple packages with the same
- sourcePackageId,
+ packageKey,
* if one is in P, use that one
* otherwise, use the one highest in the package stack
[
- rationale: we cannot use two packages with the same sourcePackageId
- in the same program, because sourcePackageId is the symbol prefix.
+ rationale: we cannot use two packages with the same packageKey
+ in the same program, because packageKey is the symbol prefix.
Hence we must select a consistent set of packages to use. We have
a default algorithm for doing this: packages higher in the stack
shadow those lower down. This default algorithm can be overriden
@@ -737,30 +896,64 @@ mkPackageState dflags pkgs0 preload0 this_package = do
ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
- ipid_selected = depClosure ipid_map [ InstalledPackageId i
- | ExposePackageId i <- flags ]
+ ipid_selected = depClosure ipid_map
+ [ InstalledPackageId i
+ | ExposePackage (PackageIdArg i) _ <- flags ]
(ignore_flags, other_flags) = partition is_ignore flags
is_ignore IgnorePackage{} = True
is_ignore _ = False
shadowed = shadowPackages pkgs0_unique ipid_selected
-
ignored = ignorePackages ignore_flags pkgs0_unique
- pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
+ isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
+ pkgs0' = filter (not . isBroken) pkgs0_unique
+
broken = findBroken pkgs0'
+
unusable = shadowed `Map.union` ignored `Map.union` broken
+ pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'
reportUnusable dflags unusable
--
+ -- Calculate the initial set of packages, prior to any package flags.
+ -- This set contains the latest version of all valid (not unusable) packages,
+ -- or is empty if we have -hide-all-packages
+ --
+ let preferLater pkg pkg' =
+ case comparing (pkgVersion.sourcePackageId) pkg pkg' of
+ GT -> pkg
+ _ -> pkg'
+ calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
+ initial = if gopt Opt_HideAllPackages dflags
+ then emptyUFM
+ else foldl' calcInitial emptyUFM pkgs1
+ vis_map0 = foldUFM (\p vm ->
+ if exposed p
+ then addToUFM vm (calcKey p)
+ (True, [], fsPackageName p)
+ else vm)
+ emptyUFM initial
+
+ --
-- Modify the package database according to the command-line flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages).
+ -- This needs to know about the unusable packages, since if a user tries
+ -- to enable an unusable package, we should let them know.
--
- pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags
- let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
+ (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable)
+ (pkgs1, vis_map0) other_flags
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the package keys of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ pkgs3 <- findWiredInPackages dflags pkgs2
+
+ --
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
-- packages. we link these packages in eagerly. The preload set
@@ -769,22 +962,15 @@ mkPackageState dflags pkgs0 preload0 this_package = do
--
let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
- get_exposed (ExposePackage s)
- = take 1 $ sortByVersion (filter (matchingStr s) pkgs2)
- -- -package P means "the latest version of P" (#7030)
- get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2
- get_exposed _ = []
+ get_exposed (ExposePackage a _) = take 1 . sortByVersion
+ . filter (matching a)
+ $ pkgs2
+ get_exposed _ = []
- -- hide packages that are subsumed by later versions
- pkgs3 <- hideOldPackages dflags pkgs2
-
- -- sort out which packages are wired in
- pkgs4 <- findWiredInPackages dflags pkgs3
-
- let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
+ let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
- | p <- pkgs4 ]
+ | p <- pkgs3 ]
lookupIPID ipid@(InstalledPackageId str)
| Just pid <- Map.lookup ipid ipid_map = return pid
@@ -796,7 +982,8 @@ mkPackageState dflags pkgs0 preload0 this_package = do
-- add base & rts to the preload packages
basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags
- = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
+ = filter (flip elemUFM pkg_db)
+ [basePackageKey, rtsPackageKey]
| otherwise = []
-- but in any case remove the current package from the set of
-- preloaded packages so that base/rts does not end up in the
@@ -808,36 +995,118 @@ mkPackageState dflags pkgs0 preload0 this_package = do
dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
- let pstate = PackageState{ preloadPackages = dep_preload,
- pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleMap pkg_db,
- installedPackageIdMap = ipid_map
- }
-
+ let pstate = PackageState{
+ preloadPackages = dep_preload,
+ pkgIdMap = pkg_db,
+ moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map,
+ moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
+ installedPackageIdMap = ipid_map
+ }
return (pstate, new_dep_preload, this_package)
-- -----------------------------------------------------------------------------
--- Make the mapping from module to package info
-
-mkModuleMap
- :: PackageConfigMap
- -> UniqFM [(PackageConfig, Bool)]
-mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
- where
- pkgids = map packageConfigId (eltsUFM pkg_db)
-
- extend_modmap pkgid modmap =
- addListToUFM_C (++) modmap
- ([(m, [(pkg, True)]) | m <- exposed_mods] ++
- [(m, [(pkg, False)]) | m <- hidden_mods])
- where
- pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
- exposed_mods = exposedModules pkg
- hidden_mods = hiddenModules pkg
-
-pprSPkg :: PackageConfig -> SDoc
-pprSPkg p = text (display (sourcePackageId p))
+-- | Makes the mapping from module to package info
+
+-- | This function is generic; we instantiate it
+mkModuleToPkgConfGeneric
+ :: forall m e.
+ -- Empty map, e.g. the initial state of the output
+ m e
+ -- How to create an entry in the map based on the calculated information
+ -> (PackageKey -> ModuleName -> PackageConfig -> ModuleOrigin -> e)
+ -- How to override the origin of an entry (used for renaming)
+ -> (e -> ModuleOrigin -> e)
+ -- How to incorporate a list of entries into the map
+ -> (m e -> [(ModuleName, e)] -> m e)
+ -- The proper arguments
+ -> DynFlags
+ -> PackageConfigMap
+ -> InstalledPackageIdMap
+ -> VisibilityMap
+ -> m e
+mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
+ dflags pkg_db ipid_map vis_map =
+ foldl' extend_modmap emptyMap (eltsUFM pkg_db)
+ where
+ extend_modmap modmap pkg = addListTo modmap theBindings
+ where
+ theBindings :: [(ModuleName, e)]
+ theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
+ = newBindings b rns
+ | otherwise = newBindings False []
+
+ newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, e)]
+ newBindings e rns = es e ++ hiddens ++ map rnBinding rns
+
+ rnBinding :: (ModuleName, ModuleName) -> (ModuleName, e)
+ rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
+ where origEntry = case lookupUFM esmap orig of
+ Just r -> r
+ Nothing -> throwGhcException (CmdLineError (showSDoc dflags
+ (text "package flag: could not find module name" <+>
+ ppr orig <+> text "in package" <+> ppr pk)))
+
+ es :: Bool -> [(ModuleName, e)]
+ es e =
+ [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++
+ [(m, sing pk' m' pkg' (fromReexportedModules e pkg))
+ | ModuleExport{ exportName = m
+ , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods
+ , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
+ pkg' = pkg_lookup pk' ]
+
+ esmap :: UniqFM e
+ esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
+ -- be overwritten
+
+ hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
+
+ pk = packageConfigId pkg
+ pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
+
+ exposed_mods = exposedModules pkg
+ reexported_mods = reexportedModules pkg
+ hidden_mods = hiddenModules pkg
+
+-- | This is a quick and efficient module map, which only contains an entry
+-- if it is specified unambiguously.
+mkModuleToPkgConf
+ :: DynFlags
+ -> PackageConfigMap
+ -> InstalledPackageIdMap
+ -> VisibilityMap
+ -> ModuleNameMap SimpleModuleConf
+mkModuleToPkgConf =
+ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
+ where emptyMap = emptyUFM
+ sing pk m pkg = SModConf (mkModule pk m) pkg
+ -- NB: don't put hidden entries in the map, they're not valid!
+ addListTo m xs = addListToUFM_C merge m (filter isVisible xs)
+ isVisible (_, SModConf _ _ o) = originVisible o
+ isVisible (_, SModConfAmbiguous) = False
+ merge (SModConf m pkg o) (SModConf m' _ o')
+ | m == m' = SModConf m pkg (o `mappend` o')
+ | otherwise = SModConfAmbiguous
+ merge _ _ = SModConfAmbiguous
+ setOrigins (SModConf m pkg _) os = SModConf m pkg os
+ setOrigins SModConfAmbiguous _ = SModConfAmbiguous
+
+-- | This is a slow and complete map, which includes information about
+-- everything, including hidden modules
+mkModuleToPkgConfAll
+ :: DynFlags
+ -> PackageConfigMap
+ -> InstalledPackageIdMap
+ -> VisibilityMap
+ -> ModuleToPkgConfAll
+mkModuleToPkgConfAll =
+ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
+ where emptyMap = Map.empty
+ sing pk m _ = Map.singleton (mkModule pk m)
+ addListTo = foldl' merge
+ merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
+ setOrigins m os = fmap (const os) m
pprIPkg :: PackageConfig -> SDoc
pprIPkg p = text (display (installedPackageId p))
@@ -854,7 +1123,7 @@ pprIPkg p = text (display (installedPackageId p))
-- use.
-- | Find all the include directories in these and the preload packages
-getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
+getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String]
getPackageIncludePath dflags pkgs =
collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
@@ -862,7 +1131,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
-- | Find all the library paths in these and the preload packages
-getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
+getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String]
getPackageLibraryPath dflags pkgs =
collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
@@ -871,7 +1140,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
-getPackageLinkOpts :: DynFlags -> [PackageId] -> IO ([String], [String], [String])
+getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String])
getPackageLinkOpts dflags pkgs =
collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
@@ -919,19 +1188,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
| otherwise = '_':t
-- | Find all the C-compiler options in these and the preload packages
-getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
+getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap ccOptions ps)
-- | Find all the package framework paths in these and the preload packages
-getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String]
+getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (nub (filter notNull (concatMap frameworkDirs ps)))
-- | Find all the package frameworks in these and the preload packages
-getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String]
+getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String]
getPackageFrameworks dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap frameworks ps)
@@ -939,41 +1208,114 @@ getPackageFrameworks dflags pkgs = do
-- -----------------------------------------------------------------------------
-- Package Utils
--- | Takes a 'Module', and if the module is in a package returns
--- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
--- and exposed is @True@ if the package exposes the module.
-lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
+-- | Takes a 'ModuleName', and if the module is in any package returns
+-- list of modules which take that name.
+lookupModuleInAllPackages :: DynFlags
+ -> ModuleName
+ -> [(Module, PackageConfig)]
lookupModuleInAllPackages dflags m
- = case lookupModuleWithSuggestions dflags m of
- Right pbs -> pbs
- Left _ -> []
-
-lookupModuleWithSuggestions
- :: DynFlags -> ModuleName
- -> Either [Module] [(PackageConfig,Bool)]
- -- Lookup module in all packages
- -- Right pbs => found in pbs
- -- Left ms => not found; but here are sugestions
-lookupModuleWithSuggestions dflags m
- = case lookupUFM (moduleToPkgConfAll pkg_state) m of
- Nothing -> Left suggestions
- Just ps -> Right ps
+ = case lookupModuleWithSuggestions dflags m Nothing of
+ LookupFound a b -> [(a,b)]
+ LookupMultiple rs -> map f rs
+ where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
+ (modulePackageKey m)))
+ _ -> []
+
+-- | The result of performing a lookup
+data LookupResult =
+ -- | Found the module uniquely, nothing else to do
+ LookupFound Module PackageConfig
+ -- | Multiple modules with the same name in scope
+ | LookupMultiple [(Module, ModuleOrigin)]
+ -- | No modules found, but there were some hidden ones with
+ -- an exact name match. First is due to package hidden, second
+ -- is due to module being hidden
+ | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
+ -- | Nothing found, here are some suggested different names
+ | LookupNotFound [ModuleSuggestion] -- suggestions
+
+data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
+ | SuggestHidden ModuleName Module ModuleOrigin
+
+lookupModuleWithSuggestions :: DynFlags
+ -> ModuleName
+ -> Maybe FastString
+ -> LookupResult
+lookupModuleWithSuggestions dflags m mb_pn
+ = case lookupUFM (moduleToPkgConf pkg_state) m of
+ Just (SModConf m pkg o) | matches mb_pn pkg o ->
+ ASSERT( originVisible o ) LookupFound m pkg
+ _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of
+ Nothing -> LookupNotFound suggestions
+ Just xs ->
+ case foldl' classify ([],[],[]) (Map.toList xs) of
+ ([], [], []) -> LookupNotFound suggestions
+ -- NB: Yes, we have to check this case too, since package qualified
+ -- imports could cause the main lookup to fail due to ambiguity,
+ -- but the second lookup to succeed.
+ (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
+ (_, _, exposed@(_:_)) -> LookupMultiple exposed
+ (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
where
+ classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
+ let origin = filterOrigin mb_pn (mod_pkg m) origin0
+ x = (m, origin)
+ in case origin of
+ ModHidden -> (hidden_pkg, x:hidden_mod, exposed)
+ _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed)
+ | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
+ | otherwise -> (x:hidden_pkg, hidden_mod, exposed)
+
+ pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
pkg_state = pkgState dflags
+ mod_pkg = pkg_lookup . modulePackageKey
+
+ matches Nothing _ _ = True -- shortcut for efficiency
+ matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o)
+
+ -- Filters out origins which are not associated with the given package
+ -- qualifier. No-op if there is no package qualifier. Test if this
+ -- excluded all origins with 'originEmpty'.
+ filterOrigin :: Maybe FastString
+ -> PackageConfig
+ -> ModuleOrigin
+ -> ModuleOrigin
+ filterOrigin Nothing _ o = o
+ filterOrigin (Just pn) pkg o =
+ case o of
+ ModHidden -> if go pkg then ModHidden else mempty
+ ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
+ fromHiddenReexport = rhs }
+ -> ModOrigin {
+ fromOrigPackage = if go pkg then e else Nothing
+ , fromExposedReexport = filter go res
+ , fromHiddenReexport = filter go rhs
+ , fromPackageFlag = False -- always excluded
+ }
+ where go pkg = pn == fsPackageName pkg
+
suggestions
| gopt Opt_HelpfulErrors dflags =
fuzzyLookup (moduleNameString m) all_mods
| otherwise = []
- all_mods :: [(String, Module)] -- All modules
- all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm)
- | pkg_config <- eltsUFM (pkgIdMap pkg_state)
- , let pkg_id = packageConfigId pkg_config
- , mod_nm <- exposedModules pkg_config ]
+ all_mods :: [(String, ModuleSuggestion)] -- All modules
+ all_mods = sortBy (comparing fst) $
+ [ (moduleNameString m, suggestion)
+ | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
+ , suggestion <- map (getSuggestion m) (Map.toList e)
+ ]
+ getSuggestion name (mod, origin) =
+ (if originVisible origin then SuggestVisible else SuggestHidden)
+ name mod origin
+
+listVisibleModuleNames :: DynFlags -> [ModuleName]
+listVisibleModuleNames dflags =
+ Map.keys (moduleToPkgConfAll (pkgState dflags))
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
-getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
+getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
let
state = pkgState dflags
@@ -983,15 +1325,15 @@ getPreloadPackagesAnd dflags pkgids =
pairs = zip pkgids (repeat Nothing)
in do
all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
- return (map (getPackageDetails state) all_pkgs)
+ return (map (getPackageDetails dflags) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
closeDeps :: DynFlags
-> PackageConfigMap
- -> Map InstalledPackageId PackageId
- -> [(PackageId, Maybe PackageId)]
- -> IO [PackageId]
+ -> Map InstalledPackageId PackageKey
+ -> [(PackageKey, Maybe PackageKey)]
+ -> IO [PackageKey]
closeDeps dflags pkg_map ipid_map ps
= throwErr dflags (closeDepsErr pkg_map ipid_map ps)
@@ -1002,22 +1344,22 @@ throwErr dflags m
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
- -> Map InstalledPackageId PackageId
- -> [(PackageId,Maybe PackageId)]
- -> MaybeErr MsgDoc [PackageId]
+ -> Map InstalledPackageId PackageKey
+ -> [(PackageKey,Maybe PackageKey)]
+ -> MaybeErr MsgDoc [PackageKey]
closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
-- internal helper
add_package :: PackageConfigMap
- -> Map InstalledPackageId PackageId
- -> [PackageId]
- -> (PackageId,Maybe PackageId)
- -> MaybeErr MsgDoc [PackageId]
+ -> Map InstalledPackageId PackageKey
+ -> [PackageKey]
+ -> (PackageKey,Maybe PackageKey)
+ -> MaybeErr MsgDoc [PackageKey]
add_package pkg_db ipid_map ps (p, mb_parent)
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
- case lookupPackage pkg_db p of
- Nothing -> Failed (missingPackageMsg (packageIdString p) <>
+ case lookupPackage' pkg_db p of
+ Nothing -> Failed (missingPackageMsg (packageKeyString p) <>
missingDependencyMsg mb_parent)
Just pkg -> do
-- Add the package's dependents also
@@ -1037,15 +1379,22 @@ missingPackageErr dflags p
missingPackageMsg :: String -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
-missingDependencyMsg :: Maybe PackageId -> SDoc
+missingDependencyMsg :: Maybe PackageKey -> SDoc
missingDependencyMsg Nothing = empty
missingDependencyMsg (Just parent)
- = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent))
+ = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
-- -----------------------------------------------------------------------------
+packageKeyPackageIdString :: DynFlags -> PackageKey -> String
+packageKeyPackageIdString dflags pkg_key
+ | pkg_key == mainPackageKey = "main"
+ | otherwise = maybe "(unknown)"
+ (display . sourcePackageId)
+ (lookupPackage dflags pkg_key)
+
-- | Will the 'Name' come from a dynamically linked library?
-isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool
+isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that
-- the synbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows
@@ -1086,11 +1435,10 @@ dumpPackages = dumpPackages' showInstalledPackageInfo
dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO ()
dumpPackages' showIPI dflags
- = do let pkg_map = pkgIdMap (pkgState dflags)
- putMsg dflags $
+ = do putMsg dflags $
vcat (map (text . showIPI
. packageConfigToInstalledPackageInfo)
- (eltsUFM pkg_map))
+ (listPackageConfigMap dflags))
-- | Show simplified package info on console, if verbosity == 4.
-- The idea is to only print package id, and any information that might
@@ -1102,4 +1450,18 @@ simpleDumpPackages = dumpPackages' showIPI
t = if trusted ipi then "T" else " "
in e ++ t ++ " " ++ i
+-- | Show the mapping of modules to where they come from.
+pprModuleMap :: DynFlags -> SDoc
+pprModuleMap dflags =
+ vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
+ where
+ pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
+ pprEntry m (m',o)
+ | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o)
+ | otherwise = ppr m' <+> parens (ppr o)
+
+fsPackageName :: PackageConfig -> FastString
+fsPackageName pkg = case packageName (sourcePackageId pkg) of
+ PackageName n -> mkFastString n
+
\end{code}
diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.lhs-boot
index 3a1712e2da..3fd0fd5422 100644
--- a/compiler/main/Packages.lhs-boot
+++ b/compiler/main/Packages.lhs-boot
@@ -1,4 +1,8 @@
\begin{code}
module Packages where
+-- Well, this is kind of stupid...
+import {-# SOURCE #-} Module (PackageKey)
+import {-# SOURCE #-} DynFlags (DynFlags)
data PackageState
+packageKeyPackageIdString :: DynFlags -> PackageKey -> String
\end{code}
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index d993ab87c8..eed4671b67 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -7,19 +7,12 @@
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module PprTyThing (
- pprTyThing,
- pprTyThingInContext,
- pprTyThingLoc,
- pprTyThingInContextLoc,
- pprTyThingHdr,
+ pprTyThing,
+ pprTyThingInContext,
+ pprTyThingLoc,
+ pprTyThingInContextLoc,
+ pprTyThingHdr,
pprTypeForUser,
pprFamInst
) where
@@ -159,9 +152,9 @@ pprTypeForUser :: Type -> SDoc
-- b) Swizzle the foralls to the top, so that without
-- -fprint-explicit-foralls we'll suppress all the foralls
-- Prime example: a class op might have type
--- forall a. C a => forall b. Ord b => stuff
+-- forall a. C a => forall b. Ord b => stuff
-- Then we want to display
--- (C a, Ord b) => stuff
+-- (C a, Ord b) => stuff
pprTypeForUser ty
= pprSigmaType (mkSigmaTy tvs ctxt tau)
where
@@ -175,6 +168,6 @@ pprTypeForUser ty
showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
- -- The tab tries to make them line up a bit
+ -- The tab tries to make them line up a bit
where
comment = ptext (sLit "--")
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 51d5af137c..1c1c52cd1f 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -235,6 +235,8 @@ initSysTools mbMinusB
-- to make that possible, so for now you can't.
gcc_prog <- getSetting "C compiler command"
gcc_args_str <- getSetting "C compiler flags"
+ cpp_prog <- getSetting "Haskell CPP command"
+ cpp_args_str <- getSetting "Haskell CPP flags"
let unreg_gcc_args = if targetUnregisterised
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
@@ -243,6 +245,7 @@ initSysTools mbMinusB
| mkTablesNextToCode targetUnregisterised
= ["-DTABLES_NEXT_TO_CODE"]
| otherwise = []
+ cpp_args= map Option (words cpp_args_str)
gcc_args = map Option (words gcc_args_str
++ unreg_gcc_args
++ tntc_gcc_args)
@@ -285,10 +288,7 @@ initSysTools mbMinusB
-- cpp is derived from gcc on all platforms
-- HACK, see setPgmP below. We keep 'words' here to remember to fix
-- Config.hs one day.
- let cpp_prog = gcc_prog
- cpp_args = Option "-E"
- : map Option (words cRAWCPP_FLAGS)
- ++ gcc_args
+
-- Other things being equal, as and ld are simply gcc
gcc_link_args_str <- getSetting "C compiler link flags"
@@ -825,7 +825,57 @@ runLink dflags args = do
args1 = map Option (getOpts dflags opt_l)
args2 = args0 ++ args1 ++ args ++ linkargs
mb_env <- getGccEnv args2
- runSomethingFiltered dflags id "Linker" p args2 mb_env
+ runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env
+ where
+ ld_filter = case (platformOS (targetPlatform dflags)) of
+ OSSolaris2 -> sunos_ld_filter
+ _ -> id
+{-
+ SunOS/Solaris ld emits harmless warning messages about unresolved
+ symbols in case of compiling into shared library when we do not
+ link against all the required libs. That is the case of GHC which
+ does not link against RTS library explicitly in order to be able to
+ choose the library later based on binary application linking
+ parameters. The warnings look like:
+
+Undefined first referenced
+ symbol in file
+stg_ap_n_fast ./T2386_Lib.o
+stg_upd_frame_info ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
+newCAF ./T2386_Lib.o
+stg_bh_upd_frame_info ./T2386_Lib.o
+stg_ap_ppp_fast ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
+stg_ap_p_fast ./T2386_Lib.o
+stg_ap_pp_fast ./T2386_Lib.o
+ld: warning: symbol referencing errors
+
+ this is actually coming from T2386 testcase. The emitting of those
+ warnings is also a reason why so many TH testcases fail on Solaris.
+
+ Following filter code is SunOS/Solaris linker specific and should
+ filter out only linker warnings. Please note that the logic is a
+ little bit more complex due to the simple reason that we need to preserve
+ any other linker emitted messages. If there are any. Simply speaking
+ if we see "Undefined" and later "ld: warning:..." then we omit all
+ text between (including) the marks. Otherwise we copy the whole output.
+-}
+ sunos_ld_filter :: String -> String
+ sunos_ld_filter = unlines . sunos_ld_filter' . lines
+ sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+ then (ld_prefix x) ++ (ld_postfix x)
+ else x
+ breakStartsWith x y = break (isPrefixOf x) y
+ ld_prefix = fst . breakStartsWith "Undefined"
+ undefined_found = not . null . snd . breakStartsWith "Undefined"
+ ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
+ ld_postfix = tail . snd . ld_warn_break
+ ld_warning_found = not . null . snd . ld_warn_break
+
runLibtool :: DynFlags -> [Option] -> IO ()
runLibtool dflags args = do
@@ -1316,7 +1366,7 @@ linesPlatform xs =
#endif
-linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
+linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO ()
linkDynLib dflags0 o_files dep_packages
= do
let -- This is a rather ugly hack to fix dynamically linked
@@ -1362,7 +1412,7 @@ linkDynLib dflags0 o_files dep_packages
OSMinGW32 ->
pkgs
_ ->
- filter ((/= rtsPackageId) . packageConfigId) pkgs
+ filter ((/= rtsPackageKey) . packageConfigId) pkgs
let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
in package_hs_libs ++ extra_libs ++ other_flags
@@ -1464,7 +1514,7 @@ linkDynLib dflags0 o_files dep_packages
-------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
- let buildingRts = thisPackage dflags == rtsPackageId
+ let buildingRts = thisPackage dflags == rtsPackageKey
let bsymbolicFlag = if buildingRts
then -- -Bsymbolic breaks the way we implement
-- hooks in the RTS
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 7d47330044..6f24e3afb8 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1019,7 +1019,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
------------------------
tidyTopBind :: DynFlags
- -> PackageId
+ -> PackageKey
-> Module
-> Id
-> UnfoldEnv
@@ -1189,7 +1189,7 @@ it as a CAF. In these cases however, we would need to use an additional
CAF list to keep track of non-collectable CAFs.
\begin{code}
-hasCafRefs :: DynFlags -> PackageId -> Module
+hasCafRefs :: DynFlags -> PackageKey -> Module
-> (Id, VarEnv Var) -> Arity -> CoreExpr
-> CafInfo
hasCafRefs dflags this_pkg this_mod p arity expr
View Lorry Controller Status