diff options
40 files changed, 581 insertions, 139 deletions
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 61beca2f5c..ad6a6b1d7b 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 8c2a07c07f..3e8423c432 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 bdfba7c9bd..5250c4f0fa 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 @@ -742,7 +747,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 @@ -759,7 +764,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 970031327c..a493da988d 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1334,9 +1334,20 @@ checkDependencies hsc_env summary iface find_res <- liftIO $ findImportedModule hsc_env mod (fmap snd 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" @@ -1344,7 +1355,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) <> @@ -1353,7 +1364,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 310007d000..c51feeb491 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 0d72bece36..3b62717a9c 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 00ba0388dd..d8aef57011 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 1a7d4ef71e..d9380e10c3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1378,6 +1378,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 @@ -1388,17 +1402,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 @@ -1419,11 +1439,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 2d1d9ebf52..89cab9ef3a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1815,7 +1815,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 @@ -1877,7 +1880,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 @@ -1886,6 +1892,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 b7707f80af..0dd6341e1f 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)] @@ -2069,6 +2084,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 0be5e3ffaf..16ee352243 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -132,9 +132,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 @@ -158,7 +159,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 -> [] @@ -175,17 +176,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 @@ -227,11 +229,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 @@ -249,7 +280,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 @@ -261,7 +292,7 @@ emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyUFM, preloadPackages = [], - moduleToPkgConfAll = Map.empty, + moduleNameDb = Map.empty, installedPackageIdMap = Map.empty } @@ -1025,7 +1056,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) @@ -1034,62 +1065,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 @@ -1199,16 +1238,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 @@ -1218,6 +1261,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 @@ -1226,23 +1302,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 @@ -1277,17 +1358,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 @@ -1426,7 +1508,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 bbf9e649aa..7209f5e7c2 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 d4ef22bf5c..6ebb05a90e 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -118,6 +118,12 @@ mk/ghcconfig*_bin_ghc-*.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 new file mode 100644 index 0000000000..e788110097 --- /dev/null +++ b/testsuite/tests/driver/recomp014/Makefile @@ -0,0 +1,31 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +# Recompilation tests + +clean: + rm -f *.o *.hi + +recomp014: clean + echo 'module A where a = False' > A.hs + echo 'module A1 where a = False' > A1.hs + echo 'module B where a :: Bool' > B.hsig + echo 'first run' + '$(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 "B is 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 "B is main:A1" + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A1.o C.o -o recomp014 + ./recomp014 + +.PHONY: clean recomp014 diff --git a/testsuite/tests/driver/recomp014/all.T b/testsuite/tests/driver/recomp014/all.T new file mode 100644 index 0000000000..affccd2f7f --- /dev/null +++ b/testsuite/tests/driver/recomp014/all.T @@ -0,0 +1,4 @@ +test('recomp014', + [ clean_cmd('$MAKE -s clean') ], + run_command, + ['$MAKE -s --no-print-directory recomp014']) diff --git a/testsuite/tests/driver/recomp014/recomp014.stdout b/testsuite/tests/driver/recomp014/recomp014.stdout new file mode 100644 index 0000000000..7d540716f0 --- /dev/null +++ b/testsuite/tests/driver/recomp014/recomp014.stdout @@ -0,0 +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 84dfc33a9f..629d4b656a 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 |