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                     ml_hspp_file = Nothing,
 127                     ml_hs_file   = Just source_fn,
 128                     ml_hi_file   = Just hifile,
 129                     ml_obj_file  = Just o_file
 130                  }
 131         ))
 132
 133
 134 newPkgCache :: [Package] -> IO (FiniteMap String (PackageName, FilePath))
 135 newPkgCache pkgs = do
 136     let extendFM fm pkg = do
 137             let dirs = import_dirs pkg
 138                 pkg_name = _PK_ (name pkg)
 139             let addDir fm dir = do
 140                     contents <- getDirectoryContents' dir
 141                     let clean_contents = filter isUsefulFile contents
 142                     return (addListToFM fm (zip clean_contents
 143                                                (repeat (pkg_name,dir))))
 144             foldM addDir fm dirs
 145
 146     pkg_map <- foldM extendFM emptyFM pkgs
 147     return pkg_map
 148
 149
 150 maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
 151 maybePackageModule mod_name = do
 152   pkg_cache <- readIORef v_PkgDirCache
 153
 154   -- hi-suffix for packages depends on the build tag.
 155   package_hisuf <-
 156         do tag <- readIORef v_Build_tag
 157            if null tag
 158                 then return "hi"
 159                 else return (tag ++ "_hi")
 160
 161   let basename = moduleNameString mod_name
 162       hi = basename ++ '.':package_hisuf
 163
 164   case lookupFM pkg_cache hi of
 165         Nothing -> return Nothing
 166         Just (pkg_name,path) ->
 167             return (Just (mkModule mod_name pkg_name,
 168                           ModuleLocation{
 169                                 ml_hspp_file = Nothing,
 170                                 ml_hs_file   = Nothing,
 171                                 ml_hi_file   = Just (path ++ '/':hi),
 172                                 ml_obj_file  = Nothing
 173                            }
 174                    ))
 175
 176 isUsefulFile fn
 177    = let suffix = (reverse . takeWhile (/= '.') . reverse) fn
 178      in  suffix `elem` ["hi", "hs", "lhs", "hi-boot", "hi-boot-5"]
 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}