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