2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
7 #include "HsVersions.h"
21 import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
24 import HsPragmas ( noGenPragmas )
29 import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
30 import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
31 import ParseIface ( parseIface )
32 import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
33 VersionsMap(..), UsagesMap(..)
36 import Bag ( emptyBag, unitBag, consBag, snocBag,
37 unionBags, unionManyBags, isEmptyBag, bagToList )
38 import ErrUtils ( Error(..), Warning(..) )
39 import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
40 fmToList, delListFromFM, sizeFM, foldFM, unitFM,
41 plusFM_C, keysFM{-ToDo:rm-}
43 import Maybes ( maybeToBool )
44 import Name ( moduleNamePair, origName, RdrName(..) )
45 import PprStyle -- ToDo:rm
46 import Outputable -- ToDo:rm
47 import PrelInfo ( builtinNameInfo )
49 import Maybes ( MaybeErr(..) )
50 import UniqFM ( emptyUFM )
51 import UniqSupply ( splitUniqSupply )
52 import Util ( sortLt, removeDups, cmpPString, startsWith,
53 panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
57 type ModuleToIfaceContents = FiniteMap Module ParsedIface
58 type ModuleToIfaceFilePath = FiniteMap Module FilePath
61 = MutableVar _RealWorld
62 (ModuleToIfaceContents, -- interfaces for individual interface files
63 ModuleToIfaceContents, -- merged interfaces based on module name
64 -- used for extracting info about original names
65 ModuleToIfaceFilePath)
68 *********************************************************
70 \subsection{Looking for interface files}
72 *********************************************************
74 Return a mapping from module-name to
75 absolute-filename-for-that-interface.
78 findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
80 findHiFiles dirs sysdirs
81 = --hPutStr stderr " findHiFiles " >>
82 do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
83 --hPutStr stderr " done\n" >>
86 do_dirs env [] = return env
87 do_dirs env (dir:dirs)
88 = do_dir env dir >>= \ new_env ->
92 = --hPutStr stderr "D" >>
93 getDirectoryContents dir >>= \ entries ->
94 do_entries env entries
96 do_entries env [] = return env
98 = do_entry env e >>= \ new_env ->
102 = case (acceptable_hi (reverse e)) of
103 Nothing -> --trace ("Deemed uncool:"++e) $
104 --hPutStr stderr "." >>
110 case (lookupFM env pmod) of
111 Nothing -> --trace ("Adding "++mod++" -> "++e) $
112 --hPutStr stderr "!" >>
113 return (addToFM env pmod (dir ++ '/':e))
114 -- ToDo: use DIR_SEP, not /
116 Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
117 --hPutStr stderr "." >>
120 acceptable_hi rev_e -- looking at pathname *backwards*
121 = case (startsWith (reverse opt_HiSuffix) rev_e) of
123 Just xs -> plausible_modname xs{-reversed-}
126 de_dot ('.' : '/' : xs) = xs
130 plausible_modname rev_e
132 cand = reverse (takeWhile is_modname_char rev_e)
134 if null cand || not (isUpper (head cand))
138 is_modname_char c = isAlphanum c || c == '_'
142 *********************************************************
144 \subsection{Reading interface files}
146 *********************************************************
148 Return cached info about a Module's interface; otherwise,
149 read the interface (using our @ModuleToIfaceFilePath@ map
150 to decide where to look).
152 Note: we have two notions of interface
153 * the interface for a particular file name
154 * the (combined) interface for a particular module name
156 The idea is that two source files may declare a module
157 with the same name with the declarations being merged.
159 This allows us to have file PreludeList.hs producing
160 PreludeList.hi but defining part of module Prelude.
161 When PreludeList is imported its contents will be
162 added to Prelude. In this way all the original names
163 for a particular module will be available the imported
166 ToDo: Check duplicate definitons are the same.
167 ToDo: Check/Merge duplicate pragmas.
171 cachedIface :: Bool -- True => want merged interface for original name
172 -> IfaceCache -- False => want file interface only
174 -> IO (MaybeErr ParsedIface Error)
176 cachedIface want_orig_iface iface_cache mod
177 = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
179 case (lookupFM iface_fm mod) of
180 Just iface -> return (want_iface iface orig_fm)
182 case (lookupFM file_fm mod) of
183 Nothing -> return (Failed (noIfaceErr mod))
185 readIface file mod >>= \ read_iface ->
187 Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
191 iface_fm' = addToFM iface_fm mod iface
192 orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
194 writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO`
195 return (want_iface iface orig_fm')
197 want_iface iface orig_fm
199 = case lookupFM orig_fm mod of
200 Nothing -> Failed (noOrigIfaceErr mod)
201 Just orig_iface -> Succeeded orig_iface
205 iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod
208 mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
209 (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
210 = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
211 ppStr "merged with", ppPStr mod1]) $
214 (True, unionBags files1 files2)
215 (panic "mergeIface: module version numbers")
216 (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from
217 (panic "mergeIface: usage version numbers") -- the merged file interfaces named above
218 (panic "mergeIface: decl version numbers")
219 (panic "mergeIface: exports")
220 (panic "mergeIface: instance modules")
221 (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2)
222 (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2)
223 (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2)
224 (unionBags idefs1 idefs2)
225 (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2)
227 dup_merge str ppr_dup dup1 dup2
228 = pprTrace "mergeIfaces:"
229 (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
230 ppr_dup dup1, ppr_dup dup2]) $
233 idecl_nm (TypeSig n _ _) = n
234 idecl_nm (NewTypeSig n _ _ _) = n
235 idecl_nm (DataSig n _ _ _ _) = n
236 idecl_nm (ClassSig n _ _ _) = n
237 idecl_nm (ValSig n _ _) = n
240 cachedDecl :: IfaceCache
241 -> Bool -- True <=> tycon or class name
243 -> IO (MaybeErr RdrIfaceDecl Error)
245 cachedDecl iface_cache class_or_tycon orig
246 = cachedIface True iface_cache mod >>= \ maybe_iface ->
248 Failed err -> return (Failed err)
249 Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
250 case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
251 Just decl -> return (Succeeded decl)
252 Nothing -> return (Failed (noDeclInIfaceErr mod str))
254 (mod, str) = moduleNamePair orig
257 cachedDeclByType :: IfaceCache
258 -> RnName{-NB: diff type than cachedDecl -}
259 -> IO (MaybeErr RdrIfaceDecl Error)
261 cachedDeclByType iface_cache rn
262 -- the idea is: check that, e.g., if we're given an
263 -- RnClass, then we really get back a ClassDecl from
264 -- the cache (not an RnData, or something silly)
265 = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl ->
267 return_maybe_decl = return maybe_decl
268 return_failed msg = return (Failed msg)
271 Failed _ -> return_maybe_decl
274 WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
275 WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn)
276 RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
278 RnSyn _ -> return_maybe_decl
279 RnData _ _ _ -> return_maybe_decl
280 RnImplicitTyCon _ -> if is_tycon_decl if_decl
281 then return_maybe_decl
282 else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
284 RnClass _ _ -> return_maybe_decl
285 RnImplicitClass _ -> if is_class_decl if_decl
286 then return_maybe_decl
287 else return_failed (badIfaceLookupErr "class" rn if_decl)
289 RnName _ -> return_maybe_decl
290 RnConstr _ _ -> return_maybe_decl
291 RnField _ _ -> return_maybe_decl
292 RnClassOp _ _ -> return_maybe_decl
293 RnImplicit _ -> if is_val_decl if_decl
294 then return_maybe_decl
295 else return_failed (badIfaceLookupErr "value" rn if_decl)
297 is_tycon_decl (TypeSig _ _ _) = True
298 is_tycon_decl (NewTypeSig _ _ _ _) = True
299 is_tycon_decl (DataSig _ _ _ _ _) = True
300 is_tycon_decl _ = False
302 is_class_decl (ClassSig _ _ _ _) = True
303 is_class_decl _ = False
305 is_val_decl (ValSig _ _ _) = True
306 is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field
307 is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr
308 is_val_decl (ClassSig _ _ _ _) = True -- may be a method
309 is_val_decl _ = False
313 readIface :: FilePath -> Module
314 -> IO (MaybeErr ParsedIface Error)
317 = --hPutStr stderr (" reading "++file) >>
318 readFile file `thenPrimIO` \ read_result ->
320 Left err -> return (Failed (cannaeReadErr file err))
321 Right contents -> --hPutStr stderr " parsing" >>
322 let parsed = parseIface contents in
323 --hPutStr stderr " done\n" >>
327 Succeeded p -> Succeeded (init_merge mod p)
330 init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
331 = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
336 rnIfaces :: IfaceCache -- iface cache (mutvar)
337 -> [Module] -- directly imported modules
339 -> RnEnv -- defined (in the source) name env
340 -> RnEnv -- mentioned (in the source) name env
341 -> RenamedHsModule -- module to extend with iface decls
342 -> [RnName] -- imported names required (really the
343 -- same info as in mentioned name env)
344 -- Also, all the things we may look up
345 -- later by key (Unique).
346 -> IO (RenamedHsModule, -- extended module
347 RnEnv, -- final env (for renaming derivings)
348 ImplicitEnv, -- implicit names used (for usage info)
349 (UsagesMap,VersionsMap,[Module]), -- usage info
350 (Bag Error, Bag Warning))
352 rnIfaces iface_cache imp_mods us
353 def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
354 occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
355 rn_module@(HsModule modname iface_version exports imports fixities
356 typedecls typesigs classdecls instdecls instsigs
357 defdecls binds sigs src_loc)
360 pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
362 pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
363 pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
364 pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
365 pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
367 pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
368 pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
369 pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
370 pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
373 -- do transitive closure to bring in all needed names/defns and insts:
375 decls_and_insts todo def_env occ_env empty_return us
376 >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
381 -- finalize what we want to say we learned about the
383 finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
384 \ usage_stuff@(usage_info, version_info, instance_mods) ->
386 return (HsModule modname iface_version exports imports fixities
387 (typedecls ++ if_typedecls)
389 (classdecls ++ if_classdecls)
390 (instdecls ++ if_instdecls)
391 instsigs defdecls binds
399 decls_and_insts todo def_env occ_env to_return us
400 = do_decls todo -- initial batch of names to process
401 (def_env, occ_env, us1) -- init stuff down
402 to_return -- acc results
407 cacheInstModules iface_cache imp_mods >>= \ errs ->
409 do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
410 (add_errs errs decls_return) us2
412 (us1,us2) = splitUniqSupply us
414 do_insts def_env occ_env prev_env done_insts to_return us
415 | size_tc_env occ_env == size_tc_env prev_env
416 = return (to_return, occ_env)
419 = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
425 do_decls new_unknowns -- new batch of names to process
426 (def_env, insts_occ_env, us2) -- init stuff down
427 insts_return -- acc results
432 do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
434 (us1,us') = splitUniqSupply us
435 (us2,us3) = splitUniqSupply us'
437 size_tc_env ((_, _, qual, unqual), _)
438 = sizeFM qual + sizeFM unqual
441 do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting
442 -- from this list; we're done when empty (nothing
443 -- more needs to be looked for)
444 -> Go_Down -- see defn below
445 -> To_Return -- accumulated result
447 RnEnv, -- extended decl env
448 RnEnv) -- extended occ env
450 do_decls to_find@[] down to_return
451 = return (to_return, defenv down, occenv down)
453 do_decls to_find@(n:ns) down to_return
454 = case (lookup_defd down n) of
455 Just _ -> -- previous processing must've found the stuff for this name;
456 -- continue with the rest:
457 -- pprTrace "do_decls:done:" (ppr PprDebug n) $
458 do_decls ns down to_return
461 | fst (moduleNamePair n) == modname ->
462 -- avoid looking in interface for the module being compiled
463 -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
464 do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
467 -- OK, see what the cache has for us...
469 cachedDeclByType iface_cache n >>= \ maybe_ans ->
471 Failed err -> -- add the error, but keep going:
472 -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
473 do_decls ns down (add_err err to_return)
475 Succeeded iface_decl -> -- something needing renaming!
477 (us1, us2) = splitUniqSupply (uniqsupply down)
479 case (initRn False{-iface-} modname (occenv down) us1 (
480 setExtraRn emptyUFM{-no fixities-} $
481 rnIfaceDecl iface_decl)) of {
482 ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
484 new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
487 pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
488 , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
489 , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
490 , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
493 do_decls (new_unknowns ++ ns)
494 (add_occs if_defd if_implicits $
495 new_uniqsupply us2 down)
497 add_implicits if_implicits $
499 add_warns if_warns to_return)
503 type Go_Down = (RnEnv, -- stuff we already have defns for;
504 -- to check quickly if we've already
505 -- found something for the name under consideration,
506 -- due to previous processing.
507 -- It starts off just w/ the defns for
508 -- the things in this module.
509 RnEnv, -- occurrence env; this gets added to as
510 -- we process new iface decls. It includes
511 -- entries for *all* occurrences, including those
512 -- for which we have definitions.
513 UniqSupply -- the obvious
516 lookup_defd (def_env, _, _) n
518 = lookupTcRnEnv def_env (origName n)
520 = lookupRnEnv def_env (origName n)
522 defenv (def_env, _, _) = def_env
523 occenv (_, occ_env, _) = occ_env
524 uniqsupply (_, _, us) = us
526 new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
528 add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
529 = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
530 ASSERT(isEmptyBag def_dups)
532 val_occs = val_defds ++ fmToList val_imps
533 tc_occs = tc_defds ++ fmToList tc_imps
535 case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
537 -- ASSERT(isEmptyBag occ_dups)
538 -- False because we may get a dup on the name we just shoved in
540 (new_def_env, new_occ_env, us) }}
543 type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
544 ImplicitEnv, -- new names used implicitly
545 (Bag Error, Bag Warning)
548 empty_return :: To_Return
549 empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
551 add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
553 AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
554 AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
555 AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
557 add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
558 = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
560 add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
561 = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
563 add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
564 add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
565 add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
569 data AddedDecl -- purely local
570 = AddedTy RenamedTyDecl
571 | AddedClass RenamedClassDecl
572 | AddedSig RenamedSig
574 rnIfaceDecl :: RdrIfaceDecl
575 -> RnM_Fixes _RealWorld
576 (AddedDecl, -- the resulting decl to add to the pot
577 ([(RdrName,RnName)], [(RdrName,RnName)]),
578 -- new val/tycon-class names that have
579 -- *been defined* while processing this decl
580 ImplicitEnv -- new implicit val/tycon-class names that we
584 rnIfaceDecl (TypeSig tc _ decl)
585 = rnTyDecl decl `thenRn` \ rn_decl ->
586 lookupTyCon tc `thenRn` \ rn_tc ->
587 getImplicitUpRn `thenRn` \ mentioned ->
589 defds = ([], [(tc, rn_tc)])
590 implicits = mentioned `sub` defds
592 returnRn (AddedTy rn_decl, defds, implicits)
594 rnIfaceDecl (NewTypeSig tc dc _ decl)
595 = rnTyDecl decl `thenRn` \ rn_decl ->
596 lookupTyCon tc `thenRn` \ rn_tc ->
597 lookupValue dc `thenRn` \ rn_dc ->
598 getImplicitUpRn `thenRn` \ mentioned ->
600 defds = ([(dc, rn_dc)], [(tc, rn_tc)])
601 implicits = mentioned `sub` defds
603 returnRn (AddedTy rn_decl, defds, implicits)
605 rnIfaceDecl (DataSig tc dcs fcs _ decl)
606 = rnTyDecl decl `thenRn` \ rn_decl ->
607 lookupTyCon tc `thenRn` \ rn_tc ->
608 mapRn lookupValue dcs `thenRn` \ rn_dcs ->
609 mapRn lookupValue fcs `thenRn` \ rn_fcs ->
610 getImplicitUpRn `thenRn` \ mentioned ->
612 defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
613 implicits = mentioned `sub` defds
615 returnRn (AddedTy rn_decl, defds, implicits)
617 rnIfaceDecl (ClassSig clas ops _ decl)
618 = rnClassDecl decl `thenRn` \ rn_decl ->
619 lookupClass clas `thenRn` \ rn_clas ->
620 mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops ->
621 getImplicitUpRn `thenRn` \ mentioned ->
623 defds = (ops `zip` rn_ops, [(clas, rn_clas)])
624 implicits = mentioned `sub` defds
626 returnRn (AddedClass rn_decl, defds, implicits)
628 rnIfaceDecl (ValSig f src_loc ty)
629 -- should rename_sig in RnBinds be used here? ToDo
630 = lookupValue f `thenRn` \ rn_f ->
631 -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
632 rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty ->
633 getImplicitUpRn `thenRn` \ mentioned ->
635 defds = ([(f, rn_f)], [])
636 implicits = mentioned `sub` defds
638 returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
641 sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
643 sub (val_ment, tc_ment) (val_defds, tc_defds)
644 = (delListFromFM val_ment (map fst val_defds),
645 delListFromFM tc_ment (map fst tc_defds))
648 % ------------------------------
650 @cacheInstModules@: cache instance modules specified in imports
653 cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
654 cacheInstModules iface_cache imp_mods
655 = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) ->
657 imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
658 (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
659 get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
661 accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
664 -- Assert that instance modules given by direct imports contains
665 -- instance modules extracted from all visited modules
667 readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) ->
669 all_ifaces = eltsFM all_iface_fm
670 (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
672 ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
674 return (bag_errs err_or_ifaces)
676 bag_errs [] = emptyBag
677 bag_errs (Failed err :rest) = err `consBag` bag_errs rest
678 bag_errs (Succeeded _:rest) = bag_errs rest
682 @rnIfaceInstStuff@: Deal with instance declarations from interface files.
685 type InstanceEnv = FiniteMap (RdrName, RdrName) Int
688 :: IfaceCache -- all about ifaces we've read
691 -> RnEnv -- current occ env
692 -> InstanceEnv -- instances for these tycon/class pairs done
695 InstanceEnv, -- extended instance env
696 RnEnv, -- final occ env
697 [RnName]) -- new unknown names
699 rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
700 = -- all the instance decls we might even want to consider
701 -- are in the ParsedIfaces that are in our cache
703 readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
705 all_ifaces = eltsFM orig_iface_fm
706 all_insts = unionManyBags (map get_insts all_ifaces)
707 interesting_insts = filter want_inst (bagToList all_insts)
710 -- Assert that there are no more instances for the done instances
712 claim_done = filter is_done_inst (bagToList all_insts)
713 claim_done_env = foldr add_done_inst emptyFM claim_done
714 has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
717 pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $
718 pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
720 ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
721 ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
723 case (initRn False{-iface-} modname occ_env us (
724 setExtraRn emptyUFM{-no fixities-} $
725 mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
726 getImplicitUpRn `thenRn` \ implicits ->
727 returnRn (insts, implicits))) of {
728 ((if_insts, if_implicits), if_errs, if_warns) ->
730 return (add_insts if_insts $
731 add_implicits if_implicits $
733 add_warns if_warns to_return,
734 foldr add_done_inst done_inst_env interesting_insts,
735 add_imp_occs if_implicits occ_env,
736 eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
739 get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts
741 add_done_inst (InstSig clas tycon _ _) inst_env
742 = addToFM_C (+) inst_env (tycon,clas) 1
744 is_done_inst (InstSig clas tycon _ _)
745 = maybeToBool (lookupFM done_inst_env (tycon,clas))
747 add_imp_occs (val_imps, tc_imps) occ_env
748 = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
749 (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
752 want_inst i@(InstSig clas tycon _ _)
753 = -- it's a "good instance" (one to hang onto) if we have a
754 -- chance of referring to *both* the class and tycon later on ...
756 mentionable tycon && mentionable clas && not (is_done_inst i)
759 = case lookupTcRnEnv occ_env nm of
761 Nothing -> -- maybe it's builtin
765 case (lookupFM b_tc_names n) of
767 Nothing -> maybeToBool (lookupFM b_keys n)
769 (b_tc_names, b_keys) -- pretty UGLY ...
770 = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
773 = ppAboves (map ppr_inst insts)
775 ppr_inst (InstSig c t _ inst_decl)
776 = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
780 rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
782 rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
787 IfaceCache -- iface cache
788 -> Module -- this module's name
791 -- -> [RnName] -- all imported names required
792 -- -> [Module] -- directly imported modules
794 VersionsMap, -- info about version numbers
795 [Module]) -- special instance modules
797 finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
799 -- pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
800 -- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
801 -- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
802 -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
804 val_stuff@(val_usages, val_versions)
805 = foldFM process_item (emptyFM, emptyFM){-init-} qual
807 (all_usages, all_versions)
808 = foldFM process_item val_stuff{-keep going-} tc_qual
810 return (all_usages, all_versions, [])
812 process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
813 -> (UsagesMap, VersionsMap) -- input
814 -> (UsagesMap, VersionsMap) -- output
816 process_item (n,m) rn as_before@(usages, versions)
819 | m == modname -- this module => add to "versions"
820 = (usages, addToFM versions n 1{-stub-})
821 | otherwise -- from another module => add to "usages"
822 = (add_to_usages usages m n 1{-stub-}, versions)
824 irrelevant (RnConstr _ _) = True -- We don't report these in their
825 irrelevant (RnField _ _) = True -- own right in usages/etc.
826 irrelevant (RnClassOp _ _) = True
829 add_to_usages usages m n version
831 case (lookupFM usages m) of
832 Nothing -> -- nothing for this module yet...
833 (1{-stub-}, unitFM n version)
835 Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
836 (mversion, addToFM mstuff n version)
842 thisModImplicitErr mod n sty
843 = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod]
846 = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
848 noOrigIfaceErr mod sty
849 = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]
851 noDeclInIfaceErr mod str sty
852 = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
853 ppPStr mod, ppStr ".", ppPStr str]
855 cannaeReadErr file err sty
856 = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
858 ifaceLookupWiredErr msg n sty
859 = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
861 badIfaceLookupErr msg name decl sty
862 = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]