summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMonad.hs2
-rw-r--r--compiler/ghci/Linker.hs46
-rw-r--r--compiler/iface/LoadIface.hs18
-rw-r--r--compiler/iface/MkIface.hs18
-rw-r--r--compiler/main/DriverMkDepend.hs5
-rw-r--r--compiler/main/DynamicLoading.hs21
-rw-r--r--compiler/main/Finder.hs77
-rw-r--r--compiler/main/GHC.hs30
-rw-r--r--compiler/main/GhcMake.hs19
-rw-r--r--compiler/main/HscTypes.hs36
-rw-r--r--compiler/main/Packages.hs212
11 files changed, 349 insertions, 135 deletions
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index f01a9d8174..ee5c6e9569 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -184,7 +184,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
else do {
; result <- liftIO $ findImportedModule hsc_env modname Nothing
; case result of
- Found _ mod -> loadModule err mod
+ FoundModule h -> loadModule err (fr_mod h)
_ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
} }
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 9446e3df2b..cec09048c2 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -562,23 +562,29 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- 3. For each dependent module, find its linkable
-- This will either be in the HPT or (in the case of one-shot
- -- compilation) we may need to use maybe_getFileLinkable
+ -- compilation) we may need to use maybe_getFileLinkable.
+ -- If the module is actually a signature, there won't be a
+ -- linkable (thus catMaybes)
; let { osuf = objectSuf dflags }
- ; lnks_needed <- mapM (get_linkable osuf) mods_needed
+ ; lnks_needed <- fmap Maybes.catMaybes
+ $ mapM (get_linkable osuf) mods_needed
; return (lnks_needed, pkgs_needed) }
where
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
- -- The ModIface contains the transitive closure of the module dependencies
- -- within the current package, *except* for boot modules: if we encounter
- -- a boot module, we have to find its real interface and discover the
- -- dependencies of that. Hence we need to traverse the dependency
- -- tree recursively. See bug #936, testcase ghci/prog007.
- follow_deps :: [Module] -- modules to follow
- -> UniqSet ModuleName -- accum. module dependencies
- -> UniqSet PackageKey -- accum. package dependencies
+ -- | Given a list of modules @mods@, recursively discover all external
+ -- package and local module (according to @this_pkg@) dependencies.
+ --
+ -- The 'ModIface' contains the transitive closure of the module dependencies
+ -- within the current package, *except* for boot modules: if we encounter
+ -- a boot module, we have to find its real interface and discover the
+ -- dependencies of that. Hence we need to traverse the dependency
+ -- tree recursively. See bug #936, testcase ghci/prog007.
+ follow_deps :: [Module] -- modules to follow
+ -> UniqSet ModuleName -- accum. module dependencies
+ -> UniqSet PackageKey -- accum. package dependencies
-> IO ([ModuleName], [PackageKey]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
@@ -601,6 +607,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
where is_boot (m,True) = Left m
is_boot (m,False) = Right m
+ -- Boot module dependencies which must be processed recursively
boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps
@@ -631,30 +638,37 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
get_linkable osuf mod_name -- A home-package module
| Just mod_info <- lookupUFM hpt mod_name
- = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
+ = adjust_linkable (hm_iface mod_info)
+ (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
+ -- ezyang: I don't actually know how to trigger this codepath,
+ -- seeing as this is GHCi logic. Template Haskell, maybe?
mb_stuff <- findHomeModule hsc_env mod_name
case mb_stuff of
- Found loc mod -> found loc mod
+ FoundExact loc mod -> found loc mod
_ -> no_obj mod_name
where
found loc mod = do {
-- ...and then find the linkable for it
mb_lnk <- findObjectLinkableMaybe mod loc ;
+ iface <- initIfaceCheck hsc_env $
+ loadUserInterface False (text "getLinkDeps2") mod ;
case mb_lnk of {
Nothing -> no_obj mod ;
- Just lnk -> adjust_linkable lnk
+ Just lnk -> adjust_linkable iface lnk
}}
- adjust_linkable lnk
+ adjust_linkable iface lnk
+ -- Signatures have no linkables! Don't return one.
+ | Just _ <- mi_sig_of iface = return Nothing
| Just new_osuf <- replace_osuf = do
new_uls <- mapM (adjust_ul new_osuf)
(linkableUnlinked lnk)
- return lnk{ linkableUnlinked=new_uls }
+ return (Just lnk{ linkableUnlinked=new_uls })
| otherwise =
- return lnk
+ return (Just lnk)
adjust_ul new_osuf (DotO file) = do
MASSERT(osuf `isSuffixOf` file)
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index cfb8a11446..9571cecddd 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -297,12 +297,17 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
-- interface; it will call the Finder again, but the ModLocation will be
-- cached from the first search.
= do { hsc_env <- getTopEnv
- -- ToDo: findImportedModule should return a list of interfaces
; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
; case res of
- Found _ mod -> fmap (fmap (:[]))
- . initIfaceTcRn
- $ loadInterface doc mod (ImportByUser want_boot)
+ FoundModule (FoundHs { fr_mod = mod })
+ -> fmap (fmap (:[]))
+ . initIfaceTcRn
+ $ loadInterface doc mod (ImportByUser want_boot)
+ FoundSigs mods _backing
+ -> initIfaceTcRn $ do
+ ms <- forM mods $ \(FoundHs { fr_mod = mod }) ->
+ loadInterface doc mod (ImportByUser want_boot)
+ return (sequence ms)
err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) }
-- | Load interface directly for a fully qualified 'Module'. (This is a fairly
@@ -758,7 +763,7 @@ findAndReadIface doc_str mod hi_boot_file
hsc_env <- getTopEnv
mb_found <- liftIO (findExactModule hsc_env mod)
case mb_found of
- Found loc mod -> do
+ FoundExact loc mod -> do
-- Found file, so read it
let file_path = addBootSuffix_maybe hi_boot_file
@@ -775,7 +780,8 @@ findAndReadIface doc_str mod hi_boot_file
traceIf (ptext (sLit "...not found"))
dflags <- getDynFlags
return (Failed (cannotFindInterface dflags
- (moduleName mod) err))
+ (moduleName mod)
+ (convFindExactResult err)))
where read_file file_path = do
traceIf (ptext (sLit "readIFace") <+> text file_path)
read_result <- readIface mod file_path
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index e7cc3adc19..91e5a68706 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1324,9 +1324,20 @@ checkDependencies hsc_env summary iface
find_res <- liftIO $ findImportedModule hsc_env mod pkg
let reason = moduleNameString mod ++ " changed"
case find_res of
- Found _ mod
+ FoundModule h -> check_mod reason (fr_mod h)
+ FoundSigs hs _backing -> check_mods reason (map fr_mod hs)
+ _otherwise -> return (RecompBecause reason)
+
+ check_mods _ [] = return UpToDate
+ check_mods reason (m:ms) = do
+ r <- check_mod reason m
+ case r of
+ UpToDate -> check_mods reason ms
+ _otherwise -> return r
+
+ check_mod reason mod
| pkg == this_pkg
- -> if moduleName mod `notElem` map fst prev_dep_mods
+ = if moduleName mod `notElem` map fst prev_dep_mods
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
@@ -1334,7 +1345,7 @@ checkDependencies hsc_env summary iface
else
return UpToDate
| otherwise
- -> if pkg `notElem` (map fst prev_dep_pkgs)
+ = if pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
@@ -1343,7 +1354,6 @@ checkDependencies hsc_env summary iface
else
return UpToDate
where pkg = modulePackageKey mod
- _otherwise -> return (RecompBecause reason)
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 03545d4828..1b4d1ac3f1 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -248,7 +248,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
-- we've done it once during downsweep
r <- findImportedModule hsc_env imp pkg
; case r of
- Found loc _
+ FoundModule (FoundHs { fr_loc = loc })
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
-> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
@@ -257,6 +257,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
| otherwise
-> return Nothing
+ -- TODO: FoundSignature. For now, we assume home package
+ -- "signature" dependencies look like FoundModule.
+
fail ->
let dflags = hsc_dflags hsc_env
in throwOneError $ mkPlainErrMsg dflags srcloc $
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 82081bf1a3..546cc6879c 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -203,7 +203,15 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
-- First find the package the module resides in by searching exposed packages and home modules
found_module <- findImportedModule hsc_env mod_name Nothing
case found_module of
- Found _ mod -> do
+ FoundModule h -> check_mod (fr_mod h)
+ FoundSigs hs _backing -> check_mods (map fr_mod hs) -- (not tested)
+ err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+ where
+ dflags = hsc_dflags hsc_env
+ meth = "lookupRdrNameInModule"
+ doc = ptext (sLit $ "contains a name used in an invocation of " ++ meth)
+
+ check_mod mod = do
-- Find the exports of the module
(_, mb_iface) <- initTcInteractive hsc_env $
initIfaceTcRn $
@@ -221,10 +229,13 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
_ -> panic "lookupRdrNameInModule"
Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
- err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
- where
- dflags = hsc_dflags hsc_env
- doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")
+
+ check_mods [] = return Nothing
+ check_mods (m:ms) = do
+ r <- check_mod m
+ case r of
+ Nothing -> check_mods ms
+ Just _ -> return r
wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index befa0304ab..ac17fd23bb 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -9,6 +9,7 @@
module Finder (
flushFinderCaches,
FindResult(..),
+ convFindExactResult, -- move to HscTypes?
findImportedModule,
findExactModule,
findHomeModule,
@@ -45,8 +46,7 @@ import System.Directory
import System.FilePath
import Control.Monad
import Data.Time
-import Data.List ( foldl' )
-
+import Data.List ( foldl', partition )
type FileExt = String -- Filename extension
type BaseName = String -- Basename of file
@@ -75,7 +75,7 @@ flushFinderCaches hsc_env =
is_ext mod _ | modulePackageKey mod /= this_pkg = True
| otherwise = False
-addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO ()
+addToFinderCache :: IORef FinderCache -> Module -> FindExactResult -> IO ()
addToFinderCache ref key val =
atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ())
@@ -83,7 +83,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
removeFromFinderCache ref key =
atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
-lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult)
+lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindExactResult)
lookupFinderCache ref key = do
c <- readIORef ref
return $! lookupModuleEnv c key
@@ -104,7 +104,7 @@ findImportedModule hsc_env mod_name mb_pkg =
Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
| otherwise -> pkg_import
where
- home_import = findHomeModule hsc_env mod_name
+ home_import = convFindExactResult `fmap` findHomeModule hsc_env mod_name
pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg
@@ -118,7 +118,7 @@ findImportedModule hsc_env mod_name mb_pkg =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: HscEnv -> Module -> IO FindResult
+findExactModule :: HscEnv -> Module -> IO FindExactResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
in if modulePackageKey mod == thisPackage dflags
@@ -152,17 +152,45 @@ orIfNotFound this or_this = do
-- been done. Otherwise, do the lookup (with the IO action) and save
-- the result in the finder cache and the module location cache (if it
-- was successful.)
-homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
+homeSearchCache :: HscEnv
+ -> ModuleName
+ -> IO FindExactResult
+ -> IO FindExactResult
homeSearchCache hsc_env mod_name do_this = do
let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
modLocationCache hsc_env mod do_this
+-- | Converts a 'FindExactResult' into a 'FindResult' in the obvious way.
+convFindExactResult :: FindExactResult -> FindResult
+convFindExactResult (FoundExact loc m) = FoundModule (FoundHs loc m)
+convFindExactResult (NoPackageExact pk) = NoPackage pk
+convFindExactResult NotFoundExact { fer_paths = paths, fer_pkg = pkg } =
+ NotFound {
+ fr_paths = paths, fr_pkg = pkg,
+ fr_pkgs_hidden = [], fr_mods_hidden = [], fr_suggestions = []
+ }
+
+foundExact :: FindExactResult -> Bool
+foundExact FoundExact{} = True
+foundExact _ = False
+
findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
-> IO FindResult
findExposedPackageModule hsc_env mod_name mb_pkg
= case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of
- LookupFound m pkg_conf ->
- findPackageModule_ hsc_env m pkg_conf
+ LookupFound (m, _) -> do
+ fmap convFindExactResult (findPackageModule hsc_env m)
+ LookupFoundSigs ms backing -> do
+ locs <- mapM (findPackageModule hsc_env . fst) ms
+ let (ok, missing) = partition foundExact locs
+ case missing of
+ -- At the moment, we return the errors one at a time. It might be
+ -- better if we collected them up and reported them all, but
+ -- FindResult doesn't have enough information to support this.
+ -- In any case, this REALLY shouldn't happen (it means there are
+ -- broken packages in the database.)
+ (m:_) -> return (convFindExactResult m)
+ _ -> return (FoundSigs [FoundHs l m | FoundExact l m <- ok] backing)
LookupMultiple rs ->
return (FoundMultiple rs)
LookupHidden pkg_hiddens mod_hiddens ->
@@ -176,7 +204,7 @@ findExposedPackageModule hsc_env mod_name mb_pkg
, fr_mods_hidden = []
, fr_suggestions = suggest })
-modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
+modLocationCache :: HscEnv -> Module -> IO FindExactResult -> IO FindExactResult
modLocationCache hsc_env mod do_this = do
m <- lookupFinderCache (hsc_FC hsc_env) mod
case m of
@@ -189,7 +217,7 @@ modLocationCache hsc_env mod do_this = do
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do
let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
- addToFinderCache (hsc_FC hsc_env) mod (Found loc mod)
+ addToFinderCache (hsc_FC hsc_env) mod (FoundExact loc mod)
return mod
uncacheModule :: HscEnv -> ModuleName -> IO ()
@@ -216,7 +244,7 @@ uncacheModule hsc_env mod = do
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
-- call this.)
-findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule :: HscEnv -> ModuleName -> IO FindExactResult
findHomeModule hsc_env mod_name =
homeSearchCache hsc_env mod_name $
let
@@ -247,19 +275,19 @@ findHomeModule hsc_env mod_name =
-- This is important only when compiling the base package (where GHC.Prim
-- is a home module).
if mod == gHC_PRIM
- then return (Found (error "GHC.Prim ModLocation") mod)
+ then return (FoundExact (error "GHC.Prim ModLocation") mod)
else searchPathExts home_path mod exts
-- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> Module -> IO FindResult
+findPackageModule :: HscEnv -> Module -> IO FindExactResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
pkg_id = modulePackageKey mod
--
case lookupPackage dflags pkg_id of
- Nothing -> return (NoPackage pkg_id)
+ Nothing -> return (NoPackageExact pkg_id)
Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
-- | Look up the interface file associated with module @mod@. This function
@@ -269,14 +297,14 @@ findPackageModule hsc_env mod = do
-- 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_ :: HscEnv -> Module -> PackageConfig -> IO FindExactResult
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.
if mod == gHC_PRIM
- then return (Found (error "GHC.Prim ModLocation") mod)
+ then return (FoundExact (error "GHC.Prim ModLocation") mod)
else
let
@@ -299,7 +327,7 @@ findPackageModule_ hsc_env mod pkg_conf =
-- don't bother looking for it.
let basename = moduleNameSlashes (moduleName mod)
loc <- mk_hi_loc one basename
- return (Found loc mod)
+ return (FoundExact loc mod)
_otherwise ->
searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
@@ -314,7 +342,7 @@ searchPathExts
FilePath -> BaseName -> IO ModLocation -- action
)
]
- -> IO FindResult
+ -> IO FindExactResult
searchPathExts paths mod exts
= do result <- search to_search
@@ -340,15 +368,13 @@ searchPathExts paths mod exts
file = base <.> ext
]
- search [] = return (NotFound { fr_paths = map fst to_search
- , fr_pkg = Just (modulePackageKey mod)
- , fr_mods_hidden = [], fr_pkgs_hidden = []
- , fr_suggestions = [] })
+ search [] = return (NotFoundExact {fer_paths = map fst to_search
+ ,fer_pkg = Just (modulePackageKey mod)})
search ((file, mk_result) : rest) = do
b <- doesFileExist file
if b
- then do { loc <- mk_result; return (Found loc mod) }
+ then do { loc <- mk_result; return (FoundExact loc mod) }
else search rest
mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
@@ -571,7 +597,8 @@ cantFindErr cannot_find _ dflags mod_name find_result
vcat (map mod_hidden mod_hiddens) $$
tried_these files
- _ -> panic "cantFindErr"
+ _ -> pprPanic "cantFindErr"
+ (ptext cannot_find <+> quotes (ppr mod_name))
build_tag = buildTag dflags
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 0848ac2d6e..197a71973b 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -1326,6 +1326,20 @@ showRichTokenStream ts = go startLoc ts ""
-- | 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.
+--
+-- However, there is a twist for local modules, see #2682.
+--
+-- The full algorithm:
+-- IF it's a package qualified import for a REMOTE package (not @this_pkg@ or
+-- this), do a normal lookup.
+-- OTHERWISE see if it is ALREADY loaded, and use it if it is.
+-- OTHERWISE do a normal lookup, but reject the result if the found result
+-- is from the LOCAL package (@this_pkg@).
+--
+-- For signatures, we return the BACKING implementation to keep the API
+-- consistent with what we had before. (ToDo: create a new GHC API which
+-- can deal with signatures.)
+--
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
let
@@ -1336,17 +1350,23 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> 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
+ FoundModule h -> return (fr_mod h)
+ FoundSigs _ backing -> return backing
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
_otherwise -> do
home <- lookupLoadedHomeModule mod_name
case home of
+ -- TODO: This COULD be a signature
Just m -> return m
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
- Found loc m | modulePackageKey m /= this_pkg -> return m
- | otherwise -> modNotLoadedError dflags m loc
+ FoundModule (FoundHs { fr_mod = m, fr_loc = loc })
+ | modulePackageKey m /= this_pkg -> return m
+ | otherwise -> modNotLoadedError dflags m loc
+ FoundSigs (FoundHs { fr_loc = loc, fr_mod = m }:_) backing
+ | modulePackageKey m /= this_pkg -> return backing
+ | otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
@@ -1367,11 +1387,13 @@ lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
lookupModule mod_name Nothing = withSession $ \hsc_env -> do
home <- lookupLoadedHomeModule mod_name
case home of
+ -- TODO: This COULD be a signature
Just m -> return m
Nothing -> liftIO $ do
res <- findExposedPackageModule hsc_env mod_name Nothing
case res of
- Found _ m -> return m
+ FoundModule (FoundHs { fr_mod = m }) -> return m
+ FoundSigs _ backing -> return backing
err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 818bb73332..7d44704652 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1800,7 +1800,10 @@ findSummaryBySourceFile summaries file
[] -> Nothing
(x:_) -> Just x
--- Summarise a module, and pick up source and timestamp.
+-- | Summarise a module, and pick up source and timestamp.
+-- Returns @Nothing@ if the module is excluded via @excl_mods@ or is an
+-- external package module (which we don't compile), otherwise returns the
+-- new module summary (or an error saying why we couldn't summarise it).
summariseModule
:: HscEnv
-> NodeMap ModSummary -- Map of old summaries
@@ -1862,7 +1865,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
uncacheModule hsc_env wanted_mod
found <- findImportedModule hsc_env wanted_mod Nothing
case found of
- Found location mod
+ -- TODO: When we add -alias support, we can validly find
+ -- multiple signatures in the home package; need to make this
+ -- logic more flexible in that case.
+ FoundModule (FoundHs { fr_loc = location, fr_mod = mod })
| isJust (ml_hs_file location) ->
-- Home package
just_found location mod
@@ -1871,6 +1877,15 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
ASSERT(modulePackageKey mod /= thisPackage dflags)
return Nothing
+ FoundSigs hs _backing
+ | Just (FoundHs { fr_loc = location, fr_mod = mod })
+ <- find (isJust . ml_hs_file . fr_loc) hs ->
+ just_found location mod
+ | otherwise ->
+ ASSERT(all (\h -> modulePackageKey (fr_mod h)
+ /= thisPackage dflags) hs)
+ return Nothing
+
err -> return $ Just $ Left $ noModError dflags loc wanted_mod err
-- Not found
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 92c57ba0e5..6105cce0cc 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -10,7 +10,7 @@
module HscTypes (
-- * compilation state
HscEnv(..), hscEPS,
- FinderCache, FindResult(..),
+ FinderCache, FindResult(..), FoundHs(..), FindExactResult(..),
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
HscStatus(..),
@@ -674,15 +674,30 @@ prepareAnnotations hsc_env mb_guts = do
-- modules along the search path. On @:load@, we flush the entire
-- contents of this cache.
--
--- Although the @FinderCache@ range is 'FindResult' for convenience,
--- in fact it will only ever contain 'Found' or 'NotFound' entries.
---
-type FinderCache = ModuleEnv FindResult
+type FinderCache = ModuleEnv FindExactResult
+
+-- | The result of search for an exact 'Module'.
+data FindExactResult
+ = FoundExact ModLocation Module
+ -- ^ The module/signature was found
+ | NoPackageExact PackageKey
+ | NotFoundExact
+ { fer_paths :: [FilePath]
+ , fer_pkg :: Maybe PackageKey
+ }
+
+-- | A found module or signature; e.g. anything with an interface file
+data FoundHs = FoundHs { fr_loc :: ModLocation
+ , fr_mod :: Module
+ -- , fr_origin :: ModuleOrigin
+ }
-- | The result of searching for an imported module.
data FindResult
- = Found ModLocation Module
+ = FoundModule FoundHs
-- ^ The module was found
+ | FoundSigs [FoundHs] Module
+ -- ^ Signatures were found, with some backing implementation
| NoPackage PackageKey
-- ^ The requested package was not found
| FoundMultiple [(Module, ModuleOrigin)]
@@ -2044,6 +2059,15 @@ type IsBootInterface = Bool
-- Invariant: the dependencies of a module @M@ never includes @M@.
--
-- Invariant: none of the lists contain duplicates.
+--
+-- NB: While this contains information about all modules and packages below
+-- this one in the the import *hierarchy*, this may not accurately reflect
+-- the full runtime dependencies of the module. This is because this module may
+-- have imported a boot module, in which case we'll only have recorded the
+-- dependencies from the hs-boot file, not the actual hs file. (This is
+-- unavoidable: usually, the actual hs file will have been compiled *after*
+-- we wrote this interface file.) See #936, and also @getLinkDeps@ in
+-- @compiler/ghci/Linker.hs@ for code which cares about this distinction.
data Dependencies
= Deps { dep_mods :: [(ModuleName, IsBootInterface)]
-- ^ All home-package modules transitively below this one
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 70476a16bd..a25e8e7ee7 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -131,9 +131,10 @@ import qualified Data.Set as Set
-- in a different DLL, by setting the DLL flag.
-- | 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!
+-- possibly simultaneously. For a given particular implementation (e.g.
+-- original module, or even a signature module), 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
@@ -157,7 +158,7 @@ data ModuleOrigin =
}
instance Outputable ModuleOrigin where
- ppr ModHidden = text "hidden module"
+ ppr ModHidden = text "hidden module" -- NB: cannot be signature
ppr (ModOrigin e res rhs f) = sep (punctuate comma (
(case e of
Nothing -> []
@@ -174,17 +175,18 @@ instance Outputable ModuleOrigin where
(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 @exposed-modules@ or
+-- @exposed-signatures@. Takes as an argument whether or not the defining
+-- package is exposed.
+fromExposed :: Bool -> ModuleOrigin
+fromExposed 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 is in @reexported-modules@
+-- or @reexported-signatures@. Takes as an argument whether or not the
+-- reexporting package is expsed, and also its 'PackageConfig'.
+fromReexported :: Bool -> PackageConfig -> ModuleOrigin
+fromReexported True pkg = ModOrigin Nothing [pkg] [] False
+fromReexported False pkg = ModOrigin Nothing [] [pkg] False
-- | Smart constructor for a module which was bound by a package flag.
fromFlag :: ModuleOrigin
@@ -226,11 +228,40 @@ type PackageConfigMap = PackageKeyMap PackageConfig
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)
+-- | Alias for 'Module' indicating we expect the interface in question to
+-- be for a signature.
+type Signature = Module
+
+-- | Alias for 'ModuleOrigin' indicating we expect it to describe a signature.
+type SignatureOrigin = ModuleOrigin
+
+-- | This is the main lookup structure we use to handle imports, which map
+-- from 'ModuleName' to 'ModuleDb', which describes all possible implementations
+-- which are available under a module name.
+type ModuleNameDb = Map ModuleName ModuleDb
+
+-- | This is an auxiliary structure per module name, and it's a map of
+-- backing implementations to more information about them. This is a map
+-- so it's easy to tell if we're bringing in an implementation for a name
+-- which is already in scope (and thus non-conflicting.)
+type ModuleDb = Map Module ModuleDesc
+
+-- | Per backing implementation, there may be multiple signatures available
+-- exporting subsets of its interface; we need to track all of them.
+type SignatureDb = Map Signature SignatureOrigin
+
+-- | Combined module description for a module: includes 'ModuleOrigin'
+-- describing the backing implementation, as well as 'SignatureDb' for any
+-- signatures of the module in question.
+data ModuleDesc = MD ModuleOrigin SignatureDb
+
+instance Outputable ModuleDesc where
+ ppr (MD o m) = ppr o <+> parens (ppr m)
+
+instance Monoid ModuleDesc where
+ mempty = MD mempty Map.empty
+ mappend (MD o m) (MD o' m') = MD (o `mappend` o')
+ (Map.unionWith mappend m m')
data PackageState = PackageState {
-- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted
@@ -248,7 +279,7 @@ data PackageState = PackageState {
-- | 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,
+ moduleNameDb :: ModuleNameDb,
-- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
-- internally deals in package keys but the database may refer to installed
@@ -1016,7 +1047,7 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do
let pstate = PackageState{
preloadPackages = dep_preload,
pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
+ moduleNameDb = mkModuleNameDb dflags pkg_db ipid_map vis_map,
installedPackageIdMap = ipid_map
}
return (pstate, new_dep_preload, this_package)
@@ -1025,62 +1056,70 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do
-- -----------------------------------------------------------------------------
-- | Makes the mapping from module to package info
-mkModuleToPkgConfAll
+mkModuleNameDb
:: DynFlags
-> PackageConfigMap
-> InstalledPackageIdMap
-> VisibilityMap
- -> ModuleToPkgConfAll
-mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
+ -> ModuleNameDb
+mkModuleNameDb dflags pkg_db ipid_map vis_map =
foldl' extend_modmap emptyMap (eltsUFM pkg_db)
where
emptyMap = Map.empty
- sing pk m _ = Map.singleton (mkModule pk m)
+ 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
extend_modmap modmap pkg = addListTo modmap theBindings
where
- theBindings :: [(ModuleName, Map Module ModuleOrigin)]
+ theBindings :: [(ModuleName, ModuleDb)]
theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
= newBindings b rns
| otherwise = newBindings False []
newBindings :: Bool
-> [(ModuleName, ModuleName)]
- -> [(ModuleName, Map Module ModuleOrigin)]
+ -> [(ModuleName, ModuleDb)]
newBindings e rns = es e ++ hiddens ++ map rnBinding rns
rnBinding :: (ModuleName, ModuleName)
- -> (ModuleName, Map Module ModuleOrigin)
- rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
+ -> (ModuleName, ModuleDb)
+ rnBinding (orig, new) = (new, fmap applyFlag origEntry)
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, Map Module ModuleOrigin)]
+ applyFlag (MD _ sigs) = MD fromFlag (fmap (const fromFlag) sigs)
+
+ es :: Bool -> [(ModuleName, ModuleDb)]
es e = do
- -- TODO: signature support
- ExposedModule m exposedReexport _exposedSignature <- exposed_mods
- let (pk', m', pkg', origin') =
+ ExposedModule m exposedReexport exposedSignature <- exposed_mods
+ let (pk', m', origin') =
case exposedReexport of
- Nothing -> (pk, m, pkg, fromExposedModules e)
+ Nothing -> (pk, m, fromExposed e)
Just (OriginalModule ipid' m') ->
- let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
- pkg' = pkg_lookup pk'
- in (pk', m', pkg', fromReexportedModules e pkg')
- return (m, sing pk' m' pkg' origin')
+ let (pk', pkg') = ipid_lookup ipid'
+ in (pk', m', fromReexported e pkg')
+ return $ case exposedSignature of
+ Nothing -> (m, sing pk' m' (MD origin' Map.empty))
+ Just (OriginalModule ipid'' m'') ->
+ let (pk'', _) = ipid_lookup ipid''
+ in (m, sing pk'' m'' (MD mempty (sing pk' m' origin')))
- esmap :: UniqFM (Map Module ModuleOrigin)
+
+ esmap :: UniqFM ModuleDb
esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
-- be overwritten
- hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
+ hiddens :: [(ModuleName, ModuleDb)]
+ hiddens = [(m, sing pk m (MD ModHidden Map.empty)) | m <- hidden_mods]
pk = packageConfigId pkg
- pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
+ pkg_lookup = expectJust "mkModuleNameDb" . lookupPackage' pkg_db
+ ipid_lookup ipid =
+ let pk = expectJust "mkModuleNameDb" (Map.lookup ipid ipid_map)
+ in (pk, pkg_lookup pk)
exposed_mods = exposedModules pkg
hidden_mods = hiddenModules pkg
@@ -1190,16 +1229,20 @@ lookupModuleInAllPackages :: DynFlags
-> [(Module, PackageConfig)]
lookupModuleInAllPackages dflags m
= 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)))
+ LookupFound (m,_) -> [(m,get_pkg m)]
+ LookupMultiple rs -> map (\(m,_) -> (m,get_pkg m)) rs
_ -> []
+ where get_pkg = expectJust "lookupModule" . lookupPackage dflags
+ . modulePackageKey
-- | The result of performing a lookup
data LookupResult =
-- | Found the module uniquely, nothing else to do
- LookupFound Module PackageConfig
+ LookupFound (Module, ModuleOrigin)
+ -- | We found (possibly multiple) signatures with a unique backing
+ -- implementation: they should be "merged" together. For good measure,
+ -- the backing implementation is recorded too.
+ | LookupFoundSigs [(Module, ModuleOrigin)] Module
-- | Multiple modules with the same name in scope
| LookupMultiple [(Module, ModuleOrigin)]
-- | No modules found, but there were some hidden ones with
@@ -1209,6 +1252,39 @@ data LookupResult =
-- | Nothing found, here are some suggested different names
| LookupNotFound [ModuleSuggestion] -- suggestions
+instance Monoid LookupResult where
+ mempty = LookupNotFound []
+
+ LookupNotFound s1 `mappend` LookupNotFound s2
+ = LookupNotFound (s1 ++ s2)
+ LookupNotFound{} `mappend` l = l
+ l `mappend` LookupNotFound{} = l
+
+ LookupHidden x1 y1 `mappend` LookupHidden x2 y2
+ = LookupHidden (x1 ++ x2) (y1 ++ y2)
+ LookupHidden{} `mappend` l = l
+ l `mappend` LookupHidden{} = l
+
+ LookupFound m1 `mappend` LookupFound m2
+ = ASSERT (fst m1 /= fst m2) LookupMultiple [m1, m2]
+ LookupFound m `mappend` LookupMultiple ms
+ = ASSERT (not (any ((==fst m).fst) ms)) LookupMultiple (m:ms)
+ LookupFound m `mappend` LookupFoundSigs ms check
+ | fst m == check = LookupFound m
+ | otherwise = LookupMultiple (m:ms)
+ l1 `mappend` l2@LookupFound{}
+ = l2 `mappend` l1
+
+ LookupMultiple ms1 `mappend` LookupFoundSigs ms2 _
+ = LookupMultiple (ms1 ++ ms2)
+ LookupMultiple ms1 `mappend` LookupMultiple ms2
+ = LookupMultiple (ms1 ++ ms2)
+ l1 `mappend` l2@LookupMultiple{}
+ = l2 `mappend` l1
+
+ LookupFoundSigs ms1 m1 `mappend` LookupFoundSigs ms2 m2
+ = ASSERT (m1 /= m2) LookupMultiple (ms1 ++ ms2)
+
data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
@@ -1217,23 +1293,28 @@ lookupModuleWithSuggestions :: DynFlags
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions dflags m mb_pn
- = case Map.lookup m (moduleToPkgConfAll pkg_state) of
+ = case Map.lookup m (moduleNameDb pkg_state) of
Nothing -> LookupNotFound suggestions
- Just xs ->
- case foldl' classify ([],[],[]) (Map.toList xs) of
- ([], [], []) -> LookupNotFound suggestions
- (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
- (_, _, exposed@(_:_)) -> LookupMultiple exposed
- (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
+ Just xs -> mconcat (LookupNotFound suggestions
+ :map classify (Map.toList xs))
where
- classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
+ classify (m, MD origin0 sigs0) =
let origin = filterOrigin mb_pn (mod_pkg m) origin0
- x = (m, origin)
+ r = (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)
+ ModHidden -> LookupHidden [] [r]
+ _ | originVisible origin -> LookupFound r
+ | otherwise ->
+ let sigs = do (back_m, back_origin0) <- Map.toList sigs0
+ let back_origin = filterOrigin mb_pn
+ (mod_pkg back_m)
+ back_origin0
+ guard (originVisible back_origin)
+ return (back_m, back_origin)
+ in case sigs of
+ [] | originEmpty origin -> LookupNotFound []
+ | otherwise -> LookupHidden [r] []
+ _ -> LookupFoundSigs sigs m
pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
pkg_state = pkgState dflags
@@ -1268,17 +1349,18 @@ lookupModuleWithSuggestions dflags m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
+ | (m, e) <- Map.toList (moduleNameDb (pkgState dflags))
, suggestion <- map (getSuggestion m) (Map.toList e)
]
- getSuggestion name (mod, origin) =
+ -- For now, don't suggest implemented signatures
+ getSuggestion name (mod, MD origin _) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames dflags =
- map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
- where visible (_, ms) = any originVisible (Map.elems ms)
+ map fst (filter visible (Map.toList (moduleNameDb (pkgState dflags))))
+ where visible (_, ms) = any (\(MD o _) -> originVisible o) (Map.elems ms)
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
@@ -1417,7 +1499,7 @@ pprPackagesSimple = pprPackagesWith pprIPI
-- | Show the mapping of modules to where they come from.
pprModuleMap :: DynFlags -> SDoc
pprModuleMap dflags =
- vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
+ vcat (map pprLine (Map.toList (moduleNameDb (pkgState dflags))))
where
pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
pprEntry m (m',o)
View Lorry Controller Status