X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=74b243ac9af897fa66608f1a34ce38336ddb7979;hb=17629712b35948e3751a39747dcc9ee0cbfb72aa;hp=732047bfb649456f0d225f463763866d37c52822;hpb=c1d8b21c963eec0cee6151b98c35e1fb372ee163;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 732047b..74b243a 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,28 +5,31 @@ \begin{code} module Finder ( - initFinder, -- :: PackageConfigInfo -> IO (), + initFinder, -- :: [PackageConfig] -> IO (), findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - emptyHomeDirCache -- :: IO () + findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> Maybe FilePath + -- -> IO ModuleLocation + emptyHomeDirCache, -- :: IO () + flushPackageCache -- :: [PackageConfig] -> IO () ) where #include "HsVersions.h" import HscTypes ( ModuleLocation(..) ) -import CmStaticInfo +import Packages ( PackageConfig(..) ) import DriverPhases import DriverState import Module -import FiniteMap -import Util -import Panic ( panic ) +import FastString +import Config import IOExts -import Directory import List +import Directory import IO import Monad -import Outputable ( showSDoc, ppr ) -- debugging only +import Outputable \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -35,94 +38,93 @@ lives in, so it can make a Module from a ModuleName, and (b) where the source, interface, and object files for a module live. \begin{code} +initFinder :: [PackageConfig] -> IO () +initFinder pkgs = return () --- v_PkgDirCache caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, panic "no pkg cache!", - FiniteMap String (PackageName, 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 pkgs - = do { -- expunge our home cache - ; writeIORef v_HomeDirCache Nothing - -- lazilly fill in the package cache - ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) - --- Debug output --- ; pkg_dbg_info <- readIORef v_PkgDirCache --- ; putStrLn (unlines (map show (fmToList pkg_dbg_info))) - } +-- empty, and lazilly fill in the package cache +flushPackageCache :: [PackageConfig] -> IO () +flushPackageCache pkgs = return () emptyHomeDirCache :: IO () -emptyHomeDirCache - = writeIORef v_HomeDirCache Nothing +emptyHomeDirCache = return () findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) findModule name - = do { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ") - ; maybe_m <- findModule_wrk name - ; case maybe_m of - Nothing -> hPutStrLn stderr "Not Found" - Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm))) - ; return maybe_m - } - -findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule_wrk name = do { j <- maybeHomeModule name ; case j of Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name + Nothing -> findPackageModule name } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) maybeHomeModule mod_name = do - home_cache <- readIORef v_HomeDirCache + home_path <- readIORef v_Import_paths - home_map <- - case home_cache of - Nothing -> do - -- populate the home dir cache, using the import path (the import - -- path is changed by -i flags on the command line, and defaults - -- to ["."]). - home_imports <- readIORef v_Import_paths - let extendFM fm path = do - contents <- getDirectoryContents' 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 mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str hs = basename ++ ".hs" lhs = basename ++ ".lhs" - case lookupFM home_map hs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs; - Nothing -> + found <- findOnPath home_path hs + case found of { + -- special case to avoid getting "./foo.hs" all the time + Just "." -> mkHomeModuleLocn mod_name basename (Just hs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (Just (path ++ '/':hs)); + Nothing -> do + + found <- findOnPath home_path lhs + case found of { + -- special case to avoid getting "./foo.hs" all the time + Just "." -> mkHomeModuleLocn mod_name basename (Just lhs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (Just (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 + found <- findOnPath home_path hi + case found of { + Just path -> mkHiOnlyModuleLocn mod_name hi; + Nothing -> do - case lookupFM home_map lhs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs; + -- last chance: .hi-boot- and .hi-boot + let hi_boot = basename ++ ".hi-boot" + let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion + found <- findOnPath home_path hi_boot_ver + case found of { + Just path -> mkHiOnlyModuleLocn mod_name hi; + Nothing -> do + found <- findOnPath home_path hi_boot + case found of { + Just path -> mkHiOnlyModuleLocn mod_name hi; Nothing -> return Nothing + }}}}} - }} -mkHomeModuleLocn mod_name basename source_fn = do +mkHiOnlyModuleLocn mod_name hi_file = do + return (Just (mkHomeModule mod_name, + ModuleLocation{ + ml_hspp_file = Nothing, + ml_hs_file = Nothing, + ml_hi_file = hi_file, + ml_obj_file = 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 maybe_source_fn = do - -- figure out the .hi file name: it lives in the same dir as the - -- source, unless there's a -ohi flag on the command line. - ohi <- readIORef v_Output_hi hisuf <- readIORef v_Hi_suf - let hifile = case ohi of - Nothing -> basename ++ '.':hisuf - Just fn -> fn + hidir <- readIORef v_Hi_dir + + let hi_rest = basename ++ '.':hisuf + hi_file | Just d <- hidir = d ++ '/':hi_rest + | otherwise = hi_rest -- figure out the .o file name. It also lives in the same dir -- as the source, but can be overriden by a -odir flag. @@ -131,32 +133,16 @@ mkHomeModuleLocn mod_name basename source_fn = do return (Just (mkHomeModule mod_name, ModuleLocation{ ml_hspp_file = Nothing, - ml_hs_file = Just source_fn, - ml_hi_file = Just hifile, + ml_hs_file = maybe_source_fn, + ml_hi_file = hi_file, ml_obj_file = Just o_file } )) -newPkgCache :: [Package] -> 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 - let clean_contents = filter isUsefulFile contents - return (addListToFM fm (zip clean_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 - pkg_cache <- readIORef v_PkgDirCache +findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule mod_name = do + pkgs <- getPackageInfo -- hi-suffix for packages depends on the build tag. package_hisuf <- @@ -165,30 +151,40 @@ maybePackageModule mod_name = do then return "hi" else return (tag ++ "_hi") - let basename = moduleNameString mod_name + let mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str hi = basename ++ '.':package_hisuf - case lookupFM pkg_cache hi of + found <- findOnPackagePath pkgs hi + case found of Nothing -> return Nothing - Just (pkg_name,path) -> + Just (pkg_name,path) -> return (Just (mkModule mod_name pkg_name, ModuleLocation{ ml_hspp_file = Nothing, ml_hs_file = Nothing, - ml_hi_file = Just (path ++ '/':hi), + ml_hi_file = 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 [] - ) - +findOnPackagePath :: [PackageConfig] -> String + -> IO (Maybe (PackageName,FilePath)) +findOnPackagePath pkgs file = loop pkgs + where + loop [] = return Nothing + loop (p:ps) = do + found <- findOnPath (import_dirs p) file + case found of + Nothing -> loop ps + Just path -> return (Just (mkFastString (name p), path)) + +findOnPath :: [String] -> String -> IO (Maybe FilePath) +findOnPath path s = loop path + where + loop [] = return Nothing + loop (d:ds) = do + let file = d ++ '/':s + b <- doesFileExist file + if b then return (Just d) else loop ds \end{code}