[project @ 2000-12-19 13:06:50 by simonmar]
[ghc-hetmet.git] / ghc / compiler / main / MkIface.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[MkIface]{Print an interface for a module}
5
6 \begin{code}
7 module MkIface ( 
8         mkModDetails, mkModDetailsFromIface, completeIface, 
9         writeIface, pprIface
10   ) where
11
12 #include "HsVersions.h"
13
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 import RnHsSyn          ( RenamedInstDecl, RenamedTyClDecl )
22 import TcHsSyn          ( TypecheckedRuleDecl )
23 import HscTypes         ( VersionInfo(..), ModIface(..), ModDetails(..),
24                           IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
25                           TyThing(..), DFunId, TypeEnv, Avails,
26                           WhatsImported(..), GenAvailInfo(..), 
27                           ImportVersion, AvailInfo, Deprecations(..),
28                           extendTypeEnvList
29                         )
30
31 import CmdLineOpts
32 import Id               ( Id, idType, idInfo, isImplicitId, isDictFunId,
33                           idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
34                         )
35 import Var              ( isId )
36 import VarSet
37 import DataCon          ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
38 import IdInfo           -- Lots
39 import CoreSyn          ( CoreBind, CoreRule(..), IdCoreRule, 
40                           isBuiltinRule, rulesRules, 
41                           bindersOf, bindersOfBinds
42                         )
43 import CoreFVs          ( ruleSomeLhsFreeVars )
44 import CoreUnfold       ( neverUnfold, unfoldingTemplate )
45 import Name             ( getName, nameModule, Name, NamedThing(..) )
46 import Name     -- Env
47 import OccName          ( pprOccName )
48 import TyCon            ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
49                           tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
50                         )
51 import Class            ( classExtraBigSig, classTyCon, DefMeth(..) )
52 import FieldLabel       ( fieldLabelType )
53 import Type             ( splitSigmaTy, tidyTopType, deNoteType )
54 import SrcLoc           ( noSrcLoc )
55 import Outputable
56 import Module           ( ModuleName )
57
58 import IO               ( IOMode(..), openFile, hClose )
59 \end{code}
60
61
62 %************************************************************************
63 %*                                                                      *
64 \subsection{Write a new interface file}
65 %*                                                                      *
66 %************************************************************************
67
68 \begin{code}
69 mkModDetails :: TypeEnv         -- From typechecker
70              -> [CoreBind]      -- Final bindings
71                                 -- they have authoritative arity info
72              -> [IdCoreRule]    -- Tidy orphan rules
73              -> ModDetails
74 mkModDetails type_env tidy_binds orphan_rules
75   = ModDetails { md_types = new_type_env,
76                  md_rules = rule_dcls,
77                  md_insts = filter isDictFunId final_ids }
78   where
79         -- The competed type environment is gotten from
80         --      a) keeping the types and classes
81         --      b) removing all Ids, 
82         --      c) adding Ids with correct IdInfo, including unfoldings,
83         --              gotten from the bindings
84         -- From (c) we keep only those Ids with Global names;
85         --          the CoreTidy pass makes sure these are all and only
86         --          the externally-accessible ones
87         -- This truncates the type environment to include only the 
88         -- exported Ids and things needed from them, which saves space
89         --
90         -- However, we do keep things like constructors, which should not appear 
91         -- in interface files, because they are needed by importing modules when
92         -- using the compilation manager
93     new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
94                                      (map AnId final_ids)
95
96         -- We keep constructor workers, because they won't appear
97         -- in the bindings from which final_ids are derived!
98     keep_it (AnId id) = hasNoBinding id
99     keep_it other     = True
100
101     final_ids  = [id | bind <- tidy_binds
102                      , id <- bindersOf bind
103                      , isGlobalName (idName id)]
104
105         -- The complete rules are gotten by combining
106         --      a) the orphan rules
107         --      b) rules embedded in the top-level Ids
108     rule_dcls | opt_OmitInterfacePragmas = []
109               | otherwise                = getRules orphan_rules tidy_binds (mkVarSet final_ids)
110
111 -- This version is used when we are re-linking a module
112 -- so we've only run the type checker on its previous interface 
113 mkModDetailsFromIface :: TypeEnv 
114                       -> [TypecheckedRuleDecl]
115                       -> ModDetails
116 mkModDetailsFromIface type_env rules
117   = ModDetails { md_types = type_env,
118                  md_rules = rule_dcls,
119                  md_insts = dfun_ids }
120   where
121     dfun_ids  = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
122     rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
123         -- All the rules from an interface are of the IfaceRuleOut form
124 \end{code}
125
126 \begin{code}
127 getRules :: [IdCoreRule]        -- Orphan rules
128          -> [CoreBind]          -- Bindings, with rules in the top-level Ids
129          -> IdSet               -- Ids that are exported, so we need their rules
130          -> [IdCoreRule]
131 getRules orphan_rules binds emitted
132   = orphan_rules ++ local_rules
133   where
134     local_rules  = [ (fn, rule)
135                    | fn <- bindersOfBinds binds,
136                      fn `elemVarSet` emitted,
137                      rule <- rulesRules (idSpecialisation fn),
138                      not (isBuiltinRule rule),
139                                 -- We can't print builtin rules in interface files
140                                 -- Since they are built in, an importing module
141                                 -- will have access to them anyway
142
143                         -- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
144                         -- from coming out, and to make it work properly we need to add ????
145                         --      (put it back in for now)
146                      all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
147                                 -- Spit out a rule only if all its lhs free vars are emitted
148                                 -- This is a good reason not to do it when we emit the Id itself
149                    ]
150
151 interestingId id = isId id && isLocalId id
152 \end{code}
153
154
155 %************************************************************************
156 %*                                                                      *
157 \subsection{Completing an interface}
158 %*                                                                      *
159 %************************************************************************
160
161 \begin{code}
162 completeIface :: Maybe ModIface         -- The old interface, if we have it
163               -> ModIface               -- The new one, minus the decls and versions
164               -> ModDetails             -- The ModDetails for this module
165               -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
166                                         -- The SDoc is a debug document giving differences
167                                         -- Nothing => no change
168
169         -- NB: 'Nothing' means that even the usages havn't changed, so there's no
170         --     need to write a new interface file.  But even if the usages have
171         --     changed, the module version may not have.
172 completeIface maybe_old_iface new_iface mod_details 
173   = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
174   where
175      new_decls   = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
176      inst_dcls   = map ifaceInstance (md_insts mod_details)
177      ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
178      rule_dcls   = map ifaceRule (md_rules mod_details)
179 \end{code}
180
181
182 \begin{code}
183 ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
184 ifaceTyCls (AClass clas) so_far
185   = cls_decl : so_far
186   where
187     cls_decl = ClassDecl { tcdCtxt      = toHsContext sc_theta,
188                            tcdName      = getName clas,
189                            tcdTyVars    = toHsTyVars clas_tyvars,
190                            tcdFDs       = toHsFDs clas_fds,
191                            tcdSigs      = map toClassOpSig op_stuff,
192                            tcdMeths     = Nothing, 
193                            tcdSysNames  = sys_names,
194                            tcdLoc       = noSrcLoc }
195
196     (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
197     tycon     = classTyCon clas
198     data_con  = head (tyConDataCons tycon)
199     sys_names = mkClassDeclSysNames (getName tycon, getName data_con, 
200                                      getName (dataConId data_con), map getName sc_sels)
201
202     toClassOpSig (sel_id, def_meth)
203         = ASSERT(sel_tyvars == clas_tyvars)
204           ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
205         where
206           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
207           def_meth' = case def_meth of
208                          NoDefMeth  -> NoDefMeth
209                          GenDefMeth -> GenDefMeth
210                          DefMeth id -> DefMeth (getName id)
211
212 ifaceTyCls (ATyCon tycon) so_far
213   | isClassTyCon tycon = so_far
214   | otherwise          = ty_decl : so_far
215   where
216     ty_decl | isSynTyCon tycon
217             = TySynonym { tcdName   = getName tycon,
218                           tcdTyVars = toHsTyVars tyvars,
219                           tcdSynRhs = toHsType syn_ty,
220                           tcdLoc    = noSrcLoc }
221
222             | isAlgTyCon tycon
223             = TyData {  tcdND     = new_or_data,
224                         tcdCtxt   = toHsContext (tyConTheta tycon),
225                         tcdName   = getName tycon,
226                         tcdTyVars = toHsTyVars tyvars,
227                         tcdCons   = map ifaceConDecl (tyConDataCons tycon),
228                         tcdNCons  = tyConFamilySize tycon,
229                         tcdDerivs = Nothing,
230                         tcdSysNames  = map getName (tyConGenIds tycon),
231                         tcdLoc       = noSrcLoc }
232
233             | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
234
235     tyvars      = tyConTyVars tycon
236     (_, syn_ty) = getSynTyConDefn tycon
237     new_or_data | isNewTyCon tycon = NewType
238                 | otherwise        = DataType
239
240     ifaceConDecl data_con 
241         = ConDecl (getName data_con) (getName (dataConId data_con))
242                   (toHsTyVars ex_tyvars)
243                   (toHsContext ex_theta)
244                   details noSrcLoc
245         where
246           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
247           field_labels   = dataConFieldLabels data_con
248           strict_marks   = dataConStrictMarks data_con
249           details | null field_labels
250                   = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
251                     VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
252
253                   | otherwise
254                   = RecCon (zipWith mk_field strict_marks field_labels)
255
256     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
257     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
258     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
259
260     mk_field strict_mark field_label
261         = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
262
263 ifaceTyCls (AnId id) so_far
264   | isImplicitId id = so_far
265   | otherwise       = iface_sig : so_far
266   where
267     iface_sig = IfaceSig { tcdName   = getName id, 
268                            tcdType   = toHsType id_type,
269                            tcdIdInfo = hs_idinfo,
270                            tcdLoc    =  noSrcLoc }
271
272     id_type = idType id
273     id_info = idInfo id
274
275     hs_idinfo | opt_OmitInterfacePragmas = []
276               | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
277                                            strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
278
279     ------------  Arity  --------------
280     arity_hsinfo = case arityInfo id_info of
281                         a@(ArityExactly n) -> [HsArity a]
282                         other              -> []
283
284     ------------ Caf Info --------------
285     caf_hsinfo = case cafInfo id_info of
286                    NoCafRefs -> [HsNoCafRefs]
287                    otherwise -> []
288
289     ------------ CPR Info --------------
290     cpr_hsinfo = case cprInfo id_info of
291                    ReturnsCPR -> [HsCprInfo]
292                    NoCPRInfo  -> []
293
294     ------------  Strictness  --------------
295     strict_hsinfo = case strictnessInfo id_info of
296                         NoStrictnessInfo -> []
297                         info             -> [HsStrictness info]
298
299
300     ------------  Worker  --------------
301     work_info   = workerInfo id_info
302     has_worker  = case work_info of { HasWorker _ _ -> True; other -> False }
303     wrkr_hsinfo = case work_info of
304                     HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
305                     NoWorker                     -> []
306
307     ------------  Unfolding  --------------
308         -- The unfolding is redundant if there is a worker
309     unfold_info = unfoldingInfo id_info
310     inline_prag = inlinePragInfo id_info
311     rhs         = unfoldingTemplate unfold_info
312     unfold_hsinfo |  neverUnfold unfold_info 
313                   || has_worker = []
314                   | otherwise   = [HsUnfold inline_prag (toUfExpr rhs)]
315 \end{code}
316
317 \begin{code}
318 ifaceInstance :: DFunId -> RenamedInstDecl
319 ifaceInstance dfun_id
320   = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc                      
321   where
322     tidy_ty = tidyTopType (deNoteType (idType dfun_id))
323                 -- The deNoteType is very important.   It removes all type
324                 -- synonyms from the instance type in interface files.
325                 -- That in turn makes sure that when reading in instance decls
326                 -- from interface files that the 'gating' mechanism works properly.
327                 -- Otherwise you could have
328                 --      type Tibble = T Int
329                 --      instance Foo Tibble where ...
330                 -- and this instance decl wouldn't get imported into a module
331                 -- that mentioned T but not Tibble.
332
333 ifaceRule (id, BuiltinRule _)
334   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
335
336 ifaceRule (id, Rule name bndrs args rhs)
337   = IfaceRule name (map toUfBndr bndrs) (getName id)
338               (map toUfExpr args) (toUfExpr rhs) noSrcLoc
339
340 bogusIfaceRule id
341   = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
342 \end{code}
343
344
345 %************************************************************************
346 %*                                                                      *
347 \subsection{Checking if the new interface is up to date
348 %*                                                                      *
349 %************************************************************************
350
351 \begin{code}
352 addVersionInfo :: Maybe ModIface                -- The old interface, read from M.hi
353                -> ModIface                      -- The new interface decls
354                -> (ModIface, Maybe SDoc)        -- Nothing => no change; no need to write new Iface
355                                                 -- Just mi => Here is the new interface to write
356                                                 --            with correct version numbers
357
358 -- NB: the fixities, declarations, rules are all assumed
359 -- to be sorted by increasing order of hsDeclName, so that 
360 -- we can compare for equality
361
362 addVersionInfo Nothing new_iface
363 -- No old interface, so definitely write a new one!
364   = (new_iface, Just (text "No old interface available"))
365
366 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, 
367                                            mi_decls   = old_decls,
368                                            mi_fixities = old_fixities }))
369                new_iface@(ModIface { mi_decls = new_decls,
370                                      mi_fixities = new_fixities })
371
372   | no_output_change && no_usage_change
373   = (new_iface, Nothing)
374         -- don't return the old iface because it may not have an
375         -- mi_globals field set to anything reasonable.
376
377   | otherwise           -- Add updated version numbers
378   = --pprTrace "completeIface" (ppr (dcl_tycl old_decls))
379     (final_iface, Just pp_diffs)
380         
381   where
382     final_iface = new_iface { mi_version = new_version }
383     new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
384                                 vers_exports = bumpVersion no_export_change (vers_exports old_version),
385                                 vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
386                                 vers_decls   = tc_vers }
387
388     no_output_change = no_tc_change && no_rule_change && no_export_change
389     no_usage_change  = mi_usages old_iface == mi_usages new_iface
390
391     no_export_change = mi_exports old_iface == mi_exports new_iface             -- Kept sorted
392     no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls             -- Ditto
393
394         -- Fill in the version number on the new declarations by looking at the old declarations.
395         -- Set the flag if anything changes. 
396         -- Assumes that the decls are sorted by hsDeclName.
397     old_vers_decls = vers_decls old_version
398     (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
399                                                        (dcl_tycl old_decls) (dcl_tycl new_decls)
400     pp_diffs = vcat [pp_tc_diffs,
401                      pp_change no_export_change "Export list",
402                      pp_change no_rule_change   "Rules",
403                      pp_change no_usage_change  "Usages"]
404     pp_change True  what = empty
405     pp_change False what = text what <+> ptext SLIT("changed")
406
407 diffDecls :: NameEnv Version                            -- Old version map
408           -> NameEnv Fixity -> NameEnv Fixity           -- Old and new fixities
409           -> [RenamedTyClDecl] -> [RenamedTyClDecl]     -- Old and new decls
410           -> (Bool,             -- True <=> no change
411               SDoc,             -- Record of differences
412               NameEnv Version)  -- New version
413
414 diffDecls old_vers old_fixities new_fixities old new
415   = diff True empty emptyNameEnv old new
416   where
417         -- When seeing if two decls are the same, 
418         -- remember to check whether any relevant fixity has changed
419     eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
420     same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
421
422     diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
423     diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
424     diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
425     diff ok_so_far pp new_vers (od:ods) (nd:nds)
426         = case od_name `compare` nd_name of
427                 LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
428                 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
429                 EQ | od `eq_tc` nd -> diff ok_so_far pp                    new_vers  ods nds
430                    | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
431         where
432           od_name = tyClDeclName od
433           nd_name = tyClDeclName nd
434           new_vers' = extendNameEnv new_vers nd_name 
435                                     (bumpVersion False (lookupNameEnv_NF old_vers od_name))
436
437     only_old d    = ptext SLIT("Only in old iface:") <+> ppr d
438     only_new d    = ptext SLIT("Only in new iface:") <+> ppr d
439     changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$ 
440                                                          (ptext SLIT("New:")  <+> ppr nd))
441 \end{code}
442
443
444
445 %************************************************************************
446 %*                                                                      *
447 \subsection{Writing an interface file}
448 %*                                                                      *
449 %************************************************************************
450
451 \begin{code}
452 writeIface :: FilePath -> ModIface -> IO ()
453 writeIface hi_path mod_iface
454   = do  { if_hdl <- openFile hi_path WriteMode
455         ; printForIface if_hdl from_this_mod (pprIface mod_iface)
456         ; hClose if_hdl
457         }
458   where
459         -- Print names unqualified if they are from this module
460     from_this_mod n = nameModule n == this_mod
461     this_mod = mi_module mod_iface
462          
463 pprIface :: ModIface -> SDoc
464 pprIface iface
465  = vcat [ ptext SLIT("__interface")
466                 <+> doubleQuotes (ptext opt_InPackage)
467                 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
468                 <+> pp_sub_vers
469                 <+> (if mi_orphan iface then char '!' else empty)
470                 <+> int opt_HiVersion
471                 <+> ptext SLIT("where")
472
473         , vcat (map pprExport (mi_exports iface))
474         , vcat (map pprUsage (mi_usages iface))
475
476         , pprFixities (mi_fixities iface) (dcl_tycl decls)
477         , pprIfaceDecls (vers_decls version_info) decls
478         , pprDeprecs (mi_deprecs iface)
479         ]
480   where
481     version_info = mi_version iface
482     decls        = mi_decls iface
483     exp_vers     = vers_exports version_info
484     rule_vers    = vers_rules version_info
485
486     pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
487                 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
488 \end{code}
489
490 When printing export lists, we print like this:
491         Avail   f               f
492         AvailTC C [C, x, y]     C(x,y)
493         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
494
495 \begin{code}
496 pprExport :: (ModuleName, Avails) -> SDoc
497 pprExport (mod, items)
498  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
499   where
500     pp_avail :: AvailInfo -> SDoc
501     pp_avail (Avail name)                    = pprOcc name
502     pp_avail (AvailTC n [])                  = empty
503     pp_avail (AvailTC n (n':ns)) | n==n'     = pprOcc n             <> pp_export ns
504                                  | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
505     
506     pp_export []    = empty
507     pp_export names = braces (hsep (map pprOcc names))
508
509 pprOcc :: Name -> SDoc  -- Print the occurrence name only
510 pprOcc n = pprOccName (nameOccName n)
511 \end{code}
512
513
514 \begin{code}
515 pprUsage :: ImportVersion Name -> SDoc
516 pprUsage (m, has_orphans, is_boot, whats_imported)
517   = hsep [ptext SLIT("import"), ppr m, 
518           pp_orphan, pp_boot,
519           pp_versions whats_imported
520     ] <> semi
521   where
522     pp_orphan | has_orphans = char '!'
523               | otherwise   = empty
524     pp_boot   | is_boot     = char '@'
525               | otherwise   = empty
526
527         -- Importing the whole module is indicated by an empty list
528     pp_versions NothingAtAll                = empty
529     pp_versions (Everything v)              = dcolon <+> int v
530     pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr 
531                                               <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
532
533     pp_export_version Nothing  = empty
534     pp_export_version (Just v) = int v
535 \end{code}
536
537 \begin{code}
538 pprIfaceDecls version_map decls
539   = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
540          , vcat (map ppr_decl (dcl_tycl decls))
541          , pprRules (dcl_rules decls)
542          ]
543   where
544     ppr_decl d  = ppr_vers d <+> ppr d <> semi
545
546         -- Print the version for the decl
547     ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
548                    Nothing -> empty
549                    Just v  -> int v
550 \end{code}
551
552 \begin{code}
553 pprFixities fixity_map decls
554   = hsep [ ppr fix <+> ppr n 
555          | d <- decls, 
556            (n,_) <- tyClDeclNames d, 
557            Just fix <- [lookupNameEnv fixity_map n]] <> semi
558
559 pprRules []    = empty
560 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
561
562 pprDeprecs NoDeprecs = empty
563 pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
564                      where
565                        guts = case deprecs of
566                                 DeprecAll txt  -> doubleQuotes (ptext txt)
567                                 DeprecSome env -> pp_deprecs env
568
569 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
570                where
571                  pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)
572 \end{code}