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