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