Finder.lhs 4.54 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
%
% (c) The University of Glasgow, 2000
%
\section[Finder]{Module Finder}

\begin{code}
module Finder (
    Finder, 		-- =  ModuleName -> IO (Maybe (Module, ModuleLocation))
    newFinder, 		-- :: PackageConfigInfo -> IO Finder, 
    ModuleLocation(..)
  ) where

#include "HsVersions.h"

import CmStaticInfo
import DriverPhases
import DriverState
import Module
import FiniteMap
import Util
import Panic

import IOExts
import Directory
import List
import IO
import Monad
\end{code}

\begin{code}
type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation))

data ModuleLocation
   = ModuleLocation {
	hs_file  :: FilePath,
	hi_file  :: FilePath,
	obj_file :: FilePath
      }

-- caches contents of package directories, never expunged
GLOBAL_VAR(pkgDirCache,    Nothing,  Maybe (FiniteMap String (PackageName, FilePath)))

-- caches contents of home directories, expunged whenever we
-- create a new finder.
GLOBAL_VAR(homeDirCache,   emptyFM,  FiniteMap String FilePath)

-- caches finder mapping, expunged whenever we create a new finder.
GLOBAL_VAR(finderMapCache, emptyFM, FiniteMap ModuleName Module)


newFinder :: PackageConfigInfo -> IO Finder
newFinder (PackageConfigInfo pkgs) = do
  -- expunge our caches
  writeIORef homeDirCache   emptyFM
  writeIORef finderMapCache emptyFM

  -- populate the home dir cache, using the import path (the import path
  -- is changed by -i flags on the command line, and defaults to ["."]).
  home_imports <- readIORef import_paths
  let extendFM fm path = do
	  contents <- getDirectoryContents' path
          return (addListToFM fm (zip contents (repeat path)))
  home_map <- foldM extendFM emptyFM home_imports
  writeIORef homeDirCache home_map

  -- populate the package cache, if necessary
  pkg_cache <- readIORef pkgDirCache
  case pkg_cache of 
    Nothing -> do

	let extendFM fm pkg = do
		let dirs = import_dirs pkg
		    pkg_name = _PK_ (name pkg)
		let addDir fm dir = do
			contents <- getDirectoryContents' dir
			return (addListToFM fm (zip contents 
						   (repeat (pkg_name,dir))))
                foldM addDir fm dirs

  	pkg_map <- foldM extendFM emptyFM pkgs
	writeIORef pkgDirCache (Just pkg_map)

    Just _ -> 
        return ()

  -- and return the finder
  return finder

  
finder :: ModuleName -> IO (Maybe (Module, ModuleLocation))
finder name = do
  j <- maybeHomeModule name
  case j of
	Just home_module -> return (Just home_module)
	Nothing -> maybePackageModule name

maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
maybeHomeModule mod_name = do
   home_cache <- readIORef homeDirCache

   let basename = moduleNameString mod_name
       hs  = basename ++ ".hs"
       lhs = basename ++ ".lhs"

   case lookupFM home_cache hs of {
	Just path -> mkHomeModuleLocn mod_name basename path hs;
	Nothing ->

   case lookupFM home_cache lhs of {
	Just path ->  mkHomeModuleLocn mod_name basename path lhs;
	Nothing -> return Nothing

   }}

mkHomeModuleLocn mod_name basename path source_fn = do

   -- figure out the .hi file name: it lives in the same dir as the
   -- source, unless there's a -ohi flag on the command line.
   ohi    <- readIORef output_hi
   hisuf  <- readIORef hi_suf
   let hifile = case ohi of
		   Nothing -> path ++ '/':basename ++ hisuf
		   Just fn -> fn

   -- figure out the .o file name.  It also lives in the same dir
   -- as the source, but can be overriden by a -odir flag.
   o_file <- odir_ify (path ++ '/':basename ++ '.':phaseInputExt Ln)

   return (Just (mkHomeModule mod_name,
                 ModuleLocation{
		    hs_file  = source_fn,
		    hi_file  = hifile,
		    obj_file = o_file
	         }
	))

maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
maybePackageModule mod_name = do
  maybe_pkg_cache <- readIORef pkgDirCache
  case maybe_pkg_cache of {
     Nothing -> panic "maybePackageModule: no pkg_cache";
     Just pkg_cache -> do

  -- hi-suffix for packages depends on the build tag.
  package_hisuf <-
	do tag <- readIORef build_tag
	   if null tag
		then return "hi"
		else return (tag ++ "_hi")

  let basename = moduleNameString mod_name
      hi  = basename ++ '.':package_hisuf

  case lookupFM pkg_cache hi of
	Nothing -> return Nothing
	Just (pkg_name,path) -> 
	    return (Just (mkModule mod_name pkg_name,
			  ModuleLocation{ 
				hs_file  = error "package module; no source",
				hi_file  = hi,
				obj_file = error "package module; no object"
			   }
		   ))

   }

getDirectoryContents' d
   = IO.catch (getDirectoryContents d)
	  (\_ -> do hPutStr stderr 
		          ("WARNING: error while reading directory " ++ d)
		    return []
	  )
	 
\end{code}