X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=4e4844d46005fa41ddf1c526d0498bceb78be1b9;hb=50027272414438955dbc41696541cbd25da55883;hp=501dbd001c69fbc91f9b2d3608d9fe7b5d5c747a;hpb=fd99cf4f7c390e4b1abc9a839a6f023d3b6c4757;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 501dbd0..4e4844d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,10 +5,11 @@ \begin{code} module Finder ( - initFinder, -- :: PackageConfigInfo -> IO (), + initFinder, -- :: [PackageConfig] -> IO (), findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - ModuleLocation(..), - mkHomeModuleLocn, + mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath + -- -> IO ModuleLocation + emptyHomeDirCache -- :: IO () ) where #include "HsVersions.h" @@ -17,15 +18,19 @@ import HscTypes ( ModuleLocation(..) ) import CmStaticInfo import DriverPhases import DriverState +import DriverUtil import Module import FiniteMap import Util +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 @@ -35,29 +40,34 @@ source, interface, and object files for a module live. \begin{code} --- caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, error "no pkg cache!", 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)) -initFinder :: PackageConfigInfo -> IO () -initFinder (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)) + } - -- lazilly fill in the package cache - writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) +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 +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 @@ -72,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 @@ -100,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 @@ -109,14 +152,15 @@ 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 :: [Package] -> IO (FiniteMap String (PackageName, FilePath)) +newPkgCache :: [PackageConfig] -> IO (FiniteMap String (PackageName, FilePath)) newPkgCache pkgs = do let extendFM fm pkg = do let dirs = import_dirs pkg @@ -142,7 +186,7 @@ maybePackageModule mod_name = do then return "hi" else return (tag ++ "_hi") - let basename = moduleNameString mod_name + let basename = moduleNameUserString mod_name hi = basename ++ '.':package_hisuf case lookupFM pkg_cache hi of @@ -150,17 +194,22 @@ maybePackageModule mod_name = do 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) (\_ -> do hPutStr stderr ("WARNING: error while reading directory " ++ d) return [] ) - + \end{code}