- idinfo = get_idinfo id
- inline_pragma = inlinePragInfo idinfo
-
- ty_pretty = pprType (idType id)
- sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
-
- prag_pretty
- | opt_OmitInterfacePragmas = empty
- | otherwise = hsep [ptext SLIT("{-##"),
- arity_pretty,
- caf_pretty,
- cpr_pretty,
- strict_pretty,
- unfold_pretty,
- spec_pretty,
- ptext SLIT("##-}")]
-
- ------------ Arity --------------
- arity_pretty = ppArityInfo (arityInfo idinfo)
-
- ------------ Caf Info --------------
- caf_pretty = ppCafInfo (cafInfo idinfo)
-
- ------------ CPR Info --------------
- cpr_pretty = ppCprInfo (cprInfo idinfo)
-
- ------------ Strictness and Worker --------------
- strict_info = strictnessInfo idinfo
- work_info = workerInfo idinfo
- has_worker = workerExists work_info
- bottoming_fn = isBottomingStrictness strict_info
- strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
-
- wrkr_pretty | not has_worker = empty
- | null con_list = ppr work_id
- | otherwise = ppr work_id <+>
- braces (hsep (map ppr con_list))
-
--- (Just work_id) = work_info
--- Temporary fix. We can't use the worker id saved by the w/w
--- pass because later optimisations may have changed it. So try
--- to snaffle from the wrapper code again ...
- (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
- con_list = uniqSetToList wrapper_cons
-
- ------------ Unfolding --------------
- unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
- | otherwise = empty
-
- show_unfold = not has_worker && -- Not unnecessary
- not bottoming_fn && -- Not necessary
- unfolding_needed -- Not dangerous
-
- unfolding_needed = case inline_pragma of
- IMustBeINLINEd -> definitely_ok_to_unfold
- IWantToBeINLINEd -> definitely_ok_to_unfold
- NoInlinePragInfo -> rhs_is_small
- other -> False
-
-
- unfold_herald = case inline_pragma of
- NoInlinePragInfo -> ptext SLIT("__u")
- other -> ppr inline_pragma
-
- rhs_is_small = case calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs of
- UnfoldNever -> False -- Too big
- other -> definitely_ok_to_unfold -- Small enough
-
- definitely_ok_to_unfold = okToUnfoldInHiFile rhs
-
- ------------ Specialisations --------------
- spec_list = specEnvToList (getIdSpecialisation id)
- spec_pretty = hsep (map pp_spec spec_list)
- pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
- if null tyvars then ptext SLIT("[ ]")
- else brackets (interppSP tyvars),
- -- The lexer interprets "[]" as a CONID. Sigh.
- hsep (map pprParendType tys),
- ptext SLIT("="),
- pprIfaceUnfolding rhs
- ]
-
- ------------ Extra free Ids --------------
- new_needed_ids = (needed_ids `minusVarSet` unitVarSet id) `unionVarSet`
- extra_ids
-
- extra_ids | opt_OmitInterfacePragmas = emptyVarSet
- | otherwise = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
- spec_ids
-
- worker_ids | has_worker && interesting work_id = unitVarSet work_id
- -- Conceivably, the worker might come from
- -- another module
- | otherwise = emptyVarSet
-
- spec_ids = foldr add emptyVarSet spec_list
- where
- add (_, _, rhs) = unionVarSet (find_fvs rhs)
-
- unfold_ids | show_unfold = find_fvs rhs
- | otherwise = emptyVarSet
-
- find_fvs expr = free_vars
- where
- free_vars = exprSomeFreeVars interesting expr
-
- interesting id = isId id && isLocallyDefined id &&
- not (omitIfaceSigForId id)
-\end{code}
-
-\begin{code}
-ifaceBinds :: Handle
- -> IdSet -- These Ids are needed already
- -> [Id] -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBind] -- In dependency order, later depend on earlier
- -> IO ()
-
-ifaceBinds hdl needed_ids final_ids binds
- = mapIO (printForIface hdl) pretties >>
- hPutStr hdl "\n"
+ 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_deprec_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
+ no_deprec_change = old_deprecs == new_deprecs
+
+ -- 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)
+ pp_diffs = vcat [pp_tc_diffs,
+ pp_change no_export_change "Export list",
+ pp_change no_rule_change "Rules",
+ pp_change no_deprec_change "Deprecations",
+ pp_change no_usage_change "Usages"]
+ pp_change True what = empty
+ pp_change False what = text what <+> ptext SLIT("changed")
+
+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