ghc/compiler/main/Finder.lhs

   1 %
   2 % (c) The University of Glasgow, 2000
   3 %
   4 \section[Finder]{Module Finder}
   5
   6 \begin{code}
   7 module Finder (
   8     initFinder,         -- :: PackageConfigInfo -> IO (),
   9     findModule,         -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  10     emptyHomeDirCache   -- :: IO ()
  11   ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HscTypes         ( ModuleLocation(..) )
  16 import CmStaticInfo
  17 import DriverPhases
  18 import DriverState
  19 import Module
  20 import FiniteMap
  21 import Util
  22 import Panic            ( panic )
  23 import Config
  24
  25 import IOExts
  26 import Directory
  27 import List
  28 import IO
  29 import Monad
  30 import Outputable       ( showSDoc, ppr )       -- debugging only
  31 \end{code}
  32
  33 The Finder provides a thin filesystem abstraction to the rest of the
  34 compiler.  For a given module, it knows (a) which package the module
  35 lives in, so it can make a Module from a ModuleName, and (b) where the
  36 source, interface, and object files for a module live.
  37
  38 \begin{code}
  39
  40 -- v_PkgDirCache caches contents of package directories, never expunged
  41 GLOBAL_VAR(v_PkgDirCache, panic "no pkg cache!",
  42            FiniteMap String (PackageName, FilePath))
  43
  44 -- v_HomeDirCache caches contents of home directories,
  45 -- expunged whenever we create a new finder.
  46 GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath))
  47
  48
  49 initFinder :: PackageConfigInfo -> IO ()
  50 initFinder pkgs
  51   = do  {       -- expunge our home cache
  52         ; writeIORef v_HomeDirCache Nothing
  53                 -- lazilly fill in the package cache
  54         ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
  55
  56 -- Debug output
  57 --      ; pkg_dbg_info <- readIORef v_PkgDirCache
  58 --      ; putStrLn (unlines (map show (fmToList pkg_dbg_info)))
  59         }
  60
  61 emptyHomeDirCache :: IO ()
  62 emptyHomeDirCache
  63    = writeIORef v_HomeDirCache Nothing
  64
  65 findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  66 findModule name
  67   = do  { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ")
  68         ; maybe_m <- findModule_wrk name
  69         ; case maybe_m of
  70              Nothing -> hPutStrLn stderr "Not Found"
  71              Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm)))
  72         ; return maybe_m
  73         }
  74
  75 findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  76 findModule_wrk name
  77   = do  { j <- maybeHomeModule name
  78         ; case j of
  79             Just home_module -> return (Just home_module)
  80             Nothing          -> maybePackageModule name
  81         }
  82
  83 maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  84 maybeHomeModule mod_name = do
  85    home_cache <- readIORef v_HomeDirCache
  86
  87    home_map <-
  88      case home_cache of
  89         Nothing -> do
  90            -- populate the home dir cache, using the import path (the import
  91            -- path is changed by -i flags on the command line, and defaults
  92            -- to ["."]).
  93            home_imports <- readIORef v_Import_paths
  94            let extendFM fm path = do
  95                    contents <- getDirectoryContents' path
  96                    let clean_contents = filter isUsefulFile contents
  97                    return (addListToFM fm (zip clean_contents (repeat path)))
  98            home_map <- foldM extendFM emptyFM home_imports
  99            writeIORef v_HomeDirCache (Just home_map)
 100            return home_map
 101
 102         Just home_map -> return home_map
 103
 104    let basename = moduleNameString mod_name
 105        hs  = basename ++ ".hs"
 106        lhs = basename ++ ".lhs"
 107
 108    case lookupFM home_map hs of {
 109         Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
 110         Nothing ->
 111
 112    case lookupFM home_map lhs of {
 113         Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) lhs;
 114         Nothing -> do
 115
 116    -- can't find a source file anywhere, check for a lone .hi file.
 117    hisuf <- readIORef v_Hi_suf
 118    let hi = basename ++ '.':hisuf
 119    case lookupFM home_map hi of {
 120         Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
 121         Nothing -> do
 122
 123    -- last chance: .hi-boot and .hi-boot-<ver>
 124    let hi_boot = basename ++ ".hi-boot"
 125    let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion
 126    case lookupFM home_map hi_boot of {
 127         Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
 128         Nothing -> do
 129    case lookupFM home_map hi_boot_ver of {
 130         Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
 131         Nothing -> return Nothing
 132    }}}}}
 133
 134 mkHomeModuleLocn mod_name basename source_fn = do
 135
 136    -- figure out the .hi file name: it lives in the same dir as the
 137    -- source, unless there's a -ohi flag on the command line.
 138    ohi    <- readIORef v_Output_hi
 139    hisuf  <- readIORef v_Hi_suf
 140    let hifile = case ohi of
 141                    Nothing -> basename ++ '.':hisuf
 142                    Just fn -> fn
 143
 144    -- figure out the .o file name.  It also lives in the same dir
 145    -- as the source, but can be overriden by a -odir flag.
 146    o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify
 147
 148    return (Just (mkHomeModule mod_name,
 149                  ModuleLocation{
 150                     ml_hspp_file = Nothing,
 151                     ml_hs_file   = Just source_fn,
 152                     ml_hi_file   = Just hifile,
 153                     ml_obj_file  = Just o_file
 154                  }
 155         ))
 156
 157
 158 newPkgCache :: [Package] -> IO (FiniteMap String (PackageName, FilePath))
 159 newPkgCache pkgs = do
 160     let extendFM fm pkg = do
 161             let dirs = import_dirs pkg
 162                 pkg_name = _PK_ (name pkg)
 163             let addDir fm dir = do
 164                     contents <- getDirectoryContents' dir
 165                     let clean_contents = filter isUsefulFile contents
 166                     return (addListToFM fm (zip clean_contents
 167                                                (repeat (pkg_name,dir))))
 168             foldM addDir fm dirs
 169
 170     pkg_map <- foldM extendFM emptyFM pkgs
 171     return pkg_map
 172
 173
 174 maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 175 maybePackageModule mod_name = do
 176   pkg_cache <- readIORef v_PkgDirCache
 177
 178   -- hi-suffix for packages depends on the build tag.
 179   package_hisuf <-
 180         do tag <- readIORef v_Build_tag
 181            if null tag
 182                 then return "hi"
 183                 else return (tag ++ "_hi")
 184
 185   let basename = moduleNameString mod_name
 186       hi = basename ++ '.':package_hisuf
 187
 188   case lookupFM pkg_cache hi of
 189         Nothing -> return Nothing
 190         Just (pkg_name,path) ->
 191             return (Just (mkModule mod_name pkg_name,
 192                           ModuleLocation{
 193                                 ml_hspp_file = Nothing,
 194                                 ml_hs_file   = Nothing,
 195                                 ml_hi_file   = Just (path ++ '/':hi),
 196                                 ml_obj_file  = Nothing
 197                            }
 198                    ))
 199
 200 isUsefulFile fn
 201    = let suffix = (reverse . takeWhile (/= '.') . reverse) fn
 202      in  suffix `elem` ["hi", "hs", "lhs", "hi-boot", "hi-boot-5"]
 203
 204 getDirectoryContents' d
 205    = IO.catch (getDirectoryContents d)
 206           (\_ -> do hPutStr stderr
 207                           ("WARNING: error while reading directory " ++ d)
 208                     return []
 209           )
 210
 211 \end{code}