Extend API for compiling to and from Core
[ghc.git] / compiler / main / Finder.lhs
1 %
2 % (c) The University of Glasgow, 2000-2006
3 %
4 \section[Finder]{Module Finder}
5
6 \begin{code}
7 module Finder (
8     flushFinderCaches,
9     FindResult(..),
10     findImportedModule,
11     findExactModule,
12     findHomeModule,
13     mkHomeModLocation,
14     mkHomeModLocation2,
15     mkHiOnlyModLocation,
16     addHomeModuleToFinder,
17     uncacheModule,
18     mkStubPaths,
19
20     findObjectLinkableMaybe,
21     findObjectLinkable,
22
23     cannotFindModule,
24     cannotFindInterface,
25
26   ) where
27
28 #include "HsVersions.h"
29
30 import Module
31 import HscTypes
32 import Packages
33 import FastString
34 import Util
35 import PrelNames        ( gHC_PRIM )
36 import DynFlags         ( DynFlags(..), isOneShot, GhcMode(..) )
37 import Outputable
38 import FiniteMap
39 import UniqFM
40 import Maybes           ( expectJust )
41
42 import Data.IORef       ( IORef, writeIORef, readIORef, modifyIORef )
43 import Data.List
44 import System.Directory
45 import System.IO
46 import Control.Monad
47 import System.Time      ( ClockTime )
48
49
50 type FileExt = String   -- Filename extension
51 type BaseName = String  -- Basename of file
52
53 -- -----------------------------------------------------------------------------
54 -- The Finder
55
56 -- The Finder provides a thin filesystem abstraction to the rest of
57 -- the compiler.  For a given module, it can tell you where the
58 -- source, interface, and object files for that module live.
59
60 -- It does *not* know which particular package a module lives in.  Use
61 -- Packages.lookupModuleInAllPackages for that.
62
63 -- -----------------------------------------------------------------------------
64 -- The finder's cache
65
66 -- remove all the home modules from the cache; package modules are
67 -- assumed to not move around during a session.
68 flushFinderCaches :: HscEnv -> IO ()
69 flushFinderCaches hsc_env = do
70   writeIORef fc_ref emptyUFM
71   flushModLocationCache this_pkg mlc_ref
72  where
73         this_pkg = thisPackage (hsc_dflags hsc_env)
74         fc_ref = hsc_FC hsc_env
75         mlc_ref = hsc_MLC hsc_env
76
77 flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO ()
78 flushModLocationCache this_pkg ref = do
79   fm <- readIORef ref
80   writeIORef ref $! filterFM is_ext fm
81   return ()
82   where is_ext mod _ | modulePackageId mod /= this_pkg = True
83                      | otherwise = False
84
85 addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO ()
86 addToFinderCache       ref key val = modifyIORef ref $ \c -> addToUFM c key val
87
88 addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO ()
89 addToModLocationCache  ref key val = modifyIORef ref $ \c -> addToFM c key val
90
91 removeFromFinderCache :: IORef FinderCache -> ModuleName -> IO ()
92 removeFromFinderCache      ref key = modifyIORef ref $ \c -> delFromUFM c key
93
94 removeFromModLocationCache :: IORef ModLocationCache -> Module -> IO ()
95 removeFromModLocationCache ref key = modifyIORef ref $ \c -> delFromFM c key
96
97 lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult)
98 lookupFinderCache ref key = do 
99    c <- readIORef ref
100    return $! lookupUFM c key
101
102 lookupModLocationCache :: IORef ModLocationCache -> Module
103                        -> IO (Maybe ModLocation)
104 lookupModLocationCache ref key = do
105    c <- readIORef ref
106    return $! lookupFM c key
107
108 -- -----------------------------------------------------------------------------
109 -- The two external entry points
110
111 -- | Locate a module that was imported by the user.  We have the
112 -- module's name, and possibly a package name.  Without a package
113 -- name, this function will use the search path and the known exposed
114 -- packages to find the module, if a package is specified then only
115 -- that package is searched for the module.
116
117 findImportedModule :: HscEnv -> ModuleName -> Maybe PackageId -> IO FindResult
118 findImportedModule hsc_env mod_name mb_pkgid =
119   case mb_pkgid of
120         Nothing                    -> unqual_import
121         Just pkg | pkg == this_pkg -> home_import
122                  | otherwise       -> pkg_import pkg
123   where
124     dflags = hsc_dflags hsc_env
125     this_pkg = thisPackage dflags
126
127     home_import     = findHomeModule hsc_env mod_name
128
129     pkg_import pkg  = findPackageModule hsc_env (mkModule pkg mod_name)
130                         -- ToDo: this isn't quite right, the module we want
131                         -- might actually be in another package, but re-exposed
132                         -- ToDo: should return NotFoundInPackage if
133                         -- the module isn't exposed by the package.
134
135     unqual_import   = home_import 
136                         `orIfNotFound`
137                       findExposedPackageModule hsc_env mod_name
138
139 -- | Locate a specific 'Module'.  The purpose of this function is to
140 -- create a 'ModLocation' for a given 'Module', that is to find out
141 -- where the files associated with this module live.  It is used when
142 -- reading the interface for a module mentioned by another interface, 
143 -- for example (a "system import").
144
145 findExactModule :: HscEnv -> Module -> IO FindResult
146 findExactModule hsc_env mod =
147    let dflags = hsc_dflags hsc_env in
148    if modulePackageId mod == thisPackage dflags
149         then findHomeModule hsc_env (moduleName mod)
150         else findPackageModule hsc_env mod
151
152 -- -----------------------------------------------------------------------------
153 -- Helpers
154
155 orIfNotFound :: IO FindResult -> IO FindResult -> IO FindResult
156 this `orIfNotFound` or_this = do
157   res <- this
158   case res of
159     NotFound here _ -> do
160         res2 <- or_this
161         case res2 of
162            NotFound or_here pkg -> return (NotFound (here ++ or_here) pkg)
163            _other -> return res2
164     _other -> return res
165
166
167 homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
168 homeSearchCache hsc_env mod_name do_this = do
169   m <- lookupFinderCache (hsc_FC hsc_env) mod_name
170   case m of 
171     Just result -> return result
172     Nothing     -> do
173         result <- do_this
174         addToFinderCache (hsc_FC hsc_env) mod_name result
175         case result of
176            Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
177            _other        -> return ()
178         return result
179
180 findExposedPackageModule :: HscEnv -> ModuleName -> IO FindResult
181 findExposedPackageModule hsc_env mod_name
182         -- not found in any package:
183   | null found = return (NotFound [] Nothing)
184         -- found in just one exposed package:
185   | [(pkg_conf, _)] <- found_exposed
186         = let pkgid = mkPackageId (package pkg_conf) in      
187           findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf
188         -- not found in any exposed package, report how it was hidden:
189   | null found_exposed, ((pkg_conf, exposed_mod):_) <- found
190         = let pkgid = mkPackageId (package pkg_conf) in
191           if not (exposed_mod)
192                 then return (ModuleHidden pkgid)
193                 else return (PackageHidden pkgid)
194   | otherwise
195         = return (FoundMultiple (map (mkPackageId.package.fst) found_exposed))
196   where
197         dflags = hsc_dflags hsc_env
198         found = lookupModuleInAllPackages dflags mod_name
199         found_exposed = filter is_exposed found
200         is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod
201
202
203 modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
204 modLocationCache hsc_env mod do_this = do
205   mb_loc <- lookupModLocationCache mlc mod
206   case mb_loc of
207      Just loc -> return (Found loc mod)
208      Nothing  -> do
209         result <- do_this
210         case result of
211             Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
212             _other -> return ()
213         return result
214   where
215     mlc = hsc_MLC hsc_env
216
217 addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
218 addHomeModuleToFinder hsc_env mod_name loc = do
219   let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
220   addToFinderCache (hsc_FC hsc_env) mod_name (Found loc mod)
221   addToModLocationCache (hsc_MLC hsc_env) mod loc
222   return mod
223
224 uncacheModule :: HscEnv -> ModuleName -> IO ()
225 uncacheModule hsc_env mod = do
226   let this_pkg = thisPackage (hsc_dflags hsc_env)
227   removeFromFinderCache (hsc_FC hsc_env) mod
228   removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod)
229
230 -- -----------------------------------------------------------------------------
231 --      The internal workers
232
233 -- | Search for a module in the home package only.
234 findHomeModule :: HscEnv -> ModuleName -> IO FindResult
235 findHomeModule hsc_env mod_name =
236    homeSearchCache hsc_env mod_name $
237    let 
238      dflags = hsc_dflags hsc_env
239      home_path = importPaths dflags
240      hisuf = hiSuf dflags
241      mod = mkModule (thisPackage dflags) mod_name
242
243      source_exts = 
244       [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")
245       , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")
246       ]
247      
248      hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)
249                , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)
250                ]
251      
252         -- In compilation manager modes, we look for source files in the home
253         -- package because we can compile these automatically.  In one-shot
254         -- compilation mode we look for .hi and .hi-boot files only.
255      exts | isOneShot (ghcMode dflags) = hi_exts
256           | otherwise                  = source_exts
257    in
258
259   -- special case for GHC.Prim; we won't find it in the filesystem.
260   -- This is important only when compiling the base package (where GHC.Prim
261   -- is a home module).
262   if mod == gHC_PRIM 
263         then return (Found (error "GHC.Prim ModLocation") mod)
264         else 
265
266    searchPathExts home_path mod exts
267
268
269 -- | Search for a module in external packages only.
270 findPackageModule :: HscEnv -> Module -> IO FindResult
271 findPackageModule hsc_env mod = do
272   let
273         dflags = hsc_dflags hsc_env
274         pkg_id = modulePackageId mod
275         pkg_map = pkgIdMap (pkgState dflags)
276   --
277   case lookupPackage pkg_map pkg_id of
278      Nothing -> return (NoPackage pkg_id)
279      Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
280       
281 findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
282 findPackageModule_ hsc_env mod pkg_conf = 
283   modLocationCache hsc_env mod $
284
285   -- special case for GHC.Prim; we won't find it in the filesystem.
286   if mod == gHC_PRIM 
287         then return (Found (error "GHC.Prim ModLocation") mod)
288         else 
289
290   let
291      dflags = hsc_dflags hsc_env
292      tag = buildTag dflags
293
294            -- hi-suffix for packages depends on the build tag.
295      package_hisuf | null tag  = "hi"
296                    | otherwise = tag ++ "_hi"
297      hi_exts =
298         [ (package_hisuf, mkHiOnlyModLocation dflags package_hisuf) ]
299
300      source_exts = 
301        [ ("hs",   mkHiOnlyModLocation dflags package_hisuf)
302        , ("lhs",  mkHiOnlyModLocation dflags package_hisuf)
303        ]
304
305      -- mkdependHS needs to look for source files in packages too, so
306      -- that we can make dependencies between package before they have
307      -- been built.
308      exts 
309       | MkDepend <- ghcMode dflags = hi_exts ++ source_exts
310       | otherwise                  = hi_exts
311       -- we never look for a .hi-boot file in an external package;
312       -- .hi-boot files only make sense for the home package.
313   in
314   searchPathExts (importDirs pkg_conf) mod exts
315
316 -- -----------------------------------------------------------------------------
317 -- General path searching
318
319 searchPathExts
320   :: [FilePath]         -- paths to search
321   -> Module             -- module name
322   -> [ (
323         FileExt,                                -- suffix
324         FilePath -> BaseName -> IO ModLocation  -- action
325        )
326      ] 
327   -> IO FindResult
328
329 searchPathExts paths mod exts 
330    = do result <- search to_search
331 {-
332         hPutStrLn stderr (showSDoc $
333                 vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
334                     , nest 2 (vcat (map text paths))
335                     , case result of
336                         Succeeded (loc, p) -> text "Found" <+> ppr loc
337                         Failed fs          -> text "not found"])
338 -}      
339         return result
340
341   where
342     basename = moduleNameSlashes (moduleName mod)
343
344     to_search :: [(FilePath, IO ModLocation)]
345     to_search = [ (file, fn path basename)
346                 | path <- paths, 
347                   (ext,fn) <- exts,
348                   let base | path == "." = basename
349                            | otherwise   = path `joinFileName` basename
350                       file = base `joinFileExt` ext
351                 ]
352
353     search [] = return (NotFound (map fst to_search) (Just (modulePackageId mod)))
354     search ((file, mk_result) : rest) = do
355       b <- doesFileExist file
356       if b 
357         then do { loc <- mk_result; return (Found loc mod) }
358         else search rest
359
360 mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
361                           -> FilePath -> BaseName -> IO ModLocation
362 mkHomeModLocationSearched dflags mod suff path basename = do
363    mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff
364
365 -- -----------------------------------------------------------------------------
366 -- Constructing a home module location
367
368 -- This is where we construct the ModLocation for a module in the home
369 -- package, for which we have a source file.  It is called from three
370 -- places:
371 --
372 --  (a) Here in the finder, when we are searching for a module to import,
373 --      using the search path (-i option).
374 --
375 --  (b) The compilation manager, when constructing the ModLocation for
376 --      a "root" module (a source file named explicitly on the command line
377 --      or in a :load command in GHCi).
378 --
379 --  (c) The driver in one-shot mode, when we need to construct a
380 --      ModLocation for a source file named on the command-line.
381 --
382 -- Parameters are:
383 --
384 -- mod
385 --      The name of the module
386 --
387 -- path
388 --      (a): The search path component where the source file was found.
389 --      (b) and (c): "."
390 --
391 -- src_basename
392 --      (a): (moduleNameSlashes mod)
393 --      (b) and (c): The filename of the source file, minus its extension
394 --
395 -- ext
396 --      The filename extension of the source file (usually "hs" or "lhs").
397
398 mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
399 mkHomeModLocation dflags mod src_filename = do
400    let (basename,extension) = splitFilename src_filename
401    mkHomeModLocation2 dflags mod basename extension
402
403 mkHomeModLocation2 :: DynFlags
404                    -> ModuleName
405                    -> FilePath  -- Of source module, without suffix
406                    -> String    -- Suffix
407                    -> IO ModLocation
408 mkHomeModLocation2 dflags mod src_basename ext = do
409    let mod_basename = moduleNameSlashes mod
410
411    obj_fn  <- mkObjPath  dflags src_basename mod_basename
412    hi_fn   <- mkHiPath   dflags src_basename mod_basename
413
414    return (ModLocation{ ml_hs_file   = Just (src_basename `joinFileExt` ext),
415                         ml_hi_file   = hi_fn,
416                         ml_obj_file  = obj_fn })
417
418 mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
419                     -> IO ModLocation
420 mkHiOnlyModLocation dflags hisuf path basename
421  = do let full_basename = path `joinFileName` basename
422       obj_fn  <- mkObjPath  dflags full_basename basename
423       return ModLocation{    ml_hs_file   = Nothing,
424                              ml_hi_file   = full_basename  `joinFileExt` hisuf,
425                                 -- Remove the .hi-boot suffix from
426                                 -- hi_file, if it had one.  We always
427                                 -- want the name of the real .hi file
428                                 -- in the ml_hi_file field.
429                              ml_obj_file  = obj_fn
430                   }
431
432 -- | Constructs the filename of a .o file for a given source file.
433 -- Does /not/ check whether the .o file exists
434 mkObjPath
435   :: DynFlags
436   -> FilePath           -- the filename of the source file, minus the extension
437   -> String             -- the module name with dots replaced by slashes
438   -> IO FilePath
439 mkObjPath dflags basename mod_basename
440   = do  let
441                 odir = objectDir dflags
442                 osuf = objectSuf dflags
443         
444                 obj_basename | Just dir <- odir = dir `joinFileName` mod_basename
445                              | otherwise        = basename
446
447         return (obj_basename `joinFileExt` osuf)
448
449 -- | Constructs the filename of a .hi file for a given source file.
450 -- Does /not/ check whether the .hi file exists
451 mkHiPath
452   :: DynFlags
453   -> FilePath           -- the filename of the source file, minus the extension
454   -> String             -- the module name with dots replaced by slashes
455   -> IO FilePath
456 mkHiPath dflags basename mod_basename
457   = do  let
458                 hidir = hiDir dflags
459                 hisuf = hiSuf dflags
460
461                 hi_basename | Just dir <- hidir = dir `joinFileName` mod_basename
462                             | otherwise         = basename
463
464         return (hi_basename `joinFileExt` hisuf)
465
466
467 -- -----------------------------------------------------------------------------
468 -- Filenames of the stub files
469
470 -- We don't have to store these in ModLocations, because they can be derived
471 -- from other available information, and they're only rarely needed.
472
473 mkStubPaths
474   :: DynFlags
475   -> ModuleName
476   -> ModLocation
477   -> (FilePath,FilePath,FilePath)
478
479 mkStubPaths dflags mod location
480   = let
481                 stubdir = stubDir dflags
482
483                 mod_basename = moduleNameSlashes mod
484                 src_basename = basenameOf (expectJust "mkStubPaths" 
485                                                 (ml_hs_file location))
486
487                 stub_basename0
488                         | Just dir <- stubdir = dir `joinFileName` mod_basename
489                         | otherwise           = src_basename
490
491                 stub_basename = stub_basename0 ++ "_stub"
492
493                 -- this is the filename we're going to use when
494                 -- #including the stub_h file from the .hc file.
495                 -- Without -stubdir, we just #include the basename
496                 -- (eg. for a module A.B, we #include "B_stub.h"),
497                 -- relying on the fact that we add an implicit -I flag
498                 -- for the directory in which the source file resides
499                 -- (see DriverPipeline.hs).  With -stubdir, we
500                 -- #include "A/B.h", assuming that the user has added
501                 -- -I<dir> along with -stubdir <dir>.
502                 include_basename
503                         | Just _ <- stubdir = mod_basename 
504                         | otherwise         = filenameOf src_basename
505      in
506         (stub_basename `joinFileExt` "c",
507          stub_basename `joinFileExt` "h",
508          (include_basename ++ "_stub") `joinFileExt` "h")
509         -- the _stub.o filename is derived from the ml_obj_file.
510
511 -- -----------------------------------------------------------------------------
512 -- findLinkable isn't related to the other stuff in here, 
513 -- but there's no other obvious place for it
514
515 findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
516 findObjectLinkableMaybe mod locn
517    = do let obj_fn = ml_obj_file locn
518         maybe_obj_time <- modificationTimeIfExists obj_fn
519         case maybe_obj_time of
520           Nothing -> return Nothing
521           Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)
522
523 -- Make an object linkable when we know the object file exists, and we know
524 -- its modification time.
525 findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable
526 findObjectLinkable mod obj_fn obj_time = do
527   let stub_fn = case splitFilename3 obj_fn of
528                         (dir, base, _ext) -> dir ++ "/" ++ base ++ "_stub.o"
529   stub_exist <- doesFileExist stub_fn
530   if stub_exist
531         then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
532         else return (LM obj_time mod [DotO obj_fn])
533
534 -- -----------------------------------------------------------------------------
535 -- Error messages
536
537 cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
538 cannotFindModule = cantFindErr SLIT("Could not find module")
539
540 cannotFindInterface  :: DynFlags -> ModuleName -> FindResult -> SDoc
541 cannotFindInterface = cantFindErr SLIT("Failed to load interface for")
542
543 cantFindErr :: LitString -> DynFlags -> ModuleName -> FindResult -> SDoc
544 cantFindErr cannot_find _dflags mod_name (FoundMultiple pkgs)
545   = hang (ptext cannot_find <+> quotes (ppr mod_name) <> colon) 2 (
546        sep [ptext SLIT("it was found in multiple packages:"),
547                 hsep (map (text.packageIdString) pkgs)]
548     )
549 cantFindErr cannot_find dflags mod_name find_result
550   = hang (ptext cannot_find <+> quotes (ppr mod_name) <> colon)
551        2 more_info
552   where
553     more_info
554       = case find_result of
555             PackageHidden pkg 
556                 -> ptext SLIT("it is a member of package") <+> ppr pkg <> comma
557                    <+> ptext SLIT("which is hidden")
558
559             ModuleHidden pkg
560                 -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package")
561                    <+> ppr pkg)
562
563             NoPackage pkg
564                 -> ptext SLIT("no package matching") <+> ppr pkg <+>
565                    ptext SLIT("was found")
566
567             NotFound files mb_pkg
568                 | null files
569                 -> ptext SLIT("it is not a module in the current program, or in any known package.")
570                 | Just pkg <- mb_pkg, pkg /= thisPackage dflags, build_tag /= ""
571                 -> let 
572                      build = if build_tag == "p" then "profiling" 
573                                                  else "\"" ++ build_tag ++ "\""
574                    in
575                    ptext SLIT("Perhaps you haven't installed the ") <> text build <>
576                    ptext SLIT(" libraries for package ") <> ppr pkg <> char '?' $$
577                    not_found files
578
579                 | otherwise
580                 -> not_found files
581
582             NotFoundInPackage pkg
583                 -> ptext SLIT("it is not in package") <+> ppr pkg
584
585             _ -> panic "cantFindErr"
586
587     build_tag = buildTag dflags
588
589     not_found files
590         | verbosity dflags < 3
591         = ptext SLIT("Use -v to see a list of the files searched for.")
592         | otherwise 
593         = hang (ptext SLIT("locations searched:")) 2 (vcat (map text files))
594 \end{code}