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