MkIface.lhs 25.8 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 4 5 6
%
\section[MkIface]{Print an interface for a module}

\begin{code}
7
module MkIface ( 
8 9
	mkModDetails, mkModDetailsFromIface, completeIface, 
	writeIface, pprIface
10
  ) where
11

12 13
#include "HsVersions.h"

14
import HsSyn
15
import HsCore		( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
16
import HsTypes		( toHsTyVars )
17
import BasicTypes	( Fixity(..), NewOrData(..),
18
			  Version, initialVersion, bumpVersion, isLoopBreaker
19
			)
20
import RnMonad
21 22
import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl )
import TcHsSyn		( TypecheckedRuleDecl )
23 24
import HscTypes		( VersionInfo(..), ModIface(..), ModDetails(..),
			  IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
25
			  TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
26
			  WhatsImported(..), GenAvailInfo(..), 
27
			  ImportVersion, AvailInfo, Deprecations(..)
28
			)
29 30

import CmdLineOpts
31
import Id		( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
32
			  idSpecialisation, idName, setIdInfo
33
			)
34
import Var		( isId )
35
import VarSet
36
import DataCon		( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
37 38 39 40
import IdInfo		-- Lots
import CoreSyn		( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, 
			  isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
			  bindersOfBinds
41
			)
42
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
43 44
import CoreUnfold	( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
import Name		( isLocallyDefined, getName, 
45
			  Name, NamedThing(..)
46
			)
47
import Name 	-- Env
48
import OccName		( pprOccName )
49
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
50
			  tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
51
			)
52
import Class		( classExtraBigSig, DefMeth(..) )
53
import FieldLabel	( fieldLabelType )
54
import Type		( splitSigmaTy, tidyTopType, deNoteType )
55
import SrcLoc		( noSrcLoc )
56
import Outputable
57
import Module		( ModuleName )
58

59
import List		( partition )
60
import IO		( IOMode(..), openFile, hClose )
61 62 63
\end{code}


64 65 66 67 68
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
69

70
\begin{code}
71 72 73 74 75 76 77 78 79
mkModDetails :: TypeEnv -> [DFunId]	-- From typechecker
	     -> [CoreBind] -> [Id]	-- Final bindings, plus the top-level Ids from the
					-- code generator; they have authoritative arity info
	     -> [IdCoreRule]		-- Tidy orphan rules
	     -> ModDetails
mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
  = ModDetails { md_types = new_type_env,
		 md_rules = rule_dcls,
		 md_insts = dfun_ids }
80
  where
81 82 83 84
	-- The competed type environment is gotten from
	-- 	a) keeping the types and classes
	--	b) removing all Ids, and Ids with correct IdInfo
	--		gotten from the bindings
85 86 87 88 89 90 91 92
	-- From (b) we keep only those Ids with Global names, plus Ids
	--	    accessible from them (notably via unfoldings)
	-- This truncates the type environment to include only the 
	-- exported Ids and things needed from them, which saves space
	--
	-- However, we do keep things like constructors, which should not appear 
	-- in interface files, because they are needed by importing modules when
	-- using the compilation manager
93 94 95 96 97 98
    new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
			`plusNameEnv`
		   mkNameEnv [(idName id, AnId id) | id <- final_ids]

    orig_type_env = nameEnvElts type_env

99 100 101 102
    final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
			   (mkVarSet stg_ids)
			   tidy_binds

103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
	-- The complete rules are gotten by combining
	--	a) the orphan rules
	--	b) rules embedded in the top-level Ids
    rule_dcls | opt_OmitInterfacePragmas = []
	      | otherwise		  = getRules orphan_rules tidy_binds (mkVarSet final_ids)

    orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
				   | (_, rule) <- orphan_rules]


-- This version is used when we are re-linking a module
-- so we've only run the type checker on its previous interface 
mkModDetailsFromIface :: TypeEnv -> [DFunId]	-- From typechecker
		      -> [TypecheckedRuleDecl]
		      -> ModDetails
mkModDetailsFromIface type_env dfun_ids rules
  = ModDetails { md_types = type_env,
		 md_rules = rule_dcls,
		 md_insts = dfun_ids }
  where
    rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
	-- All the rules from an interface are of the IfaceRuleOut form
125

126

127 128 129
completeIface :: Maybe ModIface		-- The old interface, if we have it
	      -> ModIface		-- The new one, minus the decls and versions
	      -> ModDetails		-- The ModDetails for this module
130
	      -> (ModIface, Maybe SDoc)	-- The new one, complete with decls and versions
131 132
					-- The SDoc is a debug document giving differences
					-- Nothing => no change
133

134 135 136 137
	-- NB: 'Nothing' means that even the usages havn't changed, so there's no
	--     need to write a new interface file.  But even if the usages have
	--     changed, the module version may not have.
completeIface maybe_old_iface new_iface mod_details 
138 139
  = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
  where
140
     new_decls   = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
141
     inst_dcls   = map ifaceInstance (md_insts mod_details)
142
     ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
143
     rule_dcls   = map ifaceRule (md_rules mod_details)
144 145
\end{code}

146

147 148
%************************************************************************
%*				 					*
149
\subsection{Types and classes}
150 151
%*				 					*
%************************************************************************
152

153
\begin{code}
154 155 156
ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
ifaceTyCls (AClass clas) so_far
  = cls_decl : so_far
157
  where
158 159 160 161 162 163 164
    cls_decl = ClassDecl (toHsContext sc_theta)
			 (getName clas)		 
			 (toHsTyVars clas_tyvars)
			 (toHsFDs clas_fds)
			 (map toClassOpSig op_stuff)
			 EmptyMonoBinds
			 [] noSrcLoc
165

166 167 168
    (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas

    toClassOpSig (sel_id, def_meth)
169 170 171 172 173 174 175 176
	= ASSERT(sel_tyvars == clas_tyvars)
	  ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
	  def_meth' = case def_meth of
			 NoDefMeth  -> NoDefMeth
			 GenDefMeth -> GenDefMeth
			 DefMeth id -> DefMeth (getName id)
177

178 179 180
ifaceTyCls (ATyCon tycon) so_far
  = ty_decl : so_far
  
181
  where
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
    ty_decl | isSynTyCon tycon
	    = TySynonym (getName tycon)(toHsTyVars tyvars) 
			(toHsType syn_ty) noSrcLoc

	    | isAlgTyCon tycon
	    = TyData new_or_data (toHsContext (tyConTheta tycon))
		     (getName tycon)      
		     (toHsTyVars tyvars)
		     (map ifaceConDecl (tyConDataCons tycon))
		     (tyConFamilySize tycon)
		     Nothing noSrcLoc (panic "gen1") (panic "gen2")

	    | otherwise = pprPanic "ifaceTyCls" (ppr tycon)

    tyvars      = tyConTyVars tycon
    (_, syn_ty) = getSynTyConDefn tycon
198 199
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType
200

201 202 203 204 205 206 207 208 209 210 211 212
    ifaceConDecl data_con 
	= ConDecl (getName data_con) (error "ifaceConDecl")
		  (toHsTyVars ex_tyvars)
		  (toHsContext ex_theta)
		  details noSrcLoc
	where
	  (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
          field_labels   = dataConFieldLabels data_con
          strict_marks   = dataConStrictMarks data_con
	  details | null field_labels
	    	  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	    	    VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
213

214 215
    	    	  | otherwise
	    	  = RecCon (zipWith mk_field strict_marks field_labels)
216

217 218 219
    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
220

221 222 223
    mk_field strict_mark field_label
	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))

224 225 226
ifaceTyCls (AnId id) so_far
  | omitIfaceSigForId id = so_far
  | otherwise 		 = iface_sig : so_far
227
  where
228 229
    iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc

230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
    id_type = idType id
    id_info = idInfo id

    hs_idinfo | opt_OmitInterfacePragmas = []
 	      | otherwise		 = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
					   strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo

    ------------  Arity  --------------
    arity_hsinfo = case arityInfo id_info of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []

    ------------ Caf Info --------------
    caf_hsinfo = case cafInfo id_info of
		   NoCafRefs -> [HsNoCafRefs]
		   otherwise -> []

    ------------ CPR Info --------------
    cpr_hsinfo = case cprInfo id_info of
		   ReturnsCPR -> [HsCprInfo]
		   NoCPRInfo  -> []

    ------------  Strictness  --------------
    strict_hsinfo = case strictnessInfo id_info of
			NoStrictnessInfo -> []
			info		 -> [HsStrictness info]


    ------------  Worker  --------------
259
    wrkr_hsinfo = case workerInfo id_info of
260 261 262 263
		    HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
		    NoWorker			 -> []

    ------------  Unfolding  --------------
264 265 266
    unfold_info = unfoldingInfo id_info
    inline_prag = inlinePragInfo id_info
    rhs		= unfoldingTemplate unfold_info
267 268
    unfold_hsinfo | neverUnfold unfold_info = []
		  | otherwise		    = [HsUnfold inline_prag (toUfExpr rhs)]
269 270 271 272 273
\end{code}


%************************************************************************
%*				 					*
274
\subsection{Instances and rules}
275 276 277
%*				 					*
%************************************************************************

278
\begin{code}
279 280 281
ifaceInstance :: DFunId -> RenamedInstDecl
ifaceInstance dfun_id
  = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc			 
282
  where
283 284 285 286 287 288 289 290 291 292
    tidy_ty = tidyTopType (deNoteType (idType dfun_id))
		-- The deNoteType is very important.   It removes all type
		-- synonyms from the instance type in interface files.
		-- That in turn makes sure that when reading in instance decls
		-- from interface files that the 'gating' mechanism works properly.
		-- Otherwise you could have
		--	type Tibble = T Int
		--	instance Foo Tibble where ...
		-- and this instance decl wouldn't get imported into a module
		-- that mentioned T but not Tibble.
293

294 295
ifaceRule (id, BuiltinRule _)
  = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
296

297 298 299 300 301 302
ifaceRule (id, Rule name bndrs args rhs)
  = IfaceRule name (map toUfBndr bndrs) (getName id)
	      (map toUfExpr args) (toUfExpr rhs) noSrcLoc

bogusIfaceRule id
  = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
303
\end{code}
304 305 306 307


%************************************************************************
%*				 					*
308
\subsection{Compute final Ids}
309
%*				 					* 
310 311
%************************************************************************

312 313 314
A "final Id" has exactly the IdInfo for going into an interface file, or
exporting to another module.

315
\begin{code}
316 317
bindsToIds :: IdSet		-- These Ids are needed already
	   -> IdSet		-- Ids used at code-gen time; they have better pragma info!
318
	   -> [CoreBind]	-- In dependency order, later depend on earlier
319 320
	   -> [Id]		-- Set of Ids actually spat out, complete with exactly the IdInfo
				-- they need for exporting to another module
321

322 323
bindsToIds needed_ids codegen_ids binds
  = go needed_ids (reverse binds) []
324 325 326
		-- Reverse so that later things will 
		-- provoke earlier ones to be emitted
  where
327 328 329 330 331
	-- The 'needed' set contains the Ids that are needed by earlier
	-- interface file emissions.  If the Id isn't in this set, and isn't
	-- exported, there's no need to emit anything
    need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id 

332
    go needed [] emitted
333 334
	| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
					  (sep (map ppr (varSetElems needed)))
335 336
				       emitted
	| otherwise 		     = emitted
337

338
    go needed (NonRec id rhs : binds) emitted
339 340
	| need_id needed id = go new_needed binds (new_id:emitted)
	| otherwise	    = go needed     binds emitted
341
	where
342
	  (new_id, extras) = mkFinalId codegen_ids False id rhs
343
	  new_needed       = (needed `unionVarSet` extras) `delVarSet` id
344 345 346

	-- Recursive groups are a bit more of a pain.  We may only need one to
	-- start with, but it may call out the next one, and so on.  So we
347 348 349
	-- have to look for a fixed point.  We don't want necessarily them all, 
	-- because without -O we may only need the first one (if we don't emit
	-- its unfolding)
350
    go needed (Rec pairs : binds) emitted
351
	= go needed' binds emitted' 
352
	where
353
	  (new_emitted, extras) = go_rec needed pairs
354
	  needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
355
	  emitted' = new_emitted ++ emitted 
356

357
    go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
358
    go_rec needed pairs
359 360 361
	| null needed_prs = ([], emptyVarSet)
	| otherwise 	  = (emitted ++           more_emitted,
			     extras `unionVarSet` more_extras)
362
	where
363 364 365 366 367 368
	  (needed_prs,leftover_prs)   = partition is_needed pairs
	  (emitted, extras_s)         = unzip [ mkFinalId codegen_ids True id rhs 
				    	      | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
	  extras	              = unionVarSets extras_s
	  (more_emitted, more_extras) = go_rec extras leftover_prs

369
	  is_needed (id,_) = need_id needed id
370 371 372
\end{code}


373

374
\begin{code}
375
mkFinalId :: IdSet		-- The Ids with arity info from the code generator
376
	  -> Bool		-- True <=> recursive, so don't include unfolding
377 378
	  -> Id
	  -> CoreExpr		-- The Id's right hand side
379
	  -> (Id, IdSet)	-- The emitted id, plus any *extra* needed Ids
380 381

mkFinalId codegen_ids is_rec id rhs
382 383 384
  | omitIfaceSigForId id 
  = (id, emptyVarSet)		-- An optimisation for top-level constructors and suchlike
  | otherwise
385
  = (id `setIdInfo` new_idinfo, new_needed_ids)
386
  where
387
    core_idinfo = idInfo id
388 389 390 391
    stg_idinfo  = case lookupVarSet codegen_ids id of
			Just id' -> idInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
				    idInfo id
392

393 394 395
    new_idinfo | opt_OmitInterfacePragmas
	       = vanillaIdInfo
 	       | otherwise		  
396
	       = core_idinfo `setArityInfo` 	 arity_info
397 398 399 400 401 402
			     `setCafInfo`   	 cafInfo stg_idinfo
			     `setUnfoldingInfo`	 unfold_info
			     `setWorkerInfo`	 worker_info
			     `setSpecInfo`	 emptyCoreRules
	-- We zap the specialisations because they are
	-- passed on separately through the modules IdCoreRules
403 404

    ------------  Arity  --------------
405 406
    arity_info = arityInfo stg_idinfo
    stg_arity  = arityLowerBound arity_info
sof's avatar
sof committed
407

408
    ------------  Worker  --------------
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
	-- We only treat a function as having a worker if
	-- the exported arity (which is now the number of visible lambdas)
	-- is the same as the arity at the moment of the w/w split
	-- If so, we can safely omit the unfolding inside the wrapper, and
	-- instead re-generate it from the type/arity/strictness info
	-- But if the arity has changed, we just take the simple path and
	-- put the unfolding into the interface file, forgetting the fact
	-- that it's a wrapper.  
	--
	-- How can this happen?  Sometimes we get
	--	f = coerce t (\x y -> $wf x y)
	-- at the moment of w/w split; but the eta reducer turns it into
	--	f = coerce t $wf
	-- which is perfectly fine except that the exposed arity so far as
	-- the code generator is concerned (zero) differs from the arity
	-- when we did the split (2).  
	--
	-- All this arises because we use 'arity' to mean "exactly how many
	-- top level lambdas are there" in interface files; but during the
	-- compilation of this module it means "how many things can I apply
	-- this to".
430
    worker_info = case workerInfo core_idinfo of
431 432
		     info@(HasWorker work_id wrap_arity)
			| wrap_arity == stg_arity -> info
433 434 435
			| otherwise	          -> pprTrace "ifaceId: arity change:" (ppr id) 
						     NoWorker
		     NoWorker		          -> NoWorker
436

437 438 439
    has_worker = case worker_info of
		   HasWorker _ _ -> True
		   other	 -> False
440

441
    HasWorker work_id _ = worker_info
442

443
    ------------  Unfolding  --------------
444
    inline_pragma  = inlinePragInfo core_idinfo
445
    dont_inline	   = isNeverInlinePrag inline_pragma
446 447
    loop_breaker   = isLoopBreaker (occInfo core_idinfo)
    bottoming_fn   = isBottomingStrictness (strictnessInfo core_idinfo)
448

449 450 451 452 453
    unfolding    = mkTopUnfolding rhs
    rhs_is_small = neverUnfold unfolding

    unfold_info | show_unfold = unfolding
		| otherwise   = noUnfolding
454

455 456 457
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
458
		  not loop_breaker	 &&
459 460
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
461

462

463
    ------------  Extra free Ids  --------------
464 465 466 467
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
468

469 470
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))

471
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
472 473
			-- Conceivably, the worker might come from
			-- another module
474
	       | otherwise = emptyVarSet
475

476
    unfold_ids | show_unfold = find_fvs rhs
477
	       | otherwise   = emptyVarSet
478

479
    find_fvs expr = exprSomeFreeVars interestingId expr
480

481
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
482 483
\end{code}

484

485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
\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}


512 513 514 515 516 517 518 519 520
%************************************************************************
%*				 					*
\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
521
	       -> (ModIface, Maybe SDoc)	-- Nothing => no change; no need to write new Iface
522 523 524 525 526 527 528 529 530
						-- 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!
531
  = (new_iface, Just (text "No old interface available"))
532 533 534 535 536 537 538 539

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
540
  = (old_iface, Nothing)
541 542

  | otherwise		-- Add updated version numbers
543
  = (final_iface, Just pp_tc_diffs)
544 545 546 547 548 549
	
  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),
550
				vers_decls   = tc_vers }
551

552
    no_output_change = no_tc_change && no_rule_change && no_export_change
553 554 555 556 557 558 559 560 561
    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
562 563
    (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
						       (dcl_tycl old_decls) (dcl_tycl new_decls)
564 565 566



567
diffDecls :: NameEnv Version				-- Old version map
568
	  -> NameEnv Fixity -> NameEnv Fixity		-- Old and new fixities
569
	  -> [RenamedTyClDecl] -> [RenamedTyClDecl]	-- Old and new decls
570 571 572 573
	  -> (Bool,		-- True <=> no change
	      SDoc,		-- Record of differences
	      NameEnv Version)	-- New version

574
diffDecls old_vers old_fixities new_fixities old new
575 576
  = diff True empty emptyNameEnv old new
  where
577 578 579 580 581
	-- 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

582 583 584 585
    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)
586
	= case nameOccName od_name `compare` nameOccName nd_name of
587 588
		LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
		GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
589 590
		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
591
	where
592 593
 	  od_name = tyClDeclName od
 	  nd_name = tyClDeclName nd
594 595 596 597 598 599 600 601
	  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}
602 603 604 605 606 607 608 609 610 611



%************************************************************************
%*				 					*
\subsection{Writing an interface file}
%*				 					*
%************************************************************************

\begin{code}
612 613
writeIface :: FilePath -> ModIface -> IO ()
writeIface hi_path mod_iface
614
  = do	{ if_hdl <- openFile hi_path WriteMode
615 616
	; printForIface if_hdl (pprIface mod_iface)
	; hClose if_hdl
617
	}
618
	 
619
pprIface :: ModIface -> SDoc
620 621 622 623 624 625 626 627 628
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")

629
	, vcat (map pprExport (mi_exports iface))
630 631
	, vcat (map pprUsage (mi_usages iface))

632 633
	, pprFixities (mi_fixities iface) (dcl_tycl decls)
	, pprIfaceDecls (vers_decls version_info) decls
634 635 636
	, pprDeprecs (mi_deprecs iface)
	]
  where
637
    version_info = mi_version iface
638
    decls	 = mi_decls iface
639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
    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)
654
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
655
  where
656
    pp_avail :: AvailInfo -> SDoc
657 658 659 660
    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)
661 662
    
    pp_export []    = empty
663 664 665 666
    pp_export names = braces (hsep (map pprOcc names))

pprOcc :: Name -> SDoc	-- Print the occurrence name only
pprOcc n = pprOccName (nameOccName n)
667 668 669 670 671 672
\end{code}


\begin{code}
pprUsage :: ImportVersion Name -> SDoc
pprUsage (m, has_orphans, is_boot, whats_imported)
673
  = hsep [ptext SLIT("import"), ppr m, 
674 675 676 677 678 679 680 681 682 683 684 685 686
	  pp_orphan, pp_boot,
	  pp_versions whats_imported
    ] <> semi
  where
    pp_orphan | has_orphans = char '!'
	      | otherwise   = empty
    pp_boot   | is_boot     = char '@'
              | otherwise   = empty

	-- Importing the whole module is indicated by an empty list
    pp_versions NothingAtAll   		    = empty
    pp_versions (Everything v) 		    = dcolon <+> int v
    pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr 
687
					      <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
688 689 690 691 692 693 694 695

	-- HACK for the moment: print the export-list version even if
	-- we don't use it, so that syntax of interface files doesn't change
    pp_export_version Nothing  = int 1
    pp_export_version (Just v) = int v
\end{code}

\begin{code}
696
pprIfaceDecls version_map decls
697 698 699 700 701
  = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
	 , vcat (map ppr_decl (dcl_tycl decls))
	 , pprRules (dcl_rules decls)
	 ]
  where
702
    ppr_decl d  = ppr_vers d <+> ppr d <> semi
703 704 705 706 707 708 709 710

	-- Print the version for the decl
    ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
		   Nothing -> empty
		   Just v  -> int v
\end{code}

\begin{code}
711 712 713 714 715 716
pprFixities fixity_map decls
  = hsep [ ppr fix <+> ppr n 
	 | d <- decls, 
	   (n,_) <- tyClDeclNames d, 
	   Just fix <- [lookupNameEnv fixity_map n]] <> semi

717 718 719
pprRules []    = empty
pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]

720 721 722 723 724 725 726 727 728
pprDeprecs NoDeprecs = empty
pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
		     where
		       guts = case deprecs of
				DeprecAll txt  -> ptext txt
				DeprecSome env -> pp_deprecs env

pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
	       where
729
		 pp_deprec (name, txt) = pprOcc name <+> ptext txt
730
\end{code}