summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEdward Z. Yang <ezyang@cs.stanford.edu>2014-10-07 20:54:54 -0700
committerEdward Z. Yang <ezyang@cs.stanford.edu>2015-04-07 11:55:49 -0700
commita7524eaed33324e2155c47d4a705bef1d70a2b5b (patch)
treed3bb67c7cdfc5a6afa663484efe7b15c87ce43f1
parenta058ad65e0936c1b7104ee976cbf80d97fd7232e (diff)
downloadhaskell-a7524eaed33324e2155c47d4a705bef1d70a2b5b.tar.gz
Support for multiple signature files in scope.
Summary: A common pattern when programming with signatures is to combine multiple signatures together (signature linking). We achieve this by making it not-an-error to have multiple, distinct interface files for the same module name, as long as they have the same backing implementation. When a user imports a module name, they get ALL matching signatures dumped into their scope. On the way, I refactored the module finder code, which now distinguishes between exact finds (when you had a 'Module') and regular finds (when you had a 'ModuleName'). I also refactored the package finder code to use a Monoid instance on LookupResult to collect together various results. ToDo: At the moment, if a signature is declared in the local package, it completely overrides any remote signatures. Eventually, we'll want to also pull in the remote signatures (or even override the local signature, if the full implementation is available.) There are bunch of ToDos in the code for what to do once this is done. ToDo: At the moment, whenever a module name lookup occurs in GHCi and we would have seen a signature, we instead continue and return the Module for the backing implementation. This is correct for most cases, but there might be some situations where we want something a little more fine-grained (e.g. :browse should only list identifiers which are available through the in-scope signatures, and not ALL of them.) Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu> Test Plan: validate Reviewers: simonpj, hvr, austin Subscribers: carter, thomie Differential Revision: https://phabricator.haskell.org/D790 GHC Trac Issues: #9252
-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
-rw-r--r--docs/users_guide/separate_compilation.xml5
-rw-r--r--ghc/Main.hs5
-rw-r--r--testsuite/.gitignore6
-rw-r--r--testsuite/tests/cabal/sigcabal02/Main.hs7
-rw-r--r--testsuite/tests/cabal/sigcabal02/Makefile34
-rw-r--r--testsuite/tests/cabal/sigcabal02/Setup.hs2
-rw-r--r--testsuite/tests/cabal/sigcabal02/ShouldFail.hs1
-rw-r--r--testsuite/tests/cabal/sigcabal02/all.T9
-rw-r--r--testsuite/tests/cabal/sigcabal02/p/LICENSE0
-rw-r--r--testsuite/tests/cabal/sigcabal02/p/Map.hsig18
-rw-r--r--testsuite/tests/cabal/sigcabal02/p/P.hs12
-rw-r--r--testsuite/tests/cabal/sigcabal02/p/Set.hsig13
-rw-r--r--testsuite/tests/cabal/sigcabal02/p/p.cabal14
-rw-r--r--testsuite/tests/cabal/sigcabal02/q/LICENSE0
-rw-r--r--testsuite/tests/cabal/sigcabal02/q/Map.hsig7
-rw-r--r--testsuite/tests/cabal/sigcabal02/q/Q.hs7
-rw-r--r--testsuite/tests/cabal/sigcabal02/q/q.cabal13
-rw-r--r--testsuite/tests/cabal/sigcabal02/sigcabal02.stderr4
-rw-r--r--testsuite/tests/cabal/sigcabal02/sigcabal02.stdout5
-rw-r--r--testsuite/tests/driver/recomp014/Makefile4
-rw-r--r--testsuite/tests/driver/recomp014/recomp014.stdout1
-rw-r--r--testsuite/tests/driver/sigof01/Makefile6
-rw-r--r--testsuite/tests/driver/sigof01/all.T10
-rw-r--r--testsuite/tests/driver/sigof01/sigof01i.script1
-rw-r--r--testsuite/tests/driver/sigof01/sigof01i.stdout3
-rw-r--r--testsuite/tests/driver/sigof01/sigof01i2.script3
-rw-r--r--testsuite/tests/driver/sigof01/sigof01i2.stdout8
-rw-r--r--testsuite/tests/package/package09e.stderr2
39 files changed, 545 insertions, 139 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)
diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml
index b30eff86ae..32422caedc 100644
--- a/docs/users_guide/separate_compilation.xml
+++ b/docs/users_guide/separate_compilation.xml
@@ -970,6 +970,11 @@ ghc -c A.hs
written in a subset of Haskell essentially identical to that of
<literal>hs-boot</literal> files.</para>
+ <para>Signatures can be installed like ordinary module files,
+ and when multiple signatures are brought into scope under the same
+ module name, they are merged together if their backing implementations
+ are the same.</para>
+
<para>There is one important gotcha with the current implementation:
currently, instances from backing implementations will "leak" code that
uses signatures, and explicit instance declarations in signatures are
diff --git a/ghc/Main.hs b/ghc/Main.hs
index fa266a24f8..201ee5d8d2 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -834,11 +834,12 @@ abiHash strs = do
let modname = mkModuleName str
r <- findImportedModule hsc_env modname Nothing
case r of
- Found _ m -> return m
+ FoundModule h -> return [fr_mod h]
+ FoundSigs hs _ -> return (map fr_mod hs)
_error -> throwGhcException $ CmdLineError $ showSDoc dflags $
cannotFindInterface dflags modname r
- mods <- mapM find_it strs
+ mods <- fmap concat (mapM find_it strs)
let get_iface modl = loadUserInterface False (text "abiHash") modl
ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 30188e2e06..422d42f90e 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -119,6 +119,12 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
/tests/cabal/sigcabal01/p_lazy
/tests/cabal/sigcabal01/p_strict
/tests/cabal/sigcabal01/containers
+/tests/cabal/sigcabal02/Main
+/tests/cabal/sigcabal02/p_ipid
+/tests/cabal/sigcabal02/q_ipid
+/tests/cabal/sigcabal02/containers
+/tests/cabal/sigcabal02/tmp*
+/tests/cabal/sigcabal02/inst*
/tests/cabal/local01.package.conf/
/tests/cabal/local03.package.conf/
/tests/cabal/local04.package.conf/
diff --git a/testsuite/tests/cabal/sigcabal02/Main.hs b/testsuite/tests/cabal/sigcabal02/Main.hs
new file mode 100644
index 0000000000..52def3d41f
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/Main.hs
@@ -0,0 +1,7 @@
+import Map
+import P
+import Q
+
+main = do
+ x <- foo
+ print (mymember 5 x)
diff --git a/testsuite/tests/cabal/sigcabal02/Makefile b/testsuite/tests/cabal/sigcabal02/Makefile
new file mode 100644
index 0000000000..152aaeac0e
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/Makefile
@@ -0,0 +1,34 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP=../Setup -v0
+
+# This test is for two Cabal packages exposing the same signature
+
+sigcabal02:
+ $(MAKE) clean
+ '$(GHC_PKG)' field containers id | sed 's/^.*: *//' > containers
+ '$(GHC_PKG)' init tmp.d
+ '$(TEST_HC)' -v0 --make Setup
+ cd p && $(SETUP) clean
+ cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --instantiate-with="Set=Data.Set@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance"
+ cd p && $(SETUP) build
+ cd p && $(SETUP) copy
+ cd p && $(SETUP) register --print-ipid > ../p_ipid
+ cd q && $(SETUP) clean
+ cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance"
+ cd q && $(SETUP) build
+ cd q && $(SETUP) copy
+ cd q && $(SETUP) register --print-ipid > ../q_ipid
+ '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make Main.hs
+ ./Main
+ ! '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make ShouldFail.hs
+ifneq "$(CLEANUP)" ""
+ $(MAKE) clean
+endif
+
+clean :
+ '$(GHC_PKG)' unregister --force p >/dev/null 2>&1 || true
+ '$(GHC_PKG)' unregister --force q >/dev/null 2>&1 || true
+ $(RM) -r tmp.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
diff --git a/testsuite/tests/cabal/sigcabal02/Setup.hs b/testsuite/tests/cabal/sigcabal02/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/testsuite/tests/cabal/sigcabal02/ShouldFail.hs b/testsuite/tests/cabal/sigcabal02/ShouldFail.hs
new file mode 100644
index 0000000000..98ec49e886
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/ShouldFail.hs
@@ -0,0 +1 @@
+import Set
diff --git a/testsuite/tests/cabal/sigcabal02/all.T b/testsuite/tests/cabal/sigcabal02/all.T
new file mode 100644
index 0000000000..11eb05975b
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/all.T
@@ -0,0 +1,9 @@
+if default_testopts.cleanup != '':
+ cleanup = 'CLEANUP=1'
+else:
+ cleanup = ''
+
+test('sigcabal02',
+ normal,
+ run_command,
+ ['$MAKE -s --no-print-directory sigcabal02 ' + cleanup])
diff --git a/testsuite/tests/cabal/sigcabal02/p/LICENSE b/testsuite/tests/cabal/sigcabal02/p/LICENSE
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/p/LICENSE
diff --git a/testsuite/tests/cabal/sigcabal02/p/Map.hsig b/testsuite/tests/cabal/sigcabal02/p/Map.hsig
new file mode 100644
index 0000000000..359cf64ab9
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/p/Map.hsig
@@ -0,0 +1,18 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Map where
+
+import Set
+
+type role Map nominal representational
+data Map k a
+
+instance (Show k, Show a) => Show (Map k a)
+
+size :: Map k a -> Int
+lookup :: Ord k => k -> Map k a -> Maybe a
+empty :: Map k a
+insert :: Ord k => k -> a -> Map k a -> Map k a
+delete :: Ord k => k -> Map k a -> Map k a
+
+keysSet :: Map k a -> Set k
+fromSet :: (k -> a) -> Set k -> Map k a
diff --git a/testsuite/tests/cabal/sigcabal02/p/P.hs b/testsuite/tests/cabal/sigcabal02/p/P.hs
new file mode 100644
index 0000000000..dec6b41c94
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/p/P.hs
@@ -0,0 +1,12 @@
+module P where
+
+import qualified Map
+import qualified Set
+
+foo = do
+ let x = Map.insert 0 "foo"
+ . Map.insert (6 :: Int) "foo"
+ $ Map.empty
+ print (Map.lookup 1 x)
+ print (Set.size (Map.keysSet x))
+ return x
diff --git a/testsuite/tests/cabal/sigcabal02/p/Set.hsig b/testsuite/tests/cabal/sigcabal02/p/Set.hsig
new file mode 100644
index 0000000000..1713133365
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/p/Set.hsig
@@ -0,0 +1,13 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Set where
+
+type role Set nominal
+data Set a
+
+instance Show a => Show (Set a)
+
+size :: Set a -> Int
+member :: Ord a => a -> Set a -> Bool
+empty :: Set a
+insert :: Ord a => a -> Set a -> Set a
+delete :: Ord a => a -> Set a -> Set a
diff --git a/testsuite/tests/cabal/sigcabal02/p/p.cabal b/testsuite/tests/cabal/sigcabal02/p/p.cabal
new file mode 100644
index 0000000000..bb3b2a4463
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/p/p.cabal
@@ -0,0 +1,14 @@
+name: p
+version: 1.0
+license-file: LICENSE
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+build-type: Simple
+cabal-version: >=1.20
+
+library
+ exposed-modules: P
+ exposed-signatures: Map
+ required-signatures: Set
+ build-depends: base
+ default-language: Haskell2010
diff --git a/testsuite/tests/cabal/sigcabal02/q/LICENSE b/testsuite/tests/cabal/sigcabal02/q/LICENSE
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/q/LICENSE
diff --git a/testsuite/tests/cabal/sigcabal02/q/Map.hsig b/testsuite/tests/cabal/sigcabal02/q/Map.hsig
new file mode 100644
index 0000000000..40fd0bc74c
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/q/Map.hsig
@@ -0,0 +1,7 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Map where
+
+type role Map nominal representational
+data Map k a
+
+member :: Ord k => k -> Map k a -> Bool
diff --git a/testsuite/tests/cabal/sigcabal02/q/Q.hs b/testsuite/tests/cabal/sigcabal02/q/Q.hs
new file mode 100644
index 0000000000..ba55fb97b7
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/q/Q.hs
@@ -0,0 +1,7 @@
+module Q where
+
+import qualified Map
+import Map(Map)
+
+mymember :: Int -> Map Int a -> Bool
+mymember k m = Map.member k m || Map.member (k + 1) m
diff --git a/testsuite/tests/cabal/sigcabal02/q/q.cabal b/testsuite/tests/cabal/sigcabal02/q/q.cabal
new file mode 100644
index 0000000000..2f99c4403c
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/q/q.cabal
@@ -0,0 +1,13 @@
+name: q
+version: 1.0
+license-file: LICENSE
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+build-type: Simple
+cabal-version: >=1.20
+
+library
+ exposed-modules: Q
+ exposed-signatures: Map
+ build-depends: base
+ default-language: Haskell2010
diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr b/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr
new file mode 100644
index 0000000000..7c1f09239f
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr
@@ -0,0 +1,4 @@
+
+ShouldFail.hs:1:8:
+ Could not find module ‘Set’
+ Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout b/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout
new file mode 100644
index 0000000000..48cb59e63a
--- /dev/null
+++ b/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout
@@ -0,0 +1,5 @@
+[1 of 1] Compiling Main ( Main.hs, Main.o )
+Linking Main ...
+Nothing
+2
+True
diff --git a/testsuite/tests/driver/recomp014/Makefile b/testsuite/tests/driver/recomp014/Makefile
index 8bd973594a..c9ba0e05bd 100644
--- a/testsuite/tests/driver/recomp014/Makefile
+++ b/testsuite/tests/driver/recomp014/Makefile
@@ -19,9 +19,11 @@ recomp014: clean
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A.hs
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A1.hs
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of main:A
+ echo 'import B; main = print a' > C.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
echo 'second run'
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of main:A1
- echo 'import B; main = print a' > C.hs
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A1.o C.o -o recomp014
./recomp014
diff --git a/testsuite/tests/driver/recomp014/recomp014.stdout b/testsuite/tests/driver/recomp014/recomp014.stdout
index 2f899ed73e..7d540716f0 100644
--- a/testsuite/tests/driver/recomp014/recomp014.stdout
+++ b/testsuite/tests/driver/recomp014/recomp014.stdout
@@ -1,3 +1,4 @@
first run
+compilation IS NOT required
second run
False
diff --git a/testsuite/tests/driver/sigof01/Makefile b/testsuite/tests/driver/sigof01/Makefile
index a54a1b97e4..8e373e749e 100644
--- a/testsuite/tests/driver/sigof01/Makefile
+++ b/testsuite/tests/driver/sigof01/Makefile
@@ -21,3 +21,9 @@ sigof01m:
mkdir tmp_sigof01m
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -outputdir tmp_sigof01m --make Main.hs -sig-of "B is main:A" -o tmp_sigof01m/Main
tmp_sigof01m/Main
+
+sigof01i:
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci Main.hs -sig-of "B is main:A" < sigof01i.script
+
+sigof01i2:
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci -sig-of "B is main:A" < sigof01i2.script
diff --git a/testsuite/tests/driver/sigof01/all.T b/testsuite/tests/driver/sigof01/all.T
index d0cdc3c02c..50418b9af0 100644
--- a/testsuite/tests/driver/sigof01/all.T
+++ b/testsuite/tests/driver/sigof01/all.T
@@ -7,3 +7,13 @@ test('sigof01m',
[ clean_cmd('rm -rf tmp_sigof01m') ],
run_command,
['$MAKE -s --no-print-directory sigof01m'])
+
+test('sigof01i',
+ normal,
+ run_command,
+ ['$MAKE -s --no-print-directory sigof01i'])
+
+test('sigof01i2',
+ normal,
+ run_command,
+ ['$MAKE -s --no-print-directory sigof01i2'])
diff --git a/testsuite/tests/driver/sigof01/sigof01i.script b/testsuite/tests/driver/sigof01/sigof01i.script
new file mode 100644
index 0000000000..ba2906d066
--- /dev/null
+++ b/testsuite/tests/driver/sigof01/sigof01i.script
@@ -0,0 +1 @@
+main
diff --git a/testsuite/tests/driver/sigof01/sigof01i.stdout b/testsuite/tests/driver/sigof01/sigof01i.stdout
new file mode 100644
index 0000000000..bb614cd2a0
--- /dev/null
+++ b/testsuite/tests/driver/sigof01/sigof01i.stdout
@@ -0,0 +1,3 @@
+False
+T
+True
diff --git a/testsuite/tests/driver/sigof01/sigof01i2.script b/testsuite/tests/driver/sigof01/sigof01i2.script
new file mode 100644
index 0000000000..3a91e377a3
--- /dev/null
+++ b/testsuite/tests/driver/sigof01/sigof01i2.script
@@ -0,0 +1,3 @@
+:load B
+:browse B
+:issafe
diff --git a/testsuite/tests/driver/sigof01/sigof01i2.stdout b/testsuite/tests/driver/sigof01/sigof01i2.stdout
new file mode 100644
index 0000000000..ac15dcfa1e
--- /dev/null
+++ b/testsuite/tests/driver/sigof01/sigof01i2.stdout
@@ -0,0 +1,8 @@
+class Foo a where
+ foo :: a -> a
+data T = A.T
+mkT :: T
+x :: Bool
+Trust type is (Module: Safe, Package: trusted)
+Package Trust: Off
+B is trusted!
diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr
index 9cd00a2930..70c6f22d89 100644
--- a/testsuite/tests/package/package09e.stderr
+++ b/testsuite/tests/package/package09e.stderr
@@ -1,5 +1,5 @@
package09e.hs:2:1:
Ambiguous interface for ‘M’:
- it is bound as Data.Set by a package flag
it is bound as Data.Map by a package flag
+ it is bound as Data.Set by a package flag