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   ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HscTypes         ( ModuleLocation(..) )
  15 import CmStaticInfo
  16 import DriverPhases
  17 import DriverState
  18 import Module
  19 import FiniteMap
  20 import Util
  21
  22 import IOExts
  23 import Directory
  24 import List
  25 import IO
  26 import Monad
  27 import Outputable       ( showSDoc, ppr )       -- debugging only
  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
  37 -- v_PkgDirCache caches contents of package directories, never expunged
  38 GLOBAL_VAR(v_PkgDirCache,    error "no pkg cache!",  FiniteMap String (PackageName, FilePath))
  39
  40 -- v_HomeDirCache caches contents of home directories,
  41 -- expunged whenever we create a new finder.
  42 GLOBAL_VAR(v_HomeDirCache,   Nothing,  Maybe (FiniteMap String FilePath))
  43
  44
  45 initFinder :: PackageConfigInfo -> IO ()
  46 initFinder pkgs
  47   = do  {       -- expunge our home cache
  48         ; writeIORef v_HomeDirCache Nothing
  49                 -- lazilly fill in the package cache
  50         ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
  51
  52 -- Debug output
  53 --      ; pkg_dbg_info <- readIORef v_PkgDirCache
  54 --      ; putStrLn (unlines (map show (fmToList pkg_dbg_info)))
  55         }
  56
  57 findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  58 findModule name
  59   = do  { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ")
  60         ; maybe_m <- findModule_wrk name
  61         ; case maybe_m of
  62              Nothing -> hPutStrLn stderr "Not Found"
  63              Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm)))
  64         ; return maybe_m
  65         }
  66
  67 findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  68 findModule_wrk name
  69   = do  { j <- maybeHomeModule name
  70         ; case j of
  71             Just home_module -> return (Just home_module)
  72             Nothing              -> maybePackageModule name
  73         }
  74
  75 maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
  76 maybeHomeModule mod_name = do
  77    home_cache <- readIORef v_HomeDirCache
  78
  79    home_map <-
  80      case home_cache of
  81         Nothing -> do
  82            -- populate the home dir cache, using the import path (the import
  83            -- path is changed by -i flags on the command line, and defaults
  84            -- to ["."]).
  85            home_imports <- readIORef v_Import_paths
  86            let extendFM fm path = do
  87                    contents <- getDirectoryContents' path
  88                    let clean_contents = filter isUsefulFile contents
  89                    return (addListToFM fm (zip clean_contents (repeat path)))
  90            home_map <- foldM extendFM emptyFM home_imports
  91            writeIORef v_HomeDirCache (Just home_map)
  92            return home_map
  93
  94         Just home_map -> return home_map
  95
  96    let basename = moduleNameString mod_name
  97        hs  = basename ++ ".hs"
  98        lhs = basename ++ ".lhs"
  99
 100    case lookupFM home_map hs of {
 101         Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
 102         Nothing ->
 103
 104    case lookupFM home_map lhs of {
 105         Just path ->  mkHomeModuleLocn mod_name (path ++ '/':basename) lhs;
 106         Nothing -> return Nothing
 107
 108    }}
 109
 110 mkHomeModuleLocn mod_name basename source_fn = do
 111
 112    -- figure out the .hi file name: it lives in the same dir as the
 113    -- source, unless there's a -ohi flag on the command line.
 114    ohi    <- readIORef v_Output_hi
 115    hisuf  <- readIORef v_Hi_suf
 116    let hifile = case ohi of
 117                    Nothing -> basename ++ '.':hisuf
 118                    Just fn -> fn
 119
 120    -- figure out the .o file name.  It also lives in the same dir
 121    -- as the source, but can be overriden by a -odir flag.
 122    o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify
 123
 124    return (Just (mkHomeModule mod_name,
 125                  ModuleLocation{
 126                     hs_file  = source_fn,
 127                     hi_file  = hifile,
 128                     obj_file = o_file
 129                  }
 130         ))
 131
 132
 133 newPkgCache :: [Package] -> IO (FiniteMap String (PackageName, FilePath))
 134 newPkgCache pkgs = do
 135     let extendFM fm pkg = do
 136             let dirs = import_dirs pkg
 137                 pkg_name = _PK_ (name pkg)
 138             let addDir fm dir = do
 139                     contents <- getDirectoryContents' dir
 140                     let clean_contents = filter isUsefulFile contents
 141                     return (addListToFM fm (zip clean_contents
 142                                                (repeat (pkg_name,dir))))
 143             foldM addDir fm dirs
 144
 145     pkg_map <- foldM extendFM emptyFM pkgs
 146     return pkg_map
 147
 148
 149 maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 150 maybePackageModule mod_name = do
 151   pkg_cache <- readIORef v_PkgDirCache
 152
 153   -- hi-suffix for packages depends on the build tag.
 154   package_hisuf <-
 155         do tag <- readIORef v_Build_tag
 156            if null tag
 157                 then return "hi"
 158                 else return (tag ++ "_hi")
 159
 160   let basename = moduleNameString mod_name
 161       hi = basename ++ '.':package_hisuf
 162
 163   case lookupFM pkg_cache hi of
 164         Nothing -> return Nothing
 165         Just (pkg_name,path) ->
 166             return (Just (mkModule mod_name pkg_name,
 167                           ModuleLocation{
 168                                 hs_file  = "error:_package_module;_no_source",
 169                                 hi_file  = path ++ '/':hi,
 170                                 obj_file = "error:_package_module;_no_object"
 171                            }
 172                    ))
 173
 174 isUsefulFile fn
 175    = let suffix = (reverse . takeWhile (/= '.') . reverse) fn
 176      in  suffix `elem` ["hi", "hs", "lhs", "hi-boot", "hi-boot-5"]
 177
 178 getDirectoryContents' d
 179    = IO.catch (getDirectoryContents d)
 180           (\_ -> do hPutStr stderr
 181                           ("WARNING: error while reading directory " ++ d)
 182                     return []
 183           )
 184
 185 \end{code}