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