X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=74b243ac9af897fa66608f1a34ce38336ddb7979;hb=abd4130600ca2b6ba50ff70dc6959baa4141b405;hp=b345755d95626b451d1c94bc3a147603891ef65c;hpb=75308b6727c552f6990b9984f0d2cd6374779359;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index b345755..74b243a 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,26 +5,31 @@ \begin{code} module Finder ( - Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation)) - newFinder, -- :: PackageConfigInfo -> IO Finder, - ModuleLocation(..) + initFinder, -- :: [PackageConfig] -> IO (), + findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> Maybe FilePath + -- -> IO ModuleLocation + emptyHomeDirCache, -- :: IO () + flushPackageCache -- :: [PackageConfig] -> IO () ) where #include "HsVersions.h" -import CmStaticInfo +import HscTypes ( ModuleLocation(..) ) +import Packages ( PackageConfig(..) ) import DriverPhases import DriverState import Module -import FiniteMap -import Util -import Panic +import FastString +import Config import IOExts -import Directory import List +import Directory import IO import Monad +import Outputable \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -33,155 +38,153 @@ 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} -type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation)) - --- For a module in another package, the hs_file and obj_file --- components of ModuleLocation are undefined. - --- The locations specified by a ModuleLocation may or may not --- correspond to actual files yet: for example, even if the object --- file doesn't exist, the ModuleLocation still contains the path to --- where the object file will reside if/when it is created. - -data ModuleLocation - = ModuleLocation { - hs_file :: FilePath, - hi_file :: FilePath, - obj_file :: FilePath - } - --- caches contents of package directories, never expunged -GLOBAL_VAR(pkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath))) - --- caches contents of home directories, expunged whenever we --- create a new finder. -GLOBAL_VAR(homeDirCache, emptyFM, FiniteMap String FilePath) - --- caches finder mapping, expunged whenever we create a new finder. -GLOBAL_VAR(finderMapCache, emptyFM, FiniteMap ModuleName Module) - - -newFinder :: PackageConfigInfo -> IO Finder -newFinder (PackageConfigInfo pkgs) = do - -- expunge our caches - writeIORef homeDirCache emptyFM - writeIORef finderMapCache emptyFM - - -- 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 import_paths - let extendFM fm path = do - contents <- getDirectoryContents' path - return (addListToFM fm (zip contents (repeat path))) - home_map <- foldM extendFM emptyFM home_imports - writeIORef homeDirCache home_map - - -- populate the package cache, if necessary - pkg_cache <- readIORef 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 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 +initFinder :: [PackageConfig] -> IO () +initFinder pkgs = return () + +-- empty, and lazilly fill in the package cache +flushPackageCache :: [PackageConfig] -> IO () +flushPackageCache pkgs = return () + +emptyHomeDirCache :: IO () +emptyHomeDirCache = return () + +findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findModule name + = do { j <- maybeHomeModule name + ; case j of + Just home_module -> return (Just home_module) + Nothing -> findPackageModule name + } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) maybeHomeModule mod_name = do - home_cache <- readIORef homeDirCache + home_path <- readIORef v_Import_paths - 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_cache hs of { - Just path -> mkHomeModuleLocn mod_name basename path hs; - Nothing -> - - case lookupFM home_cache lhs of { - Just path -> mkHomeModuleLocn mod_name basename path lhs; + 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 + + -- 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 path 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 output_hi - hisuf <- readIORef hi_suf - let hifile = case ohi of - Nothing -> path ++ '/':basename ++ hisuf - Just fn -> fn + hisuf <- readIORef v_Hi_suf + 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. - o_file <- odir_ify (path ++ '/':basename ++ '.':phaseInputExt Ln) + o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify return (Just (mkHomeModule mod_name, ModuleLocation{ - hs_file = source_fn, - hi_file = hifile, - obj_file = o_file + ml_hspp_file = Nothing, + ml_hs_file = maybe_source_fn, + ml_hi_file = hi_file, + ml_obj_file = Just o_file } )) -maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -maybePackageModule mod_name = do - maybe_pkg_cache <- readIORef pkgDirCache - case maybe_pkg_cache of { - Nothing -> panic "maybePackageModule: no pkg_cache"; - Just pkg_cache -> do + +findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule mod_name = do + pkgs <- getPackageInfo -- hi-suffix for packages depends on the build tag. package_hisuf <- - do tag <- readIORef build_tag + do tag <- readIORef v_Build_tag if null tag then return "hi" else return (tag ++ "_hi") - let basename = moduleNameString mod_name - hi = basename ++ '.':package_hisuf + 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{ - 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 = path ++ '/':hi, + ml_obj_file = Nothing } )) - } - -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}