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