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     flushPackageCache   -- :: [PackageConfig] -> IO ()
  14   ) where
  15
  16 #include "HsVersions.h"
  17
  18 import HscTypes         ( ModuleLocation(..) )
  19 import CmStaticInfo
  20 import DriverPhases
  21 import DriverState
  22 import DriverUtil
  23 import Module
  24 import FiniteMap
  25 import Util
  26 import Panic            ( panic )
  27 import Config
  28
  29 import IOExts
  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 emptyHomeDirCache
  55         flushPackageCache pkgs
  56
  57 -- empty, and lazilly fill in the package cache
  58 flushPackageCache :: [PackageConfig] -> IO ()
  59 flushPackageCache pkgs = writeIORef v_PkgDirCache
  60                             (unsafePerformIO (newPkgCache pkgs))
  61
  62 emptyHomeDirCache :: IO ()
  63 emptyHomeDirCache = writeIORef v_HomeDirCache Nothing
  64
  65 findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  66 findModule name
  67   = do  { j <- maybeHomeModule name
  68         ; case j of
  69             Just home_module -> return (Just home_module)
  70             Nothing          -> maybePackageModule name
  71         }
  72
  73 maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  74 maybeHomeModule mod_name = do
  75    home_cache <- readIORef v_HomeDirCache
  76
  77    home_map <-
  78      case home_cache of
  79         Nothing -> do
  80            -- populate the home dir cache, using the import path (the import
  81            -- path is changed by -i flags on the command line, and defaults
  82            -- to ["."]).
  83            home_imports <- readIORef v_Import_paths
  84            let extendFM fm path = do
  85                    contents <- softGetDirectoryContents path
  86                    let clean_contents = filter isUsefulFile contents
  87                    return (addListToFM fm (zip clean_contents (repeat path)))
  88            home_map <- foldM extendFM emptyFM (reverse home_imports)
  89            writeIORef v_HomeDirCache (Just home_map)
  90            return home_map
  91
  92         Just home_map -> return home_map
  93
  94    let basename = moduleNameUserString mod_name
  95        hs  = basename ++ ".hs"
  96        lhs = basename ++ ".lhs"
  97
  98    case lookupFM home_map hs of {
  99           -- special case to avoid getting "./foo.hs" all the time
 100         Just "."  -> mkHomeModuleLocn mod_name basename hs;
 101         Just path -> mkHomeModuleLocn mod_name
 102                         (path ++ '/':basename) (path ++ '/':hs);
 103         Nothing ->
 104
 105    case lookupFM home_map lhs of {
 106           -- special case to avoid getting "./foo.hs" all the time
 107         Just "."  -> mkHomeModuleLocn mod_name basename lhs;
 108         Just path ->  mkHomeModuleLocn mod_name
 109                         (path ++ '/':basename) (path ++ '/':lhs);
 110         Nothing -> do
 111
 112    -- can't find a source file anywhere, check for a lone .hi file.
 113    hisuf <- readIORef v_Hi_suf
 114    let hi = basename ++ '.':hisuf
 115    case lookupFM home_map hi of {
 116         Just path ->  mkHomeModuleLocn mod_name
 117                         (path ++ '/':basename) (path ++ '/':hs);
 118         Nothing -> do
 119
 120    -- last chance: .hi-boot-<ver> and .hi-boot
 121    let hi_boot = basename ++ ".hi-boot"
 122    let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion
 123    case lookupFM home_map hi_boot_ver of {
 124         Just path ->  mkHomeModuleLocn mod_name
 125                         (path ++ '/':basename) (path ++ '/':hs);
 126         Nothing -> do
 127    case lookupFM home_map hi_boot of {
 128         Just path ->  mkHomeModuleLocn mod_name
 129                         (path ++ '/':basename) (path ++ '/':hs);
 130         Nothing -> return Nothing
 131    }}}}}
 132
 133
 134 -- The .hi file always follows the module name, whereas the object
 135 -- file may follow the name of the source file in the case where the
 136 -- two differ (see summariseFile in compMan/CompManager.lhs).
 137
 138 mkHomeModuleLocn mod_name basename source_fn = do
 139
 140    hisuf  <- readIORef v_Hi_suf
 141    hidir  <- readIORef v_Hi_dir
 142
 143    let dir | Just d <- hidir = d
 144            | otherwise       = getdir basename
 145
 146        hifile = dir ++ '/':moduleNameUserString mod_name ++ '.':hisuf
 147
 148    -- figure out the .o file name.  It also lives in the same dir
 149    -- as the source, but can be overriden by a -odir flag.
 150    o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify
 151
 152    return (Just (mkHomeModule mod_name,
 153                  ModuleLocation{
 154                     ml_hspp_file = Nothing,
 155                     ml_hs_file   = Just source_fn,
 156                     ml_hi_file   = hifile,
 157                     ml_obj_file  = Just o_file
 158                  }
 159         ))
 160
 161
 162 newPkgCache :: [PackageConfig] -> IO (FiniteMap String (PackageName, FilePath))
 163 newPkgCache pkgs = do
 164     let extendFM fm pkg = do
 165             let dirs = import_dirs pkg
 166                 pkg_name = _PK_ (name pkg)
 167             let addDir fm dir = do
 168                     contents <- softGetDirectoryContents dir
 169                     return (addListToFM fm (zip contents
 170                                                (repeat (pkg_name,dir))))
 171             foldM addDir fm dirs
 172
 173     pkg_map <- foldM extendFM emptyFM pkgs
 174     return pkg_map
 175
 176
 177 maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 178 maybePackageModule mod_name = do
 179   pkg_cache <- readIORef v_PkgDirCache
 180
 181   -- hi-suffix for packages depends on the build tag.
 182   package_hisuf <-
 183         do tag <- readIORef v_Build_tag
 184            if null tag
 185                 then return "hi"
 186                 else return (tag ++ "_hi")
 187
 188   let basename = moduleNameUserString mod_name
 189       hi = basename ++ '.':package_hisuf
 190
 191   case lookupFM pkg_cache hi of
 192         Nothing -> return Nothing
 193         Just (pkg_name,path) ->
 194             return (Just (mkModule mod_name pkg_name,
 195                           ModuleLocation{
 196                                 ml_hspp_file = Nothing,
 197                                 ml_hs_file   = Nothing,
 198                                 ml_hi_file   = path ++ '/':hi,
 199                                 ml_obj_file  = Nothing
 200                            }
 201                    ))
 202
 203 isUsefulFile fn
 204    = let suffix = (reverse . takeWhile (/= '.') . reverse) fn
 205      in  suffix `elem` ["hi", "hs", "lhs", "hi-boot", "hi-boot-5"]
 206 \end{code}