+interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
+\end{code}
+
+
+\begin{code}
+getRules :: [IdCoreRule] -- Orphan rules
+ -> [CoreBind] -- Bindings, with rules in the top-level Ids
+ -> IdSet -- Ids that are exported, so we need their rules
+ -> [IdCoreRule]
+getRules orphan_rules binds emitted
+ = orphan_rules ++ local_rules
+ where
+ local_rules = [ (fn, rule)
+ | fn <- bindersOfBinds binds,
+ fn `elemVarSet` emitted,
+ rule <- rulesRules (idSpecialisation fn),
+ not (isBuiltinRule rule),
+ -- We can't print builtin rules in interface files
+ -- Since they are built in, an importing module
+ -- will have access to them anyway
+
+ -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
+ -- from coming out, and to make it work properly we need to add ????
+ -- (put it back in for now)
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+ -- Spit out a rule only if all its lhs free vars are emitted
+ -- This is a good reason not to do it when we emit the Id itself
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Checking if the new interface is up to date
+%* *
+%************************************************************************
+
+\begin{code}
+addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
+ -> ModIface -- The new interface decls
+ -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface
+ -- Just mi => Here is the new interface to write
+ -- with correct version numbers
+
+-- NB: the fixities, declarations, rules are all assumed
+-- to be sorted by increasing order of hsDeclName, so that
+-- we can compare for equality
+
+addVersionInfo Nothing new_iface
+-- No old interface, so definitely write a new one!
+ = (new_iface, Just (text "No old interface available"))
+
+addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
+ mi_decls = old_decls,
+ mi_fixities = old_fixities }))
+ new_iface@(ModIface { mi_decls = new_decls,
+ mi_fixities = new_fixities })
+
+ | no_output_change && no_usage_change
+ = (old_iface, Nothing)
+
+ | otherwise -- Add updated version numbers
+ = (final_iface, Just pp_tc_diffs)
+
+ where
+ final_iface = new_iface { mi_version = new_version }
+ new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
+ vers_exports = bumpVersion no_export_change (vers_exports old_version),
+ vers_rules = bumpVersion no_rule_change (vers_rules old_version),
+ vers_decls = tc_vers }
+
+ no_output_change = no_tc_change && no_rule_change && no_export_change
+ no_usage_change = mi_usages old_iface == mi_usages new_iface
+
+ no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
+ no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
+
+ -- Fill in the version number on the new declarations by looking at the old declarations.
+ -- Set the flag if anything changes.
+ -- Assumes that the decls are sorted by hsDeclName.
+ old_vers_decls = vers_decls old_version
+ (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
+ (dcl_tycl old_decls) (dcl_tycl new_decls)
+
+
+
+diffDecls :: NameEnv Version -- Old version map
+ -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
+ -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
+ -> (Bool, -- True <=> no change
+ SDoc, -- Record of differences
+ NameEnv Version) -- New version
+
+diffDecls old_vers old_fixities new_fixities old new
+ = diff True empty emptyNameEnv old new
+ where
+ -- When seeing if two decls are the same,
+ -- remember to check whether any relevant fixity has changed
+ eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
+ same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
+
+ diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
+ diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
+ diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
+ diff ok_so_far pp new_vers (od:ods) (nd:nds)
+ = case od_name `compare` nd_name of
+ LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
+ GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
+ EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
+ | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
+ where
+ od_name = tyClDeclName od
+ nd_name = tyClDeclName nd
+ new_vers' = extendNameEnv new_vers nd_name
+ (bumpVersion True (lookupNameEnv_NF old_vers od_name))
+
+ only_old d = ptext SLIT("Only in old iface:") <+> ppr d
+ only_new d = ptext SLIT("Only in new iface:") <+> ppr d
+ changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
+ (ptext SLIT("New:") <+> ppr nd))
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Writing an interface file}
+%* *
+%************************************************************************
+
+\begin{code}
+writeIface :: FilePath -> ModIface -> IO ()
+writeIface hi_path mod_iface
+ = do { if_hdl <- openFile hi_path WriteMode
+ ; printForIface if_hdl (pprIface mod_iface)
+ ; hClose if_hdl
+ }
+
+pprIface :: ModIface -> SDoc
+pprIface iface
+ = vcat [ ptext SLIT("__interface")
+ <+> doubleQuotes (ptext opt_InPackage)
+ <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
+ <+> pp_sub_vers
+ <+> (if mi_orphan iface then char '!' else empty)
+ <+> int opt_HiVersion
+ <+> ptext SLIT("where")
+
+ , vcat (map pprExport (mi_exports iface))
+ , vcat (map pprUsage (mi_usages iface))
+
+ , pprFixities (mi_fixities iface) (dcl_tycl decls)
+ , pprIfaceDecls (vers_decls version_info) decls
+ , pprDeprecs (mi_deprecs iface)
+ ]
+ where
+ version_info = mi_version iface
+ decls = mi_decls iface
+ exp_vers = vers_exports version_info
+ rule_vers = vers_rules version_info
+
+ pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
+ | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
+\end{code}
+
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+
+\begin{code}
+pprExport :: (ModuleName, Avails) -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
+ where
+ pp_avail :: AvailInfo -> SDoc
+ pp_avail (Avail name) = pprOcc name
+ pp_avail (AvailTC n []) = empty
+ pp_avail (AvailTC n (n':ns)) | n==n' = pprOcc n <> pp_export ns
+ | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)