Use stable ordering in the dependencies
[ghc.git] / 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         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 = ASSERT( isExternalName 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 dependeny 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 0)
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) (fmToList groupFM)
919                        -- NB. the fmToList is in a random order,
920                        -- because Ord Module is not a predictable
921                        -- ordering.  Hence we perform a final sort
922                        -- using the stable Module ordering.
923     ]
924   where
925         -- Group by the module where the exported entities are defined
926         -- (which may not be the same for all Names in an Avail)
927         -- Deliberately use FiniteMap rather than UniqFM so we
928         -- get a canonical ordering
929     groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
930     groupFM = foldl add emptyModuleEnv exports
931
932     add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
933             -> Module -> GenAvailInfo OccName
934             -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
935     add_one env mod avail 
936       =  extendModuleEnv_C plusFM env mod 
937                 (unitFM (occNameFS (availName avail)) avail)
938
939         -- NB: we should not get T(X) and T(Y) in the export list
940         --     else the plusFM will simply discard one!  They
941         --     should have been combined by now.
942     add env (Avail n)
943       = ASSERT( isExternalName n ) 
944         add_one env (nameModule n) (Avail (nameOccName n))
945
946     add env (AvailTC tc ns)
947       = ASSERT( all isExternalName ns ) 
948         foldl add_for_mod env mods
949       where
950         tc_occ = nameOccName tc
951         mods   = nub (map nameModule ns)
952                 -- Usually just one, but see Note [Original module]
953
954         add_for_mod env mod
955             = add_one env mod (AvailTC tc_occ (sort names_from_mod))
956               -- NB. sort the children, we need a canonical order
957             where
958               names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
959 \end{code}
960
961 Note [Orignal module]
962 ~~~~~~~~~~~~~~~~~~~~~
963 Consider this:
964         module X where { data family T }
965         module Y( T(..) ) where { import X; data instance T Int = MkT Int }
966 The exported Avail from Y will look like
967         X.T{X.T, Y.MkT}
968 That is, in Y, 
969   - only MkT is brought into scope by the data instance;
970   - but the parent (used for grouping and naming in T(..) exports) is X.T
971   - and in this case we export X.T too
972
973 In the result of MkIfaceExports, the names are grouped by defining module,
974 so we may need to split up a single Avail into multiple ones.
975
976
977 %************************************************************************
978 %*                                                                      *
979         Load the old interface file for this module (unless
980         we have it aleady), and check whether it is up to date
981         
982 %*                                                                      *
983 %************************************************************************
984
985 \begin{code}
986 checkOldIface :: HscEnv
987               -> ModSummary
988               -> Bool                   -- Source unchanged
989               -> Maybe ModIface         -- Old interface from compilation manager, if any
990               -> IO (RecompileRequired, Maybe ModIface)
991
992 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
993   = do  { showPass (hsc_dflags hsc_env) 
994                    ("Checking old interface for " ++ 
995                         showSDoc (ppr (ms_mod mod_summary))) ;
996
997         ; initIfaceCheck hsc_env $
998           check_old_iface hsc_env mod_summary source_unchanged maybe_iface
999      }
1000
1001 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
1002                 -> IfG (Bool, Maybe ModIface)
1003 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1004  =  do  -- CHECK WHETHER THE SOURCE HAS CHANGED
1005     { when (not source_unchanged)
1006            (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
1007
1008      -- If the source has changed and we're in interactive mode, avoid reading
1009      -- an interface; just return the one we might have been supplied with.
1010     ; let dflags = hsc_dflags hsc_env
1011     ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1012          return (outOfDate, maybe_iface)
1013       else
1014       case maybe_iface of {
1015         Just old_iface -> do -- Use the one we already have
1016           { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1017           ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1018           ; return (recomp, Just old_iface) }
1019
1020       ; Nothing -> do
1021
1022         -- Try and read the old interface for the current module
1023         -- from the .hi file left from the last time we compiled it
1024     { let iface_path = msHiFilePath mod_summary
1025     ; read_result <- readIface (ms_mod mod_summary) iface_path False
1026     ; case read_result of {
1027          Failed err -> do       -- Old interface file not found, or garbled; give up
1028                 { traceIf (text "FYI: cannot read old interface file:"
1029                                  $$ nest 4 err)
1030                 ; return (outOfDate, Nothing) }
1031
1032       ;  Succeeded iface -> do
1033
1034         -- We have got the old iface; check its versions
1035     { traceIf (text "Read the interface file" <+> text iface_path)
1036     ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1037     ; return (recomp, Just iface)
1038     }}}}}
1039
1040 \end{code}
1041
1042 @recompileRequired@ is called from the HscMain.   It checks whether
1043 a recompilation is required.  It needs access to the persistent state,
1044 finder, etc, because it may have to load lots of interface files to
1045 check their versions.
1046
1047 \begin{code}
1048 type RecompileRequired = Bool
1049 upToDate, outOfDate :: Bool
1050 upToDate  = False       -- Recompile not required
1051 outOfDate = True        -- Recompile required
1052
1053 checkVersions :: HscEnv
1054               -> Bool           -- True <=> source unchanged
1055               -> ModSummary
1056               -> ModIface       -- Old interface
1057               -> IfG RecompileRequired
1058 checkVersions hsc_env source_unchanged mod_summary iface
1059   | not source_unchanged
1060   = return outOfDate
1061   | otherwise
1062   = do  { traceHiDiffs (text "Considering whether compilation is required for" <+> 
1063                         ppr (mi_module iface) <> colon)
1064
1065         ; recomp <- checkDependencies hsc_env mod_summary iface
1066         ; if recomp then return outOfDate else do {
1067
1068         -- Source code unchanged and no errors yet... carry on 
1069         --
1070         -- First put the dependent-module info, read from the old
1071         -- interface, into the envt, so that when we look for
1072         -- interfaces we look for the right one (.hi or .hi-boot)
1073         -- 
1074         -- It's just temporary because either the usage check will succeed 
1075         -- (in which case we are done with this module) or it'll fail (in which
1076         -- case we'll compile the module from scratch anyhow).
1077         --      
1078         -- We do this regardless of compilation mode, although in --make mode
1079         -- all the dependent modules should be in the HPT already, so it's
1080         -- quite redundant
1081           updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1082
1083         ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1084         ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1085     }}
1086   where
1087         -- This is a bit of a hack really
1088     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1089     mod_deps = mkModDeps (dep_mods (mi_deps iface))
1090
1091
1092 -- If the direct imports of this module are resolved to targets that
1093 -- are not among the dependencies of the previous interface file,
1094 -- then we definitely need to recompile.  This catches cases like
1095 --   - an exposed package has been upgraded
1096 --   - we are compiling with different package flags
1097 --   - a home module that was shadowing a package module has been removed
1098 --   - a new home module has been added that shadows a package module
1099 -- See bug #1372.
1100 --
1101 -- Returns True if recompilation is required.
1102 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1103 checkDependencies hsc_env summary iface
1104  = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1105   where
1106    prev_dep_mods = dep_mods (mi_deps iface)
1107    prev_dep_pkgs = dep_pkgs (mi_deps iface)
1108
1109    this_pkg = thisPackage (hsc_dflags hsc_env)
1110
1111    orM = foldr f (return False)
1112     where f m rest = do b <- m; if b then return True else rest
1113
1114    dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
1115      find_res <- liftIO $ findImportedModule hsc_env mod pkg
1116      case find_res of
1117         Found _ mod
1118           | pkg == this_pkg
1119            -> if moduleName mod `notElem` map fst prev_dep_mods
1120                  then do traceHiDiffs $
1121                            text "imported module " <> quotes (ppr mod) <>
1122                            text " not among previous dependencies"
1123                          return outOfDate
1124                  else
1125                          return upToDate
1126           | otherwise
1127            -> if pkg `notElem` prev_dep_pkgs
1128                  then do traceHiDiffs $
1129                            text "imported module " <> quotes (ppr mod) <>
1130                            text " is from package " <> quotes (ppr pkg) <>
1131                            text ", which is not among previous dependencies"
1132                          return outOfDate
1133                  else
1134                          return upToDate
1135            where pkg = modulePackageId mod
1136         _otherwise  -> return outOfDate
1137
1138 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1139               -> IfG RecompileRequired
1140 needInterface mod continue
1141   = do  -- Load the imported interface if possible
1142     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1143     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1144
1145     mb_iface <- loadInterface doc_str mod ImportBySystem
1146         -- Load the interface, but don't complain on failure;
1147         -- Instead, get an Either back which we can test
1148
1149     case mb_iface of
1150       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1151                                       ppr mod]))
1152                   -- Couldn't find or parse a module mentioned in the
1153                   -- old interface file.  Don't complain: it might
1154                   -- just be that the current module doesn't need that
1155                   -- import and it's been deleted
1156       Succeeded iface -> continue iface
1157
1158
1159 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1160 -- Given the usage information extracted from the old
1161 -- M.hi file for the module being compiled, figure out
1162 -- whether M needs to be recompiled.
1163
1164 checkModUsage _this_pkg UsagePackageModule{
1165                                 usg_mod = mod,
1166                                 usg_mod_hash = old_mod_hash }
1167   = needInterface mod $ \iface -> do
1168     checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1169         -- We only track the ABI hash of package modules, rather than
1170         -- individual entity usages, so if the ABI hash changes we must
1171         -- recompile.  This is safe but may entail more recompilation when
1172         -- a dependent package has changed.
1173
1174 checkModUsage this_pkg UsageHomeModule{ 
1175                                 usg_mod_name = mod_name, 
1176                                 usg_mod_hash = old_mod_hash,
1177                                 usg_exports = maybe_old_export_hash,
1178                                 usg_entities = old_decl_hash }
1179   = do
1180     let mod = mkModule this_pkg mod_name
1181     needInterface mod $ \iface -> do
1182
1183     let
1184         new_mod_hash    = mi_mod_hash    iface
1185         new_decl_hash   = mi_hash_fn     iface
1186         new_export_hash = mi_exp_hash    iface
1187
1188         -- CHECK MODULE
1189     recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1190     if not recompile then return upToDate else do
1191                                  
1192         -- CHECK EXPORT LIST
1193     checkMaybeHash maybe_old_export_hash new_export_hash
1194         (ptext (sLit "  Export list changed")) $ do
1195
1196         -- CHECK ITEMS ONE BY ONE
1197     recompile <- checkList [ checkEntityUsage new_decl_hash u 
1198                            | u <- old_decl_hash]
1199     if recompile 
1200       then return outOfDate     -- This one failed, so just bail out now
1201       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
1202
1203 ------------------------
1204 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1205 checkModuleFingerprint old_mod_hash new_mod_hash
1206   | new_mod_hash == old_mod_hash
1207   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1208
1209   | otherwise
1210   = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
1211                      old_mod_hash new_mod_hash
1212
1213 ------------------------
1214 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1215                -> IfG RecompileRequired -> IfG RecompileRequired
1216 checkMaybeHash maybe_old_hash new_hash doc continue
1217   | Just hash <- maybe_old_hash, hash /= new_hash
1218   = out_of_date_hash doc hash new_hash
1219   | otherwise
1220   = continue
1221
1222 ------------------------
1223 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1224                  -> (OccName, Fingerprint)
1225                  -> IfG Bool
1226 checkEntityUsage new_hash (name,old_hash)
1227   = case new_hash name of
1228
1229         Nothing       ->        -- We used it before, but it ain't there now
1230                           out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1231
1232         Just (_, new_hash)      -- It's there, but is it up to date?
1233           | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
1234                                        return upToDate
1235           | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
1236                                                      old_hash new_hash
1237
1238 up_to_date, out_of_date :: SDoc -> IfG Bool
1239 up_to_date  msg = traceHiDiffs msg >> return upToDate
1240 out_of_date msg = traceHiDiffs msg >> return outOfDate
1241
1242 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1243 out_of_date_hash msg old_hash new_hash 
1244   = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1245
1246 ----------------------
1247 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1248 -- This helper is used in two places
1249 checkList []             = return upToDate
1250 checkList (check:checks) = do recompile <- check
1251                               if recompile
1252                                 then return outOfDate
1253                                 else checkList checks
1254 \end{code}
1255
1256 %************************************************************************
1257 %*                                                                      *
1258                 Converting things to their Iface equivalents
1259 %*                                                                      *
1260 %************************************************************************
1261
1262 \begin{code}
1263 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1264 -- Assumption: the thing is already tidied, so that locally-bound names
1265 --             (lambdas, for-alls) already have non-clashing OccNames
1266 -- Reason: Iface stuff uses OccNames, and the conversion here does
1267 --         not do tidying on the way
1268 tyThingToIfaceDecl (AnId id)
1269   = IfaceId { ifName      = getOccName id,
1270               ifType      = toIfaceType (idType id),
1271               ifIdDetails = toIfaceIdDetails (idDetails id),
1272               ifIdInfo    = info }
1273   where
1274     info = case toIfaceIdInfo (idInfo id) of
1275                 []    -> NoInfo
1276                 items -> HasInfo items
1277
1278 tyThingToIfaceDecl (AClass clas)
1279   = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
1280                  ifName   = getOccName clas,
1281                  ifTyVars = toIfaceTvBndrs clas_tyvars,
1282                  ifFDs    = map toIfaceFD clas_fds,
1283                  ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1284                  ifSigs   = map toIfaceClassOp op_stuff,
1285                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1286   where
1287     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
1288       = classExtraBigSig clas
1289     tycon = classTyCon clas
1290
1291     toIfaceClassOp (sel_id, def_meth)
1292         = ASSERT(sel_tyvars == clas_tyvars)
1293           IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1294         where
1295                 -- Be careful when splitting the type, because of things
1296                 -- like         class Foo a where
1297                 --                op :: (?x :: String) => a -> a
1298                 -- and          class Baz a where
1299                 --                op :: (Ord a) => a -> a
1300           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1301           op_ty                = funResultTy rho_ty
1302
1303     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1304
1305 tyThingToIfaceDecl (ATyCon tycon)
1306   | isSynTyCon tycon
1307   = IfaceSyn {  ifName    = getOccName tycon,
1308                 ifTyVars  = toIfaceTvBndrs tyvars,
1309                 ifSynRhs  = syn_rhs,
1310                 ifSynKind = syn_ki,
1311                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1312              }
1313
1314   | isAlgTyCon tycon
1315   = IfaceData { ifName    = getOccName tycon,
1316                 ifTyVars  = toIfaceTvBndrs tyvars,
1317                 ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
1318                 ifCons    = ifaceConDecls (algTyConRhs tycon),
1319                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
1320                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1321                 ifGeneric = tyConHasGenerics tycon,
1322                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1323
1324   | isForeignTyCon tycon
1325   = IfaceForeign { ifName    = getOccName tycon,
1326                    ifExtName = tyConExtName tycon }
1327
1328   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1329   where
1330     tyvars = tyConTyVars tycon
1331     (syn_rhs, syn_ki) 
1332        = case synTyConRhs tycon of
1333             OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
1334             SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1335
1336     ifaceConDecls (NewTyCon { data_con = con })     = 
1337       IfNewTyCon  (ifaceConDecl con)
1338     ifaceConDecls (DataTyCon { data_cons = cons })  = 
1339       IfDataTyCon (map ifaceConDecl cons)
1340     ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
1341     ifaceConDecls AbstractTyCon                     = IfAbstractTyCon
1342         -- The last case happens when a TyCon has been trimmed during tidying
1343         -- Furthermore, tyThingToIfaceDecl is also used
1344         -- in TcRnDriver for GHCi, when browsing a module, in which case the
1345         -- AbstractTyCon case is perfectly sensible.
1346
1347     ifaceConDecl data_con 
1348         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
1349                     ifConInfix   = dataConIsInfix data_con,
1350                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
1351                     ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1352                     ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
1353                     ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
1354                     ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1355                     ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
1356                     ifConFields  = map getOccName 
1357                                        (dataConFieldLabels data_con),
1358                     ifConStricts = dataConStrictMarks data_con }
1359
1360     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1361
1362     famInstToIface Nothing                    = Nothing
1363     famInstToIface (Just (famTyCon, instTys)) = 
1364       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1365
1366 tyThingToIfaceDecl (ADataCon dc)
1367  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
1368
1369
1370 getFS :: NamedThing a => a -> FastString
1371 getFS x = occNameFS (getOccName x)
1372
1373 --------------------------
1374 instanceToIfaceInst :: Instance -> IfaceInst
1375 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1376                                 is_cls = cls_name, is_tcs = mb_tcs })
1377   = ASSERT( cls_name == className cls )
1378     IfaceInst { ifDFun    = dfun_name,
1379                 ifOFlag   = oflag,
1380                 ifInstCls = cls_name,
1381                 ifInstTys = map do_rough mb_tcs,
1382                 ifInstOrph = orph }
1383   where
1384     do_rough Nothing  = Nothing
1385     do_rough (Just n) = Just (toIfaceTyCon_name n)
1386
1387     dfun_name = idName dfun_id
1388     mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1389     is_local name = nameIsLocalOrFrom mod name
1390
1391         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1392     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1393                 -- Slightly awkward: we need the Class to get the fundeps
1394     (tvs, fds) = classTvsFds cls
1395     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1396     orph | is_local cls_name = Just (nameOccName cls_name)
1397          | all isJust mb_ns  = head mb_ns
1398          | otherwise         = Nothing
1399     
1400     mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
1401                                 -- that is not in the "determined" arguments
1402     mb_ns | null fds   = [choose_one arg_names]
1403           | otherwise  = map do_one fds
1404     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1405                                           , not (tv `elem` rtvs)]
1406
1407     choose_one :: [NameSet] -> Maybe OccName
1408     choose_one nss = case nameSetToList (unionManyNameSets nss) of
1409                         []      -> Nothing
1410                         (n : _) -> Just (nameOccName n)
1411
1412 --------------------------
1413 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1414 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1415                                  fi_fam = fam,
1416                                  fi_tcs = mb_tcs })
1417   = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
1418                  , ifFamInstFam    = fam
1419                  , ifFamInstTys    = map do_rough mb_tcs }
1420   where
1421     do_rough Nothing  = Nothing
1422     do_rough (Just n) = Just (toIfaceTyCon_name n)
1423
1424 --------------------------
1425 toIfaceLetBndr :: Id -> IfaceLetBndr
1426 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
1427                                (toIfaceType (idType id)) 
1428                                prag_info
1429   where
1430         -- Stripped-down version of tcIfaceIdInfo
1431         -- Change this if you want to export more IdInfo for
1432         -- non-top-level Ids.  Don't forget to change
1433         -- CoreTidy.tidyLetBndr too!
1434         --
1435         -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1436     id_info = idInfo id
1437     inline_prag = inlinePragInfo id_info
1438     prag_info | isDefaultInlinePragma inline_prag = NoInfo
1439               | otherwise                         = HasInfo [HsInline inline_prag]
1440
1441 --------------------------
1442 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1443 toIfaceIdDetails VanillaId                      = IfVanillaId
1444 toIfaceIdDetails DFunId                         = IfVanillaId               
1445 toIfaceIdDetails (RecSelId { sel_naughty = n
1446                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
1447 toIfaceIdDetails other                          = pprTrace "toIfaceIdDetails" (ppr other) 
1448                                                   IfVanillaId   -- Unexpected
1449
1450 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1451 toIfaceIdInfo id_info
1452   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
1453                inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo] 
1454   where
1455     ------------  Arity  --------------
1456     arity_info = arityInfo id_info
1457     arity_hsinfo | arity_info == 0 = Nothing
1458                  | otherwise       = Just (HsArity arity_info)
1459
1460     ------------ Caf Info --------------
1461     caf_info   = cafInfo id_info
1462     caf_hsinfo = case caf_info of
1463                    NoCafRefs -> Just HsNoCafRefs
1464                    _other    -> Nothing
1465
1466     ------------  Strictness  --------------
1467         -- No point in explicitly exporting TopSig
1468     strict_hsinfo = case newStrictnessInfo id_info of
1469                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1470                         _other                        -> Nothing
1471
1472     ------------  Worker  --------------
1473     work_info   = workerInfo id_info
1474     has_worker  = workerExists work_info
1475     wrkr_hsinfo = case work_info of
1476                     HasWorker work_id wrap_arity -> 
1477                         Just (HsWorker ((idName work_id)) wrap_arity)
1478                     NoWorker -> Nothing
1479
1480     ------------  Unfolding  --------------
1481     -- The unfolding is redundant if there is a worker
1482     unfold_info  = unfoldingInfo id_info
1483     rhs          = unfoldingTemplate unfold_info
1484     no_unfolding = neverUnfold unfold_info
1485                         -- The CoreTidy phase retains unfolding info iff
1486                         -- we want to expose the unfolding, taking into account
1487                         -- unconditional NOINLINE, etc.  See TidyPgm.addExternal
1488     unfold_hsinfo | no_unfolding = Nothing                      
1489                   | has_worker   = Nothing      -- Unfolding is implicit
1490                   | otherwise    = Just (HsUnfold (toIfaceExpr rhs))
1491                                         
1492     ------------  Inline prag  --------------
1493     inline_prag = inlinePragInfo id_info
1494     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1495                   | no_unfolding && not has_worker 
1496                       && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
1497                                                       = Nothing
1498                         -- If the iface file give no unfolding info, we 
1499                         -- don't need to say when inlining is OK!
1500                   | otherwise                         = Just (HsInline inline_prag)
1501
1502 --------------------------
1503 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1504 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1505   = pprTrace "toHsRule: builtin" (ppr fn) $
1506     bogusIfaceRule fn
1507
1508 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
1509                                 ru_act = act, ru_bndrs = bndrs,
1510                                 ru_args = args, ru_rhs = rhs })
1511   = IfaceRule { ifRuleName  = name, ifActivation = act, 
1512                 ifRuleBndrs = map toIfaceBndr bndrs,
1513                 ifRuleHead  = fn, 
1514                 ifRuleArgs  = map do_arg args,
1515                 ifRuleRhs   = toIfaceExpr rhs,
1516                 ifRuleOrph  = orph }
1517   where
1518         -- For type args we must remove synonyms from the outermost
1519         -- level.  Reason: so that when we read it back in we'll
1520         -- construct the same ru_rough field as we have right now;
1521         -- see tcIfaceRule
1522     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1523     do_arg arg       = toIfaceExpr arg
1524
1525         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1526         -- A rule is an orphan only if none of the variables
1527         -- mentioned on its left-hand side are locally defined
1528     lhs_names = fn : nameSetToList (exprsFreeNames args)
1529                 -- No need to delete bndrs, because
1530                 -- exprsFreeNames finds only External names
1531
1532     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1533                         (n : _) -> Just (nameOccName n)
1534                         []      -> Nothing
1535
1536 bogusIfaceRule :: Name -> IfaceRule
1537 bogusIfaceRule id_name
1538   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
1539         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
1540         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1541
1542 ---------------------
1543 toIfaceExpr :: CoreExpr -> IfaceExpr
1544 toIfaceExpr (Var v)       = toIfaceVar v
1545 toIfaceExpr (Lit l)       = IfaceLit l
1546 toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
1547 toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1548 toIfaceExpr (App f a)     = toIfaceApp f [a]
1549 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1550 toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1551 toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
1552 toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1553
1554 ---------------------
1555 toIfaceNote :: Note -> IfaceNote
1556 toIfaceNote (SCC cc)      = IfaceSCC cc
1557 toIfaceNote InlineMe      = IfaceInlineMe
1558 toIfaceNote (CoreNote s)  = IfaceCoreNote s
1559
1560 ---------------------
1561 toIfaceBind :: Bind Id -> IfaceBinding
1562 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1563 toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1564
1565 ---------------------
1566 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1567            -> (IfaceConAlt, [FastString], IfaceExpr)
1568 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1569
1570 ---------------------
1571 toIfaceCon :: AltCon -> IfaceConAlt
1572 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1573                         | otherwise       = IfaceDataAlt (getName dc)
1574                         where
1575                           tc = dataConTyCon dc
1576            
1577 toIfaceCon (LitAlt l) = IfaceLitAlt l
1578 toIfaceCon DEFAULT    = IfaceDefault
1579
1580 ---------------------
1581 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1582 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1583 toIfaceApp (Var v) as
1584   = case isDataConWorkId_maybe v of
1585         -- We convert the *worker* for tuples into IfaceTuples
1586         Just dc |  isTupleTyCon tc && saturated 
1587                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1588           where
1589             val_args  = dropWhile isTypeArg as
1590             saturated = val_args `lengthIs` idArity v
1591             tup_args  = map toIfaceExpr val_args
1592             tc        = dataConTyCon dc
1593
1594         _ -> mkIfaceApps (toIfaceVar v) as
1595
1596 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1597
1598 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1599 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1600
1601 ---------------------
1602 toIfaceVar :: Id -> IfaceExpr
1603 toIfaceVar v 
1604   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1605           -- Foreign calls have special syntax
1606   | isExternalName name             = IfaceExt name
1607   | Just (TickBox m ix) <- isTickBoxOp_maybe v
1608                                     = IfaceTick m ix
1609   | otherwise                       = IfaceLcl (getFS name)
1610   where
1611     name = idName v
1612 \end{code}