X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=2fc393da3b613049469cf98f4bdb582e8e52c517;hb=f8d8ea662828a295e27a2f5f52ce38d68fd3dee2;hp=b24b8d5f54a61ec784f843e240e13c14ebfa521a;hpb=c0d27f30fd54ed3786c1fb0dbae02e4336604121;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index b24b8d5..2fc393d 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -5,27 +5,30 @@
 
 \begin{code}
 module Finder (
-    Finder, 		-- =  ModuleName -> IO (Maybe (Module, ModuleLocation))
-    newFinder, 		-- :: PackageConfigInfo -> IO Finder, 
-    ModuleLocation(..),
-    mkHomeModuleLocn
+    initFinder, 	-- :: [PackageConfig] -> IO (), 
+    findModule,		-- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+    mkHomeModuleLocn,	-- :: ModuleName -> String -> Maybe FilePath 
+			--	-> IO ModuleLocation
+    emptyHomeDirCache,	-- :: IO ()
+    flushPackageCache   -- :: [PackageConfig] -> IO ()
   ) where
 
 #include "HsVersions.h"
 
-import HscTypes		( Finder, ModuleLocation(..) )
-import CmStaticInfo
+import HscTypes		( ModuleLocation(..) )
+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
 \end{code}
 
 The Finder provides a thin filesystem abstraction to the rest of the
@@ -34,74 +37,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,    Nothing,  Maybe (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 ()
 
+emptyHomeDirCache :: IO ()
+emptyHomeDirCache = return ()
 
-newFinder :: PackageConfigInfo -> IO Finder
-newFinder (PackageConfigInfo pkgs) = do
-  -- expunge our home cache
-  writeIORef v_HomeDirCache Nothing
-
-  -- and return the finder
-  return (finder pkgs)
-
-  
-finder :: [Package] -> ModuleName -> IO (Maybe (Module, ModuleLocation))
-finder pkgs name = do
-  j <- maybeHomeModule name
-  case j of
-	Just home_module -> return (Just home_module)
-	Nothing -> maybePackageModule pkgs name
+findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+findModule name
+  = do	{ j <- maybeHomeModule name
+	; case j of
+	    Just home_module -> return (Just home_module)
+	    Nothing	     -> maybePackageModule 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
 
-   case lookupFM home_map lhs of {
-	Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) lhs;
+   -- 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-<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
+   }}}}}
 
-   }}
 
-mkHomeModuleLocn mod_name basename 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 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.
@@ -109,38 +131,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
 	         }
 	))
 
-maybePackageModule :: [Package] -> ModuleName 
-	-> IO (Maybe (Module, ModuleLocation))
-
-maybePackageModule pkgs mod_name = do
-  maybe_pkg_cache <- readIORef v_PkgDirCache
-
-  -- populate the package cache, if necessary
-  pkg_cache <-
-    case maybe_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 v_PkgDirCache (Just pkg_map)
-        return pkg_map
-
-      Just pkg_cache -> 
-        return pkg_cache
+maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+maybePackageModule mod_name = do
+  pkgs <- getPackageInfo
 
   -- hi-suffix for packages depends on the build tag.
   package_hisuf <-
@@ -149,26 +150,39 @@ maybePackageModule pkgs mod_name = do
 		then return "hi"
 		else return (tag ++ "_hi")
 
-  let basename = moduleNameString mod_name
-      hi  = basename ++ '.':package_hisuf
+  let basename = moduleNameUserString mod_name
+      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,
+				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 ++ '/':file))
+
+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}