+import PprStyle ( PprStyle(..) )
+import Unique ( Unique )
+import Util ( pprPanic, pprTrace, Ord3(..) )
+import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer )
+import Outputable
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{Statistics}
+%* *
+%*********************************************************
+
+\begin{code}
+getRnStats :: [RenamedHsDecl] -> RnMG Doc
+getRnStats all_decls
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ n_mods = sizeFM mod_vers_map
+
+ decls_imported = filter is_imported_decl all_decls
+ decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
+ name == availName avail,
+ -- Data, newtype, and class decls are in the decls_fm
+ -- under multiple names; the tycon/class, and each
+ -- constructor/class op too.
+ not (isLocallyDefined name)
+ ]
+
+ (cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd, _) = count_decls decls_read
+ (cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported
+
+ inst_decls_unslurped = length (bagToList unslurped_insts)
+ inst_decls_read = id_sp + inst_decls_unslurped
+
+ stats = vcat
+ [int n_mods <> text " interfaces read",
+ hsep [int cd_sp, text "class decls imported, out of",
+ int cd_rd, text "read"],
+ hsep [int dd_sp, text "data decls imported (of which", int add_sp, text "abstractly), out of",
+ int dd_rd, text "read"],
+ hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), out of",
+ int nd_rd, text "read"],
+ hsep [int sd_sp, text "type synonym decls imported, out of",
+ int sd_rd, text "read"],
+ hsep [int vd_sp, text "value signatures imported, out of",
+ int vd_rd, text "read"],
+ hsep [int id_sp, text "instance decls imported, out of",
+ int inst_decls_read, text "read"]
+ ]
+ in
+ returnRn (hcat [text "Renamer stats: ", stats])
+
+is_imported_decl (DefD _) = False
+is_imported_decl (ValD _) = False
+is_imported_decl decl = not (isLocallyDefined (hsDeclName decl))
+
+count_decls decls
+ = -- pprTrace "count_decls" (ppr PprDebug decls
+ --
+ -- $$
+ -- text "========="
+ -- $$
+ -- ppr PprDebug imported_decls
+ -- ) $
+ (class_decls,
+ data_decls, abstract_data_decls,
+ newtype_decls, abstract_newtype_decls,
+ syn_decls,
+ val_decls,
+ inst_decls)
+ where
+ class_decls = length [() | ClD _ <- decls]
+ data_decls = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls]
+ newtype_decls = length [() | TyD (TyData NewType _ _ _ _ _ _ _) <- decls]
+ abstract_data_decls = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls]
+ abstract_newtype_decls = length [() | TyD (TyData NewType _ _ _ [] _ _ _) <- decls]
+ syn_decls = length [() | TyD (TySynonym _ _ _ _) <- decls]
+ val_decls = length [() | SigD _ <- decls]
+ inst_decls = length [() | InstD _ <- decls]
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Loading a new interface file}
+%* *
+%*********************************************************
+
+\begin{code}
+loadInterface :: Doc -> Module -> RnMG Ifaces
+loadInterface doc_str load_mod
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts deferred_data_decls inst_mods = ifaces
+ in
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ if maybeToBool (lookupFM export_envs load_mod)
+ then
+ returnRn ifaces -- Already in the cache; don't re-read it
+ else
+
+ -- READ THE MODULE IN
+ findAndReadIface doc_str load_mod `thenRn` \ read_result ->
+ case read_result of {
+ -- Check for not found
+ Nothing -> -- Not found, so add an empty export env to the Ifaces map
+ -- so that we don't look again
+ let
+ new_export_envs = addToFM export_envs load_mod ([],[])
+ new_ifaces = Ifaces this_mod mod_vers_map
+ new_export_envs
+ decls all_names imp_names insts deferred_data_decls inst_mods
+ in
+ setIfacesRn new_ifaces `thenRn_`
+ failWithRn new_ifaces (noIfaceErr load_mod) ;
+
+ -- Found and parsed!
+ Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
+
+ -- LOAD IT INTO Ifaces
+ mapRn loadExport exports `thenRn` \ avails_s ->
+ foldlRn (loadDecl load_mod) decls rd_decls `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
+ let
+ export_env = (concat avails_s, fixs)
+
+ -- Exclude this module from the "special-inst" modules
+ new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
+
+ new_ifaces = Ifaces this_mod
+ (addToFM mod_vers_map load_mod mod_vers)
+ (addToFM export_envs load_mod export_env)
+ new_decls
+ all_names imp_names
+ new_insts
+ deferred_data_decls
+ new_inst_mods
+ in
+ setIfacesRn new_ifaces `thenRn_`
+ returnRn new_ifaces
+ }
+
+loadExport :: ExportItem -> RnMG [AvailInfo]
+loadExport (mod, entities)
+ = mapRn load_entity entities
+ where
+ new_name occ = newGlobalName mod occ
+
+-- The communcation between this little code fragment and the "entity" rule
+-- in ParseIface.y is a bit gruesome. The idea is that things which are
+-- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas
+-- things destined to be Avails show up as (occ, [])
+
+ load_entity (occ, occs)
+ = new_name occ `thenRn` \ name ->
+ if null occs then
+ returnRn (Avail name)
+ else
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (AvailTC name names)
+
+loadDecl :: Module -> DeclsMap
+ -> (Version, RdrNameHsDecl)
+ -> RnMG DeclsMap
+loadDecl mod decls_map (version, decl)
+ = getDeclBinders new_implicit_name decl `thenRn` \ avail ->
+ returnRn (addListToFM decls_map
+ [(name,(version,avail,decl)) | name <- availNames avail]
+ )
+ where
+ new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
+
+loadInstDecl :: Module
+ -> Bag IfaceInst
+ -> RdrNameInstDecl
+ -> RnMG (Bag IfaceInst)
+loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
+ =
+ -- Find out what type constructors and classes are "gates" for the
+ -- instance declaration. If all these "gates" are slurped in then
+ -- we should slurp the instance decl too.
+ --
+ -- We *don't* want to count names in the context part as gates, though.
+ -- For example:
+ -- instance Foo a => Baz (T a) where ...
+ --
+ -- Here the gates are Baz and T, but *not* Foo.
+ let
+ munged_inst_ty = case inst_ty of
+ HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
+ HsPreForAllTy cxt ty -> HsPreForAllTy [] ty
+ other -> inst_ty
+ in
+ -- We find the gates by renaming the instance type with in a
+ -- and returning the occurrence pool.
+ initRnMS emptyRnEnv mod_name InterfaceMode (
+ findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)
+ ) `thenRn` \ gate_names ->
+ returnRn (((mod_name, decl), gate_names) `consBag` insts)
+\end{code}
+
+
+%********************************************************
+%* *
+\subsection{Loading usage information}
+%* *
+%********************************************************
+
+\begin{code}
+checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
+checkUpToDate mod_name
+ = findAndReadIface doc_str mod_name `thenRn` \ read_result ->
+ case read_result of
+ Nothing -> -- Old interface file not found, so we'd better bail out
+ traceRn (sep [ptext SLIT("Didnt find old iface"),
+ pprModule PprDebug mod_name]) `thenRn_`
+ returnRn False
+
+ Just (ParsedIface _ _ usages _ _ _ _ _)
+ -> -- Found it, so now check it
+ checkModUsage usages
+ where
+ -- Only look in current directory, with suffix .hi
+ doc_str = sep [ptext SLIT("Need usage info from"), pprModule PprDebug mod_name]
+
+checkModUsage [] = returnRn True -- Yes! Everything is up to date!
+
+checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
+ = loadInterface doc_str mod `thenRn` \ ifaces ->
+ let
+ Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
+ maybe_new_mod_vers = lookupFM mod_vers mod
+ Just new_mod_vers = maybe_new_mod_vers
+ in
+ -- If we can't find a version number for the old module then
+ -- bail out saying things aren't up to date
+ if not (maybeToBool maybe_new_mod_vers) then
+ returnRn False
+ else
+
+ -- If the module version hasn't changed, just move on
+ if new_mod_vers == old_mod_vers then
+ traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_`
+ checkModUsage rest
+ else
+ traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_`
+
+ -- New module version, so check entities inside
+ checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date ->
+ if up_to_date then
+ traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_`
+ checkModUsage rest -- This one's ok, so check the rest
+ else
+ returnRn False -- This one failed, so just bail out now
+ where
+ doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod]
+
+
+checkEntityUsage mod decls []
+ = returnRn True -- Yes! All up to date!
+
+checkEntityUsage mod decls ((occ_name,old_vers) : rest)
+ = newGlobalName mod occ_name `thenRn` \ name ->
+ case lookupFM decls name of
+
+ Nothing -> -- We used it before, but it ain't there now
+ traceRn (sep [ptext SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_`
+ returnRn False
+
+ Just (new_vers,_,_) -- It's there, but is it up to date?
+ | new_vers == old_vers
+ -- Up to date, so check the rest
+ -> checkEntityUsage mod decls rest
+
+ | otherwise
+ -- Out of date, so bale out
+ -> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_`
+ returnRn False
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Getting in a declaration}
+%* *
+%*********************************************************
+
+\begin{code}
+importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
+ -- Returns Nothing for a wired-in or already-slurped decl
+
+importDecl name necessity
+ = checkSlurped name `thenRn` \ already_slurped ->
+ if already_slurped then
+ -- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
+ returnRn Nothing -- Already dealt with
+ else
+ if isWiredInName name then
+ getWiredInDecl name
+ else
+ getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
+ (mod,_) = modAndOcc name
+ in
+ if mod == this_mod then -- Don't bring in decls from
+ pprTrace "importDecl wierdness:" (ppr PprDebug name) $
+ returnRn Nothing -- the renamed module's own interface file
+ --
+ else
+ getNonWiredInDecl name necessity
+\end{code}
+
+\begin{code}
+getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
+getNonWiredInDecl needed_name necessity
+ = traceRn doc_str `thenRn_`
+ loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
+ case lookupFM decls needed_name of
+
+ -- Special case for data/newtype type declarations
+ Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
+ -> getNonWiredDataDecl needed_name version avail ty_decl `thenRn` \ (avail', maybe_decl) ->
+ recordSlurp (Just version) avail' `thenRn_`
+ returnRn maybe_decl
+
+ Just (version,avail,decl)
+ -> recordSlurp (Just version) avail `thenRn_`
+ returnRn (Just decl)
+
+ Nothing -> -- Can happen legitimately for "Optional" occurrences
+ case necessity of {
+ Optional -> addWarnRn (getDeclWarn needed_name);
+ other -> addErrRn (getDeclErr needed_name)
+ } `thenRn_`
+ returnRn Nothing
+ where
+ doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name]
+ (mod,_) = modAndOcc needed_name
+
+ is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
+ is_data_or_newtype other = False
+\end{code}
+
+@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
+It behaves exactly as if the wired in decl were actually in an interface file.
+Specifically,
+
+ * if the wired-in name is a data type constructor or a data constructor,
+ it brings in the type constructor and all the data constructors; and
+ marks as "occurrences" any free vars of the data con.
+
+ * similarly for synonum type constructor
+
+ * if the wired-in name is another wired-in Id, it marks as "occurrences"
+ the free vars of the Id's type.
+
+ * it loads the interface file for the wired-in thing for the
+ sole purpose of making sure that its instance declarations are available
+
+All this is necessary so that we know all types that are "in play", so
+that we know just what instances to bring into scope.
+
+\begin{code}
+getWiredInDecl name
+ = get_wired `thenRn` \ avail ->
+ recordSlurp Nothing avail `thenRn_`
+
+ -- Force in the home module in case it has instance decls for
+ -- the thing we are interested in.
+ --
+ -- Mini hack 1: no point for non-tycons/class; and if we
+ -- do this we find PrelNum trying to import PackedString,
+ -- because PrelBase's .hi file mentions PackedString.unpackString
+ -- But PackedString.hi isn't built by that point!
+ --
+ -- Mini hack 2; GHC is guaranteed not to have
+ -- instance decls, so it's a waste of time to read it
+ --
+ -- NB: We *must* look at the availName of the slurped avail,
+ -- not the name passed to getWiredInDecl! Why? Because if a data constructor
+ -- or class op is passed to getWiredInDecl we'll pull in the whole data/class
+ -- decl, and recordSlurp will record that fact. But since the data constructor
+ -- isn't a tycon/class we won't force in the home module. And even if the
+ -- type constructor/class comes along later, loadDecl will say that it's already
+ -- been slurped, so getWiredInDecl won't even be called. Pretty obscure bug, this was.
+ let
+ main_name = availName avail
+ main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
+ (mod,_) = modAndOcc main_name
+ doc_str = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
+ in
+ (if not main_is_tc || mod == gHC__ then
+ returnRn ()
+ else
+ loadInterface doc_str mod `thenRn_`
+ returnRn ()
+ ) `thenRn_`
+
+ returnRn Nothing -- No declaration to process further
+ where
+
+ get_wired | is_tycon -- ... a type constructor
+ = get_wired_tycon the_tycon
+
+ | (isDataCon the_id) -- ... a wired-in data constructor
+ = get_wired_tycon (dataConTyCon the_id)
+
+ | otherwise -- ... a wired-in non data-constructor
+ = get_wired_id the_id
+
+ maybe_wired_in_tycon = maybeWiredInTyConName name
+ is_tycon = maybeToBool maybe_wired_in_tycon
+ maybe_wired_in_id = maybeWiredInIdName name
+ Just the_tycon = maybe_wired_in_tycon
+ Just the_id = maybe_wired_in_id