X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=a5db92671d25264682a7389ae89184a53834a873;hb=224131a71a9edbd6aa8d5a704f1012f8a0a88814;hp=732047bfb649456f0d225f463763866d37c52822;hpb=c1d8b21c963eec0cee6151b98c35e1fb372ee163;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 732047b..a5db926 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,28 +5,32 @@ \begin{code} module Finder ( - initFinder, -- :: PackageConfigInfo -> IO (), + initFinder, -- :: [PackageConfig] -> IO (), findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - emptyHomeDirCache -- :: IO () + findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) + findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> 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 DriverUtil 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 \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -35,160 +39,170 @@ 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 name = findModuleDep name False -findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule_wrk name - = do { j <- maybeHomeModule name +findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) +findModuleDep name is_source + = do { j <- maybeHomeModule name is_source ; case j of Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name + Nothing -> findPackageMod name False } -maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -maybeHomeModule mod_name = do - home_cache <- readIORef v_HomeDirCache - - 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 - hs = basename ++ ".hs" - lhs = basename ++ ".lhs" - - case lookupFM home_map hs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs; - Nothing -> - - case lookupFM home_map lhs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs; - Nothing -> return Nothing - - }} - -mkHomeModuleLocn mod_name basename 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 +maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) +maybeHomeModule mod_name is_source = do + home_path <- readIORef v_Import_paths + hisuf <- readIORef v_Hi_suf + mode <- readIORef v_GhcMode + + let mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi files only. + -- + -- When generating dependencies, we're interested in either category. + -- + source_exts = + [ ("hs", \ _ fName path -> mkHomeModuleLocn mod_name path fName) + , ("lhs", \ _ fName path -> mkHomeModuleLocn mod_name path fName) + ] + hi_exts = [ (hisuf, \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) ] + + std_exts + | mode == DoMkDependHS = hi_exts ++ source_exts + | isCompManagerMode mode = source_exts + | otherwise = hi_exts + + -- last chance: .hi-boot- and .hi-boot + hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion + + boot_exts = + [ (hi_boot_ver, \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) + , ("hi-boot", \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) + ] + + searchPathExts + (map ((,) undefined) home_path) + basename + (if is_source then (boot_exts++std_exts) else std_exts ++ boot_exts) + -- for SOURCE imports, check the hi-boot extensions + -- before the source/iface ones, to avoid + -- creating circ Makefile deps. + +mkHiOnlyModuleLocn mod_name hi_file = + return + ( 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 -- everything but the extension + source_fn -- full path to the source (required) + = do + hisuf <- readIORef v_Hi_suf - let hifile = case ohi of - Nothing -> basename ++ '.':hisuf - Just fn -> fn + hidir <- readIORef v_Hi_dir + + -- take the *last* component of the module name (if a hierarchical name), + -- and append it to the directory to get the .hi file name. + let (_,mod_str) = split_longest_prefix (moduleNameUserString mod_name) (=='.') + hi_filename = mod_str ++ '.':hisuf + hi_path | Just d <- hidir = d + | otherwise = getdir basename + hi = hi_path ++ '/':hi_filename -- 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 (basename ++ '.':phaseInputExt Ln) >>= osuf_ify - return (Just (mkHomeModule mod_name, - ModuleLocation{ - 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 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 - - -- hi-suffix for packages depends on the build tag. + return (mkHomeModule mod_name, + ModuleLocation{ ml_hspp_file = Nothing + , ml_hs_file = Just source_fn + , ml_hi_file = hi + , ml_obj_file = Just o_file + }) + +findPackageMod :: ModuleName + -> Bool + -> IO (Maybe (Module, ModuleLocation)) +findPackageMod mod_name hiOnly = do + pkgs <- getPackageInfo + + -- hi-suffix for packages depends on the build tag. package_hisuf <- 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 - - case lookupFM pkg_cache hi of - Nothing -> return Nothing - 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_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 [] - ) - + let imp_dirs = concatMap (\ pkg -> map ((,) pkg) (import_dirs pkg)) pkgs + mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str + + mkPackageModule mod_name pkg mbFName path = + return ( mkModule mod_name (mkFastString (name pkg)) + , ModuleLocation{ ml_hspp_file = Nothing + , ml_hs_file = mbFName + , ml_hi_file = path ++ '.':package_hisuf + , ml_obj_file = Nothing + }) + + searchPathExts + imp_dirs basename + ((package_hisuf,\ pkg fName path -> mkPackageModule mod_name pkg Nothing path) : + -- can packages contain hi-boots? + (if hiOnly then [] else + [ ("hs", \ pkg fName path -> mkPackageModule mod_name pkg (Just fName) path) + , ("lhs", \ pkg fName path -> mkPackageModule mod_name pkg (Just fName) path) + ])) + where + +findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule mod_name = findPackageMod mod_name True + +searchPathExts :: [(a, FilePath)] + -> String + -> [(String, a -> FilePath -> String -> IO (Module, ModuleLocation))] + -> IO (Maybe (Module, ModuleLocation)) +searchPathExts path basename exts = search exts + where + search [] = return Nothing + search ((x,f):xs) = do + let fName = (basename ++ '.':x) + found <- findOnPath path fName + case found of + -- special case to avoid getting "./foo." all the time + Just (v,".") -> fmap Just (f v fName basename) + Just (v,path) -> fmap Just (f v (path ++ '/':fName) + (path ++ '/':basename)) + Nothing -> search xs + +findOnPath :: [(a,String)] -> String -> IO (Maybe (a, FilePath)) +findOnPath path s = loop path + where + loop [] = return Nothing + loop ((a,d):ds) = do + let file = d ++ '/':s + b <- doesFileExist file + if b then return (Just (a,d)) else loop ds \end{code}