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