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