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