X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=4e4844d46005fa41ddf1c526d0498bceb78be1b9;hb=50027272414438955dbc41696541cbd25da55883;hp=673bdb927651344245e6b5d57084675f44b23c2a;hpb=6eaf5c6c69483cab51ba2967b75655459fa5cc96;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 673bdb9..4e4844d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,8 +5,11 @@ \begin{code} module Finder ( - initFinder, -- :: PackageConfigInfo -> IO (), - findModule -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + initFinder, -- :: [PackageConfig] -> IO (), + findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath + -- -> IO ModuleLocation + emptyHomeDirCache -- :: IO () ) where #include "HsVersions.h" @@ -15,16 +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 ( showSDoc, ppr ) -- debugging only +import Outputable \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -35,41 +41,32 @@ source, interface, and object files for a module live. \begin{code} -- v_PkgDirCache caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, error "no pkg cache!", FiniteMap String (PackageName, FilePath)) +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)) +GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) -initFinder :: PackageConfigInfo -> IO () +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)) - --- Debug output --- ; pkg_dbg_info <- readIORef v_PkgDirCache --- ; putStrLn (unlines (map show (fmToList pkg_dbg_info))) } +emptyHomeDirCache :: IO () +emptyHomeDirCache + = writeIORef v_HomeDirCache Nothing + 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 -> maybePackageModule name } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) @@ -93,19 +90,49 @@ maybeHomeModule mod_name = do 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 @@ -114,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 @@ -123,22 +152,22 @@ 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 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 + return (addListToFM fm (zip contents (repeat (pkg_name,dir)))) foldM addDir fm dirs @@ -157,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 @@ -165,9 +194,10 @@ 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 = path ++ '/':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 } )) @@ -181,5 +211,5 @@ getDirectoryContents' d ("WARNING: error while reading directory " ++ d) return [] ) - + \end{code}