X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=74b243ac9af897fa66608f1a34ce38336ddb7979;hb=af630baad68f35adf76d898f5be768f447bc7ff8;hp=1f7addb0a092d4125179599b7af9aec197cc4f23;hpb=6ef5df4a1bc630798e0de5e676afe11086b68606;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 1f7addb..74b243a 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -5,26 +5,31 @@
 
 \begin{code}
 module Finder (
-    initFinder, 	-- :: PackageConfigInfo -> IO (), 
-    findModule		-- :: ModuleName -> IO (Maybe (Module, 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 HscTypes		( ModuleLocation(..) )
-import CmStaticInfo
+import Packages		( PackageConfig(..) )
 import DriverPhases
 import DriverState
 import Module
-import FiniteMap
-import Util
+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
@@ -33,83 +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 ()
 
--- caches contents of package directories, never expunged
-GLOBAL_VAR(v_PkgDirCache,    error "no pkg cache!",  FiniteMap String (PackageName, FilePath))
-
--- caches contents of home directories, expunged whenever we
--- create a new finder.
-GLOBAL_VAR(v_HomeDirCache,   Nothing,  Maybe (FiniteMap String FilePath))
+-- empty, and lazilly fill in the package cache
+flushPackageCache :: [PackageConfig] -> IO ()
+flushPackageCache pkgs = return ()
 
-
-initFinder :: PackageConfigInfo -> IO ()
-initFinder (PackageConfigInfo pkgs) = do
-  -- expunge our home cache
-  writeIORef v_HomeDirCache Nothing
-  -- lazilly fill in the package cache
-  writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
-  pkg_dbg_info <- readIORef v_PkgDirCache
-  putStrLn (unlines (map show (fmToList pkg_dbg_info)))
+emptyHomeDirCache :: IO ()
+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
+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 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
-		   return (addListToFM fm (zip 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-<ver> 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
+	         }
+	))
 
-   }}
+-- 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
+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.
@@ -117,31 +132,17 @@ 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   = 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
-    		    return (addListToFM fm (zip 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 <-
@@ -150,25 +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{ 
-				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}