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