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, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
37 import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
38 import ErrUtils ( Error(..), Warning(..) )
39 import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
40 fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-}
42 import Maybes ( maybeToBool )
43 import Name ( moduleNamePair, origName, isRdrLexCon,
44 RdrName(..){-instance NamedThing-}
46 import PprStyle -- ToDo:rm
47 import Outputable -- ToDo:rm
48 import PrelInfo ( builtinNameInfo )
50 import Maybes ( MaybeErr(..) )
51 import UniqFM ( emptyUFM )
52 import UniqSupply ( splitUniqSupply )
53 import Util ( sortLt, removeDups, cmpPString, startsWith,
54 panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
58 type ModuleToIfaceContents = FiniteMap Module ParsedIface
59 type ModuleToIfaceFilePath = FiniteMap Module FilePath
62 = MutableVar _RealWorld (ModuleToIfaceContents,
63 ModuleToIfaceFilePath)
66 *********************************************************
68 \subsection{Looking for interface files}
70 *********************************************************
72 Return a mapping from module-name to
73 absolute-filename-for-that-interface.
75 findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
77 findHiFiles dirs sysdirs
78 = hPutStr stderr " findHiFiles " >>
79 do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
80 hPutStr stderr " done\n" >>
83 do_dirs env [] = return env
84 do_dirs env (dir:dirs)
85 = do_dir env dir >>= \ new_env ->
89 = hPutStr stderr "D" >>
90 getDirectoryContents dir >>= \ entries ->
91 do_entries env entries
93 do_entries env [] = return env
95 = do_entry env e >>= \ new_env ->
99 = case (acceptable_hi (reverse e)) of
100 Nothing -> --trace ("Deemed uncool:"++e) $
101 hPutStr stderr "." >>
107 case (lookupFM env pmod) of
108 Nothing -> --trace ("Adding "++mod++" -> "++e) $
109 hPutStr stderr "!" >>
110 return (addToFM env pmod (dir ++ '/':e))
111 -- ToDo: use DIR_SEP, not /
113 Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
114 hPutStr stderr "." >>
117 acceptable_hi rev_e -- looking at pathname *backwards*
118 = case (startsWith (reverse opt_HiSuffix) rev_e) of
120 Just xs -> plausible_modname xs{-reversed-}
123 de_dot ('.' : '/' : xs) = xs
127 plausible_modname rev_e
129 cand = reverse (takeWhile is_modname_char rev_e)
131 if null cand || not (isUpper (head cand))
135 is_modname_char c = isAlphanum c || c == '_'
138 *********************************************************
140 \subsection{Reading interface files}
142 *********************************************************
144 Return cached info about a Module's interface; otherwise,
145 read the interface (using our @ModuleToIfaceFilePath@ map
146 to decide where to look).
149 cachedIface :: IfaceCache
151 -> IO (MaybeErr ParsedIface Error)
153 cachedIface iface_cache mod
154 = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
156 case (lookupFM iface_fm mod) of
157 Just iface -> return (Succeeded iface)
159 case (lookupFM file_fm mod) of
160 Nothing -> return (Failed (noIfaceErr mod))
162 readIface file mod >>= \ read_iface ->
164 Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
168 iface_fm' = addToFM iface_fm mod iface
170 writeVar iface_cache (iface_fm', file_fm) `seqPrimIO`
171 return (Succeeded iface)
174 cachedDecl :: IfaceCache
175 -> Bool -- True <=> tycon or class name
177 -> IO (MaybeErr RdrIfaceDecl Error)
179 -- ToDo: this is where the check for Prelude.map being
180 -- located in PreludeList.map should be done ...
182 cachedDecl iface_cache class_or_tycon orig
183 = cachedIface iface_cache mod >>= \ maybe_iface ->
185 Failed err -> return (Failed err)
186 Succeeded (ParsedIface _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
187 case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
188 Just decl -> return (Succeeded decl)
189 Nothing -> return (Failed (noDeclInIfaceErr mod str))
191 (mod, str) = moduleNamePair orig
194 cachedDeclByType :: IfaceCache
195 -> RnName{-NB: diff type than cachedDecl -}
196 -> IO (MaybeErr RdrIfaceDecl Error)
198 cachedDeclByType iface_cache rn
199 -- the idea is: check that, e.g., if we're given an
200 -- RnClass, then we really get back a ClassDecl from
201 -- the cache (not an RnData, or something silly)
202 = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl ->
204 return_maybe_decl = return maybe_decl
205 return_failed msg = return (Failed msg)
208 Failed _ -> return_maybe_decl
211 WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
212 WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn)
213 RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
215 RnSyn _ -> return_maybe_decl
216 RnData _ _ _ -> return_maybe_decl
217 RnImplicitTyCon _ -> if is_tycon_decl if_decl
218 then return_maybe_decl
219 else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
221 RnClass _ _ -> return_maybe_decl
222 RnImplicitClass _ -> if is_class_decl if_decl
223 then return_maybe_decl
224 else return_failed (badIfaceLookupErr "class" rn if_decl)
226 RnName _ -> return_maybe_decl
227 RnConstr _ _ -> return_maybe_decl
228 RnField _ _ -> return_maybe_decl
229 RnClassOp _ _ -> return_maybe_decl
230 RnImplicit _ -> if is_val_decl if_decl
231 then return_maybe_decl
232 else return_failed (badIfaceLookupErr "value" rn if_decl)
234 is_tycon_decl (TypeSig _ _ _) = True
235 is_tycon_decl (NewTypeSig _ _ _ _) = True
236 is_tycon_decl (DataSig _ _ _ _ _) = True
237 is_tycon_decl _ = False
239 is_class_decl (ClassSig _ _ _ _) = True
240 is_class_decl _ = False
242 is_val_decl (ValSig _ _ _) = True
243 is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field
244 is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr
245 is_val_decl (ClassSig _ _ _ _) = True -- may be a method
246 is_val_decl _ = False
250 readIface :: FilePath -> Module
251 -> IO (MaybeErr ParsedIface Error)
254 = hPutStr stderr (" reading "++file) >>
255 readFile file `thenPrimIO` \ read_result ->
257 Left err -> return (Failed (cannaeReadErr file err))
258 Right contents -> hPutStr stderr " parsing" >>
259 let parsed = parseIface contents in
260 hPutStr stderr " done\n" >>
266 rnIfaces :: IfaceCache -- iface cache (mutvar)
267 -> [Module] -- directly imported modules
269 -> RnEnv -- defined (in the source) name env
270 -> RnEnv -- mentioned (in the source) name env
271 -> RenamedHsModule -- module to extend with iface decls
272 -> [RnName] -- imported names required (really the
273 -- same info as in mentioned name env)
274 -- Also, all the things we may look up
275 -- later by key (Unique).
276 -> IO (RenamedHsModule, -- extended module
277 RnEnv, -- final env (for renaming derivings)
278 ImplicitEnv, -- implicit names used (for usage info)
279 (UsagesMap,VersionsMap,[Module]), -- usage info
280 (Bag Error, Bag Warning))
282 rnIfaces iface_cache imp_mods us
283 def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
284 occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
285 rn_module@(HsModule modname iface_version exports imports fixities
286 typedecls typesigs classdecls instdecls instsigs
287 defdecls binds sigs src_loc)
290 pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
292 pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
293 pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
294 pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
295 pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
297 pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
298 pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
299 pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
300 pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
303 -- do transitive closure to bring in all needed names/defns and insts:
305 decls_and_insts todo def_env occ_env empty_return us
306 >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
311 -- finalize what we want to say we learned about the
313 finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
314 \ usage_stuff@(usage_info, version_info, instance_mods) ->
316 return (HsModule modname iface_version exports imports fixities
317 (typedecls ++ if_typedecls)
319 (classdecls ++ if_classdecls)
320 (instdecls ++ if_instdecls)
321 instsigs defdecls binds
329 decls_and_insts todo def_env occ_env to_return us
330 = do_decls todo -- initial batch of names to process
331 (def_env, occ_env, us1) -- init stuff down
332 to_return -- acc results
337 cacheInstModules iface_cache imp_mods >>= \ errs ->
339 do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
340 (add_errs errs decls_return) us2
342 (us1,us2) = splitUniqSupply us
344 do_insts def_env occ_env prev_env done_insts to_return us
345 | size_tc_env occ_env == size_tc_env prev_env
346 = return (to_return, occ_env)
349 = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
355 do_decls new_unknowns -- new batch of names to process
356 (def_env, insts_occ_env, us2) -- init stuff down
357 insts_return -- acc results
362 do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
364 (us1,us') = splitUniqSupply us
365 (us2,us3) = splitUniqSupply us'
367 size_tc_env ((_, _, qual, unqual), _)
368 = sizeFM qual + sizeFM unqual
371 do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting
372 -- from this list; we're done when empty (nothing
373 -- more needs to be looked for)
374 -> Go_Down -- see defn below
375 -> To_Return -- accumulated result
377 RnEnv, -- extended decl env
378 RnEnv) -- extended occ env
380 do_decls to_find@[] down to_return
381 = return (to_return, defenv down, occenv down)
383 do_decls to_find@(n:ns) down to_return
384 = case (lookup_defd down n) of
385 Just _ -> -- previous processing must've found the stuff for this name;
386 -- continue with the rest:
387 -- pprTrace "do_decls:done:" (ppr PprDebug n) $
388 do_decls ns down to_return
390 Nothing -> -- OK, see what the cache has for us...
392 cachedDeclByType iface_cache n >>= \ maybe_ans ->
394 Failed err -> -- add the error, but keep going:
395 -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
396 do_decls ns down (add_err err to_return)
398 Succeeded iface_decl -> -- something needing renaming!
400 (us1, us2) = splitUniqSupply (uniqsupply down)
402 case (initRn False{-iface-} modname (occenv down) us1 (
403 setExtraRn emptyUFM{-no fixities-} $
404 rnIfaceDecl iface_decl)) of {
405 ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
407 new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
410 pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
411 , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
412 , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
413 , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
416 do_decls (new_unknowns ++ ns)
417 (add_occs if_defd if_implicits $
418 new_uniqsupply us2 down)
420 add_implicits if_implicits $
422 add_warns if_warns to_return)
426 type Go_Down = (RnEnv, -- stuff we already have defns for;
427 -- to check quickly if we've already
428 -- found something for the name under consideration,
429 -- due to previous processing.
430 -- It starts off just w/ the defns for
431 -- the things in this module.
432 RnEnv, -- occurrence env; this gets added to as
433 -- we process new iface decls. It includes
434 -- entries for *all* occurrences, including those
435 -- for which we have definitions.
436 UniqSupply -- the obvious
439 lookup_defd (def_env, _, _) n
441 = lookupTcRnEnv def_env (origName n)
443 = lookupRnEnv def_env (origName n)
445 defenv (def_env, _, _) = def_env
446 occenv (_, occ_env, _) = occ_env
447 uniqsupply (_, _, us) = us
449 new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
451 add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
452 = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
453 ASSERT(isEmptyBag def_dups)
455 val_occs = val_defds ++ fmToList val_imps
456 tc_occs = tc_defds ++ fmToList tc_imps
458 case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
460 -- ASSERT(isEmptyBag occ_dups)
461 -- False because we may get a dup on the name we just shoved in
463 (new_def_env, new_occ_env, us) }}
466 type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
467 ImplicitEnv, -- new names used implicitly
468 (Bag Error, Bag Warning)
471 empty_return :: To_Return
472 empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
474 add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
476 AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
477 AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
478 AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
480 add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
481 = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
483 add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
484 = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
486 add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
487 add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
488 add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
492 data AddedDecl -- purely local
493 = AddedTy RenamedTyDecl
494 | AddedClass RenamedClassDecl
495 | AddedSig RenamedSig
497 rnIfaceDecl :: RdrIfaceDecl
498 -> RnM_Fixes _RealWorld
499 (AddedDecl, -- the resulting decl to add to the pot
500 ([(RdrName,RnName)], [(RdrName,RnName)]),
501 -- new val/tycon-class names that have
502 -- *been defined* while processing this decl
503 ImplicitEnv -- new implicit val/tycon-class names that we
507 rnIfaceDecl (TypeSig tc _ decl)
508 = rnTyDecl decl `thenRn` \ rn_decl ->
509 lookupTyCon tc `thenRn` \ rn_tc ->
510 getImplicitUpRn `thenRn` \ mentioned ->
512 defds = ([], [(tc, rn_tc)])
513 implicits = mentioned `sub` defds
515 returnRn (AddedTy rn_decl, defds, implicits)
517 rnIfaceDecl (NewTypeSig tc dc _ decl)
518 = rnTyDecl decl `thenRn` \ rn_decl ->
519 lookupTyCon tc `thenRn` \ rn_tc ->
520 lookupValue dc `thenRn` \ rn_dc ->
521 getImplicitUpRn `thenRn` \ mentioned ->
523 defds = ([(dc, rn_dc)], [(tc, rn_tc)])
524 implicits = mentioned `sub` defds
526 returnRn (AddedTy rn_decl, defds, implicits)
528 rnIfaceDecl (DataSig tc dcs fcs _ decl)
529 = rnTyDecl decl `thenRn` \ rn_decl ->
530 lookupTyCon tc `thenRn` \ rn_tc ->
531 mapRn lookupValue dcs `thenRn` \ rn_dcs ->
532 mapRn lookupValue fcs `thenRn` \ rn_fcs ->
533 getImplicitUpRn `thenRn` \ mentioned ->
535 defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
536 implicits = mentioned `sub` defds
538 returnRn (AddedTy rn_decl, defds, implicits)
540 rnIfaceDecl (ClassSig clas ops _ decl)
541 = rnClassDecl decl `thenRn` \ rn_decl ->
542 lookupClass clas `thenRn` \ rn_clas ->
543 mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops ->
544 getImplicitUpRn `thenRn` \ mentioned ->
546 defds = (ops `zip` rn_ops, [(clas, rn_clas)])
547 implicits = mentioned `sub` defds
549 returnRn (AddedClass rn_decl, defds, implicits)
551 rnIfaceDecl (ValSig f src_loc ty)
552 -- should rename_sig in RnBinds be used here? ToDo
553 = lookupValue f `thenRn` \ rn_f ->
554 -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
555 rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty ->
556 getImplicitUpRn `thenRn` \ mentioned ->
558 defds = ([(f, rn_f)], [])
559 implicits = mentioned `sub` defds
561 returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
564 sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
566 sub (val_ment, tc_ment) (val_defds, tc_defds)
567 = (delListFromFM val_ment (map fst val_defds),
568 delListFromFM tc_ment (map fst tc_defds))
571 % ------------------------------
573 @cacheInstModules@: cache instance modules specified in imports
576 cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
577 cacheInstModules iface_cache imp_mods
578 = readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
580 imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
581 (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
582 get_ims (ParsedIface _ _ _ _ _ _ ims _ _ _ _ _) = ims
584 accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->
587 -- Assert that instance modules given by direct imports contains
588 -- instance modules extracted from all visited modules
590 readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) ->
592 all_ifaces = eltsFM all_iface_fm
593 (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
595 ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
597 return (bag_errs err_or_ifaces)
599 bag_errs [] = emptyBag
600 bag_errs (Failed err :rest) = err `consBag` bag_errs rest
601 bag_errs (Succeeded _:rest) = bag_errs rest
605 @rnIfaceInstStuff@: Deal with instance declarations from interface files.
608 type InstanceEnv = FiniteMap (RdrName, RdrName) Int
611 :: IfaceCache -- all about ifaces we've read
614 -> RnEnv -- current occ env
615 -> InstanceEnv -- instances for these tycon/class pairs done
618 InstanceEnv, -- extended instance env
619 RnEnv, -- final occ env
620 [RnName]) -- new unknown names
622 rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
623 = -- all the instance decls we might even want to consider
624 -- are in the ParsedIfaces that are in our cache
626 readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
628 all_ifaces = eltsFM iface_fm
629 all_insts = unionManyBags (map get_insts all_ifaces)
630 interesting_insts = filter want_inst (bagToList all_insts)
633 -- Assert that there are no more instances for the done instances
635 claim_done = filter is_done_inst (bagToList all_insts)
636 claim_done_env = foldr add_done_inst emptyFM claim_done
637 has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
640 pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $
641 pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
643 ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
644 ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
646 case (initRn False{-iface-} modname occ_env us (
647 setExtraRn emptyUFM{-no fixities-} $
648 mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
649 getImplicitUpRn `thenRn` \ implicits ->
650 returnRn (insts, implicits))) of {
651 ((if_insts, if_implicits), if_errs, if_warns) ->
653 return (add_insts if_insts $
654 add_implicits if_implicits $
656 add_warns if_warns to_return,
657 foldr add_done_inst done_inst_env interesting_insts,
658 add_imp_occs if_implicits occ_env,
659 eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
662 get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ insts _) = insts
664 add_done_inst (InstSig clas tycon _ _) inst_env
665 = addToFM_C (+) inst_env (tycon,clas) 1
667 is_done_inst (InstSig clas tycon _ _)
668 = maybeToBool (lookupFM done_inst_env (tycon,clas))
670 add_imp_occs (val_imps, tc_imps) occ_env
671 = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
672 (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
675 want_inst i@(InstSig clas tycon _ _)
676 = -- it's a "good instance" (one to hang onto) if we have a
677 -- chance of referring to *both* the class and tycon later on ...
679 mentionable tycon && mentionable clas && not (is_done_inst i)
682 = case lookupTcRnEnv occ_env nm of
684 Nothing -> -- maybe it's builtin
688 case (lookupFM b_tc_names n) of
690 Nothing -> maybeToBool (lookupFM b_keys n)
692 (b_tc_names, b_keys) -- pretty UGLY ...
693 = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
696 = ppAboves (map ppr_inst insts)
698 ppr_inst (InstSig c t _ inst_decl)
699 = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
703 rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
705 rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
710 IfaceCache -- iface cache
713 -- -> [RnName] -- all imported names required
714 -- -> [Module] -- directly imported modules
716 VersionsMap, -- info about version numbers
717 [Module]) -- special instance modules
719 finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
721 pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
722 -- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
723 pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
724 -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
726 return (emptyFM, emptyFM, [])
732 = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
734 noDeclInIfaceErr mod str sty
735 = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
736 ppPStr mod, ppStr ".", ppPStr str]
738 cannaeReadErr file err sty
739 = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
741 ifaceLookupWiredErr msg n sty
742 = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
744 badIfaceLookupErr msg name decl sty
745 = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]