X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=fc945b68beb3f9dfe372f3e8decf48587c78c7ff;hb=027168af50b6eee2ee043caf7a030d490b40967e;hp=6cb1fc9ae1562691c655807e60fb1bb93de83595;hpb=74a7a2645c2399155a11503e0d558f921d0c7f36;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 6cb1fc9..fc945b6 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -7,7 +7,9 @@ module Finder ( initFinder, -- :: [PackageConfig] -> IO (), findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - mkHomeModuleLocn, -- :: ModuleName -> String -> Maybe FilePath + findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) + findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath -- -> IO ModuleLocation emptyHomeDirCache, -- :: IO () flushPackageCache -- :: [PackageConfig] -> IO () @@ -16,15 +18,12 @@ module Finder ( #include "HsVersions.h" import HscTypes ( ModuleLocation(..) ) -import CmStaticInfo +import Packages ( PackageConfig(..) ) import DriverPhases import DriverState import DriverUtil import Module -import FiniteMap import FastString -import Util -import Panic ( panic ) import Config import IOExts @@ -32,13 +31,16 @@ import List import Directory import IO import Monad -import Outputable \end{code} The Finder provides a thin filesystem abstraction to the rest of the -compiler. For a given module, it knows (a) which package the module -lives in, so it can make a Module from a ModuleName, and (b) where the -source, interface, and object files for a module live. +compiler. For a given module, it knows (a) whether the module lives +in the home package or in another package, so it can make a Module +from a ModuleName, and (b) where the source, interface, and object +files for a module live. + +It does *not* know which particular package a module lives in, because +that information is only contained in the interface file. \begin{code} initFinder :: [PackageConfig] -> IO () @@ -52,141 +54,150 @@ emptyHomeDirCache :: IO () emptyHomeDirCache = return () findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule name - = do { j <- maybeHomeModule name +findModule name = findModuleDep name False + +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 +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 - hs = basename ++ ".hs" - lhs = basename ++ ".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 - }}}}} - - -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 - } - )) + + -- 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 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 maybe_source_fn = do +mkHomeModuleLocn mod_name + basename -- everything but the extension + source_fn -- full path to the source (required) + = do 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 + -- 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 = maybe_source_fn, - ml_hi_file = hi_file, - ml_obj_file = Just o_file - } - )) - - -maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -maybePackageModule mod_name = do + 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. + -- 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 = moduleNameUserString mod_name - hi = basename ++ '.':package_hisuf - - found <- findOnPackagePath pkgs hi - case found 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 = path, - ml_obj_file = Nothing - } - )) - -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 ++ '/':file)) - -findOnPath :: [String] -> String -> IO (Maybe FilePath) -findOnPath path s = loop path + let imp_dirs = concatMap import_dirs pkgs + mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str + + retPackageModule mod_name mbFName path = + return ( mkPackageModule mod_name + , 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,\ fName path -> retPackageModule mod_name Nothing path) : + -- can packages contain hi-boots? + (if hiOnly then [] else + [ ("hs", \ fName path -> retPackageModule mod_name (Just fName) path) + , ("lhs", \ fName path -> retPackageModule mod_name (Just fName) 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 + +findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule mod_name = findPackageMod mod_name True + +searchPathExts :: [FilePath] + -> String + -> [(String, FilePath -> String -> IO (Module, ModuleLocation))] + -> IO (Maybe (Module, ModuleLocation)) +searchPathExts path basename exts = search path + where + search [] = return Nothing + search (p:ps) = loop exts + where + base | p == "." = basename + | otherwise = p ++ '/':basename + + loop [] = search ps + loop ((ext,fn):exts) = do + let file = base ++ '.':ext + b <- doesFileExist file + if b then Just `liftM` fn file base + else loop exts \end{code}