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