[project @ 2000-11-06 08:15:20 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / Finder.lhs

diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 501dbd0..732047b 100644 (file)
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -7,8 +7,7 @@
 module Finder (
     initFinder,        -- :: PackageConfigInfo -> IO (), 
     findModule,                -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
-    ModuleLocation(..),
-    mkHomeModuleLocn,
+    emptyHomeDirCache  -- :: IO ()
   ) where
 
 #include "HsVersions.h"
@@ -20,12 +19,14 @@ import DriverState
 import Module
 import FiniteMap
 import Util
+import Panic           ( panic )
 
 import IOExts
 import Directory
 import List
 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,29 +36,48 @@ source, interface, and object files for a module live.
 
 \begin{code}
 
--- caches contents of package directories, never expunged
-GLOBAL_VAR(v_PkgDirCache,    error "no pkg cache!",  FiniteMap String (PackageName, FilePath))
+-- v_PkgDirCache caches contents of package directories, never expunged
+GLOBAL_VAR(v_PkgDirCache, panic "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))
+-- 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 (PackageConfigInfo pkgs) = do
-  -- expunge our home cache
-  writeIORef v_HomeDirCache Nothing
+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
 
-  -- lazilly fill in the package cache
-  writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
-
-  
 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
+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
+       }
 
 maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 maybeHomeModule mod_name = do
@@ -72,7 +92,8 @@ maybeHomeModule mod_name = do
           home_imports <- readIORef v_Import_paths
           let extendFM fm path = do
                   contents <- getDirectoryContents' path
-                  return (addListToFM fm (zip contents (repeat 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
@@ -109,9 +130,10 @@ 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
                 }
        ))
 
@@ -123,7 +145,8 @@ newPkgCache pkgs = do
                pkg_name = _PK_ (name pkg)
            let addDir fm dir = do
                    contents <- getDirectoryContents' dir
-                   return (addListToFM fm (zip contents 
+                   let clean_contents = filter isUsefulFile contents
+                   return (addListToFM fm (zip clean_contents 
                                               (repeat (pkg_name,dir))))
            foldM addDir fm dirs
     
@@ -150,12 +173,17 @@ 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  = 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
                           }
                   ))
 
+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