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