diff options
Diffstat (limited to 'compiler/main/Finder.hs')
| -rw-r--r-- | compiler/main/Finder.hs | 203 |
1 files changed, 142 insertions, 61 deletions
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index e813e9e52c..2bcdd3360c 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -71,25 +71,25 @@ type BaseName = String -- Basename of file -- assumed to not move around during a session. flushFinderCaches :: HscEnv -> IO () flushFinderCaches hsc_env = - atomicModifyIORef' fc_ref $ \fm -> (filterModuleEnv is_ext fm, ()) + atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where this_pkg = thisPackage (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env - is_ext mod _ | moduleUnitId mod /= this_pkg = True + is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True | otherwise = False -addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO () +addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache ref key val = - atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ()) + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) -removeFromFinderCache :: IORef FinderCache -> Module -> IO () +removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () removeFromFinderCache ref key = - atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) lookupFinderCache ref key = do c <- readIORef ref - return $! lookupModuleEnv c key + return $! lookupInstalledModuleEnv c key -- ----------------------------------------------------------------------------- -- The three external entry points @@ -131,11 +131,11 @@ findPluginModule hsc_env mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> VirginModule -> IO FindResult +findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if moduleUnitId mod == thisPackage dflags - then findHomeModule hsc_env (moduleName mod) + in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (installedModuleName mod) else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- @@ -169,9 +169,9 @@ 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 InstalledFindResult -> IO InstalledFindResult homeSearchCache hsc_env mod_name do_this = do - let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name modLocationCache hsc_env mod do_this findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString @@ -190,8 +190,20 @@ findExposedPluginPackageModule hsc_env mod_name findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of - LookupFound m pkg_conf -> - findPackageModule_ hsc_env m pkg_conf + LookupFound m pkg_conf -> do + let im = fst (splitModuleInsts m) + r' <- findPackageModule_ hsc_env im pkg_conf + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = []}) LookupMultiple rs -> return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> @@ -205,7 +217,7 @@ findLookupResult hsc_env r = case r of , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -215,20 +227,43 @@ modLocationCache hsc_env mod do_this = do addToFinderCache (hsc_FC hsc_env) mod result return result +mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule +mkHomeInstalledModule dflags mod_name = + let iuid = fst (splitUnitIdInsts (thisPackage dflags)) + in InstalledModule iuid mod_name + +-- This returns a module because it's more convenient for users 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) - return mod + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) + return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () -uncacheModule hsc_env mod = do - let this_pkg = thisPackage (hsc_dflags hsc_env) - removeFromFinderCache (hsc_FC hsc_env) (mkModule this_pkg mod) +uncacheModule hsc_env mod_name = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + removeFromFinderCache (hsc_FC hsc_env) mod -- ----------------------------------------------------------------------------- -- The internal workers +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = do + r <- findInstalledHomeModule hsc_env mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_suggestions = [] + } + where + dflags = hsc_dflags hsc_env + uid = thisPackage dflags + -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations: @@ -245,14 +280,14 @@ 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 hsc_env mod_name = +findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ let dflags = hsc_dflags hsc_env home_path = importPaths dflags hisuf = hiSuf dflags - mod = mkModule (thisPackage dflags) mod_name + mod = mkHomeInstalledModule dflags mod_name source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") @@ -275,20 +310,20 @@ findHomeModule hsc_env mod_name = -- special case for GHC.Prim; we won't find it in the filesystem. -- 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) + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> VirginModule -> IO FindResult +findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = moduleUnitId mod + pkg_id = installedModuleUnitId mod -- - case lookupPackage dflags pkg_id of - Nothing -> return (NoPackage pkg_id) + case lookupInstalledPackage dflags pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf -- | Look up the interface file associated with module @mod@. This function @@ -298,14 +333,14 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult findPackageModule_ hsc_env mod pkg_conf = - ASSERT( moduleUnitId mod == packageConfigId pkg_conf ) + ASSERT( installedModuleUnitId mod == installedPackageConfigId 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) + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) else let @@ -326,9 +361,9 @@ findPackageModule_ hsc_env mod pkg_conf = [one] | MkDepend <- ghcMode dflags -> do -- there's only one place that this .hi file can be, so -- don't bother looking for it. - let basename = moduleNameSlashes (moduleName mod) + let basename = moduleNameSlashes (installedModuleName mod) loc <- mk_hi_loc one basename - return (Found loc mod) + return (InstalledFound loc mod) _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -337,13 +372,13 @@ findPackageModule_ hsc_env mod pkg_conf = searchPathExts :: [FilePath] -- paths to search - -> Module -- module name + -> InstalledModule -- module name -> [ ( FileExt, -- suffix FilePath -> BaseName -> IO ModLocation -- action ) ] - -> IO FindResult + -> IO InstalledFindResult searchPathExts paths mod exts = do result <- search to_search @@ -358,7 +393,7 @@ searchPathExts paths mod exts return result where - basename = moduleNameSlashes (moduleName mod) + basename = moduleNameSlashes (installedModuleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) @@ -369,15 +404,12 @@ searchPathExts paths mod exts file = base <.> ext ] - search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (moduleUnitId mod) - , fr_mods_hidden = [], fr_pkgs_hidden = [] - , fr_suggestions = [] }) + search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId 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 (InstalledFound loc mod) } else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt @@ -539,9 +571,9 @@ cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc cannotFindModule = cantFindErr (sLit "Could not find module") (sLit "Ambiguous module name") -cannotFindInterface :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindInterface = cantFindErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") +cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult -> SDoc @@ -581,7 +613,7 @@ cantFindErr cannot_find _ dflags mod_name find_result = case find_result of NoPackage pkg -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg + text "was found" NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens @@ -642,18 +674,6 @@ cantFindErr cannot_find _ dflags mod_name find_result text "to the build-depends in your .cabal file." | otherwise = Outputable.empty - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id FastString into a source package ID - -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - mod_hidden pkg = text "it is a hidden module in the package" <+> quotes (ppr pkg) @@ -693,3 +713,64 @@ cantFindErr cannot_find _ dflags mod_name find_result = parens (text "needs flag -package-id" <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty + +cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult + -> SDoc +cantFindInstalledErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files + + _ -> panic "cantFindInstalledErr" + + build_tag = buildTag dflags + + looks_like_srcpkgid :: InstalledUnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id FastString into a source package ID + -- FastString and see if it means anything. + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files + + tried_these files + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) |