compiler/iface/MkIface.lhs

   1 %
   2 % (c) The University of Glasgow 2006-2008
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   4 %
   5
   6 \begin{code}
   7 module MkIface (
   8         mkUsedNames,
   9         mkDependencies,
  10         mkIface,        -- Build a ModIface from a ModGuts,
  11                         -- including computing version information
  12
  13         mkIfaceTc,
  14
  15         writeIfaceFile, -- Write the interface file
  16
  17         checkOldIface,  -- See if recompilation is required, by
  18                         -- comparing version information
  19
  20         tyThingToIfaceDecl -- Converting things to their Iface equivalents
  21  ) where
  22 \end{code}
  23
  24         -----------------------------------------------
  25                 Recompilation checking
  26         -----------------------------------------------
  27
  28 A complete description of how recompilation checking works can be
  29 found in the wiki commentary:
  30
  31  http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
  32
  33 Please read the above page for a top-down description of how this all
  34 works.  Notes below cover specific issues related to the implementation.
  35
  36 Basic idea:
  37
  38   * In the mi_usages information in an interface, we record the
  39     fingerprint of each free variable of the module
  40
  41   * In mkIface, we compute the fingerprint of each exported thing A.f.
  42     For each external thing that A.f refers to, we include the fingerprint
  43     of the external reference when computing the fingerprint of A.f.  So
  44     if anything that A.f depends on changes, then A.f's fingerprint will
  45     change.
  46
  47   * In checkOldIface we compare the mi_usages for the module with
  48     the actual fingerprint for all each thing recorded in mi_usages
  49
  50 \begin{code}
  51 #include "HsVersions.h"
  52
  53 import IfaceSyn
  54 import LoadIface
  55 import Id
  56 import IdInfo
  57 import Demand
  58 import Annotations
  59 import CoreSyn
  60 import CoreFVs
  61 import Class
  62 import TyCon
  63 import DataCon
  64 import Type
  65 import TcType
  66 import InstEnv
  67 import FamInstEnv
  68 import TcRnMonad
  69 import HsSyn
  70 import HscTypes
  71 import Finder
  72 import DynFlags
  73 import VarEnv
  74 import Var
  75 import Name
  76 import RdrName
  77 import NameEnv
  78 import NameSet
  79 import Module
  80 import BinIface
  81 import ErrUtils
  82 import Digraph
  83 import SrcLoc
  84 import Outputable
  85 import BasicTypes       hiding ( SuccessFlag(..) )
  86 import LazyUniqFM
  87 import Unique
  88 import Util             hiding ( eqListBy )
  89 import FiniteMap
  90 import FastString
  91 import Maybes
  92 import ListSetOps
  93 import Binary
  94 import Fingerprint
  95 import Bag
  96
  97 import Control.Monad
  98 import Data.List
  99 import Data.IORef
 100 import System.FilePath
 101 \end{code}
 102
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Completing an interface}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 \begin{code}
 112 mkIface :: HscEnv
 113         -> Maybe Fingerprint    -- The old fingerprint, if we have it
 114         -> ModDetails           -- The trimmed, tidied interface
 115         -> ModGuts              -- Usages, deprecations, etc
 116         -> IO (Messages,
 117                Maybe (ModIface, -- The new one
 118                       Bool))    -- True <=> there was an old Iface, and the
 119                                 --          new one is identical, so no need
 120                                 --          to write it
 121
 122 mkIface hsc_env maybe_old_fingerprint mod_details
 123          ModGuts{     mg_module    = this_mod,
 124                       mg_boot      = is_boot,
 125                       mg_used_names = used_names,
 126                       mg_deps      = deps,
 127                       mg_dir_imps  = dir_imp_mods,
 128                       mg_rdr_env   = rdr_env,
 129                       mg_fix_env   = fix_env,
 130                       mg_warns   = warns,
 131                       mg_hpc_info  = hpc_info }
 132         = mkIface_ hsc_env maybe_old_fingerprint
 133                    this_mod is_boot used_names deps rdr_env
 134                    fix_env warns hpc_info dir_imp_mods mod_details
 135
 136 -- | make an interface from the results of typechecking only.  Useful
 137 -- for non-optimising compilation, or where we aren't generating any
 138 -- object code at all ('HscNothing').
 139 mkIfaceTc :: HscEnv
 140           -> Maybe Fingerprint  -- The old fingerprint, if we have it
 141           -> ModDetails         -- gotten from mkBootModDetails, probably
 142           -> TcGblEnv           -- Usages, deprecations, etc
 143           -> IO (Messages, Maybe (ModIface, Bool))
 144 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
 145   tc_result@TcGblEnv{ tcg_mod = this_mod,
 146                       tcg_src = hsc_src,
 147                       tcg_imports = imports,
 148                       tcg_rdr_env = rdr_env,
 149                       tcg_fix_env = fix_env,
 150                       tcg_warns = warns,
 151                       tcg_hpc = other_hpc_info
 152                     }
 153   = do
 154           used_names <- mkUsedNames tc_result
 155           deps <- mkDependencies tc_result
 156           let hpc_info = emptyHpcInfo other_hpc_info
 157           mkIface_ hsc_env maybe_old_fingerprint
 158                    this_mod (isHsBoot hsc_src) used_names deps rdr_env
 159                    fix_env warns hpc_info (imp_mods imports) mod_details
 160
 161
 162 mkUsedNames :: TcGblEnv -> IO NameSet
 163 mkUsedNames
 164           TcGblEnv{ tcg_inst_uses = dfun_uses_var,
 165                     tcg_dus = dus
 166                   }
 167  = do
 168         dfun_uses <- readIORef dfun_uses_var            -- What dfuns are used
 169         return (allUses dus `unionNameSets` dfun_uses)
 170
 171 mkDependencies :: TcGblEnv -> IO Dependencies
 172 mkDependencies
 173           TcGblEnv{ tcg_mod = mod,
 174                     tcg_imports = imports,
 175                     tcg_th_used = th_var
 176                   }
 177  = do
 178       th_used   <- readIORef th_var                     -- Whether TH is used
 179       let
 180         dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
 181                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
 182                 -- it before recording the modules on which this one depends!
 183                 -- (We want to retain M.hi-boot in imp_dep_mods so that
 184                 --  loadHiBootInterface can see if M's direct imports depend
 185                 --  on M.hi-boot, and hence that we should do the hi-boot consistency
 186                 --  check.)
 187
 188         pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
 189              | otherwise = imp_dep_pkgs imports
 190
 191       return Deps { dep_mods   = sortBy (stableModuleNameCmp `on` fst) dep_mods,
 192                     dep_pkgs   = sortBy stablePackageIdCmp pkgs,
 193                     dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
 194                     dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
 195                 -- sort to get into canonical order
 196                 -- NB. remember to use lexicographic ordering
 197
 198 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
 199          -> NameSet -> Dependencies -> GlobalRdrEnv
 200          -> NameEnv FixItem -> Warnings -> HpcInfo
 201          -> ImportedMods
 202          -> ModDetails
 203          -> IO (Messages, Maybe (ModIface, Bool))
 204 mkIface_ hsc_env maybe_old_fingerprint
 205          this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
 206          dir_imp_mods
 207          ModDetails{  md_insts     = insts,
 208                       md_fam_insts = fam_insts,
 209                       md_rules     = rules,
 210                       md_anns      = anns,
 211                       md_vect_info = vect_info,
 212                       md_types     = type_env,
 213                       md_exports   = exports }
 214 -- NB:  notice that mkIface does not look at the bindings
 215 --      only at the TypeEnv.  The previous Tidy phase has
 216 --      put exactly the info into the TypeEnv that we want
 217 --      to expose in the interface
 218
 219   = do  { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
 220
 221         ; let   { entities = typeEnvElts type_env ;
 222                   decls  = [ tyThingToIfaceDecl entity
 223                            | entity <- entities,
 224                              let name = getName entity,
 225                              not (isImplicitTyThing entity),
 226                                 -- No implicit Ids and class tycons in the interface file
 227                              not (isWiredInName name),
 228                                 -- Nor wired-in things; the compiler knows about them anyhow
 229                              nameIsLocalOrFrom this_mod name  ]
 230                                 -- Sigh: see Note [Root-main Id] in TcRnDriver
 231
 232                 ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
 233                 ; warns     = src_warns
 234                 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
 235                 ; iface_insts = map instanceToIfaceInst insts
 236                 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
 237                 ; iface_vect_info = flattenVectInfo vect_info
 238
 239                 ; intermediate_iface = ModIface {
 240                         mi_module   = this_mod,
 241                         mi_boot     = is_boot,
 242                         mi_deps     = deps,
 243                         mi_usages   = usages,
 244                         mi_exports  = mkIfaceExports exports,
 245
 246                         -- Sort these lexicographically, so that
 247                         -- the result is stable across compilations
 248                         mi_insts    = sortLe le_inst iface_insts,
 249                         mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
 250                         mi_rules    = sortLe le_rule iface_rules,
 251
 252                         mi_vect_info = iface_vect_info,
 253
 254                         mi_fixities = fixities,
 255                         mi_warns  = warns,
 256                         mi_anns     = mkIfaceAnnotations anns,
 257                         mi_globals  = Just rdr_env,
 258
 259                         -- Left out deliberately: filled in by addVersionInfo
 260                         mi_iface_hash = fingerprint0,
 261                         mi_mod_hash  = fingerprint0,
 262                         mi_exp_hash  = fingerprint0,
 263                         mi_orphan_hash = fingerprint0,
 264                         mi_orphan    = False,   -- Always set by addVersionInfo, but
 265                                                 -- it's a strict field, so we can't omit it.
 266                         mi_finsts    = False,   -- Ditto
 267                         mi_decls     = deliberatelyOmitted "decls",
 268                         mi_hash_fn   = deliberatelyOmitted "hash_fn",
 269                         mi_hpc       = isHpcUsed hpc_info,
 270
 271                         -- And build the cached values
 272                         mi_warn_fn = mkIfaceWarnCache warns,
 273                         mi_fix_fn = mkIfaceFixCache fixities }
 274                 }
 275
 276         ; (new_iface, no_change_at_all)
 277                 <- {-# SCC "versioninfo" #-}
 278                          addFingerprints hsc_env maybe_old_fingerprint
 279                                          intermediate_iface decls
 280
 281                 -- Warn about orphans
 282         ; let orph_warnings   --- Laziness means no work done unless -fwarn-orphans
 283                 | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
 284                 | otherwise                   = emptyBag
 285               errs_and_warns = (orph_warnings, emptyBag)
 286               unqual = mkPrintUnqualified dflags rdr_env
 287               inst_warns = listToBag [ instOrphWarn unqual d
 288                                      | (d,i) <- insts `zip` iface_insts
 289                                      , isNothing (ifInstOrph i) ]
 290               rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
 291                                      | r <- iface_rules
 292                                      , isNothing (ifRuleOrph r) ]
 293
 294         ; if errorsFound dflags errs_and_warns
 295             then return ( errs_and_warns, Nothing )
 296             else do {
 297
 298 -- XXX  ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
 299
 300                 -- Debug printing
 301         ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
 302                         (pprModIface new_iface)
 303
 304                 -- bug #1617: on reload we weren't updating the PrintUnqualified
 305                 -- correctly.  This stems from the fact that the interface had
 306                 -- not changed, so addVersionInfo returns the old ModIface
 307                 -- with the old GlobalRdrEnv (mi_globals).
 308         ; let final_iface = new_iface{ mi_globals = Just rdr_env }
 309
 310         ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
 311   where
 312      r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
 313      i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2
 314      i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
 315
 316      le_occ :: Name -> Name -> Bool
 317         -- Compare lexicographically by OccName, *not* by unique, because
 318         -- the latter is not stable across compilations
 319      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
 320
 321      dflags = hsc_dflags hsc_env
 322      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
 323      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 324
 325      flattenVectInfo (VectInfo { vectInfoVar   = vVar
 326                                , vectInfoTyCon = vTyCon
 327                                }) =
 328        IfaceVectInfo {
 329          ifaceVectInfoVar        = [ Var.varName v
 330                                    | (v, _) <- varEnvElts vVar],
 331          ifaceVectInfoTyCon      = [ tyConName t
 332                                    | (t, t_v) <- nameEnvElts vTyCon
 333                                    , t /= t_v],
 334          ifaceVectInfoTyConReuse = [ tyConName t
 335                                    | (t, t_v) <- nameEnvElts vTyCon
 336                                    , t == t_v]
 337        }
 338
 339 -----------------------------
 340 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
 341 writeIfaceFile dflags location new_iface
 342     = do createDirectoryHierarchy (takeDirectory hi_file_path)
 343          writeBinIface dflags hi_file_path new_iface
 344     where hi_file_path = ml_hi_file location
 345
 346
 347 -- -----------------------------------------------------------------------------
 348 -- Look up parents and versions of Names
 349
 350 -- This is like a global version of the mi_hash_fn field in each ModIface.
 351 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
 352 -- the parent and version info.
 353
 354 mkHashFun
 355         :: HscEnv                       -- needed to look up versions
 356         -> ExternalPackageState         -- ditto
 357         -> (Name -> Fingerprint)
 358 mkHashFun hsc_env eps
 359   = \name ->
 360       let
 361         mod = ASSERT2( isExternalName name, ppr name ) nameModule name
 362         occ = nameOccName name
 363         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
 364                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
 365       in
 366         snd (mi_hash_fn iface occ `orElse`
 367                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
 368   where
 369       hpt = hsc_HPT hsc_env
 370       pit = eps_PIT eps
 371
 372 -- ---------------------------------------------------------------------------
 373 -- Compute fingerprints for the interface
 374
 375 addFingerprints
 376         :: HscEnv
 377         -> Maybe Fingerprint -- the old fingerprint, if any
 378         -> ModIface          -- The new interface (lacking decls)
 379         -> [IfaceDecl]       -- The new decls
 380         -> IO (ModIface,     -- Updated interface
 381                Bool)         -- True <=> no changes at all;
 382                              -- no need to write Iface
 383
 384 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 385  = do
 386    eps <- hscEPS hsc_env
 387    let
 388         -- the ABI of a declaration represents everything that is made
 389         -- visible about the declaration that a client can depend on.
 390         -- see IfaceDeclABI below.
 391        declABI :: IfaceDecl -> IfaceDeclABI
 392        declABI decl = (this_mod, decl, extras)
 393         where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
 394
 395        edges :: [(IfaceDeclABI, Unique, [Unique])]
 396        edges = [ (abi, getUnique (ifName decl), out)
 397                | decl <- new_decls
 398                , let abi = declABI decl
 399                , let out = localOccs $ freeNamesDeclABI abi
 400                ]
 401
 402        name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
 403        localOccs = map (getUnique . getParent . getOccName)
 404                         . filter ((== this_mod) . name_module)
 405                         . nameSetToList
 406           where getParent occ = lookupOccEnv parent_map occ `orElse` occ
 407
 408         -- maps OccNames to their parents in the current module.
 409         -- e.g. a reference to a constructor must be turned into a reference
 410         -- to the TyCon for the purposes of calculating dependencies.
 411        parent_map :: OccEnv OccName
 412        parent_map = foldr extend emptyOccEnv new_decls
 413           where extend d env =
 414                   extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
 415                   where n = ifName d
 416
 417         -- strongly-connected groups of declarations, in dependency order
 418        groups = stronglyConnCompFromEdgedVertices edges
 419
 420        global_hash_fn = mkHashFun hsc_env eps
 421
 422         -- how to output Names when generating the data to fingerprint.
 423         -- Here we want to output the fingerprint for each top-level
 424         -- Name, whether it comes from the current module or another
 425         -- module.  In this way, the fingerprint for a declaration will
 426         -- change if the fingerprint for anything it refers to (transitively)
 427         -- changes.
 428        mk_put_name :: (OccEnv (OccName,Fingerprint))
 429                    -> BinHandle -> Name -> IO  ()
 430        mk_put_name local_env bh name
 431           | isWiredInName name  =  putNameLiterally bh name
 432            -- wired-in names don't have fingerprints
 433           | otherwise
 434           = ASSERT( isExternalName name )
 435             let hash | nameModule name /= this_mod =  global_hash_fn name
 436                      | otherwise =
 437                         snd (lookupOccEnv local_env (getOccName name)
 438                            `orElse` pprPanic "urk! lookup local fingerprint"
 439                                        (ppr name)) -- (undefined,fingerprint0))
 440                 -- This panic indicates that we got the dependency
 441                 -- analysis wrong, because we needed a fingerprint for
 442                 -- an entity that wasn't in the environment.  To debug
 443                 -- it, turn the panic into a trace, uncomment the
 444                 -- pprTraces below, run the compile again, and inspect
 445                 -- the output and the generated .hi file with
 446                 -- --show-iface.
 447             in
 448             put_ bh hash
 449
 450         -- take a strongly-connected group of declarations and compute
 451         -- its fingerprint.
 452
 453        fingerprint_group :: (OccEnv (OccName,Fingerprint),
 454                              [(Fingerprint,IfaceDecl)])
 455                          -> SCC IfaceDeclABI
 456                          -> IO (OccEnv (OccName,Fingerprint),
 457                                 [(Fingerprint,IfaceDecl)])
 458
 459        fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
 460           = do let hash_fn = mk_put_name local_env
 461                    decl = abiDecl abi
 462                -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
 463                hash <- computeFingerprint dflags hash_fn abi
 464                return (extend_hash_env (hash,decl) local_env,
 465                        (hash,decl) : decls_w_hashes)
 466
 467        fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
 468           = do let decls = map abiDecl abis
 469                    local_env' = foldr extend_hash_env local_env
 470                                    (zip (repeat fingerprint0) decls)
 471                    hash_fn = mk_put_name local_env'
 472                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
 473                let stable_abis = sortBy cmp_abiNames abis
 474                 -- put the cycle in a canonical order
 475                hash <- computeFingerprint dflags hash_fn stable_abis
 476                let pairs = zip (repeat hash) decls
 477                return (foldr extend_hash_env local_env pairs,
 478                        pairs ++ decls_w_hashes)
 479
 480        extend_hash_env :: (Fingerprint,IfaceDecl)
 481                        -> OccEnv (OccName,Fingerprint)
 482                        -> OccEnv (OccName,Fingerprint)
 483        extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
 484         where
 485           decl_name = ifName d
 486           item = (decl_name, hash)
 487           env1 = extendOccEnv env0 decl_name item
 488           add_imp bndr env = extendOccEnv env bndr item
 489
 490    --
 491    (local_env, decls_w_hashes) <-
 492        foldM fingerprint_group (emptyOccEnv, []) groups
 493
 494    -- when calculating fingerprints, we always need to use canonical
 495    -- ordering for lists of things.  In particular, the mi_deps has various
 496    -- lists of modules and suchlike, so put these all in canonical order:
 497    let sorted_deps = sortDependencies (mi_deps iface0)
 498
 499    -- the export hash of a module depends on the orphan hashes of the
 500    -- orphan modules below us in the dependency tree.  This is the way
 501    -- that changes in orphans get propagated all the way up the
 502    -- dependency tree.  We only care about orphan modules in the current
 503    -- package, because changes to orphans outside this package will be
 504    -- tracked by the usage on the ABI hash of package modules that we import.
 505    let orph_mods = filter ((== this_pkg) . modulePackageId)
 506                    $ dep_orphs sorted_deps
 507    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
 508
 509    orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
 510                       (map IfaceInstABI orph_insts, orph_rules, fam_insts)
 511
 512    -- the export list hash doesn't depend on the fingerprints of
 513    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
 514    export_hash <- computeFingerprint dflags putNameLiterally
 515                       (mi_exports iface0, orphan_hash, dep_orphan_hashes)
 516
 517    -- put the declarations in a canonical order, sorted by OccName
 518    let sorted_decls = eltsFM $ listToFM $
 519                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
 520
 521    -- the ABI hash depends on:
 522    --   - decls
 523    --   - export list
 524    --   - orphans
 525    --   - deprecations
 526    --   - XXX vect info?
 527    mod_hash <- computeFingerprint dflags putNameLiterally
 528                       (map fst sorted_decls,
 529                        export_hash,
 530                        orphan_hash,
 531                        mi_warns iface0)
 532
 533    -- The interface hash depends on:
 534    --    - the ABI hash, plus
 535    --    - usages
 536    --    - deps
 537    --    - hpc
 538    iface_hash <- computeFingerprint dflags putNameLiterally
 539                       (mod_hash,
 540                        mi_usages iface0,
 541                        sorted_deps,
 542                        mi_hpc iface0)
 543
 544    let
 545     no_change_at_all = Just iface_hash == mb_old_fingerprint
 546
 547     final_iface = iface0 {
 548                 mi_mod_hash    = mod_hash,
 549                 mi_iface_hash  = iface_hash,
 550                 mi_exp_hash    = export_hash,
 551                 mi_orphan_hash = orphan_hash,
 552                 mi_orphan      = not (null orph_rules && null orph_insts),
 553                 mi_finsts      = not . null $ mi_fam_insts iface0,
 554                 mi_decls       = sorted_decls,
 555                 mi_hash_fn     = lookupOccEnv local_env }
 556    --
 557    return (final_iface, no_change_at_all)
 558
 559   where
 560     this_mod = mi_module iface0
 561     dflags = hsc_dflags hsc_env
 562     this_pkg = thisPackage dflags
 563     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
 564     (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
 565         -- ToDo: shouldn't we be splitting fam_insts into orphans and
 566         -- non-orphans?
 567     fam_insts = mi_fam_insts iface0
 568     fix_fn = mi_fix_fn iface0
 569
 570
 571 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
 572 getOrphanHashes hsc_env mods = do
 573   eps <- hscEPS hsc_env
 574   let
 575     hpt        = hsc_HPT hsc_env
 576     pit        = eps_PIT eps
 577     dflags     = hsc_dflags hsc_env
 578     get_orph_hash mod =
 579           case lookupIfaceByModule dflags hpt pit mod of
 580             Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
 581             Just iface -> mi_orphan_hash iface
 582   --
 583   return (map get_orph_hash mods)
 584
 585
 586 sortDependencies :: Dependencies -> Dependencies
 587 sortDependencies d
 588  = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
 589           dep_pkgs   = sortBy (compare `on` packageIdFS)  (dep_pkgs d),
 590           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
 591           dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
 592
 593 -- The ABI of a declaration consists of:
 594      -- the full name of the identifier (inc. module and package, because
 595      --   these are used to construct the symbol name by which the
 596      --   identifier is known externally).
 597      -- the fixity of the identifier
 598      -- the declaration itself, as exposed to clients.  That is, the
 599      --   definition of an Id is included in the fingerprint only if
 600      --   it is made available as as unfolding in the interface.
 601      -- for Ids: rules
 602      -- for classes: instances, fixity & rules for methods
 603      -- for datatypes: instances, fixity & rules for constrs
 604 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
 605
 606 abiDecl :: IfaceDeclABI -> IfaceDecl
 607 abiDecl (_, decl, _) = decl
 608
 609 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
 610 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
 611                          ifName (abiDecl abi2)
 612
 613 freeNamesDeclABI :: IfaceDeclABI -> NameSet
 614 freeNamesDeclABI (_mod, decl, extras) =
 615   freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
 616
 617 data IfaceDeclExtras
 618   = IfaceIdExtras    Fixity [IfaceRule]
 619   | IfaceDataExtras  Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
 620   | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
 621   | IfaceSynExtras   Fixity
 622   | IfaceOtherDeclExtras
 623
 624 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
 625 freeNamesDeclExtras (IfaceIdExtras    _ rules)
 626   = unionManyNameSets (map freeNamesIfRule rules)
 627 freeNamesDeclExtras (IfaceDataExtras  _ _insts subs)
 628   = unionManyNameSets (map freeNamesSub subs)
 629 freeNamesDeclExtras (IfaceClassExtras _ _insts subs)
 630   = unionManyNameSets (map freeNamesSub subs)
 631 freeNamesDeclExtras (IfaceSynExtras _)
 632   = emptyNameSet
 633 freeNamesDeclExtras IfaceOtherDeclExtras
 634   = emptyNameSet
 635
 636 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
 637 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
 638
 639 instance Binary IfaceDeclExtras where
 640   get _bh = panic "no get for IfaceDeclExtras"
 641   put_ bh (IfaceIdExtras fix rules) = do
 642    putByte bh 1; put_ bh fix; put_ bh rules
 643   put_ bh (IfaceDataExtras fix insts cons) = do
 644    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
 645   put_ bh (IfaceClassExtras fix insts methods) = do
 646    putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
 647   put_ bh (IfaceSynExtras fix) = do
 648    putByte bh 4; put_ bh fix
 649   put_ bh IfaceOtherDeclExtras = do
 650    putByte bh 5
 651
 652 declExtras :: (OccName -> Fixity)
 653            -> OccEnv [IfaceRule]
 654            -> OccEnv [IfaceInst]
 655            -> IfaceDecl
 656            -> IfaceDeclExtras
 657
 658 declExtras fix_fn rule_env inst_env decl
 659   = case decl of
 660       IfaceId{} -> IfaceIdExtras (fix_fn n)
 661                         (lookupOccEnvL rule_env n)
 662       IfaceData{ifCons=cons} ->
 663                      IfaceDataExtras (fix_fn n)
 664                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
 665                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
 666       IfaceClass{ifSigs=sigs} ->
 667                      IfaceClassExtras (fix_fn n)
 668                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
 669                         [id_extras op | IfaceClassOp op _ _ <- sigs]
 670       IfaceSyn{} -> IfaceSynExtras (fix_fn n)
 671       _other -> IfaceOtherDeclExtras
 672   where
 673         n = ifName decl
 674         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
 675
 676 --
 677 -- When hashing an instance, we hash only its structure, not the
 678 -- fingerprints of the things it mentions.  See the section on instances
 679 -- in the commentary,
 680 --    http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
 681 --
 682 newtype IfaceInstABI = IfaceInstABI IfaceInst
 683
 684 instance Binary IfaceInstABI where
 685   get = panic "no get for IfaceInstABI"
 686   put_ bh (IfaceInstABI inst) = do
 687     let ud  = getUserData bh
 688         bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
 689     put_ bh' inst
 690
 691 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
 692 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
 693
 694 -- used when we want to fingerprint a structure without depending on the
 695 -- fingerprints of external Names that it refers to.
 696 putNameLiterally :: BinHandle -> Name -> IO ()
 697 putNameLiterally bh name = ASSERT( isExternalName name )
 698   do { put_ bh $! nameModule name
 699      ; put_ bh $! nameOccName name }
 700
 701 computeFingerprint :: Binary a
 702                    => DynFlags
 703                    -> (BinHandle -> Name -> IO ())
 704                    -> a
 705                    -> IO Fingerprint
 706
 707 computeFingerprint _dflags put_name a = do
 708   bh <- openBinMem (3*1024) -- just less than a block
 709   ud <- newWriteState put_name putFS
 710   bh <- return $ setUserData bh ud
 711   put_ bh a
 712   fingerprintBinMem bh
 713
 714 {-
 715 -- for testing: use the md5sum command to generate fingerprints and
 716 -- compare the results against our built-in version.
 717   fp' <- oldMD5 dflags bh
 718   if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
 719                else return fp
 720
 721 oldMD5 dflags bh = do
 722   tmp <- newTempName dflags "bin"
 723   writeBinMem bh tmp
 724   tmp2 <- newTempName dflags "md5"
 725   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
 726   r <- system cmd
 727   case r of
 728     ExitFailure _ -> ghcError (PhaseFailed cmd r)
 729     ExitSuccess -> do
 730         hash_str <- readFile tmp2
 731         return $! readHexFingerprint hash_str
 732 -}
 733
 734 instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
 735 instOrphWarn unqual inst
 736   = mkWarnMsg (getSrcSpan inst) unqual $
 737     hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
 738
 739 ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
 740 ruleOrphWarn unqual mod rule
 741   = mkWarnMsg silly_loc unqual $
 742     ptext (sLit "Orphan rule:") <+> ppr rule
 743   where
 744     silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
 745     -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
 746     -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
 747
 748 ----------------------
 749 -- mkOrphMap partitions instance decls or rules into
 750 --      (a) an OccEnv for ones that are not orphans,
 751 --          mapping the local OccName to a list of its decls
 752 --      (b) a list of orphan decls
 753 mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
 754                                         -- Nothing for an orphan decl
 755           -> [decl]                     -- Sorted into canonical order
 756           -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
 757                                         --      each sublist in canonical order
 758               [decl])                   -- Orphan decls; in canonical order
 759 mkOrphMap get_key decls
 760   = foldl go (emptyOccEnv, []) decls
 761   where
 762     go (non_orphs, orphs) d
 763         | Just occ <- get_key d
 764         = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
 765         | otherwise = (non_orphs, d:orphs)
 766 \end{code}
 767
 768
 769 %*********************************************************
 770 %*                                                      *
 771 \subsection{Keeping track of what we've slurped, and fingerprints}
 772 %*                                                      *
 773 %*********************************************************
 774
 775
 776 \begin{code}
 777 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
 778 mkUsageInfo hsc_env this_mod dir_imp_mods used_names
 779   = do  { eps <- hscEPS hsc_env
 780         ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
 781                                      dir_imp_mods used_names
 782         ; usages `seqList`  return usages }
 783          -- seq the list of Usages returned: occasionally these
 784          -- don't get evaluated for a while and we can end up hanging on to
 785          -- the entire collection of Ifaces.
 786
 787 mk_usage_info :: PackageIfaceTable
 788               -> HscEnv
 789               -> Module
 790               -> ImportedMods
 791               -> NameSet
 792               -> [Usage]
 793 mk_usage_info pit hsc_env this_mod direct_imports used_names
 794   = mapCatMaybes mkUsage usage_mods
 795   where
 796     hpt = hsc_HPT hsc_env
 797     dflags = hsc_dflags hsc_env
 798     this_pkg = thisPackage dflags
 799
 800     used_mods    = moduleEnvKeys ent_map
 801     dir_imp_mods = (moduleEnvKeys direct_imports)
 802     all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
 803     usage_mods   = sortBy stableModuleCmp all_mods
 804                         -- canonical order is imported, to avoid interface-file
 805                         -- wobblage.
 806
 807     -- ent_map groups together all the things imported and used
 808     -- from a particular module
 809     ent_map :: ModuleEnv [OccName]
 810     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
 811      where
 812       add_mv name mv_map
 813         | isWiredInName name = mv_map  -- ignore wired-in names
 814         | otherwise
 815         = case nameModule_maybe name of
 816              Nothing  -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
 817              Just mod -> -- We use this fiddly lambda function rather than
 818                          -- (++) as the argument to extendModuleEnv_C to
 819                          -- avoid quadratic behaviour (trac #2680)
 820                          extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
 821                    where occ = nameOccName name
 822
 823     -- We want to create a Usage for a home module if
 824     --  a) we used something from it; has something in used_names
 825     --  b) we imported it, even if we used nothing from it
 826     --     (need to recompile if its export list changes: export_fprint)
 827     mkUsage :: Module -> Maybe Usage
 828     mkUsage mod
 829       | isNothing maybe_iface           -- We can't depend on it if we didn't
 830                                         -- load its interface.
 831       || mod == this_mod                -- We don't care about usages of
 832                                         -- things in *this* module
 833       = Nothing
 834
 835       | modulePackageId mod /= this_pkg
 836       = Just UsagePackageModule{ usg_mod      = mod,
 837                                  usg_mod_hash = mod_hash }
 838         -- for package modules, we record the module hash only
 839
 840       | (null used_occs
 841           && isNothing export_hash
 842           && not is_direct_import
 843           && not finsts_mod)
 844       = Nothing                 -- Record no usage info
 845         -- for directly-imported modules, we always want to record a usage
 846         -- on the orphan hash.  This is what triggers a recompilation if
 847         -- an orphan is added or removed somewhere below us in the future.
 848
 849       | otherwise
 850       = Just UsageHomeModule {
 851                       usg_mod_name = moduleName mod,
 852                       usg_mod_hash = mod_hash,
 853                       usg_exports  = export_hash,
 854                       usg_entities = fmToList ent_hashs }
 855       where
 856         maybe_iface  = lookupIfaceByModule dflags hpt pit mod
 857                 -- In one-shot mode, the interfaces for home-package
 858                 -- modules accumulate in the PIT not HPT.  Sigh.
 859
 860         is_direct_import = mod `elemModuleEnv` direct_imports
 861
 862         Just iface   = maybe_iface
 863         finsts_mod   = mi_finsts    iface
 864         hash_env     = mi_hash_fn   iface
 865         mod_hash     = mi_mod_hash  iface
 866         export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
 867                     | otherwise             = Nothing
 868
 869         used_occs = lookupModuleEnv ent_map mod `orElse` []
 870
 871         -- Making a FiniteMap here ensures that (a) we remove duplicates
 872         -- when we have usages on several subordinates of a single parent,
 873         -- and (b) that the usages emerge in a canonical order, which
 874         -- is why we use FiniteMap rather than OccEnv: FiniteMap works
 875         -- using Ord on the OccNames, which is a lexicographic ordering.
 876         ent_hashs :: FiniteMap OccName Fingerprint
 877         ent_hashs = listToFM (map lookup_occ used_occs)
 878
 879         lookup_occ occ =
 880             case hash_env occ of
 881                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
 882                 Just r  -> r
 883
 884         depend_on_exports mod =
 885            case lookupModuleEnv direct_imports mod of
 886                 Just _ -> True
 887                   -- Even if we used 'import M ()', we have to register a
 888                   -- usage on the export list because we are sensitive to
 889                   -- changes in orphan instances/rules.
 890                 Nothing -> False
 891                   -- In GHC 6.8.x the above line read "True", and in
 892                   -- fact it recorded a dependency on *all* the
 893                   -- modules underneath in the dependency tree.  This
 894                   -- happens to make orphans work right, but is too
 895                   -- expensive: it'll read too many interface files.
 896                   -- The 'isNothing maybe_iface' check above saved us
 897                   -- from generating many of these usages (at least in
 898                   -- one-shot mode), but that's even more bogus!
 899 \end{code}
 900
 901 \begin{code}
 902 mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
 903 mkIfaceAnnotations = map mkIfaceAnnotation
 904
 905 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
 906 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
 907         ifAnnotatedTarget = fmap nameOccName target,
 908         ifAnnotatedValue = serialized
 909     }
 910 \end{code}
 911
 912 \begin{code}
 913 mkIfaceExports :: [AvailInfo]
 914                -> [(Module, [GenAvailInfo OccName])]
 915                   -- Group by module and sort by occurrence
 916 mkIfaceExports exports
 917   = [ (mod, eltsFM avails)
 918     | (mod, avails) <- sortBy (stableModuleCmp `on` fst)
 919                               (moduleEnvToList groupFM)
 920                        -- NB. the fmToList is in a random order,
 921                        -- because Ord Module is not a predictable
 922                        -- ordering.  Hence we perform a final sort
 923                        -- using the stable Module ordering.
 924     ]
 925   where
 926         -- Group by the module where the exported entities are defined
 927         -- (which may not be the same for all Names in an Avail)
 928         -- Deliberately use FiniteMap rather than UniqFM so we
 929         -- get a canonical ordering
 930     groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 931     groupFM = foldl add emptyModuleEnv exports
 932
 933     add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 934             -> Module -> GenAvailInfo OccName
 935             -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 936     add_one env mod avail
 937       =  extendModuleEnv_C plusFM env mod
 938                 (unitFM (occNameFS (availName avail)) avail)
 939
 940         -- NB: we should not get T(X) and T(Y) in the export list
 941         --     else the plusFM will simply discard one!  They
 942         --     should have been combined by now.
 943     add env (Avail n)
 944       = ASSERT( isExternalName n )
 945         add_one env (nameModule n) (Avail (nameOccName n))
 946
 947     add env (AvailTC tc ns)
 948       = ASSERT( all isExternalName ns )
 949         foldl add_for_mod env mods
 950       where
 951         tc_occ = nameOccName tc
 952         mods   = nub (map nameModule ns)
 953                 -- Usually just one, but see Note [Original module]
 954
 955         add_for_mod env mod
 956             = add_one env mod (AvailTC tc_occ (sort names_from_mod))
 957               -- NB. sort the children, we need a canonical order
 958             where
 959               names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
 960 \end{code}
 961
 962 Note [Orignal module]
 963 ~~~~~~~~~~~~~~~~~~~~~
 964 Consider this:
 965         module X where { data family T }
 966         module Y( T(..) ) where { import X; data instance T Int = MkT Int }
 967 The exported Avail from Y will look like
 968         X.T{X.T, Y.MkT}
 969 That is, in Y,
 970   - only MkT is brought into scope by the data instance;
 971   - but the parent (used for grouping and naming in T(..) exports) is X.T
 972   - and in this case we export X.T too
 973
 974 In the result of MkIfaceExports, the names are grouped by defining module,
 975 so we may need to split up a single Avail into multiple ones.
 976
 977
 978 %************************************************************************
 979 %*                                                                      *
 980         Load the old interface file for this module (unless
 981         we have it aleady), and check whether it is up to date
 982
 983 %*                                                                      *
 984 %************************************************************************
 985
 986 \begin{code}
 987 checkOldIface :: HscEnv
 988               -> ModSummary
 989               -> Bool                   -- Source unchanged
 990               -> Maybe ModIface         -- Old interface from compilation manager, if any
 991               -> IO (RecompileRequired, Maybe ModIface)
 992
 993 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
 994   = do  { showPass (hsc_dflags hsc_env)
 995                    ("Checking old interface for " ++
 996                         showSDoc (ppr (ms_mod mod_summary))) ;
 997
 998         ; initIfaceCheck hsc_env $
 999           check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1000      }
1001
1002 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
1003                 -> IfG (Bool, Maybe ModIface)
1004 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1005  =  do  -- CHECK WHETHER THE SOURCE HAS CHANGED
1006     { when (not source_unchanged)
1007            (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
1008
1009      -- If the source has changed and we're in interactive mode, avoid reading
1010      -- an interface; just return the one we might have been supplied with.
1011     ; let dflags = hsc_dflags hsc_env
1012     ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1013          return (outOfDate, maybe_iface)
1014       else
1015       case maybe_iface of {
1016         Just old_iface -> do -- Use the one we already have
1017           { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1018           ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1019           ; return (recomp, Just old_iface) }
1020
1021       ; Nothing -> do
1022
1023         -- Try and read the old interface for the current module
1024         -- from the .hi file left from the last time we compiled it
1025     { let iface_path = msHiFilePath mod_summary
1026     ; read_result <- readIface (ms_mod mod_summary) iface_path False
1027     ; case read_result of {
1028          Failed err -> do       -- Old interface file not found, or garbled; give up
1029                 { traceIf (text "FYI: cannot read old interface file:"
1030                                  $$ nest 4 err)
1031                 ; return (outOfDate, Nothing) }
1032
1033       ;  Succeeded iface -> do
1034
1035         -- We have got the old iface; check its versions
1036     { traceIf (text "Read the interface file" <+> text iface_path)
1037     ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1038     ; return (recomp, Just iface)
1039     }}}}}
1040
1041 \end{code}
1042
1043 @recompileRequired@ is called from the HscMain.   It checks whether
1044 a recompilation is required.  It needs access to the persistent state,
1045 finder, etc, because it may have to load lots of interface files to
1046 check their versions.
1047
1048 \begin{code}
1049 type RecompileRequired = Bool
1050 upToDate, outOfDate :: Bool
1051 upToDate  = False       -- Recompile not required
1052 outOfDate = True        -- Recompile required
1053
1054 checkVersions :: HscEnv
1055               -> Bool           -- True <=> source unchanged
1056               -> ModSummary
1057               -> ModIface       -- Old interface
1058               -> IfG RecompileRequired
1059 checkVersions hsc_env source_unchanged mod_summary iface
1060   | not source_unchanged
1061   = return outOfDate
1062   | otherwise
1063   = do  { traceHiDiffs (text "Considering whether compilation is required for" <+>
1064                         ppr (mi_module iface) <> colon)
1065
1066         ; recomp <- checkDependencies hsc_env mod_summary iface
1067         ; if recomp then return outOfDate else do {
1068
1069         -- Source code unchanged and no errors yet... carry on
1070         --
1071         -- First put the dependent-module info, read from the old
1072         -- interface, into the envt, so that when we look for
1073         -- interfaces we look for the right one (.hi or .hi-boot)
1074         --
1075         -- It's just temporary because either the usage check will succeed
1076         -- (in which case we are done with this module) or it'll fail (in which
1077         -- case we'll compile the module from scratch anyhow).
1078         --
1079         -- We do this regardless of compilation mode, although in --make mode
1080         -- all the dependent modules should be in the HPT already, so it's
1081         -- quite redundant
1082           updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1083
1084         ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1085         ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1086     }}
1087   where
1088         -- This is a bit of a hack really
1089     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1090     mod_deps = mkModDeps (dep_mods (mi_deps iface))
1091
1092
1093 -- If the direct imports of this module are resolved to targets that
1094 -- are not among the dependencies of the previous interface file,
1095 -- then we definitely need to recompile.  This catches cases like
1096 --   - an exposed package has been upgraded
1097 --   - we are compiling with different package flags
1098 --   - a home module that was shadowing a package module has been removed
1099 --   - a new home module has been added that shadows a package module
1100 -- See bug #1372.
1101 --
1102 -- Returns True if recompilation is required.
1103 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1104 checkDependencies hsc_env summary iface
1105  = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1106   where
1107    prev_dep_mods = dep_mods (mi_deps iface)
1108    prev_dep_pkgs = dep_pkgs (mi_deps iface)
1109
1110    this_pkg = thisPackage (hsc_dflags hsc_env)
1111
1112    orM = foldr f (return False)
1113     where f m rest = do b <- m; if b then return True else rest
1114
1115    dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
1116      find_res <- liftIO $ findImportedModule hsc_env mod pkg
1117      case find_res of
1118         Found _ mod
1119           | pkg == this_pkg
1120            -> if moduleName mod `notElem` map fst prev_dep_mods
1121                  then do traceHiDiffs $
1122                            text "imported module " <> quotes (ppr mod) <>
1123                            text " not among previous dependencies"
1124                          return outOfDate
1125                  else
1126                          return upToDate
1127           | otherwise
1128            -> if pkg `notElem` prev_dep_pkgs
1129                  then do traceHiDiffs $
1130                            text "imported module " <> quotes (ppr mod) <>
1131                            text " is from package " <> quotes (ppr pkg) <>
1132                            text ", which is not among previous dependencies"
1133                          return outOfDate
1134                  else
1135                          return upToDate
1136            where pkg = modulePackageId mod
1137         _otherwise  -> return outOfDate
1138
1139 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1140               -> IfG RecompileRequired
1141 needInterface mod continue
1142   = do  -- Load the imported interface if possible
1143     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1144     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1145
1146     mb_iface <- loadInterface doc_str mod ImportBySystem
1147         -- Load the interface, but don't complain on failure;
1148         -- Instead, get an Either back which we can test
1149
1150     case mb_iface of
1151       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1152                                       ppr mod]))
1153                   -- Couldn't find or parse a module mentioned in the
1154                   -- old interface file.  Don't complain: it might
1155                   -- just be that the current module doesn't need that
1156                   -- import and it's been deleted
1157       Succeeded iface -> continue iface
1158
1159
1160 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1161 -- Given the usage information extracted from the old
1162 -- M.hi file for the module being compiled, figure out
1163 -- whether M needs to be recompiled.
1164
1165 checkModUsage _this_pkg UsagePackageModule{
1166                                 usg_mod = mod,
1167                                 usg_mod_hash = old_mod_hash }
1168   = needInterface mod $ \iface -> do
1169     checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1170         -- We only track the ABI hash of package modules, rather than
1171         -- individual entity usages, so if the ABI hash changes we must
1172         -- recompile.  This is safe but may entail more recompilation when
1173         -- a dependent package has changed.
1174
1175 checkModUsage this_pkg UsageHomeModule{
1176                                 usg_mod_name = mod_name,
1177                                 usg_mod_hash = old_mod_hash,
1178                                 usg_exports = maybe_old_export_hash,
1179                                 usg_entities = old_decl_hash }
1180   = do
1181     let mod = mkModule this_pkg mod_name
1182     needInterface mod $ \iface -> do
1183
1184     let
1185         new_mod_hash    = mi_mod_hash    iface
1186         new_decl_hash   = mi_hash_fn     iface
1187         new_export_hash = mi_exp_hash    iface
1188
1189         -- CHECK MODULE
1190     recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1191     if not recompile then return upToDate else do
1192
1193         -- CHECK EXPORT LIST
1194     checkMaybeHash maybe_old_export_hash new_export_hash
1195         (ptext (sLit "  Export list changed")) $ do
1196
1197         -- CHECK ITEMS ONE BY ONE
1198     recompile <- checkList [ checkEntityUsage new_decl_hash u
1199                            | u <- old_decl_hash]
1200     if recompile
1201       then return outOfDate     -- This one failed, so just bail out now
1202       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
1203
1204 ------------------------
1205 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1206 checkModuleFingerprint old_mod_hash new_mod_hash
1207   | new_mod_hash == old_mod_hash
1208   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1209
1210   | otherwise
1211   = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
1212                      old_mod_hash new_mod_hash
1213
1214 ------------------------
1215 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1216                -> IfG RecompileRequired -> IfG RecompileRequired
1217 checkMaybeHash maybe_old_hash new_hash doc continue
1218   | Just hash <- maybe_old_hash, hash /= new_hash
1219   = out_of_date_hash doc hash new_hash
1220   | otherwise
1221   = continue
1222
1223 ------------------------
1224 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1225                  -> (OccName, Fingerprint)
1226                  -> IfG Bool
1227 checkEntityUsage new_hash (name,old_hash)
1228   = case new_hash name of
1229
1230         Nothing       ->        -- We used it before, but it ain't there now
1231                           out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1232
1233         Just (_, new_hash)      -- It's there, but is it up to date?
1234           | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
1235                                        return upToDate
1236           | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
1237                                                      old_hash new_hash
1238
1239 up_to_date, out_of_date :: SDoc -> IfG Bool
1240 up_to_date  msg = traceHiDiffs msg >> return upToDate
1241 out_of_date msg = traceHiDiffs msg >> return outOfDate
1242
1243 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1244 out_of_date_hash msg old_hash new_hash
1245   = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1246
1247 ----------------------
1248 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1249 -- This helper is used in two places
1250 checkList []             = return upToDate
1251 checkList (check:checks) = do recompile <- check
1252                               if recompile
1253                                 then return outOfDate
1254                                 else checkList checks
1255 \end{code}
1256
1257 %************************************************************************
1258 %*                                                                      *
1259                 Converting things to their Iface equivalents
1260 %*                                                                      *
1261 %************************************************************************
1262
1263 \begin{code}
1264 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1265 -- Assumption: the thing is already tidied, so that locally-bound names
1266 --             (lambdas, for-alls) already have non-clashing OccNames
1267 -- Reason: Iface stuff uses OccNames, and the conversion here does
1268 --         not do tidying on the way
1269 tyThingToIfaceDecl (AnId id)
1270   = IfaceId { ifName      = getOccName id,
1271               ifType      = toIfaceType (idType id),
1272               ifIdDetails = toIfaceIdDetails (idDetails id),
1273               ifIdInfo    = info }
1274   where
1275     info = case toIfaceIdInfo (idInfo id) of
1276                 []    -> NoInfo
1277                 items -> HasInfo items
1278
1279 tyThingToIfaceDecl (AClass clas)
1280   = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
1281                  ifName   = getOccName clas,
1282                  ifTyVars = toIfaceTvBndrs clas_tyvars,
1283                  ifFDs    = map toIfaceFD clas_fds,
1284                  ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1285                  ifSigs   = map toIfaceClassOp op_stuff,
1286                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1287   where
1288     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1289       = classExtraBigSig clas
1290     tycon = classTyCon clas
1291
1292     toIfaceClassOp (sel_id, def_meth)
1293         = ASSERT(sel_tyvars == clas_tyvars)
1294           IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1295         where
1296                 -- Be careful when splitting the type, because of things
1297                 -- like         class Foo a where
1298                 --                op :: (?x :: String) => a -> a
1299                 -- and          class Baz a where
1300                 --                op :: (Ord a) => a -> a
1301           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1302           op_ty                = funResultTy rho_ty
1303
1304     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1305
1306 tyThingToIfaceDecl (ATyCon tycon)
1307   | isSynTyCon tycon
1308   = IfaceSyn {  ifName    = getOccName tycon,
1309                 ifTyVars  = toIfaceTvBndrs tyvars,
1310                 ifSynRhs  = syn_rhs,
1311                 ifSynKind = syn_ki,
1312                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1313              }
1314
1315   | isAlgTyCon tycon
1316   = IfaceData { ifName    = getOccName tycon,
1317                 ifTyVars  = toIfaceTvBndrs tyvars,
1318                 ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
1319                 ifCons    = ifaceConDecls (algTyConRhs tycon),
1320                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
1321                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1322                 ifGeneric = tyConHasGenerics tycon,
1323                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1324
1325   | isForeignTyCon tycon
1326   = IfaceForeign { ifName    = getOccName tycon,
1327                    ifExtName = tyConExtName tycon }
1328
1329   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1330   where
1331     tyvars = tyConTyVars tycon
1332     (syn_rhs, syn_ki)
1333        = case synTyConRhs tycon of
1334             OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
1335             SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1336
1337     ifaceConDecls (NewTyCon { data_con = con })     =
1338       IfNewTyCon  (ifaceConDecl con)
1339     ifaceConDecls (DataTyCon { data_cons = cons })  =
1340       IfDataTyCon (map ifaceConDecl cons)
1341     ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
1342     ifaceConDecls AbstractTyCon                     = IfAbstractTyCon
1343         -- The last case happens when a TyCon has been trimmed during tidying
1344         -- Furthermore, tyThingToIfaceDecl is also used
1345         -- in TcRnDriver for GHCi, when browsing a module, in which case the
1346         -- AbstractTyCon case is perfectly sensible.
1347
1348     ifaceConDecl data_con
1349         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
1350                     ifConInfix   = dataConIsInfix data_con,
1351                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
1352                     ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1353                     ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
1354                     ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
1355                     ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1356                     ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
1357                     ifConFields  = map getOccName
1358                                        (dataConFieldLabels data_con),
1359                     ifConStricts = dataConStrictMarks data_con }
1360
1361     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1362
1363     famInstToIface Nothing                    = Nothing
1364     famInstToIface (Just (famTyCon, instTys)) =
1365       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1366
1367 tyThingToIfaceDecl (ADataCon dc)
1368  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
1369
1370
1371 getFS :: NamedThing a => a -> FastString
1372 getFS x = occNameFS (getOccName x)
1373
1374 --------------------------
1375 instanceToIfaceInst :: Instance -> IfaceInst
1376 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1377                                 is_cls = cls_name, is_tcs = mb_tcs })
1378   = ASSERT( cls_name == className cls )
1379     IfaceInst { ifDFun    = dfun_name,
1380                 ifOFlag   = oflag,
1381                 ifInstCls = cls_name,
1382                 ifInstTys = map do_rough mb_tcs,
1383                 ifInstOrph = orph }
1384   where
1385     do_rough Nothing  = Nothing
1386     do_rough (Just n) = Just (toIfaceTyCon_name n)
1387
1388     dfun_name = idName dfun_id
1389     mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1390     is_local name = nameIsLocalOrFrom mod name
1391
1392         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1393     (_, cls, tys) = tcSplitDFunTy (idType dfun_id)
1394                 -- Slightly awkward: we need the Class to get the fundeps
1395     (tvs, fds) = classTvsFds cls
1396     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1397     orph | is_local cls_name = Just (nameOccName cls_name)
1398          | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
1399          | otherwise         = Nothing
1400
1401     mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
1402                                 -- that is not in the "determined" arguments
1403     mb_ns | null fds   = [choose_one arg_names]
1404           | otherwise  = map do_one fds
1405     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1406                                           , not (tv `elem` rtvs)]
1407
1408     choose_one :: [NameSet] -> Maybe OccName
1409     choose_one nss = case nameSetToList (unionManyNameSets nss) of
1410                         []      -> Nothing
1411                         (n : _) -> Just (nameOccName n)
1412
1413 --------------------------
1414 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1415 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1416                                  fi_fam = fam,
1417                                  fi_tcs = mb_tcs })
1418   = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
1419                  , ifFamInstFam    = fam
1420                  , ifFamInstTys    = map do_rough mb_tcs }
1421   where
1422     do_rough Nothing  = Nothing
1423     do_rough (Just n) = Just (toIfaceTyCon_name n)
1424
1425 --------------------------
1426 toIfaceLetBndr :: Id -> IfaceLetBndr
1427 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
1428                                (toIfaceType (idType id))
1429                                prag_info
1430   where
1431         -- Stripped-down version of tcIfaceIdInfo
1432         -- Change this if you want to export more IdInfo for
1433         -- non-top-level Ids.  Don't forget to change
1434         -- CoreTidy.tidyLetBndr too!
1435         --
1436         -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1437     id_info = idInfo id
1438     inline_prag = inlinePragInfo id_info
1439     prag_info | isDefaultInlinePragma inline_prag = NoInfo
1440               | otherwise                         = HasInfo [HsInline inline_prag]
1441
1442 --------------------------
1443 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1444 toIfaceIdDetails VanillaId                      = IfVanillaId
1445 toIfaceIdDetails (DFunId {})                    = IfDFunId
1446 toIfaceIdDetails (RecSelId { sel_naughty = n
1447                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
1448 toIfaceIdDetails other                          = pprTrace "toIfaceIdDetails" (ppr other)
1449                                                   IfVanillaId   -- Unexpected
1450
1451 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1452 toIfaceIdInfo id_info
1453   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1454                inline_hsinfo,  unfold_hsinfo]
1455   where
1456     ------------  Arity  --------------
1457     arity_info = arityInfo id_info
1458     arity_hsinfo | arity_info == 0 = Nothing
1459                  | otherwise       = Just (HsArity arity_info)
1460
1461     ------------ Caf Info --------------
1462     caf_info   = cafInfo id_info
1463     caf_hsinfo = case caf_info of
1464                    NoCafRefs -> Just HsNoCafRefs
1465                    _other    -> Nothing
1466
1467     ------------  Strictness  --------------
1468         -- No point in explicitly exporting TopSig
1469     strict_hsinfo = case strictnessInfo id_info of
1470                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1471                         _other                        -> Nothing
1472
1473     ------------  Unfolding  --------------
1474     unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
1475     loop_breaker  = isNonRuleLoopBreaker (occInfo id_info)
1476
1477     ------------  Inline prag  --------------
1478     inline_prag = inlinePragInfo id_info
1479     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1480                   | otherwise = Just (HsInline inline_prag)
1481
1482 --------------------------
1483 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
1484 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
1485   = case guidance of
1486         InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w)))
1487         InlineRule { ir_sat = InlSat }        -> Just (HsUnfold lb (IfInlineRule arity True  (toIfaceExpr rhs)))
1488         InlineRule { ir_sat = InlUnSat }      -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs)))
1489         UnfoldIfGoodArgs {} -> vanilla_unfold
1490         UnfoldNever         -> vanilla_unfold   -- Yes, even if guidance is UnfoldNever, expose the unfolding
1491                                                 -- If we didn't want to expose the unfolding, TidyPgm would
1492                                                 -- have stuck in NoUnfolding.  For supercompilation we want
1493                                                 -- to see that unfolding!
1494   where
1495     vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
1496
1497 toIfUnfolding lb (DFunUnfolding _con ops)
1498   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
1499       -- No need to serialise the data constructor;
1500       -- we can recover it from the type of the dfun
1501 toIfUnfolding _ _
1502   = Nothing
1503
1504 --------------------------
1505 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1506 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1507   = pprTrace "toHsRule: builtin" (ppr fn) $
1508     bogusIfaceRule fn
1509
1510 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
1511                                 ru_act = act, ru_bndrs = bndrs,
1512                                 ru_args = args, ru_rhs = rhs })
1513   = IfaceRule { ifRuleName  = name, ifActivation = act,
1514                 ifRuleBndrs = map toIfaceBndr bndrs,
1515                 ifRuleHead  = fn,
1516                 ifRuleArgs  = map do_arg args,
1517                 ifRuleRhs   = toIfaceExpr rhs,
1518                 ifRuleOrph  = orph }
1519   where
1520         -- For type args we must remove synonyms from the outermost
1521         -- level.  Reason: so that when we read it back in we'll
1522         -- construct the same ru_rough field as we have right now;
1523         -- see tcIfaceRule
1524     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1525     do_arg arg       = toIfaceExpr arg
1526
1527         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1528         -- A rule is an orphan only if none of the variables
1529         -- mentioned on its left-hand side are locally defined
1530     lhs_names = fn : nameSetToList (exprsFreeNames args)
1531                 -- No need to delete bndrs, because
1532                 -- exprsFreeNames finds only External names
1533
1534     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1535                         (n : _) -> Just (nameOccName n)
1536                         []      -> Nothing
1537
1538 bogusIfaceRule :: Name -> IfaceRule
1539 bogusIfaceRule id_name
1540   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1541         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1542         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1543
1544 ---------------------
1545 toIfaceExpr :: CoreExpr -> IfaceExpr
1546 toIfaceExpr (Var v)       = toIfaceVar v
1547 toIfaceExpr (Lit l)       = IfaceLit l
1548 toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
1549 toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1550 toIfaceExpr (App f a)     = toIfaceApp f [a]
1551 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1552 toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1553 toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
1554 toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1555
1556 ---------------------
1557 toIfaceNote :: Note -> IfaceNote
1558 toIfaceNote (SCC cc)      = IfaceSCC cc
1559 toIfaceNote (CoreNote s)  = IfaceCoreNote s
1560
1561 ---------------------
1562 toIfaceBind :: Bind Id -> IfaceBinding
1563 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1564 toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1565
1566 ---------------------
1567 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1568            -> (IfaceConAlt, [FastString], IfaceExpr)
1569 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1570
1571 ---------------------
1572 toIfaceCon :: AltCon -> IfaceConAlt
1573 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1574                         | otherwise       = IfaceDataAlt (getName dc)
1575                         where
1576                           tc = dataConTyCon dc
1577
1578 toIfaceCon (LitAlt l) = IfaceLitAlt l
1579 toIfaceCon DEFAULT    = IfaceDefault
1580
1581 ---------------------
1582 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1583 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1584 toIfaceApp (Var v) as
1585   = case isDataConWorkId_maybe v of
1586         -- We convert the *worker* for tuples into IfaceTuples
1587         Just dc |  isTupleTyCon tc && saturated
1588                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1589           where
1590             val_args  = dropWhile isTypeArg as
1591             saturated = val_args `lengthIs` idArity v
1592             tup_args  = map toIfaceExpr val_args
1593             tc        = dataConTyCon dc
1594
1595         _ -> mkIfaceApps (toIfaceVar v) as
1596
1597 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1598
1599 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1600 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1601
1602 ---------------------
1603 toIfaceVar :: Id -> IfaceExpr
1604 toIfaceVar v
1605   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1606           -- Foreign calls have special syntax
1607   | isExternalName name             = IfaceExt name
1608   | Just (TickBox m ix) <- isTickBoxOp_maybe v
1609                                     = IfaceTick m ix
1610   | otherwise                       = IfaceLcl (getFS name)
1611   where
1612     name = idName v
1613 \end{code}