+rnIfaces :: IfaceCache -- iface cache (mutvar)
+ -> [Module] -- directly imported modules
+ -> UniqSupply
+ -> RnEnv -- defined (in the source) name env
+ -> RnEnv -- mentioned (in the source) name env
+ -> RenamedHsModule -- module to extend with iface decls
+ -> [RnName] -- imported names required (really the
+ -- same info as in mentioned name env)
+ -- Also, all the things we may look up
+ -- later by key (Unique).
+ -> IO (RenamedHsModule, -- extended module
+ RnEnv, -- final env (for renaming derivings)
+ ImplicitEnv, -- implicit names used (for usage info)
+ (UsagesMap,VersionsMap,[Module]), -- usage info
+ (Bag Error, Bag Warning))
+
+rnIfaces iface_cache imp_mods us
+ def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
+ occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
+ rn_module@(HsModule modname iface_version exports imports fixities
+ typedecls typesigs classdecls instdecls instsigs
+ defdecls binds sigs src_loc)
+ todo
+ = {-
+ pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
+
+ pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
+ pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
+ pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
+ pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+
+ pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
+ pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
+ pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
+ pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
+ -}
+
+ -- do transitive closure to bring in all needed names/defns and insts:
+
+ decls_and_insts todo def_env occ_env empty_return us
+ >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
+ if_implicits,
+ if_errs_warns),
+ if_final_env) ->
+
+ -- finalize what we want to say we learned about the
+ -- things we used
+ finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
+ \ usage_stuff@(usage_info, version_info, instance_mods) ->
+
+ return (HsModule modname iface_version exports imports fixities
+ (typedecls ++ if_typedecls)
+ typesigs
+ (classdecls ++ if_classdecls)
+ (instdecls ++ if_instdecls)
+ instsigs defdecls binds
+ (sigs ++ if_sigs)
+ src_loc,
+ if_final_env,
+ if_implicits,
+ usage_stuff,
+ if_errs_warns)
+ where
+ decls_and_insts todo def_env occ_env to_return us
+ = do_decls todo -- initial batch of names to process
+ (def_env, occ_env, us1) -- init stuff down
+ to_return -- acc results
+ >>= \ (decls_return,
+ decls_def_env,
+ decls_occ_env) ->
+
+ cacheInstModules iface_cache imp_mods >>= \ errs ->
+
+ do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
+ (add_errs errs decls_return) us2
+ where
+ (us1,us2) = splitUniqSupply us
+
+ do_insts def_env occ_env prev_env done_insts to_return us
+ | size_tc_env occ_env == size_tc_env prev_env
+ = return (to_return, occ_env)
+
+ | otherwise
+ = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
+ >>= \ (insts_return,
+ new_insts,
+ insts_occ_env,
+ new_unknowns) ->
+
+ do_decls new_unknowns -- new batch of names to process
+ (def_env, insts_occ_env, us2) -- init stuff down
+ insts_return -- acc results
+ >>= \ (decls_return,
+ decls_def_env,
+ decls_occ_env) ->
+
+ do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
+ where
+ (us1,us') = splitUniqSupply us
+ (us2,us3) = splitUniqSupply us'
+
+ size_tc_env ((_, _, qual, unqual), _)
+ = sizeFM qual + sizeFM unqual
+
+
+ do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting
+ -- from this list; we're done when empty (nothing
+ -- more needs to be looked for)
+ -> Go_Down -- see defn below
+ -> To_Return -- accumulated result
+ -> IO (To_Return,
+ RnEnv, -- extended decl env
+ RnEnv) -- extended occ env
+
+ do_decls to_find@[] down to_return
+ = return (to_return, defenv down, occenv down)
+
+ do_decls to_find@(n:ns) down to_return
+ = case (lookup_defd down n) of
+ Just _ -> -- previous processing must've found the stuff for this name;
+ -- continue with the rest:
+ -- pprTrace "do_decls:done:" (ppr PprDebug n) $
+ do_decls ns down to_return
+
+ Nothing
+ | fst (moduleNamePair n) == modname ->
+ -- avoid looking in interface for the module being compiled
+ -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
+ do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
+
+ | otherwise ->
+ -- OK, see what the cache has for us...
+
+ cachedDeclByType iface_cache n >>= \ maybe_ans ->
+ case maybe_ans of
+ Failed err -> -- add the error, but keep going:
+ -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ do_decls ns down (add_err err to_return)
+
+ Succeeded iface_decl -> -- something needing renaming!
+ let
+ (us1, us2) = splitUniqSupply (uniqsupply down)
+ in
+ case (initRn False{-iface-} modname (occenv down) us1 (
+ setExtraRn emptyUFM{-no fixities-} $
+ rnIfaceDecl iface_decl)) of {
+ ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
+ let
+ new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
+ in
+ {-
+ pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
+ , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
+ , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
+ , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
+ ]) $
+ -}
+ do_decls (new_unknowns ++ ns)
+ (add_occs if_defd if_implicits $
+ new_uniqsupply us2 down)
+ (add_decl if_decl $
+ add_implicits if_implicits $
+ add_errs if_errs $
+ add_warns if_warns to_return)
+ }
+
+-----------
+type Go_Down = (RnEnv, -- stuff we already have defns for;
+ -- to check quickly if we've already
+ -- found something for the name under consideration,
+ -- due to previous processing.
+ -- It starts off just w/ the defns for
+ -- the things in this module.
+ RnEnv, -- occurrence env; this gets added to as
+ -- we process new iface decls. It includes
+ -- entries for *all* occurrences, including those
+ -- for which we have definitions.
+ UniqSupply -- the obvious
+ )
+
+lookup_defd (def_env, _, _) n
+ | isRnTyConOrClass n
+ = lookupTcRnEnv def_env (origName n)
+ | otherwise
+ = lookupRnEnv def_env (origName n)
+
+defenv (def_env, _, _) = def_env
+occenv (_, occ_env, _) = occ_env
+uniqsupply (_, _, us) = us
+
+new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
+
+add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
+ = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
+ ASSERT(isEmptyBag def_dups)
+ let
+ val_occs = val_defds ++ fmToList val_imps
+ tc_occs = tc_defds ++ fmToList tc_imps
+ in
+ case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
+
+-- ASSERT(isEmptyBag occ_dups)
+-- False because we may get a dup on the name we just shoved in
+
+ (new_def_env, new_occ_env, us) }}
+
+----------------
+type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
+ ImplicitEnv, -- new names used implicitly
+ (Bag Error, Bag Warning)
+ )
+
+empty_return :: To_Return
+empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
+
+add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
+ = case decl of
+ AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
+ AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
+ AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
+
+add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
+ = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
+
+add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
+ = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
+
+add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
+add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
+add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
+\end{code}
+
+\begin{code}
+data AddedDecl -- purely local
+ = AddedTy RenamedTyDecl
+ | AddedClass RenamedClassDecl
+ | AddedSig RenamedSig
+
+rnIfaceDecl :: RdrIfaceDecl
+ -> RnM_Fixes _RealWorld
+ (AddedDecl, -- the resulting decl to add to the pot
+ ([(RdrName,RnName)], [(RdrName,RnName)]),
+ -- new val/tycon-class names that have
+ -- *been defined* while processing this decl
+ ImplicitEnv -- new implicit val/tycon-class names that we
+ -- stumbled into
+ )
+
+rnIfaceDecl (TypeSig tc _ decl)
+ = rnTyDecl decl `thenRn` \ rn_decl ->
+ lookupTyCon tc `thenRn` \ rn_tc ->
+ getImplicitUpRn `thenRn` \ mentioned ->
+ let
+ defds = ([], [(tc, rn_tc)])
+ implicits = mentioned `sub` defds
+ in
+ returnRn (AddedTy rn_decl, defds, implicits)
+
+rnIfaceDecl (NewTypeSig tc dc _ decl)
+ = rnTyDecl decl `thenRn` \ rn_decl ->
+ lookupTyCon tc `thenRn` \ rn_tc ->
+ lookupValue dc `thenRn` \ rn_dc ->
+ getImplicitUpRn `thenRn` \ mentioned ->
+ let
+ defds = ([(dc, rn_dc)], [(tc, rn_tc)])
+ implicits = mentioned `sub` defds
+ in
+ returnRn (AddedTy rn_decl, defds, implicits)
+
+rnIfaceDecl (DataSig tc dcs fcs _ decl)
+ = rnTyDecl decl `thenRn` \ rn_decl ->
+ lookupTyCon tc `thenRn` \ rn_tc ->
+ mapRn lookupValue dcs `thenRn` \ rn_dcs ->
+ mapRn lookupValue fcs `thenRn` \ rn_fcs ->
+ getImplicitUpRn `thenRn` \ mentioned ->
+ let
+ defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
+ implicits = mentioned `sub` defds
+ in
+ returnRn (AddedTy rn_decl, defds, implicits)
+
+rnIfaceDecl (ClassSig clas ops _ decl)
+ = rnClassDecl decl `thenRn` \ rn_decl ->
+ lookupClass clas `thenRn` \ rn_clas ->
+ mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops ->
+ getImplicitUpRn `thenRn` \ mentioned ->
+ let
+ defds = (ops `zip` rn_ops, [(clas, rn_clas)])
+ implicits = mentioned `sub` defds
+ in
+ returnRn (AddedClass rn_decl, defds, implicits)
+
+rnIfaceDecl (ValSig f src_loc ty)
+ -- should rename_sig in RnBinds be used here? ToDo
+ = lookupValue f `thenRn` \ rn_f ->
+ -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
+ rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty ->
+ getImplicitUpRn `thenRn` \ mentioned ->
+ let
+ defds = ([(f, rn_f)], [])
+ implicits = mentioned `sub` defds
+ in
+ returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
+
+----
+sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
+
+sub (val_ment, tc_ment) (val_defds, tc_defds)
+ = (delListFromFM val_ment (map fst val_defds),
+ delListFromFM tc_ment (map fst tc_defds))
+\end{code}
+
+% ------------------------------
+
+@cacheInstModules@: cache instance modules specified in imports
+
+\begin{code}
+cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
+cacheInstModules iface_cache imp_mods
+ = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) ->
+ let
+ imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
+ (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
+ get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
+ in
+ accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
+
+ -- Sanity Check:
+ -- Assert that instance modules given by direct imports contains
+ -- instance modules extracted from all visited modules
+
+ readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) ->
+ let
+ all_ifaces = eltsFM all_iface_fm
+ (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
+ in
+ ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
+
+ return (bag_errs err_or_ifaces)
+ where
+ bag_errs [] = emptyBag
+ bag_errs (Failed err :rest) = err `consBag` bag_errs rest
+ bag_errs (Succeeded _:rest) = bag_errs rest
+\end{code}
+
+
+@rnIfaceInstStuff@: Deal with instance declarations from interface files.
+
+\begin{code}
+type InstanceEnv = FiniteMap (RdrName, RdrName) Int
+
+rnIfaceInstStuff
+ :: IfaceCache -- all about ifaces we've read
+ -> Module