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     Finder,             -- =  ModuleName -> IO (Maybe (Module, ModuleLocation))
   9     newFinder,          -- :: PackageConfigInfo -> IO Finder,
  10     ModuleLocation(..)
  11   ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CmStaticInfo
  16 import DriverPhases
  17 import DriverState
  18 import Module
  19 import FiniteMap
  20 import Util
  21 import Panic
  22
  23 import IOExts
  24 import Directory
  25 import List
  26 import IO
  27 import Monad
  28 \end{code}
  29
  30 The Finder provides a thin filesystem abstraction to the rest of the
  31 compiler.  For a given module, it knows (a) which package the module
  32 lives in, so it can make a Module from a ModuleName, and (b) where the
  33 source, interface, and object files for a module live.
  34
  35 \begin{code}
  36 type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation))
  37
  38 -- For a module in another package, the hs_file and obj_file
  39 -- components of ModuleLocation are undefined.
  40
  41 -- The locations specified by a ModuleLocation may or may not
  42 -- correspond to actual files yet: for example, even if the object
  43 -- file doesn't exist, the ModuleLocation still contains the path to
  44 -- where the object file will reside if/when it is created.
  45
  46 data ModuleLocation
  47    = ModuleLocation {
  48         hs_file  :: FilePath,
  49         hi_file  :: FilePath,
  50         obj_file :: FilePath
  51       }
  52
  53 -- caches contents of package directories, never expunged
  54 GLOBAL_VAR(pkgDirCache,    Nothing,  Maybe (FiniteMap String (PackageName, FilePath)))
  55
  56 -- caches contents of home directories, expunged whenever we
  57 -- create a new finder.
  58 GLOBAL_VAR(homeDirCache,   emptyFM,  FiniteMap String FilePath)
  59
  60 -- caches finder mapping, expunged whenever we create a new finder.
  61 GLOBAL_VAR(finderMapCache, emptyFM, FiniteMap ModuleName Module)
  62
  63
  64 newFinder :: PackageConfigInfo -> IO Finder
  65 newFinder (PackageConfigInfo pkgs) = do
  66   -- expunge our caches
  67   writeIORef homeDirCache   emptyFM
  68   writeIORef finderMapCache emptyFM
  69
  70   -- populate the home dir cache, using the import path (the import path
  71   -- is changed by -i flags on the command line, and defaults to ["."]).
  72   home_imports <- readIORef import_paths
  73   let extendFM fm path = do
  74           contents <- getDirectoryContents' path
  75           return (addListToFM fm (zip contents (repeat path)))
  76   home_map <- foldM extendFM emptyFM home_imports
  77   writeIORef homeDirCache home_map
  78
  79   -- populate the package cache, if necessary
  80   pkg_cache <- readIORef pkgDirCache
  81   case pkg_cache of
  82     Nothing -> do
  83
  84         let extendFM fm pkg = do
  85                 let dirs = import_dirs pkg
  86                     pkg_name = _PK_ (name pkg)
  87                 let addDir fm dir = do
  88                         contents <- getDirectoryContents' dir
  89                         return (addListToFM fm (zip contents
  90                                                    (repeat (pkg_name,dir))))
  91                 foldM addDir fm dirs
  92
  93         pkg_map <- foldM extendFM emptyFM pkgs
  94         writeIORef pkgDirCache (Just pkg_map)
  95
  96     Just _ ->
  97         return ()
  98
  99   -- and return the finder
 100   return finder
 101
 102
 103 finder :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 104 finder name = do
 105   j <- maybeHomeModule name
 106   case j of
 107         Just home_module -> return (Just home_module)
 108         Nothing -> maybePackageModule name
 109
 110 maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 111 maybeHomeModule mod_name = do
 112    home_cache <- readIORef homeDirCache
 113
 114    let basename = moduleNameString mod_name
 115        hs  = basename ++ ".hs"
 116        lhs = basename ++ ".lhs"
 117
 118    case lookupFM home_cache hs of {
 119         Just path -> mkHomeModuleLocn mod_name basename path hs;
 120         Nothing ->
 121
 122    case lookupFM home_cache lhs of {
 123         Just path ->  mkHomeModuleLocn mod_name basename path lhs;
 124         Nothing -> return Nothing
 125
 126    }}
 127
 128 mkHomeModuleLocn mod_name basename path source_fn = do
 129
 130    -- figure out the .hi file name: it lives in the same dir as the
 131    -- source, unless there's a -ohi flag on the command line.
 132    ohi    <- readIORef output_hi
 133    hisuf  <- readIORef hi_suf
 134    let hifile = case ohi of
 135                    Nothing -> path ++ '/':basename ++ hisuf
 136                    Just fn -> fn
 137
 138    -- figure out the .o file name.  It also lives in the same dir
 139    -- as the source, but can be overriden by a -odir flag.
 140    o_file <- odir_ify (path ++ '/':basename ++ '.':phaseInputExt Ln)
 141
 142    return (Just (mkHomeModule mod_name,
 143                  ModuleLocation{
 144                     hs_file  = source_fn,
 145                     hi_file  = hifile,
 146                     obj_file = o_file
 147                  }
 148         ))
 149
 150 maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 151 maybePackageModule mod_name = do
 152   maybe_pkg_cache <- readIORef pkgDirCache
 153   case maybe_pkg_cache of {
 154      Nothing -> panic "maybePackageModule: no pkg_cache";
 155      Just pkg_cache -> do
 156
 157   -- hi-suffix for packages depends on the build tag.
 158   package_hisuf <-
 159         do tag <- readIORef build_tag
 160            if null tag
 161                 then return "hi"
 162                 else return (tag ++ "_hi")
 163
 164   let basename = moduleNameString mod_name
 165       hi  = basename ++ '.':package_hisuf
 166
 167   case lookupFM pkg_cache hi of
 168         Nothing -> return Nothing
 169         Just (pkg_name,path) ->
 170             return (Just (mkModule mod_name pkg_name,
 171                           ModuleLocation{
 172                                 hs_file  = error "package module; no source",
 173                                 hi_file  = hi,
 174                                 obj_file = error "package module; no object"
 175                            }
 176                    ))
 177
 178    }
 179
 180 getDirectoryContents' d
 181    = IO.catch (getDirectoryContents d)
 182           (\_ -> do hPutStr stderr
 183                           ("WARNING: error while reading directory " ++ d)
 184                     return []
 185           )
 186
 187 \end{code}