[project @ 1997-01-06 21:08:42 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnIfaces.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module RnIfaces (
10         getInterfaceExports,
11         getImportedInstDecls,
12         getSpecialInstModules,
13         getDecl, getWiredInDecl,
14         getImportVersions,
15
16         checkUpToDate,
17
18         getDeclBinders,
19         mkSearchPath
20     ) where
21
22 IMP_Ubiq()
23
24
25 import HsSyn            ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), 
26                           HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
27                           FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
28                         )
29 import HsPragmas        ( noGenPragmas )
30 import RdrHsSyn         ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), 
31                           RdrName, rdrNameOcc
32                         )
33 import RnEnv            ( newGlobalName, lookupRn, addImplicitOccsRn, availNames )
34 import RnSource         ( rnHsType )
35 import RnMonad
36 import ParseIface       ( parseIface )
37
38 import ErrUtils         ( SYN_IE(Error), SYN_IE(Warning) )
39 import FiniteMap        ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList )
40 import Name             ( Name {-instance NamedThing-}, Provenance, OccName(..),
41                           modAndOcc, occNameString, moduleString, pprModule,
42                           NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
43                           minusNameSet, mkNameSet,
44                           isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
45                          )
46 import Id               ( GenId, Id(..), idType, dataConTyCon, isDataCon )
47 import TyCon            ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
48 import Type             ( namesOfType )
49 import TyVar            ( GenTyVar )
50 import SrcLoc           ( mkIfaceSrcLoc )
51 import PrelMods         ( gHC__ )
52 import Bag
53 import Maybes           ( MaybeErr(..), expectJust, maybeToBool )
54 import ListSetOps       ( unionLists )
55 import Pretty
56 import PprStyle         ( PprStyle(..) )
57 import Util             ( pprPanic )
58 \end{code}
59
60
61
62 %*********************************************************
63 %*                                                      *
64 \subsection{Loading a new interface file}
65 %*                                                      *
66 %*********************************************************
67
68 \begin{code}
69 loadInterface :: Pretty -> Module -> RnMG Ifaces
70 loadInterface doc_str load_mod 
71   = getIfacesRn                 `thenRn` \ ifaces ->
72     let
73         Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces
74     in
75         -- CHECK WHETHER WE HAVE IT ALREADY
76     if maybeToBool (lookupFM export_env_map load_mod) 
77     then
78         returnRn ifaces         -- Already in the cache; don't re-read it
79     else
80
81         -- READ THE MODULE IN
82     findAndReadIface doc_str load_mod           `thenRn` \ read_result ->
83     case read_result of {
84         -- Check for not found
85         Nothing ->      -- Not found, so add an empty export env to the Ifaces map
86                         -- so that we don't look again
87                    let
88                         new_export_env_map = addToFM export_env_map load_mod ([],[])
89                         new_ifaces = Ifaces this_mod mod_vers_map 
90                                             new_export_env_map 
91                                             vers_map decls_map inst_map inst_mods
92                    in
93                    setIfacesRn new_ifaces               `thenRn_`
94                    failWithRn new_ifaces (noIfaceErr load_mod) ;
95
96         -- Found and parsed!
97         Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->
98
99         -- LOAD IT INTO Ifaces
100     mapRn loadExport exports                                    `thenRn` \ avails_s ->
101     foldlRn (loadDecl load_mod) (decls_map,vers_map) decls      `thenRn` \ (new_decls_map, new_vers_map) ->
102     foldlRn (loadInstDecl load_mod) inst_map insts              `thenRn` \ new_insts_map ->
103     let
104          export_env = (concat avails_s, fixs)
105
106                         -- Exclude this module from the "special-inst" modules
107          new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
108
109          new_ifaces = Ifaces this_mod
110                              (addToFM mod_vers_map load_mod mod_vers)
111                              (addToFM export_env_map load_mod export_env)
112                              new_vers_map
113                              new_decls_map
114                              new_insts_map
115                              new_inst_mods 
116     in
117     setIfacesRn new_ifaces              `thenRn_`
118     returnRn new_ifaces
119     }
120
121 loadExport :: ExportItem -> RnMG [AvailInfo]
122 loadExport (mod, entities)
123   = mapRn load_entity entities
124   where
125     new_name occ = newGlobalName mod occ
126
127     load_entity (occ, occs)
128       = new_name occ            `thenRn` \ name ->
129         mapRn new_name occs     `thenRn` \ names ->
130         returnRn (Avail name names)
131
132 loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
133 loadVersion mod vers_map (occ, version)
134   = newGlobalName mod occ                       `thenRn` \ name ->
135     returnRn (addToFM vers_map name version)
136
137
138 loadDecl :: Module -> (DeclsMap, VersionMap)
139          -> (Version, RdrNameHsDecl)
140          -> RnMG (DeclsMap, VersionMap)
141 loadDecl mod (decls_map, vers_map) (version, decl)
142   = getDeclBinders new_implicit_name decl       `thenRn` \ avail@(Avail name _) ->
143     returnRn (addListToFM decls_map
144                           [(name,(avail,decl)) | name <- availNames avail],
145               addToFM vers_map name version
146     )
147   where
148     new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
149
150 loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst)
151 loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
152   = initRnMS emptyRnEnv mod_name InterfaceMode $
153
154         -- Find out what type constructors and classes are mentioned in the
155         -- instance declaration.  We have to be a bit clever.
156         --
157         -- We want to rename the type so that we can find what
158         -- (free) type constructors are inside it.  But we must *not* thereby
159         -- put new occurrences into the global pool because otherwise we'll force
160         -- them all to be loaded.  We kill two birds with ones stone by renaming
161         -- with a fresh occurrence pool.
162     findOccurrencesRn (rnHsType inst_ty)        `thenRn` \ ty_names ->
163
164     returnRn ((ty_names, mod_name, decl) `consBag` insts)
165 \end{code}
166
167
168 %********************************************************
169 %*                                                      *
170 \subsection{Loading usage information}
171 %*                                                      *
172 %********************************************************
173
174 \begin{code}
175 checkUpToDate :: Module -> RnMG Bool            -- True <=> no need to recompile
176 checkUpToDate mod_name
177   = findAndReadIface doc_str mod_name           `thenRn` \ read_result ->
178     case read_result of
179         Nothing ->      -- Old interface file not found, so we'd better bale out
180                     traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name]) `thenRn_`
181                     returnRn False
182
183         Just (ParsedIface _ _ usages _ _ _ _ _) 
184                 ->      -- Found it, so now check it
185                     checkModUsage usages
186   where
187         -- Only look in current directory, with suffix .hi
188     doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
189
190
191 checkModUsage [] = returnRn True                -- Yes!  Everything is up to date!
192
193 checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
194   = loadInterface doc_str mod           `thenRn` \ ifaces ->
195     let
196         Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces
197         maybe_new_mod_vers = lookupFM mod_vers_map mod
198         Just new_mod_vers  = maybe_new_mod_vers
199     in
200         -- If we can't find a version number for the old module then
201         -- bale out saying things aren't up to date
202     if not (maybeToBool maybe_new_mod_vers) then
203         returnRn False
204     else
205
206         -- If the module version hasn't changed, just move on
207     if new_mod_vers == old_mod_vers then
208         traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod])     `thenRn_`
209         checkModUsage rest
210     else
211     traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod])       `thenRn_`
212
213         -- New module version, so check entities inside
214     checkEntityUsage mod new_vers_map old_local_vers    `thenRn` \ up_to_date ->
215     if up_to_date then
216         traceRn (ppStr "...but the bits I use havn't.") `thenRn_`
217         checkModUsage rest      -- This one's ok, so check the rest
218     else
219         returnRn False          -- This one failed, so just bail out now
220   where
221     doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod]
222
223
224 checkEntityUsage mod new_vers_map [] 
225   = returnRn True       -- Yes!  All up to date!
226
227 checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
228   = newGlobalName mod occ_name          `thenRn` \ name ->
229     case lookupFM new_vers_map name of
230
231         Nothing       ->        -- We used it before, but it ain't there now
232                           traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name])  `thenRn_`
233                           returnRn False
234
235         Just new_vers ->        -- It's there, but is it up to date?
236                           if new_vers == old_vers then
237                                 -- Up to date, so check the rest
238                                 checkEntityUsage mod new_vers_map rest
239                           else
240                                 traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name])  `thenRn_`
241                                 returnRn False  -- Out of date, so bale out
242 \end{code}
243
244
245 %*********************************************************
246 %*                                                      *
247 \subsection{Getting in a declaration}
248 %*                                                      *
249 %*********************************************************
250
251 \begin{code}
252 getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl)
253 getDecl name
254   = traceRn doc_str                     `thenRn_`
255     loadInterface doc_str mod           `thenRn` \ (Ifaces _ _ _ _ decls_map _ _) ->
256     case lookupFM decls_map name of
257
258       Just avail_w_decl -> returnRn avail_w_decl
259
260       Nothing           ->      -- Can happen legitimately for "Optional" occurrences
261                            returnRn (NotAvailable, ValD EmptyBinds)
262   where
263      (mod,_) = modAndOcc name
264      doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name]
265 \end{code}
266
267 @getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
268 It behaves exactly as if the wired in decl were actually in an interface file.
269 Specifically,
270   *     if the wired-in name is a data type constructor or a data constructor, 
271         it brings in the type constructor and all the data constructors; and
272         marks as "occurrences" any free vars of the data con.
273
274   *     similarly for synonum type constructor
275
276   *     if the wired-in name is another wired-in Id, it marks as "occurrences"
277         the free vars of the Id's type.
278
279   *     it loads the interface file for the wired-in thing for the
280         sole purpose of making sure that its instance declarations are available
281
282 All this is necessary so that we know all types that are "in play", so
283 that we know just what instances to bring into scope.
284         
285 \begin{code}
286 getWiredInDecl :: Name -> RnMG AvailInfo
287 getWiredInDecl name
288   =     -- Force in the home module in case it has instance decls for
289         -- the thing we are interested in
290     (if mod == gHC__ then
291         returnRn ()                     -- Mini hack; GHC is guaranteed not to have
292                                         -- instance decls, so it's a waste of time
293                                         -- to read it
294     else
295         loadInterface doc_str mod       `thenRn_`
296         returnRn ()
297     )                                           `thenRn_`
298
299     if (maybeToBool maybe_wired_in_tycon) then
300         get_wired_tycon the_tycon
301     else                                -- Must be a wired-in-Id
302     if (isDataCon the_id) then          -- ... a wired-in data constructor
303         get_wired_tycon (dataConTyCon the_id)
304     else                                -- ... a wired-in non data-constructor
305         get_wired_id the_id
306   where
307     doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
308     (mod,_) = modAndOcc name
309     maybe_wired_in_tycon = maybeWiredInTyConName name
310     maybe_wired_in_id    = maybeWiredInIdName    name
311     Just the_tycon       = maybe_wired_in_tycon
312     Just the_id          = maybe_wired_in_id
313
314 get_wired_id id
315   = addImplicitOccsRn (nameSetToList id_mentioned)      `thenRn_`
316     returnRn (Avail (getName id) [])
317   where
318     id_mentioned         = namesOfType (idType id)
319
320 get_wired_tycon tycon 
321   | isSynTyCon tycon
322   = addImplicitOccsRn (nameSetToList mentioned)         `thenRn_`
323     returnRn (Avail (getName tycon) [])
324   where
325     (tyvars,ty) = getSynTyConDefn tycon
326     mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
327
328 get_wired_tycon tycon 
329   | otherwise           -- data or newtype
330   = addImplicitOccsRn (nameSetToList mentioned)         `thenRn_`
331     returnRn (Avail (getName tycon) (map getName data_cons))
332   where
333     data_cons = tyConDataCons tycon
334     mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
335 \end{code}
336
337
338 %*********************************************************
339 %*                                                      *
340 \subsection{Getting other stuff}
341 %*                                                      *
342 %*********************************************************
343
344 \begin{code}
345 getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
346 getInterfaceExports mod
347   = loadInterface doc_str mod           `thenRn` \ (Ifaces _ _ export_envs _ _ _ _) ->
348     case lookupFM export_envs mod of
349         Nothing ->      -- Not there; it must be that the interface file wasn't found;
350                         -- the error will have been reported already.
351                         -- (Actually loadInterface should put the empty export env in there
352                         --  anyway, but this does no harm.)
353                       returnRn ([],[])
354
355         Just stuff -> returnRn stuff
356   where
357     doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"]
358
359
360 getImportedInstDecls :: RnMG [IfaceInst]
361 getImportedInstDecls
362   =     -- First load any special-instance modules that aren't aready loaded
363     getSpecialInstModules                       `thenRn` \ inst_mods ->
364     mapRn load_it inst_mods                     `thenRn_`
365
366         -- Now we're ready to grab the instance declarations
367     getIfacesRn                                         `thenRn` \ ifaces ->
368     let
369          Ifaces _ _ _ _ _ insts _ = ifaces
370     in
371     returnRn (bagToList insts) 
372   where
373     load_it mod = loadInterface (doc_str mod) mod
374     doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"]
375
376 getSpecialInstModules :: RnMG [Module]
377 getSpecialInstModules 
378   = getIfacesRn                                         `thenRn` \ ifaces ->
379     let
380          Ifaces _ _ _ _ _ _ inst_mods = ifaces
381     in
382     returnRn inst_mods
383 \end{code}
384
385 \begin{code}
386 getImportVersions :: [AvailInfo]                        -- Imported avails
387                   -> RnMG (VersionInfo Name)    -- Version info for these names
388
389 getImportVersions imported_avails       
390   = getIfacesRn                                 `thenRn` \ ifaces ->
391     let
392          Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces
393
394          -- import_versions is harder: we have to group together all the things imported
395          -- from a particular module.  We do this with yet another finite map
396
397          mv_map :: FiniteMap Module [LocalVersion Name]
398          mv_map            = foldl add_mv emptyFM imported_avails
399          add_mv mv_map (Avail name _) 
400             | isWiredInName name = mv_map       -- Don't record versions for wired-in names
401             | otherwise = case lookupFM mv_map mod of
402                                 Just versions -> addToFM mv_map mod ((name,version):versions)
403                                 Nothing       -> addToFM mv_map mod [(name,version)]
404             where
405              (mod,_) = modAndOcc name
406              version = case lookupFM version_map name of
407                          Just v  -> v
408                          Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name)
409
410          import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions)
411                            | (mod, local_versions) <- fmToList mv_map
412                            ]
413
414          -- Question: should we filter the builtins out of import_versions?
415     in
416     returnRn import_versions
417 \end{code}
418
419 %*********************************************************
420 %*                                                      *
421 \subsection{Getting binders out of a declaration}
422 %*                                                      *
423 %*********************************************************
424
425 @getDeclBinders@ returns the names for a @RdrNameHsDecl@.
426 It's used for both source code (from @availsFromDecl@) and interface files
427 (from @loadDecl@).
428
429 It doesn't deal with source-code specific things: ValD, DefD.  They
430 are handled by the sourc-code specific stuff in RnNames.
431
432 \begin{code}
433 getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)              -- New-name function
434                 -> RdrNameHsDecl
435                 -> RnMG AvailInfo
436
437 getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
438   = new_name tycon src_loc                      `thenRn` \ tycon_name ->
439     getConFieldNames new_name condecls          `thenRn` \ sub_names ->
440     returnRn (Avail tycon_name sub_names)
441
442 getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
443   = new_name tycon src_loc              `thenRn` \ tycon_name ->
444     new_name con src_loc                `thenRn` \ con_name ->
445     returnRn (Avail tycon_name [con_name])
446
447 getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
448   = new_name tycon src_loc              `thenRn` \ tycon_name ->
449     returnRn (Avail tycon_name [])
450
451 getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
452   = new_name cname src_loc                      `thenRn` \ class_name ->
453     mapRn (getClassOpNames new_name) sigs       `thenRn` \ sub_names ->
454     returnRn (Avail class_name sub_names)
455
456 getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
457   = new_name var src_loc                        `thenRn` \ var_name ->
458     returnRn (Avail var_name [])
459
460 getDeclBinders new_name (DefD _)  = returnRn NotAvailable
461 getDeclBinders new_name (InstD _) = returnRn NotAvailable
462
463 ----------------
464 getConFieldNames new_name (ConDecl con _ src_loc : rest)
465   = new_name con src_loc                `thenRn` \ n ->
466     getConFieldNames new_name rest      `thenRn` \ ns -> 
467     returnRn (n:ns)
468
469 getConFieldNames new_name (NewConDecl con _ src_loc : rest)
470   = new_name con src_loc                `thenRn` \ n ->
471     getConFieldNames new_name rest      `thenRn` \ ns -> 
472     returnRn (n:ns)
473
474 getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest)
475   = new_name con src_loc                `thenRn` \ n ->
476     getConFieldNames new_name rest      `thenRn` \ ns -> 
477     returnRn (n:ns)
478
479 getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest)
480   = mapRn (\n -> new_name n src_loc) (con:fields)       `thenRn` \ cfs ->
481     getConFieldNames new_name rest                      `thenRn` \ ns  -> 
482     returnRn (cfs ++ ns)
483   where
484     fields = concat (map fst fielddecls)
485
486 getConFieldNames new_name [] = returnRn []
487
488 getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
489 \end{code}
490
491
492 %*********************************************************
493 %*                                                      *
494 \subsection{Reading an interface file}
495 %*                                                      *
496 %*********************************************************
497
498 \begin{code}
499 findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface)
500         -- Nothing <=> file not found, or unreadable, or illegible
501         -- Just x  <=> successfully found and parsed 
502 findAndReadIface doc_str mod
503   = traceRn trace_msg                   `thenRn_`
504     getSearchPathRn                     `thenRn` \ dirs ->
505     try dirs dirs
506   where
507     trace_msg = ppHang (ppBesides [ppStr "Reading interface for ", 
508                                    pprModule PprDebug mod, ppSemi])
509                      4 (ppBesides [ppStr "reason: ", doc_str])
510
511     try all_dirs [] = traceRn (ppStr "...failed")       `thenRn_`
512                       returnRn Nothing
513
514     try all_dirs (dir:dirs)
515         = readIface file_path   `thenRn` \ read_result ->
516           case read_result of
517                 Nothing    -> try all_dirs dirs
518                 Just iface -> traceRn (ppStr "...done") `thenRn_`
519                               returnRn (Just iface)
520         where
521           file_path = dir ++ "/" ++ moduleString mod ++ ".hi"
522 \end{code}
523
524 @readIface@ trys just one file.
525
526 \begin{code}
527 readIface :: String -> RnMG (Maybe ParsedIface) 
528         -- Nothing <=> file not found, or unreadable, or illegible
529         -- Just x  <=> successfully found and parsed 
530 readIface file_path
531   = ioToRnMG (readFile file_path)       `thenRn` \ read_result ->
532     case read_result of
533         Right contents    -> case parseIface contents of
534                                 Failed err      -> failWithRn Nothing err 
535                                 Succeeded iface -> returnRn (Just iface)
536
537         Left  (NoSuchThing _) -> returnRn Nothing
538
539         Left  err             -> failWithRn Nothing
540                                             (cannaeReadFile file_path err)
541
542 \end{code}
543
544 mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into
545 a list of directories.  For example:
546
547         mkSearchPath "foo:.:baz"  =  ["foo", ".", "baz"]
548
549 \begin{code}
550 mkSearchPath :: Maybe String -> SearchPath
551 mkSearchPath Nothing = ["."]
552 mkSearchPath (Just s)
553   = go s
554   where
555     go "" = []
556     go s  = first : go (drop 1 rest)
557           where
558             (first,rest) = span (/= ':') s
559 \end{code}
560
561 %*********************************************************
562 %*                                                      *
563 \subsection{Errors}
564 %*                                                      *
565 %*********************************************************
566
567 \begin{code}
568 noIfaceErr mod sty
569   = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)]
570 --      , ppStr " in"]) 4 (ppAboves (map ppStr dirs))
571
572 cannaeReadFile file err sty
573   = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
574 \end{code}