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(..), IfaceDecls(..), ModIface(..), ModDetails(..),
  24                           TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
  25                           WhatsImported(..), GenAvailInfo(..),
  26                           ImportVersion, AvailInfo, Deprecations(..)
  27                         )
  28
  29 import CmdLineOpts
  30 import Id               ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
  31                           idSpecialisation, idName, setIdInfo
  32                         )
  33 import Var              ( isId )
  34 import VarSet
  35 import DataCon          ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
  36 import IdInfo           -- Lots
  37 import CoreSyn          ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
  38                           isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
  39                           bindersOfBinds
  40                         )
  41 import CoreFVs          ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
  42 import CoreUnfold       ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
  43 import Name             ( isLocallyDefined, getName,
  44                           Name, NamedThing(..)
  45                         )
  46 import Name     -- Env
  47 import OccName          ( pprOccName )
  48 import TyCon            ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
  49                           tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
  50                         )
  51 import Class            ( classExtraBigSig, 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 List             ( partition )
  59 import IO               ( IOMode(..), openFile, hClose )
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{Write a new interface file}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 mkModDetails :: TypeEnv -> [DFunId]     -- From typechecker
  71              -> [CoreBind] -> [Id]      -- Final bindings, plus the top-level Ids from the
  72                                         -- code generator; they have authoritative arity info
  73              -> [IdCoreRule]            -- Tidy orphan rules
  74              -> ModDetails
  75 mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
  76   = ModDetails { md_types = new_type_env,
  77                  md_rules = rule_dcls,
  78                  md_insts = dfun_ids }
  79   where
  80         -- The competed type environment is gotten from
  81         --      a) keeping the types and classes
  82         --      b) removing all Ids, and Ids with correct IdInfo
  83         --              gotten from the bindings
  84         -- From (b) we keep only those Ids with Global names, plus Ids
  85         --          accessible from them (notably via unfoldings)
  86         -- This truncates the type environment to include only the
  87         -- exported Ids and things needed from them, which saves space
  88         --
  89         -- However, we do keep things like constructors, which should not appear
  90         -- in interface files, because they are needed by importing modules when
  91         -- using the compilation manager
  92     new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
  93                         `plusNameEnv`
  94                    mkNameEnv [(idName id, AnId id) | id <- final_ids]
  95
  96     orig_type_env = nameEnvElts type_env
  97
  98     final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
  99                            (mkVarSet stg_ids)
 100                            tidy_binds
 101
 102         -- The complete rules are gotten by combining
 103         --      a) the orphan rules
 104         --      b) rules embedded in the top-level Ids
 105     rule_dcls | opt_OmitInterfacePragmas = []
 106               | otherwise                 = getRules orphan_rules tidy_binds (mkVarSet final_ids)
 107
 108     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
 109                                    | (_, rule) <- orphan_rules]
 110
 111
 112 -- This version is used when we are re-linking a module
 113 -- so we've only run the type checker on its previous interface
 114 mkModDetailsFromIface :: TypeEnv -> [DFunId]    -- From typechecker
 115                       -> [TypecheckedRuleDecl]
 116                       -> ModDetails
 117 mkModDetailsFromIface type_env dfun_ids rules
 118   = ModDetails { md_types = type_env,
 119                  md_rules = rule_dcls,
 120                  md_insts = dfun_ids }
 121   where
 122     rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
 123         -- All the rules from an interface are of the IfaceRuleOut form
 124
 125
 126 completeIface :: Maybe ModIface         -- The old interface, if we have it
 127               -> ModIface               -- The new one, minus the decls and versions
 128               -> ModDetails             -- The ModDetails for this module
 129               -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
 130                                         -- The SDoc is a debug document giving differences
 131                                         -- Nothing => no change
 132
 133         -- NB: 'Nothing' means that even the usages havn't changed, so there's no
 134         --     need to write a new interface file.  But even if the usages have
 135         --     changed, the module version may not have.
 136 completeIface maybe_old_iface new_iface mod_details
 137   = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
 138   where
 139      new_decls = IfaceDecls { dcl_tycl  = ty_cls_dcls,
 140                               dcl_insts = inst_dcls,
 141                               dcl_rules = rule_dcls }
 142
 143      inst_dcls   = map ifaceInstance (md_insts mod_details)
 144      ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
 145      rule_dcls   = map ifaceRule (md_rules mod_details)
 146 \end{code}
 147
 148
 149 %************************************************************************
 150 %*                                                                      *
 151 \subsection{Types and classes}
 152 %*                                                                      *
 153 %************************************************************************
 154
 155 \begin{code}
 156 ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
 157 ifaceTyCls (AClass clas) so_far
 158   = cls_decl : so_far
 159   where
 160     cls_decl = ClassDecl (toHsContext sc_theta)
 161                          (getName clas)
 162                          (toHsTyVars clas_tyvars)
 163                          (toHsFDs clas_fds)
 164                          (map toClassOpSig op_stuff)
 165                          EmptyMonoBinds
 166                          [] noSrcLoc
 167
 168     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 169
 170     toClassOpSig (sel_id, def_meth)
 171         = ASSERT(sel_tyvars == clas_tyvars)
 172           ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
 173         where
 174           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
 175           def_meth' = case def_meth of
 176                          NoDefMeth  -> NoDefMeth
 177                          GenDefMeth -> GenDefMeth
 178                          DefMeth id -> DefMeth (getName id)
 179
 180 ifaceTyCls (ATyCon tycon) so_far
 181   = ty_decl : so_far
 182
 183   where
 184     ty_decl | isSynTyCon tycon
 185             = TySynonym (getName tycon)(toHsTyVars tyvars)
 186                         (toHsType syn_ty) noSrcLoc
 187
 188             | isAlgTyCon tycon
 189             = TyData new_or_data (toHsContext (tyConTheta tycon))
 190                      (getName tycon)
 191                      (toHsTyVars tyvars)
 192                      (map ifaceConDecl (tyConDataCons tycon))
 193                      (tyConFamilySize tycon)
 194                      Nothing noSrcLoc (panic "gen1") (panic "gen2")
 195
 196             | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 197
 198     tyvars      = tyConTyVars tycon
 199     (_, syn_ty) = getSynTyConDefn tycon
 200     new_or_data | isNewTyCon tycon = NewType
 201                 | otherwise        = DataType
 202
 203     ifaceConDecl data_con
 204         = ConDecl (getName data_con) (error "ifaceConDecl")
 205                   (toHsTyVars ex_tyvars)
 206                   (toHsContext ex_theta)
 207                   details noSrcLoc
 208         where
 209           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
 210           field_labels   = dataConFieldLabels data_con
 211           strict_marks   = dataConStrictMarks data_con
 212           details | null field_labels
 213                   = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
 214                     VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 215
 216                   | otherwise
 217                   = RecCon (zipWith mk_field strict_marks field_labels)
 218
 219     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
 220     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
 221     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 222
 223     mk_field strict_mark field_label
 224         = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 225
 226 ifaceTyCls (AnId id) so_far
 227   | omitIfaceSigForId id = so_far
 228   | otherwise            = iface_sig : so_far
 229   where
 230     iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
 231
 232     id_type = idType id
 233     id_info = idInfo id
 234
 235     hs_idinfo | opt_OmitInterfacePragmas = []
 236               | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++
 237                                            strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 238
 239     ------------  Arity  --------------
 240     arity_hsinfo = case arityInfo id_info of
 241                         a@(ArityExactly n) -> [HsArity a]
 242                         other              -> []
 243
 244     ------------ Caf Info --------------
 245     caf_hsinfo = case cafInfo id_info of
 246                    NoCafRefs -> [HsNoCafRefs]
 247                    otherwise -> []
 248
 249     ------------ CPR Info --------------
 250     cpr_hsinfo = case cprInfo id_info of
 251                    ReturnsCPR -> [HsCprInfo]
 252                    NoCPRInfo  -> []
 253
 254     ------------  Strictness  --------------
 255     strict_hsinfo = case strictnessInfo id_info of
 256                         NoStrictnessInfo -> []
 257                         info             -> [HsStrictness info]
 258
 259
 260     ------------  Worker  --------------
 261     wrkr_hsinfo = case workerInfo id_info of
 262                     HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
 263                     NoWorker                     -> []
 264
 265     ------------  Unfolding  --------------
 266     unfold_info = unfoldingInfo id_info
 267     inline_prag = inlinePragInfo id_info
 268     rhs         = unfoldingTemplate unfold_info
 269     unfold_hsinfo | neverUnfold unfold_info = []
 270                   | otherwise               = [HsUnfold inline_prag (toUfExpr rhs)]
 271 \end{code}
 272
 273
 274 %************************************************************************
 275 %*                                                                      *
 276 \subsection{Instances and rules}
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 \begin{code}
 281 ifaceInstance :: DFunId -> RenamedInstDecl
 282 ifaceInstance dfun_id
 283   = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
 284   where
 285     tidy_ty = tidyTopType (deNoteType (idType dfun_id))
 286                 -- The deNoteType is very important.   It removes all type
 287                 -- synonyms from the instance type in interface files.
 288                 -- That in turn makes sure that when reading in instance decls
 289                 -- from interface files that the 'gating' mechanism works properly.
 290                 -- Otherwise you could have
 291                 --      type Tibble = T Int
 292                 --      instance Foo Tibble where ...
 293                 -- and this instance decl wouldn't get imported into a module
 294                 -- that mentioned T but not Tibble.
 295
 296 ifaceRule (id, BuiltinRule _)
 297   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
 298
 299 ifaceRule (id, Rule name bndrs args rhs)
 300   = IfaceRule name (map toUfBndr bndrs) (getName id)
 301               (map toUfExpr args) (toUfExpr rhs) noSrcLoc
 302
 303 bogusIfaceRule id
 304   = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
 305 \end{code}
 306
 307
 308 %************************************************************************
 309 %*                                                                      *
 310 \subsection{Compute final Ids}
 311 %*                                                                      *
 312 %************************************************************************
 313
 314 A "final Id" has exactly the IdInfo for going into an interface file, or
 315 exporting to another module.
 316
 317 \begin{code}
 318 bindsToIds :: IdSet             -- These Ids are needed already
 319            -> IdSet             -- Ids used at code-gen time; they have better pragma info!
 320            -> [CoreBind]        -- In dependency order, later depend on earlier
 321            -> [Id]              -- Set of Ids actually spat out, complete with exactly the IdInfo
 322                                 -- they need for exporting to another module
 323
 324 bindsToIds needed_ids codegen_ids binds
 325   = go needed_ids (reverse binds) []
 326                 -- Reverse so that later things will
 327                 -- provoke earlier ones to be emitted
 328   where
 329         -- The 'needed' set contains the Ids that are needed by earlier
 330         -- interface file emissions.  If the Id isn't in this set, and isn't
 331         -- exported, there's no need to emit anything
 332     need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
 333
 334     go needed [] emitted
 335         | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
 336                                           (sep (map ppr (varSetElems needed)))
 337                                        emitted
 338         | otherwise                  = emitted
 339
 340     go needed (NonRec id rhs : binds) emitted
 341         | need_id needed id = go new_needed binds (new_id:emitted)
 342         | otherwise         = go needed     binds emitted
 343         where
 344           (new_id, extras) = mkFinalId codegen_ids False id rhs
 345           new_needed       = (needed `unionVarSet` extras) `delVarSet` id
 346
 347         -- Recursive groups are a bit more of a pain.  We may only need one to
 348         -- start with, but it may call out the next one, and so on.  So we
 349         -- have to look for a fixed point.  We don't want necessarily them all,
 350         -- because without -O we may only need the first one (if we don't emit
 351         -- its unfolding)
 352     go needed (Rec pairs : binds) emitted
 353         = go needed' binds emitted'
 354         where
 355           (new_emitted, extras) = go_rec needed pairs
 356           needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
 357           emitted' = new_emitted ++ emitted
 358
 359     go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
 360     go_rec needed pairs
 361         | null needed_prs = ([], emptyVarSet)
 362         | otherwise       = (emitted ++           more_emitted,
 363                              extras `unionVarSet` more_extras)
 364         where
 365           (needed_prs,leftover_prs)   = partition is_needed pairs
 366           (emitted, extras_s)         = unzip [ mkFinalId codegen_ids True id rhs
 367                                               | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
 368           extras                      = unionVarSets extras_s
 369           (more_emitted, more_extras) = go_rec extras leftover_prs
 370
 371           is_needed (id,_) = need_id needed id
 372 \end{code}
 373
 374
 375
 376 \begin{code}
 377 mkFinalId :: IdSet              -- The Ids with arity info from the code generator
 378           -> Bool               -- True <=> recursive, so don't include unfolding
 379           -> Id
 380           -> CoreExpr           -- The Id's right hand side
 381           -> (Id, IdSet)        -- The emitted id, plus any *extra* needed Ids
 382
 383 mkFinalId codegen_ids is_rec id rhs
 384   | omitIfaceSigForId id
 385   = (id, emptyVarSet)           -- An optimisation for top-level constructors and suchlike
 386   | otherwise
 387   = (id `setIdInfo` new_idinfo, new_needed_ids)
 388   where
 389     core_idinfo = idInfo id
 390     stg_idinfo  = case lookupVarSet codegen_ids id of
 391                         Just id' -> idInfo id'
 392                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
 393                                     idInfo id
 394
 395     new_idinfo | opt_OmitInterfacePragmas
 396                = vanillaIdInfo
 397                | otherwise
 398                = core_idinfo `setArityInfo`      arity_info
 399                              `setCafInfo`        cafInfo stg_idinfo
 400                              `setUnfoldingInfo`  unfold_info
 401                              `setWorkerInfo`     worker_info
 402                              `setSpecInfo`       emptyCoreRules
 403         -- We zap the specialisations because they are
 404         -- passed on separately through the modules IdCoreRules
 405
 406     ------------  Arity  --------------
 407     arity_info = arityInfo stg_idinfo
 408     stg_arity  = arityLowerBound arity_info
 409
 410     ------------  Worker  --------------
 411         -- We only treat a function as having a worker if
 412         -- the exported arity (which is now the number of visible lambdas)
 413         -- is the same as the arity at the moment of the w/w split
 414         -- If so, we can safely omit the unfolding inside the wrapper, and
 415         -- instead re-generate it from the type/arity/strictness info
 416         -- But if the arity has changed, we just take the simple path and
 417         -- put the unfolding into the interface file, forgetting the fact
 418         -- that it's a wrapper.
 419         --
 420         -- How can this happen?  Sometimes we get
 421         --      f = coerce t (\x y -> $wf x y)
 422         -- at the moment of w/w split; but the eta reducer turns it into
 423         --      f = coerce t $wf
 424         -- which is perfectly fine except that the exposed arity so far as
 425         -- the code generator is concerned (zero) differs from the arity
 426         -- when we did the split (2).
 427         --
 428         -- All this arises because we use 'arity' to mean "exactly how many
 429         -- top level lambdas are there" in interface files; but during the
 430         -- compilation of this module it means "how many things can I apply
 431         -- this to".
 432     worker_info = case workerInfo core_idinfo of
 433                      info@(HasWorker work_id wrap_arity)
 434                         | wrap_arity == stg_arity -> info
 435                         | otherwise               -> pprTrace "ifaceId: arity change:" (ppr id)
 436                                                      NoWorker
 437                      NoWorker                     -> NoWorker
 438
 439     has_worker = case worker_info of
 440                    HasWorker _ _ -> True
 441                    other         -> False
 442
 443     HasWorker work_id _ = worker_info
 444
 445     ------------  Unfolding  --------------
 446     inline_pragma  = inlinePragInfo core_idinfo
 447     dont_inline    = isNeverInlinePrag inline_pragma
 448     loop_breaker   = isLoopBreaker (occInfo core_idinfo)
 449     bottoming_fn   = isBottomingStrictness (strictnessInfo core_idinfo)
 450
 451     unfolding    = mkTopUnfolding rhs
 452     rhs_is_small = neverUnfold unfolding
 453
 454     unfold_info | show_unfold = unfolding
 455                 | otherwise   = noUnfolding
 456
 457     show_unfold = not has_worker         &&     -- Not unnecessary
 458                   not bottoming_fn       &&     -- Not necessary
 459                   not dont_inline        &&
 460                   not loop_breaker       &&
 461                   rhs_is_small           &&     -- Small enough
 462                   okToUnfoldInHiFile rhs        -- No casms etc
 463
 464
 465     ------------  Extra free Ids  --------------
 466     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 467                    | otherwise                = worker_ids      `unionVarSet`
 468                                                 unfold_ids      `unionVarSet`
 469                                                 spec_ids
 470
 471     spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
 472
 473     worker_ids | has_worker && interestingId work_id = unitVarSet work_id
 474                         -- Conceivably, the worker might come from
 475                         -- another module
 476                | otherwise = emptyVarSet
 477
 478     unfold_ids | show_unfold = find_fvs rhs
 479                | otherwise   = emptyVarSet
 480
 481     find_fvs expr = exprSomeFreeVars interestingId expr
 482
 483 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
 484 \end{code}
 485
 486
 487 \begin{code}
 488 getRules :: [IdCoreRule]        -- Orphan rules
 489          -> [CoreBind]          -- Bindings, with rules in the top-level Ids
 490          -> IdSet               -- Ids that are exported, so we need their rules
 491          -> [IdCoreRule]
 492 getRules orphan_rules binds emitted
 493   = orphan_rules ++ local_rules
 494   where
 495     local_rules  = [ (fn, rule)
 496                    | fn <- bindersOfBinds binds,
 497                      fn `elemVarSet` emitted,
 498                      rule <- rulesRules (idSpecialisation fn),
 499                      not (isBuiltinRule rule),
 500                                 -- We can't print builtin rules in interface files
 501                                 -- Since they are built in, an importing module
 502                                 -- will have access to them anyway
 503
 504                         -- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
 505                         -- from coming out, and to make it work properly we need to add ????
 506                         --      (put it back in for now)
 507                      all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
 508                                 -- Spit out a rule only if all its lhs free vars are emitted
 509                                 -- This is a good reason not to do it when we emit the Id itself
 510                    ]
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection{Checking if the new interface is up to date
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 addVersionInfo :: Maybe ModIface                -- The old interface, read from M.hi
 522                -> ModIface                      -- The new interface decls
 523                -> (ModIface, Maybe SDoc)        -- Nothing => no change; no need to write new Iface
 524                                                 -- Just mi => Here is the new interface to write
 525                                                 --            with correct version numbers
 526
 527 -- NB: the fixities, declarations, rules are all assumed
 528 -- to be sorted by increasing order of hsDeclName, so that
 529 -- we can compare for equality
 530
 531 addVersionInfo Nothing new_iface
 532 -- No old interface, so definitely write a new one!
 533   = (new_iface, Just (text "No old interface available"))
 534
 535 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
 536                                            mi_decls   = old_decls,
 537                                            mi_fixities = old_fixities }))
 538                new_iface@(ModIface { mi_decls = new_decls,
 539                                      mi_fixities = new_fixities })
 540
 541   | no_output_change && no_usage_change
 542   = (old_iface, Nothing)
 543
 544   | otherwise           -- Add updated version numbers
 545   = (final_iface, Just pp_tc_diffs)
 546
 547   where
 548     final_iface = new_iface { mi_version = new_version }
 549     new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
 550                                 vers_exports = bumpVersion no_export_change (vers_exports old_version),
 551                                 vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
 552                                 vers_decls   = tc_vers }
 553
 554     no_output_change = no_tc_change && no_rule_change && no_export_change
 555     no_usage_change  = mi_usages old_iface == mi_usages new_iface
 556
 557     no_export_change = mi_exports old_iface == mi_exports new_iface             -- Kept sorted
 558     no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls             -- Ditto
 559
 560         -- Fill in the version number on the new declarations by looking at the old declarations.
 561         -- Set the flag if anything changes.
 562         -- Assumes that the decls are sorted by hsDeclName.
 563     old_vers_decls = vers_decls old_version
 564     (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
 565                                                        (dcl_tycl old_decls) (dcl_tycl new_decls)
 566
 567
 568
 569 diffDecls :: NameEnv Version                            -- Old version map
 570           -> NameEnv Fixity -> NameEnv Fixity           -- Old and new fixities
 571           -> [RenamedTyClDecl] -> [RenamedTyClDecl]     -- Old and new decls
 572           -> (Bool,             -- True <=> no change
 573               SDoc,             -- Record of differences
 574               NameEnv Version)  -- New version
 575
 576 diffDecls old_vers old_fixities new_fixities old new
 577   = diff True empty emptyNameEnv old new
 578   where
 579         -- When seeing if two decls are the same,
 580         -- remember to check whether any relevant fixity has changed
 581     eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
 582     same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
 583
 584     diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
 585     diff ok_so_far pp new_vers old []      = (False,     pp, new_vers)
 586     diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
 587     diff ok_so_far pp new_vers (od:ods) (nd:nds)
 588         = case od_name `compare` nd_name of
 589                 LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
 590                 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
 591                 EQ | od `eq_tc` nd -> diff ok_so_far pp                    new_vers  ods nds
 592                    | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
 593         where
 594           od_name = tyClDeclName od
 595           nd_name = tyClDeclName nd
 596           new_vers' = extendNameEnv new_vers nd_name
 597                                     (bumpVersion True (lookupNameEnv_NF old_vers od_name))
 598
 599     only_old d   = ptext SLIT("Only in old iface:") <+> ppr d
 600     only_new d   = ptext SLIT("Only in new iface:") <+> ppr d
 601     changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
 602                                                          (ptext SLIT("New:") <+> ppr nd))
 603 \end{code}
 604
 605
 606
 607 %************************************************************************
 608 %*                                                                      *
 609 \subsection{Writing an interface file}
 610 %*                                                                      *
 611 %************************************************************************
 612
 613 \begin{code}
 614 writeIface :: FilePath -> ModIface -> IO ()
 615 writeIface hi_path mod_iface
 616   = do  { if_hdl <- openFile hi_path WriteMode
 617         ; printForIface if_hdl (pprIface mod_iface)
 618         ; hClose if_hdl
 619         }
 620
 621 pprIface :: ModIface -> SDoc
 622 pprIface iface
 623  = vcat [ ptext SLIT("__interface")
 624                 <+> doubleQuotes (ptext opt_InPackage)
 625                 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
 626                 <+> pp_sub_vers
 627                 <+> (if mi_orphan iface then char '!' else empty)
 628                 <+> int opt_HiVersion
 629                 <+> ptext SLIT("where")
 630
 631         , vcat (map pprExport (mi_exports iface))
 632         , vcat (map pprUsage (mi_usages iface))
 633
 634         , pprFixities (mi_fixities iface) (dcl_tycl decls)
 635         , pprIfaceDecls (vers_decls version_info) decls
 636         , pprDeprecs (mi_deprecs iface)
 637         ]
 638   where
 639     version_info = mi_version iface
 640     decls        = mi_decls iface
 641     exp_vers     = vers_exports version_info
 642     rule_vers    = vers_rules version_info
 643
 644     pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
 645                 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
 646 \end{code}
 647
 648 When printing export lists, we print like this:
 649         Avail   f               f
 650         AvailTC C [C, x, y]     C(x,y)
 651         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 652
 653 \begin{code}
 654 pprExport :: (ModuleName, Avails) -> SDoc
 655 pprExport (mod, items)
 656  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
 657   where
 658     pp_avail :: AvailInfo -> SDoc
 659     pp_avail (Avail name)                    = pprOcc name
 660     pp_avail (AvailTC n [])                  = empty
 661     pp_avail (AvailTC n (n':ns)) | n==n'     = pprOcc n             <> pp_export ns
 662                                  | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
 663
 664     pp_export []    = empty
 665     pp_export names = braces (hsep (map pprOcc names))
 666
 667 pprOcc :: Name -> SDoc  -- Print the occurrence name only
 668 pprOcc n = pprOccName (nameOccName n)
 669 \end{code}
 670
 671
 672 \begin{code}
 673 pprUsage :: ImportVersion Name -> SDoc
 674 pprUsage (m, has_orphans, is_boot, whats_imported)
 675   = hsep [ptext SLIT("import"), ppr m,
 676           pp_orphan, pp_boot,
 677           pp_versions whats_imported
 678     ] <> semi
 679   where
 680     pp_orphan | has_orphans = char '!'
 681               | otherwise   = empty
 682     pp_boot   | is_boot     = char '@'
 683               | otherwise   = empty
 684
 685         -- Importing the whole module is indicated by an empty list
 686     pp_versions NothingAtAll                = empty
 687     pp_versions (Everything v)              = dcolon <+> int v
 688     pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
 689                                               <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
 690
 691         -- HACK for the moment: print the export-list version even if
 692         -- we don't use it, so that syntax of interface files doesn't change
 693     pp_export_version Nothing  = int 1
 694     pp_export_version (Just v) = int v
 695 \end{code}
 696
 697 \begin{code}
 698 pprIfaceDecls version_map decls
 699   = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
 700          , vcat (map ppr_decl (dcl_tycl decls))
 701          , pprRules (dcl_rules decls)
 702          ]
 703   where
 704     ppr_decl d  = ppr_vers d <+> ppr d <> semi
 705
 706         -- Print the version for the decl
 707     ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
 708                    Nothing -> empty
 709                    Just v  -> int v
 710 \end{code}
 711
 712 \begin{code}
 713 pprFixities fixity_map decls
 714   = hsep [ ppr fix <+> ppr n
 715          | d <- decls,
 716            (n,_) <- tyClDeclNames d,
 717            Just fix <- [lookupNameEnv fixity_map n]] <> semi
 718
 719 pprRules []    = empty
 720 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
 721
 722 pprDeprecs NoDeprecs = empty
 723 pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
 724                      where
 725                        guts = case deprecs of
 726                                 DeprecAll txt  -> ptext txt
 727                                 DeprecSome env -> pp_deprecs env
 728
 729 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
 730                where
 731                  pp_deprec (name, txt) = pprOcc name <+> ptext txt
 732 \end{code}