X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=4e4844d46005fa41ddf1c526d0498bceb78be1b9;hb=50027272414438955dbc41696541cbd25da55883;hp=f49018c5a3281a34df9a8ee4b07630345e60bba6;hpb=6c0aafc41d20abd1afb9ba1ea965709e4c24abf0;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index f49018c..4e4844d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,28 +5,32 @@ \begin{code} module Finder ( - Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation)) - newFinder, -- :: PackageConfigInfo -> IO Finder, - ModuleLocation(..), - mkHomeModuleLocn + initFinder, -- :: [PackageConfig] -> IO (), + findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath + -- -> IO ModuleLocation + emptyHomeDirCache -- :: IO () ) where #include "HsVersions.h" -import HscTypes ( Finder, ModuleLocation(..) ) +import HscTypes ( ModuleLocation(..) ) import CmStaticInfo import DriverPhases import DriverState +import DriverUtil import Module import FiniteMap import Util -import Panic +import Panic ( panic ) +import Config import IOExts import Directory import List import IO import Monad +import Outputable \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -36,49 +40,34 @@ source, interface, and object files for a module live. \begin{code} --- caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath))) +-- v_PkgDirCache caches contents of package directories, never expunged +GLOBAL_VAR(v_PkgDirCache, panic "no pkg cache!", + FiniteMap String (PackageName, FilePath)) --- caches contents of home directories, expunged whenever we --- create a new finder. -GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) +-- v_HomeDirCache caches contents of home directories, +-- expunged whenever we create a new finder. +GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) -newFinder :: PackageConfigInfo -> IO Finder -newFinder (PackageConfigInfo pkgs) = do - -- expunge our home cache - writeIORef v_HomeDirCache Nothing +initFinder :: [PackageConfig] -> IO () +initFinder pkgs + = do { -- expunge our home cache + ; writeIORef v_HomeDirCache Nothing + -- lazilly fill in the package cache + ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) + } - -- populate the package cache, if necessary - pkg_cache <- readIORef v_PkgDirCache - case pkg_cache of - Nothing -> do - - let extendFM fm pkg = do - let dirs = import_dirs pkg - pkg_name = _PK_ (name pkg) - let addDir fm dir = do - contents <- getDirectoryContents' dir - return (addListToFM fm (zip contents - (repeat (pkg_name,dir)))) - foldM addDir fm dirs - - pkg_map <- foldM extendFM emptyFM pkgs - writeIORef v_PkgDirCache (Just pkg_map) - - Just _ -> - return () - - -- and return the finder - return finder - - -finder :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -finder name = do - j <- maybeHomeModule name - case j of - Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name +emptyHomeDirCache :: IO () +emptyHomeDirCache + = writeIORef v_HomeDirCache Nothing + +findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findModule name + = do { j <- maybeHomeModule name + ; case j of + Just home_module -> return (Just home_module) + Nothing -> maybePackageModule name + } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) maybeHomeModule mod_name = do @@ -93,26 +82,57 @@ maybeHomeModule mod_name = do home_imports <- readIORef v_Import_paths let extendFM fm path = do contents <- getDirectoryContents' path - return (addListToFM fm (zip contents (repeat path))) + let clean_contents = filter isUsefulFile contents + return (addListToFM fm (zip clean_contents (repeat path))) home_map <- foldM extendFM emptyFM home_imports writeIORef v_HomeDirCache (Just home_map) return home_map Just home_map -> return home_map - let basename = moduleNameString mod_name + let basename = moduleNameUserString mod_name hs = basename ++ ".hs" lhs = basename ++ ".lhs" case lookupFM home_map hs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs; + -- special case to avoid getting "./foo.hs" all the time + Just "." -> mkHomeModuleLocn mod_name basename hs; + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> case lookupFM home_map lhs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs; + -- special case to avoid getting "./foo.hs" all the time + Just "." -> mkHomeModuleLocn mod_name basename lhs; + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':lhs); + Nothing -> do + + -- can't find a source file anywhere, check for a lone .hi file. + hisuf <- readIORef v_Hi_suf + let hi = basename ++ '.':hisuf + case lookupFM home_map hi of { + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); + Nothing -> do + + -- last chance: .hi-boot- and .hi-boot + let hi_boot = basename ++ ".hi-boot" + let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion + case lookupFM home_map hi_boot_ver of { + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); + Nothing -> do + case lookupFM home_map hi_boot of { + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> return Nothing + }}}}} - }} + +-- The .hi file always follows the module name, whereas the object +-- file may follow the name of the source file in the case where the +-- two differ (see summariseFile in compMan/CompManager.lhs). mkHomeModuleLocn mod_name basename source_fn = do @@ -121,7 +141,9 @@ mkHomeModuleLocn mod_name basename source_fn = do ohi <- readIORef v_Output_hi hisuf <- readIORef v_Hi_suf let hifile = case ohi of - Nothing -> basename ++ '.':hisuf + Nothing -> getdir basename + ++ '/':moduleNameUserString mod_name + ++ '.':hisuf Just fn -> fn -- figure out the .o file name. It also lives in the same dir @@ -130,18 +152,32 @@ mkHomeModuleLocn mod_name basename source_fn = do return (Just (mkHomeModule mod_name, ModuleLocation{ - hs_file = source_fn, - hi_file = hifile, - obj_file = o_file + ml_hspp_file = Nothing, + ml_hs_file = Just source_fn, + ml_hi_file = Just hifile, + ml_obj_file = Just o_file } )) + +newPkgCache :: [PackageConfig] -> IO (FiniteMap String (PackageName, FilePath)) +newPkgCache pkgs = do + let extendFM fm pkg = do + let dirs = import_dirs pkg + pkg_name = _PK_ (name pkg) + let addDir fm dir = do + contents <- getDirectoryContents' dir + return (addListToFM fm (zip contents + (repeat (pkg_name,dir)))) + foldM addDir fm dirs + + pkg_map <- foldM extendFM emptyFM pkgs + return pkg_map + + maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) maybePackageModule mod_name = do - maybe_pkg_cache <- readIORef v_PkgDirCache - case maybe_pkg_cache of { - Nothing -> panic "maybePackageModule: no pkg_cache"; - Just pkg_cache -> do + pkg_cache <- readIORef v_PkgDirCache -- hi-suffix for packages depends on the build tag. package_hisuf <- @@ -150,21 +186,24 @@ maybePackageModule mod_name = do then return "hi" else return (tag ++ "_hi") - let basename = moduleNameString mod_name - hi = basename ++ '.':package_hisuf + let basename = moduleNameUserString mod_name + hi = basename ++ '.':package_hisuf case lookupFM pkg_cache hi of Nothing -> return Nothing Just (pkg_name,path) -> return (Just (mkModule mod_name pkg_name, ModuleLocation{ - hs_file = error "package module; no source", - hi_file = hi, - obj_file = error "package module; no object" + ml_hspp_file = Nothing, + ml_hs_file = Nothing, + ml_hi_file = Just (path ++ '/':hi), + ml_obj_file = Nothing } )) - } +isUsefulFile fn + = let suffix = (reverse . takeWhile (/= '.') . reverse) fn + in suffix `elem` ["hi", "hs", "lhs", "hi-boot", "hi-boot-5"] getDirectoryContents' d = IO.catch (getDirectoryContents d) @@ -172,5 +211,5 @@ getDirectoryContents' d ("WARNING: error while reading directory " ++ d) return [] ) - + \end{code}