{-
(c) The University of Glasgow 2006-2008
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-}

{-# LANGUAGE CPP, NondecreasingIndentation #-}
{-# LANGUAGE MultiWayIf #-}

-- | Module for constructing @ModIface@ values (interface files),
-- writing them to disk and comparing two versions to see if
-- recompilation is required.
module MkIface (
        mkIface,        -- Build a ModIface from a ModGuts,
                        -- including computing version information

        mkIfaceTc,

        writeIfaceFile, -- Write the interface file

        checkOldIface,  -- See if recompilation is required, by
                        -- comparing version information
        RecompileRequired(..), recompileRequired,
        mkIfaceExports,

        coAxiomToIfaceDecl,
        tyThingToIfaceDecl -- Converting things to their Iface equivalents
 ) where

{-
  -----------------------------------------------
          Recompilation checking
  -----------------------------------------------

A complete description of how recompilation checking works can be
found in the wiki commentary:

 http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance

Please read the above page for a top-down description of how this all
works.  Notes below cover specific issues related to the implementation.

Basic idea:

  * In the mi_usages information in an interface, we record the
    fingerprint of each free variable of the module

  * In mkIface, we compute the fingerprint of each exported thing A.f.
    For each external thing that A.f refers to, we include the fingerprint
    of the external reference when computing the fingerprint of A.f.  So
    if anything that A.f depends on changes, then A.f's fingerprint will
    change.
    Also record any dependent files added with
      * addDependentFile
      * #include
      * -optP-include

  * In checkOldIface we compare the mi_usages for the module with
    the actual fingerprint for all each thing recorded in mi_usages
-}

#include "HsVersions.h"

import GhcPrelude

import IfaceSyn
import BinFingerprint
import LoadIface
import ToIface
import FlagChecker

import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
import Id
import Annotations
import CoreSyn
import Class
import TyCon
import CoAxiom
import ConLike
import DataCon
import Type
import TcType
import InstEnv
import FamInstEnv
import TcRnMonad
import HsSyn
import HscTypes
import Finder
import DynFlags
import VarEnv
import Var
import Name
import Avail
import RdrName
import NameEnv
import NameSet
import Module
import BinIface
import ErrUtils
import Digraph
import SrcLoc
import Outputable
import BasicTypes       hiding ( SuccessFlag(..) )
import Unique
import Util             hiding ( eqListBy )
import FastString
import Maybes
import Binary
import Fingerprint
import Exception
import UniqSet
import Packages
import ExtractDocs

import Control.Monad
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Ord
import Data.IORef
import System.Directory
import System.FilePath
import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),
                 pluginRecompile', plugins )

--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
import qualified Data.Semigroup

{-
************************************************************************
*                                                                      *
\subsection{Completing an interface}
*                                                                      *
************************************************************************
-}

mkIface :: HscEnv
        -> Maybe Fingerprint    -- The old fingerprint, if we have it
        -> ModDetails           -- The trimmed, tidied interface
        -> ModGuts              -- Usages, deprecations, etc
        -> IO (ModIface, -- The new one
               Bool)     -- True <=> there was an old Iface, and the
                         --          new one is identical, so no need
                         --          to write it

mkIface :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (ModIface, Bool)
mkIface hsc_env :: HscEnv
hsc_env maybe_old_fingerprint :: Maybe Fingerprint
maybe_old_fingerprint mod_details :: ModDetails
mod_details
         ModGuts{     mg_module :: ModGuts -> Module
mg_module       = Module
this_mod,
                      mg_hsc_src :: ModGuts -> HscSource
mg_hsc_src      = HscSource
hsc_src,
                      mg_usages :: ModGuts -> [Usage]
mg_usages       = [Usage]
usages,
                      mg_used_th :: ModGuts -> Bool
mg_used_th      = Bool
used_th,
                      mg_deps :: ModGuts -> Dependencies
mg_deps         = Dependencies
deps,
                      mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env      = GlobalRdrEnv
rdr_env,
                      mg_fix_env :: ModGuts -> FixityEnv
mg_fix_env      = FixityEnv
fix_env,
                      mg_warns :: ModGuts -> Warnings
mg_warns        = Warnings
warns,
                      mg_hpc_info :: ModGuts -> HpcInfo
mg_hpc_info     = HpcInfo
hpc_info,
                      mg_safe_haskell :: ModGuts -> SafeHaskellMode
mg_safe_haskell = SafeHaskellMode
safe_mode,
                      mg_trust_pkg :: ModGuts -> Bool
mg_trust_pkg    = Bool
self_trust,
                      mg_doc_hdr :: ModGuts -> Maybe HsDocString
mg_doc_hdr      = Maybe HsDocString
doc_hdr,
                      mg_decl_docs :: ModGuts -> DeclDocMap
mg_decl_docs    = DeclDocMap
decl_docs,
                      mg_arg_docs :: ModGuts -> ArgDocMap
mg_arg_docs     = ArgDocMap
arg_docs
                    }
        = HscEnv
-> Maybe Fingerprint
-> Module
-> HscSource
-> Bool
-> Dependencies
-> GlobalRdrEnv
-> FixityEnv
-> Warnings
-> HpcInfo
-> Bool
-> SafeHaskellMode
-> [Usage]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> ModDetails
-> IO (ModIface, Bool)
mkIface_ HscEnv
hsc_env Maybe Fingerprint
maybe_old_fingerprint
                   Module
this_mod HscSource
hsc_src Bool
used_th Dependencies
deps GlobalRdrEnv
rdr_env FixityEnv
fix_env
                   Warnings
warns HpcInfo
hpc_info Bool
self_trust
                   SafeHaskellMode
safe_mode [Usage]
usages
                   Maybe HsDocString
doc_hdr DeclDocMap
decl_docs ArgDocMap
arg_docs
                   ModDetails
mod_details

-- | make an interface from the results of typechecking only.  Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
mkIfaceTc :: HscEnv
          -> Maybe Fingerprint  -- The old fingerprint, if we have it
          -> SafeHaskellMode    -- The safe haskell mode
          -> ModDetails         -- gotten from mkBootModDetails, probably
          -> TcGblEnv           -- Usages, deprecations, etc
          -> IO (ModIface, Bool)
mkIfaceTc :: HscEnv
-> Maybe Fingerprint
-> SafeHaskellMode
-> ModDetails
-> TcGblEnv
-> IO (ModIface, Bool)
mkIfaceTc hsc_env :: HscEnv
hsc_env maybe_old_fingerprint :: Maybe Fingerprint
maybe_old_fingerprint safe_mode :: SafeHaskellMode
safe_mode mod_details :: ModDetails
mod_details
  tc_result :: TcGblEnv
tc_result@TcGblEnv{ tcg_mod :: TcGblEnv -> Module
tcg_mod = Module
this_mod,
                      tcg_src :: TcGblEnv -> HscSource
tcg_src = HscSource
hsc_src,
                      tcg_imports :: TcGblEnv -> ImportAvails
tcg_imports = ImportAvails
imports,
                      tcg_rdr_env :: TcGblEnv -> GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env,
                      tcg_fix_env :: TcGblEnv -> FixityEnv
tcg_fix_env = FixityEnv
fix_env,
                      tcg_merged :: TcGblEnv -> [(Module, Fingerprint)]
tcg_merged = [(Module, Fingerprint)]
merged,
                      tcg_warns :: TcGblEnv -> Warnings
tcg_warns = Warnings
warns,
                      tcg_hpc :: TcGblEnv -> Bool
tcg_hpc = Bool
other_hpc_info,
                      tcg_th_splice_used :: TcGblEnv -> TcRef Bool
tcg_th_splice_used = TcRef Bool
tc_splice_used,
                      tcg_dependent_files :: TcGblEnv -> TcRef [FilePath]
tcg_dependent_files = TcRef [FilePath]
dependent_files
                    }
  = do
          let used_names :: NameSet
used_names = TcGblEnv -> NameSet
mkUsedNames TcGblEnv
tc_result
          let pluginModules :: [ModIface]
pluginModules =
                (LoadedPlugin -> ModIface) -> [LoadedPlugin] -> [ModIface]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> ModIface
lpModule (DynFlags -> [LoadedPlugin]
cachedPlugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
          Dependencies
deps <- InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
mkDependencies
                    (DynFlags -> InstalledUnitId
thisInstalledUnitId (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
                    ((ModIface -> Module) -> [ModIface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModIface -> Module
mi_module [ModIface]
pluginModules) TcGblEnv
tc_result
          let hpc_info :: HpcInfo
hpc_info = Bool -> HpcInfo
emptyHpcInfo Bool
other_hpc_info
          Bool
used_th <- TcRef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef TcRef Bool
tc_splice_used
          [FilePath]
dep_files <- (TcRef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef TcRef [FilePath]
dependent_files)
          -- Do NOT use semantic module here; this_mod in mkUsageInfo
          -- is used solely to decide if we should record a dependency
          -- or not.  When we instantiate a signature, the semantic
          -- module is something we want to record dependencies for,
          -- but if you pass that in here, we'll decide it's the local
          -- module and does not need to be recorded as a dependency.
          -- See Note [Identity versus semantic module]
          [Usage]
usages <- HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [FilePath]
-> [(Module, Fingerprint)]
-> [ModIface]
-> IO [Usage]
mkUsageInfo HscEnv
hsc_env Module
this_mod (ImportAvails -> ImportedMods
imp_mods ImportAvails
imports) NameSet
used_names
                      [FilePath]
dep_files [(Module, Fingerprint)]
merged [ModIface]
pluginModules

          let (doc_hdr' :: Maybe HsDocString
doc_hdr', doc_map :: DeclDocMap
doc_map, arg_map :: ArgDocMap
arg_map) = TcGblEnv -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv
tc_result

          HscEnv
-> Maybe Fingerprint
-> Module
-> HscSource
-> Bool
-> Dependencies
-> GlobalRdrEnv
-> FixityEnv
-> Warnings
-> HpcInfo
-> Bool
-> SafeHaskellMode
-> [Usage]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> ModDetails
-> IO (ModIface, Bool)
mkIface_ HscEnv
hsc_env Maybe Fingerprint
maybe_old_fingerprint
                   Module
this_mod HscSource
hsc_src
                   Bool
used_th Dependencies
deps GlobalRdrEnv
rdr_env
                   FixityEnv
fix_env Warnings
warns HpcInfo
hpc_info
                   (ImportAvails -> Bool
imp_trust_own_pkg ImportAvails
imports) SafeHaskellMode
safe_mode [Usage]
usages
                   Maybe HsDocString
doc_hdr' DeclDocMap
doc_map ArgDocMap
arg_map
                   ModDetails
mod_details



mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
         -> Bool -> Dependencies -> GlobalRdrEnv
         -> NameEnv FixItem -> Warnings -> HpcInfo
         -> Bool
         -> SafeHaskellMode
         -> [Usage]
         -> Maybe HsDocString
         -> DeclDocMap
         -> ArgDocMap
         -> ModDetails
         -> IO (ModIface, Bool)
mkIface_ :: HscEnv
-> Maybe Fingerprint
-> Module
-> HscSource
-> Bool
-> Dependencies
-> GlobalRdrEnv
-> FixityEnv
-> Warnings
-> HpcInfo
-> Bool
-> SafeHaskellMode
-> [Usage]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> ModDetails
-> IO (ModIface, Bool)
mkIface_ hsc_env :: HscEnv
hsc_env maybe_old_fingerprint :: Maybe Fingerprint
maybe_old_fingerprint
         this_mod :: Module
this_mod hsc_src :: HscSource
hsc_src used_th :: Bool
used_th deps :: Dependencies
deps rdr_env :: GlobalRdrEnv
rdr_env fix_env :: FixityEnv
fix_env src_warns :: Warnings
src_warns
         hpc_info :: HpcInfo
hpc_info pkg_trust_req :: Bool
pkg_trust_req safe_mode :: SafeHaskellMode
safe_mode usages :: [Usage]
usages
         doc_hdr :: Maybe HsDocString
doc_hdr decl_docs :: DeclDocMap
decl_docs arg_docs :: ArgDocMap
arg_docs
         ModDetails{  md_insts :: ModDetails -> [ClsInst]
md_insts     = [ClsInst]
insts,
                      md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
fam_insts,
                      md_rules :: ModDetails -> [CoreRule]
md_rules     = [CoreRule]
rules,
                      md_anns :: ModDetails -> [Annotation]
md_anns      = [Annotation]
anns,
                      md_types :: ModDetails -> TypeEnv
md_types     = TypeEnv
type_env,
                      md_exports :: ModDetails -> [AvailInfo]
md_exports   = [AvailInfo]
exports,
                      md_complete_sigs :: ModDetails -> [CompleteMatch]
md_complete_sigs = [CompleteMatch]
complete_sigs }
-- NB:  notice that mkIface does not look at the bindings
--      only at the TypeEnv.  The previous Tidy phase has
--      put exactly the info into the TypeEnv that we want
--      to expose in the interface

  = do
    let semantic_mod :: Module
semantic_mod = DynFlags -> ModuleName -> Module
canonicalizeHomeModule (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (Module -> ModuleName
moduleName Module
this_mod)
        entities :: [TyThing]
entities = TypeEnv -> [TyThing]
typeEnvElts TypeEnv
type_env
        decls :: [IfaceDecl]
decls  = [ TyThing -> IfaceDecl
tyThingToIfaceDecl TyThing
entity
                 | TyThing
entity <- [TyThing]
entities,
                   let name :: Name
name = TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
entity,
                   Bool -> Bool
not (TyThing -> Bool
isImplicitTyThing TyThing
entity),
                      -- No implicit Ids and class tycons in the interface file
                   Bool -> Bool
not (Name -> Bool
isWiredInName Name
name),
                      -- Nor wired-in things; the compiler knows about them anyhow
                   Module -> Name -> Bool
nameIsLocalOrFrom Module
semantic_mod Name
name  ]
                      -- Sigh: see Note [Root-main Id] in TcRnDriver
                      -- NB: ABSOLUTELY need to check against semantic_mod,
                      -- because all of the names in an hsig p[H=<H>]:H
                      -- are going to be for <H>, not the former id!
                      -- See Note [Identity versus semantic module]

        fixities :: [(OccName, Fixity)]
fixities    = ((OccName, Fixity) -> (OccName, Fixity) -> Ordering)
-> [(OccName, Fixity)] -> [(OccName, Fixity)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((OccName, Fixity) -> OccName)
-> (OccName, Fixity) -> (OccName, Fixity) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (OccName, Fixity) -> OccName
forall a b. (a, b) -> a
fst)
          [(OccName
occ,Fixity
fix) | FixItem occ :: OccName
occ fix :: Fixity
fix <- FixityEnv -> [FixItem]
forall a. NameEnv a -> [a]
nameEnvElts FixityEnv
fix_env]
          -- The order of fixities returned from nameEnvElts is not
          -- deterministic, so we sort by OccName to canonicalize it.
          -- See Note [Deterministic UniqFM] in UniqDFM for more details.
        warns :: Warnings
warns       = Warnings
src_warns
        iface_rules :: [IfaceRule]
iface_rules = (CoreRule -> IfaceRule) -> [CoreRule] -> [IfaceRule]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> IfaceRule
coreRuleToIfaceRule [CoreRule]
rules
        iface_insts :: [IfaceClsInst]
iface_insts = (ClsInst -> IfaceClsInst) -> [ClsInst] -> [IfaceClsInst]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> IfaceClsInst
instanceToIfaceInst ([ClsInst] -> [IfaceClsInst]) -> [ClsInst] -> [IfaceClsInst]
forall a b. (a -> b) -> a -> b
$ SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances SafeHaskellMode
safe_mode [ClsInst]
insts
        iface_fam_insts :: [IfaceFamInst]
iface_fam_insts = (FamInst -> IfaceFamInst) -> [FamInst] -> [IfaceFamInst]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> IfaceFamInst
famInstToIfaceFamInst [FamInst]
fam_insts
        trust_info :: IfaceTrustInfo
trust_info  = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
safe_mode
        annotations :: [IfaceAnnotation]
annotations = (Annotation -> IfaceAnnotation)
-> [Annotation] -> [IfaceAnnotation]
forall a b. (a -> b) -> [a] -> [b]
map Annotation -> IfaceAnnotation
mkIfaceAnnotation [Annotation]
anns
        icomplete_sigs :: [IfaceCompleteMatch]
icomplete_sigs = (CompleteMatch -> IfaceCompleteMatch)
-> [CompleteMatch] -> [IfaceCompleteMatch]
forall a b. (a -> b) -> [a] -> [b]
map CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig [CompleteMatch]
complete_sigs

        intermediate_iface :: ModIface
intermediate_iface = $WModIface :: Module
-> Maybe Module
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Bool
-> Bool
-> HscSource
-> Dependencies
-> [Usage]
-> [AvailInfo]
-> Fingerprint
-> Bool
-> [(OccName, Fixity)]
-> Warnings
-> [IfaceAnnotation]
-> [(Fingerprint, IfaceDecl)]
-> Maybe GlobalRdrEnv
-> [IfaceClsInst]
-> [IfaceFamInst]
-> [IfaceRule]
-> Fingerprint
-> (OccName -> Maybe WarningTxt)
-> (OccName -> Maybe Fixity)
-> (OccName -> Maybe (OccName, Fingerprint))
-> Bool
-> IfaceTrustInfo
-> Bool
-> [IfaceCompleteMatch]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> ModIface
ModIface {
              mi_module :: Module
mi_module      = Module
this_mod,
              -- Need to record this because it depends on the -instantiated-with flag
              -- which could change
              mi_sig_of :: Maybe Module
mi_sig_of      = if Module
semantic_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
this_mod
                                then Maybe Module
forall a. Maybe a
Nothing
                                else Module -> Maybe Module
forall a. a -> Maybe a
Just Module
semantic_mod,
              mi_hsc_src :: HscSource
mi_hsc_src     = HscSource
hsc_src,
              mi_deps :: Dependencies
mi_deps        = Dependencies
deps,
              mi_usages :: [Usage]
mi_usages      = [Usage]
usages,
              mi_exports :: [AvailInfo]
mi_exports     = [AvailInfo] -> [AvailInfo]
mkIfaceExports [AvailInfo]
exports,

              -- Sort these lexicographically, so that
              -- the result is stable across compilations
              mi_insts :: [IfaceClsInst]
mi_insts       = (IfaceClsInst -> IfaceClsInst -> Ordering)
-> [IfaceClsInst] -> [IfaceClsInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IfaceClsInst -> IfaceClsInst -> Ordering
cmp_inst     [IfaceClsInst]
iface_insts,
              mi_fam_insts :: [IfaceFamInst]
mi_fam_insts   = (IfaceFamInst -> IfaceFamInst -> Ordering)
-> [IfaceFamInst] -> [IfaceFamInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IfaceFamInst -> IfaceFamInst -> Ordering
cmp_fam_inst [IfaceFamInst]
iface_fam_insts,
              mi_rules :: [IfaceRule]
mi_rules       = (IfaceRule -> IfaceRule -> Ordering) -> [IfaceRule] -> [IfaceRule]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IfaceRule -> IfaceRule -> Ordering
cmp_rule     [IfaceRule]
iface_rules,

              mi_fixities :: [(OccName, Fixity)]
mi_fixities    = [(OccName, Fixity)]
fixities,
              mi_warns :: Warnings
mi_warns       = Warnings
warns,
              mi_anns :: [IfaceAnnotation]
mi_anns        = [IfaceAnnotation]
annotations,
              mi_globals :: Maybe GlobalRdrEnv
mi_globals     = GlobalRdrEnv -> Maybe GlobalRdrEnv
maybeGlobalRdrEnv GlobalRdrEnv
rdr_env,

              -- Left out deliberately: filled in by addFingerprints
              mi_iface_hash :: Fingerprint
mi_iface_hash  = Fingerprint
fingerprint0,
              mi_mod_hash :: Fingerprint
mi_mod_hash    = Fingerprint
fingerprint0,
              mi_flag_hash :: Fingerprint
mi_flag_hash   = Fingerprint
fingerprint0,
              mi_opt_hash :: Fingerprint
mi_opt_hash    = Fingerprint
fingerprint0,
              mi_hpc_hash :: Fingerprint
mi_hpc_hash    = Fingerprint
fingerprint0,
              mi_exp_hash :: Fingerprint
mi_exp_hash    = Fingerprint
fingerprint0,
              mi_plugin_hash :: Fingerprint
mi_plugin_hash = Fingerprint
fingerprint0,
              mi_used_th :: Bool
mi_used_th     = Bool
used_th,
              mi_orphan_hash :: Fingerprint
mi_orphan_hash = Fingerprint
fingerprint0,
              mi_orphan :: Bool
mi_orphan      = Bool
False, -- Always set by addFingerprints, but
                                      -- it's a strict field, so we can't omit it.
              mi_finsts :: Bool
mi_finsts      = Bool
False, -- Ditto
              mi_decls :: [(Fingerprint, IfaceDecl)]
mi_decls       = FilePath -> [(Fingerprint, IfaceDecl)]
forall a. FilePath -> a
deliberatelyOmitted "decls",
              mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn     = FilePath -> OccName -> Maybe (OccName, Fingerprint)
forall a. FilePath -> a
deliberatelyOmitted "hash_fn",
              mi_hpc :: Bool
mi_hpc         = HpcInfo -> Bool
isHpcUsed HpcInfo
hpc_info,
              mi_trust :: IfaceTrustInfo
mi_trust       = IfaceTrustInfo
trust_info,
              mi_trust_pkg :: Bool
mi_trust_pkg   = Bool
pkg_trust_req,

              -- And build the cached values
              mi_warn_fn :: OccName -> Maybe WarningTxt
mi_warn_fn     = Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache Warnings
warns,
              mi_fix_fn :: OccName -> Maybe Fixity
mi_fix_fn      = [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache [(OccName, Fixity)]
fixities,
              mi_complete_sigs :: [IfaceCompleteMatch]
mi_complete_sigs = [IfaceCompleteMatch]
icomplete_sigs,
              mi_doc_hdr :: Maybe HsDocString
mi_doc_hdr     = Maybe HsDocString
doc_hdr,
              mi_decl_docs :: DeclDocMap
mi_decl_docs   = DeclDocMap
decl_docs,
              mi_arg_docs :: ArgDocMap
mi_arg_docs    = ArgDocMap
arg_docs }

    (new_iface :: ModIface
new_iface, no_change_at_all :: Bool
no_change_at_all)
          <- {-# SCC "versioninfo" #-}
                   HscEnv
-> Maybe Fingerprint
-> ModIface
-> [IfaceDecl]
-> IO (ModIface, Bool)
addFingerprints HscEnv
hsc_env Maybe Fingerprint
maybe_old_fingerprint
                                   ModIface
intermediate_iface [IfaceDecl]
decls

    -- Debug printing
    DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_hi "FINAL INTERFACE"
                  (ModIface -> SDoc
pprModIface ModIface
new_iface)

    -- bug #1617: on reload we weren't updating the PrintUnqualified
    -- correctly.  This stems from the fact that the interface had
    -- not changed, so addFingerprints returns the old ModIface
    -- with the old GlobalRdrEnv (mi_globals).
    let final_iface :: ModIface
final_iface = ModIface
new_iface{ mi_globals :: Maybe GlobalRdrEnv
mi_globals = GlobalRdrEnv -> Maybe GlobalRdrEnv
maybeGlobalRdrEnv GlobalRdrEnv
rdr_env }

    (ModIface, Bool) -> IO (ModIface, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
final_iface, Bool
no_change_at_all)
  where
     cmp_rule :: IfaceRule -> IfaceRule -> Ordering
cmp_rule     = (IfaceRule -> RuleName) -> IfaceRule -> IfaceRule -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing IfaceRule -> RuleName
ifRuleName
     -- Compare these lexicographically by OccName, *not* by unique,
     -- because the latter is not stable across compilations:
     cmp_inst :: IfaceClsInst -> IfaceClsInst -> Ordering
cmp_inst     = (IfaceClsInst -> OccName)
-> IfaceClsInst -> IfaceClsInst -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Name -> OccName
nameOccName (Name -> OccName)
-> (IfaceClsInst -> Name) -> IfaceClsInst -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceClsInst -> Name
ifDFun)
     cmp_fam_inst :: IfaceFamInst -> IfaceFamInst -> Ordering
cmp_fam_inst = (IfaceFamInst -> OccName)
-> IfaceFamInst -> IfaceFamInst -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Name -> OccName
nameOccName (Name -> OccName)
-> (IfaceFamInst -> Name) -> IfaceFamInst -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceFamInst -> Name
ifFamInstTcName)

     dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

     -- We only fill in mi_globals if the module was compiled to byte
     -- code.  Otherwise, the compiler may not have retained all the
     -- top-level bindings and they won't be in the TypeEnv (see
     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
     -- by GHCi to decide whether the module has its full top-level
     -- scope available. (#5534)
     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
maybeGlobalRdrEnv rdr_env :: GlobalRdrEnv
rdr_env
         | HscTarget -> Bool
targetRetainsAllBindings (DynFlags -> HscTarget
hscTarget DynFlags
dflags) = GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a. a -> Maybe a
Just GlobalRdrEnv
rdr_env
         | Bool
otherwise                                   = Maybe GlobalRdrEnv
forall a. Maybe a
Nothing

     deliberatelyOmitted :: String -> a
     deliberatelyOmitted :: FilePath -> a
deliberatelyOmitted x :: FilePath
x = FilePath -> a
forall a. FilePath -> a
panic ("Deliberately omitted: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x)

     ifFamInstTcName :: IfaceFamInst -> Name
ifFamInstTcName = IfaceFamInst -> Name
ifFamInstFam

-----------------------------
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags :: DynFlags
dflags hi_file_path :: FilePath
hi_file_path new_iface :: ModIface
new_iface
    = do Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
hi_file_path)
         DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface DynFlags
dflags FilePath
hi_file_path ModIface
new_iface


-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names

-- This is like a global version of the mi_hash_fn field in each ModIface.
-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
-- the parent and version info.

mkHashFun
        :: HscEnv                       -- needed to look up versions
        -> ExternalPackageState         -- ditto
        -> (Name -> IO Fingerprint)
mkHashFun :: HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun hsc_env :: HscEnv
hsc_env eps :: ExternalPackageState
eps name :: Name
name
  | Module -> Bool
isHoleModule Module
orig_mod
  = Module -> IO Fingerprint
lookup (UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) (Module -> ModuleName
moduleName Module
orig_mod))
  | Bool
otherwise
  = Module -> IO Fingerprint
lookup Module
orig_mod
  where
      dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
      pit :: PackageIfaceTable
pit = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
      occ :: OccName
occ = Name -> OccName
nameOccName Name
name
      orig_mod :: Module
orig_mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
      lookup :: Module -> IO Fingerprint
lookup mod :: Module
mod = do
        MASSERT2( isExternalName name, ppr name )
        ModIface
iface <- case DynFlags
-> HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule DynFlags
dflags HomePackageTable
hpt PackageIfaceTable
pit Module
mod of
                  Just iface :: ModIface
iface -> ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
                  Nothing -> do
                      -- This can occur when we're writing out ifaces for
                      -- requirements; we didn't do any /real/ typechecking
                      -- so there's no guarantee everything is loaded.
                      -- Kind of a heinous hack.
                      ModIface
iface <- HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
                            (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface (FilePath -> SDoc
text "lookupVers2") Module
mod WhereFrom
ImportBySystem
                      ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
        Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ (OccName, Fingerprint) -> Fingerprint
forall a b. (a, b) -> b
snd (ModIface -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn ModIface
iface OccName
occ Maybe (OccName, Fingerprint)
-> (OccName, Fingerprint) -> (OccName, Fingerprint)
forall a. Maybe a -> a -> a
`orElse`
                  FilePath -> SDoc -> (OccName, Fingerprint)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "lookupVers1" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ))

-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface

{-
Note [Fingerprinting IfaceDecls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The general idea here is that we first examine the 'IfaceDecl's and determine
the recursive groups of them. We then walk these groups in dependency order,
serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
hash using MD5 to produce a fingerprint for the group.

However, the serialization that we use is a bit funny: we override the @putName@
operation with our own which serializes the hash of a 'Name' instead of the
'Name' itself. This ensures that the fingerprint of a decl changes if anything
in its transitive closure changes. This trick is why we must be careful about
traversing in dependency order: we need to ensure that we have hashes for
everything referenced by the decl which we are fingerprinting.

Moreover, we need to be careful to distinguish between serialization of binding
Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
field of a IfaceClsInst): only in the non-binding case should we include the
fingerprint; in the binding case we shouldn't since it is merely the name of the
thing that we are currently fingerprinting.
-}

-- | Add fingerprints for top-level declarations to a 'ModIface'.
--
-- See Note [Fingerprinting IfaceDecls]
addFingerprints
        :: HscEnv
        -> Maybe Fingerprint -- the old fingerprint, if any
        -> ModIface          -- The new interface (lacking decls)
        -> [IfaceDecl]       -- The new decls
        -> IO (ModIface,     -- Updated interface
               Bool)         -- True <=> no changes at all;
                             -- no need to write Iface

addFingerprints :: HscEnv
-> Maybe Fingerprint
-> ModIface
-> [IfaceDecl]
-> IO (ModIface, Bool)
addFingerprints hsc_env :: HscEnv
hsc_env mb_old_fingerprint :: Maybe Fingerprint
mb_old_fingerprint iface0 :: ModIface
iface0 new_decls :: [IfaceDecl]
new_decls
 = do
   ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
   let
        -- The ABI of a declaration represents everything that is made
        -- visible about the declaration that a client can depend on.
        -- see IfaceDeclABI below.
       declABI :: IfaceDecl -> IfaceDeclABI
       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
       -- See also Note [Identity versus semantic module]
       declABI :: IfaceDecl -> IfaceDeclABI
declABI decl :: IfaceDecl
decl = (Module
this_mod, IfaceDecl
decl, IfaceDeclExtras
extras)
        where extras :: IfaceDeclExtras
extras = (OccName -> Maybe Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv Name
-> IfaceDecl
-> IfaceDeclExtras
declExtras OccName -> Maybe Fixity
fix_fn OccName -> [AnnPayload]
ann_fn OccEnv [IfaceRule]
non_orph_rules OccEnv [IfaceClsInst]
non_orph_insts
                                  OccEnv [IfaceFamInst]
non_orph_fis OccEnv Name
top_lvl_name_env IfaceDecl
decl

       -- This is used for looking up the Name of a default method
       -- from its OccName. See Note [default method Name]
       top_lvl_name_env :: OccEnv Name
top_lvl_name_env =
         [(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [ (Name -> OccName
nameOccName Name
nm, Name
nm)
                  | IfaceId { ifName :: IfaceDecl -> Name
ifName = Name
nm } <- [IfaceDecl]
new_decls ]

       -- Dependency edges between declarations in the current module.
       -- This is computed by finding the free external names of each
       -- declaration, including IfaceDeclExtras (things that a
       -- declaration implicitly depends on).
       edges :: [ Node Unique IfaceDeclABI ]
       edges :: [Node Unique IfaceDeclABI]
edges = [ IfaceDeclABI -> Unique -> [Unique] -> Node Unique IfaceDeclABI
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode IfaceDeclABI
abi (OccName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl)) [Unique]
out
               | IfaceDecl
decl <- [IfaceDecl]
new_decls
               , let abi :: IfaceDeclABI
abi = IfaceDecl -> IfaceDeclABI
declABI IfaceDecl
decl
               , let out :: [Unique]
out = NameSet -> [Unique]
localOccs (NameSet -> [Unique]) -> NameSet -> [Unique]
forall a b. (a -> b) -> a -> b
$ IfaceDeclABI -> NameSet
freeNamesDeclABI IfaceDeclABI
abi
               ]

       name_module :: Name -> Module
name_module n :: Name
n = ASSERT2( isExternalName n, ppr n ) nameModule n
       localOccs :: NameSet -> [Unique]
localOccs =
         (Name -> Unique) -> [Name] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (OccName -> Unique) -> (Name -> OccName) -> Name -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> OccName
getParent (OccName -> OccName) -> (Name -> OccName) -> Name -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName)
                        -- NB: names always use semantic module, so
                        -- filtering must be on the semantic module!
                        -- See Note [Identity versus semantic module]
                        ([Name] -> [Unique]) -> (NameSet -> [Name]) -> NameSet -> [Unique]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
semantic_mod) (Module -> Bool) -> (Name -> Module) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Module
name_module)
                        ([Name] -> [Name]) -> (NameSet -> [Name]) -> NameSet -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
                   -- It's OK to use nonDetEltsUFM as localOccs is only
                   -- used to construct the edges and
                   -- stronglyConnCompFromEdgedVertices is deterministic
                   -- even with non-deterministic order of edges as
                   -- explained in Note [Deterministic SCC] in Digraph.
          where getParent :: OccName -> OccName
                getParent :: OccName -> OccName
getParent occ :: OccName
occ = OccEnv OccName -> OccName -> Maybe OccName
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv OccName
parent_map OccName
occ Maybe OccName -> OccName -> OccName
forall a. Maybe a -> a -> a
`orElse` OccName
occ

        -- maps OccNames to their parents in the current module.
        -- e.g. a reference to a constructor must be turned into a reference
        -- to the TyCon for the purposes of calculating dependencies.
       parent_map :: OccEnv OccName
       parent_map :: OccEnv OccName
parent_map = (OccEnv OccName -> IfaceDecl -> OccEnv OccName)
-> OccEnv OccName -> [IfaceDecl] -> OccEnv OccName
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OccEnv OccName -> IfaceDecl -> OccEnv OccName
extend OccEnv OccName
forall a. OccEnv a
emptyOccEnv [IfaceDecl]
new_decls
          where extend :: OccEnv OccName -> IfaceDecl -> OccEnv OccName
extend env :: OccEnv OccName
env d :: IfaceDecl
d =
                  OccEnv OccName -> [(OccName, OccName)] -> OccEnv OccName
forall a. OccEnv a -> [(OccName, a)] -> OccEnv a
extendOccEnvList OccEnv OccName
env [ (OccName
b,OccName
n) | OccName
b <- IfaceDecl -> [OccName]
ifaceDeclImplicitBndrs IfaceDecl
d ]
                  where n :: OccName
n = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
d

        -- Strongly-connected groups of declarations, in dependency order
       groups :: [SCC IfaceDeclABI]
       groups :: [SCC IfaceDeclABI]
groups = [Node Unique IfaceDeclABI] -> [SCC IfaceDeclABI]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Unique IfaceDeclABI]
edges

       global_hash_fn :: Name -> IO Fingerprint
global_hash_fn = HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps

        -- How to output Names when generating the data to fingerprint.
        -- Here we want to output the fingerprint for each top-level
        -- Name, whether it comes from the current module or another
        -- module.  In this way, the fingerprint for a declaration will
        -- change if the fingerprint for anything it refers to (transitively)
        -- changes.
       mk_put_name :: OccEnv (OccName,Fingerprint)
                   -> BinHandle -> Name -> IO  ()
       mk_put_name :: OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name local_env :: OccEnv (OccName, Fingerprint)
local_env bh :: BinHandle
bh name :: Name
name
          | Name -> Bool
isWiredInName Name
name  =  BinHandle -> Name -> IO ()
putNameLiterally BinHandle
bh Name
name
           -- wired-in names don't have fingerprints
          | Bool
otherwise
          = ASSERT2( isExternalName name, ppr name )
            let hash :: IO Fingerprint
hash | HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
semantic_mod =  Name -> IO Fingerprint
global_hash_fn Name
name
                     -- Get it from the REAL interface!!
                     -- This will trigger when we compile an hsig file
                     -- and we know a backing impl for it.
                     -- See Note [Identity versus semantic module]
                     | Module
semantic_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod
                     , Bool -> Bool
not (Module -> Bool
isHoleModule Module
semantic_mod) = Name -> IO Fingerprint
global_hash_fn Name
name
                     | Bool
otherwise = Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return ((OccName, Fingerprint) -> Fingerprint
forall a b. (a, b) -> b
snd (OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
local_env (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name)
                           Maybe (OccName, Fingerprint)
-> (OccName, Fingerprint) -> (OccName, Fingerprint)
forall a. Maybe a -> a -> a
`orElse` FilePath -> SDoc -> (OccName, Fingerprint)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "urk! lookup local fingerprint"
                                       (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ OccEnv (OccName, Fingerprint) -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccEnv (OccName, Fingerprint)
local_env)))
                -- This panic indicates that we got the dependency
                -- analysis wrong, because we needed a fingerprint for
                -- an entity that wasn't in the environment.  To debug
                -- it, turn the panic into a trace, uncomment the
                -- pprTraces below, run the compile again, and inspect
                -- the output and the generated .hi file with
                -- --show-iface.
            in IO Fingerprint
hash IO Fingerprint -> (Fingerprint -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh

        -- take a strongly-connected group of declarations and compute
        -- its fingerprint.

       fingerprint_group :: (OccEnv (OccName,Fingerprint),
                             [(Fingerprint,IfaceDecl)])
                         -> SCC IfaceDeclABI
                         -> IO (OccEnv (OccName,Fingerprint),
                                [(Fingerprint,IfaceDecl)])

       fingerprint_group :: (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
fingerprint_group (local_env :: OccEnv (OccName, Fingerprint)
local_env, decls_w_hashes :: [(Fingerprint, IfaceDecl)]
decls_w_hashes) (AcyclicSCC abi :: IfaceDeclABI
abi)
          = do let hash_fn :: BinHandle -> Name -> IO ()
hash_fn = OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env
                   decl :: IfaceDecl
decl = IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi
               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
               Fingerprint
hash <- (BinHandle -> Name -> IO ()) -> IfaceDeclABI -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
hash_fn IfaceDeclABI
abi
               OccEnv (OccName, Fingerprint)
env' <- OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env (Fingerprint
hash,IfaceDecl
decl)
               (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (m :: * -> *) a. Monad m => a -> m a
return (OccEnv (OccName, Fingerprint)
env', (Fingerprint
hash,IfaceDecl
decl) (Fingerprint, IfaceDecl)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. a -> [a] -> [a]
: [(Fingerprint, IfaceDecl)]
decls_w_hashes)

       fingerprint_group (local_env :: OccEnv (OccName, Fingerprint)
local_env, decls_w_hashes :: [(Fingerprint, IfaceDecl)]
decls_w_hashes) (CyclicSCC abis :: [IfaceDeclABI]
abis)
          = do let decls :: [IfaceDecl]
decls = (IfaceDeclABI -> IfaceDecl) -> [IfaceDeclABI] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map IfaceDeclABI -> IfaceDecl
abiDecl [IfaceDeclABI]
abis
               OccEnv (OccName, Fingerprint)
local_env1 <- (OccEnv (OccName, Fingerprint)
 -> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint)))
-> OccEnv (OccName, Fingerprint)
-> [(Fingerprint, IfaceDecl)]
-> IO (OccEnv (OccName, Fingerprint))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env
                                   ([Fingerprint] -> [IfaceDecl] -> [(Fingerprint, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Fingerprint -> [Fingerprint]
forall a. a -> [a]
repeat Fingerprint
fingerprint0) [IfaceDecl]
decls)
               let hash_fn :: BinHandle -> Name -> IO ()
hash_fn = OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env1
               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
               let stable_abis :: [IfaceDeclABI]
stable_abis = (IfaceDeclABI -> IfaceDeclABI -> Ordering)
-> [IfaceDeclABI] -> [IfaceDeclABI]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames [IfaceDeclABI]
abis
                -- put the cycle in a canonical order
               Fingerprint
hash <- (BinHandle -> Name -> IO ()) -> [IfaceDeclABI] -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
hash_fn [IfaceDeclABI]
stable_abis
               let pairs :: [(Fingerprint, IfaceDecl)]
pairs = [Fingerprint] -> [IfaceDecl] -> [(Fingerprint, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Fingerprint -> [Fingerprint]
forall a. a -> [a]
repeat Fingerprint
hash) [IfaceDecl]
decls
               OccEnv (OccName, Fingerprint)
local_env2 <- (OccEnv (OccName, Fingerprint)
 -> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint)))
-> OccEnv (OccName, Fingerprint)
-> [(Fingerprint, IfaceDecl)]
-> IO (OccEnv (OccName, Fingerprint))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env [(Fingerprint, IfaceDecl)]
pairs
               (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (m :: * -> *) a. Monad m => a -> m a
return (OccEnv (OccName, Fingerprint)
local_env2, [(Fingerprint, IfaceDecl)]
pairs [(Fingerprint, IfaceDecl)]
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. [a] -> [a] -> [a]
++ [(Fingerprint, IfaceDecl)]
decls_w_hashes)

       -- we have fingerprinted the whole declaration, but we now need
       -- to assign fingerprints to all the OccNames that it binds, to
       -- use when referencing those OccNames in later declarations.
       --
       extend_hash_env :: OccEnv (OccName,Fingerprint)
                       -> (Fingerprint,IfaceDecl)
                       -> IO (OccEnv (OccName,Fingerprint))
       extend_hash_env :: OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env env0 :: OccEnv (OccName, Fingerprint)
env0 (hash :: Fingerprint
hash,d :: IfaceDecl
d) = do
          OccEnv (OccName, Fingerprint) -> IO (OccEnv (OccName, Fingerprint))
forall (m :: * -> *) a. Monad m => a -> m a
return (((OccName, Fingerprint)
 -> OccEnv (OccName, Fingerprint) -> OccEnv (OccName, Fingerprint))
-> OccEnv (OccName, Fingerprint)
-> [(OccName, Fingerprint)]
-> OccEnv (OccName, Fingerprint)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(b :: OccName
b,fp :: Fingerprint
fp) env :: OccEnv (OccName, Fingerprint)
env -> OccEnv (OccName, Fingerprint)
-> OccName
-> (OccName, Fingerprint)
-> OccEnv (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv (OccName, Fingerprint)
env OccName
b (OccName
b,Fingerprint
fp)) OccEnv (OccName, Fingerprint)
env0
                 (Fingerprint -> IfaceDecl -> [(OccName, Fingerprint)]
ifaceDeclFingerprints Fingerprint
hash IfaceDecl
d))

   --
   (local_env :: OccEnv (OccName, Fingerprint)
local_env, decls_w_hashes :: [(Fingerprint, IfaceDecl)]
decls_w_hashes) <-
       ((OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
 -> SCC IfaceDeclABI
 -> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)]))
-> (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> [SCC IfaceDeclABI]
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
fingerprint_group (OccEnv (OccName, Fingerprint)
forall a. OccEnv a
emptyOccEnv, []) [SCC IfaceDeclABI]
groups

   -- when calculating fingerprints, we always need to use canonical
   -- ordering for lists of things.  In particular, the mi_deps has various
   -- lists of modules and suchlike, so put these all in canonical order:
   let sorted_deps :: Dependencies
sorted_deps = Dependencies -> Dependencies
sortDependencies (ModIface -> Dependencies
mi_deps ModIface
iface0)

   -- The export hash of a module depends on the orphan hashes of the
   -- orphan modules below us in the dependency tree.  This is the way
   -- that changes in orphans get propagated all the way up the
   -- dependency tree.
   --
   -- Note [A bad dep_orphs optimization]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   -- In a previous version of this code, we filtered out orphan modules which
   -- were not from the home package, justifying it by saying that "we'd
   -- pick up the ABI hashes of the external module instead".  This is wrong.
   -- Suppose that we have:
   --
   --       module External where
   --           instance Show (a -> b)
   --
   --       module Home1 where
   --           import External
   --
   --       module Home2 where
   --           import Home1
   --
   -- The export hash of Home1 needs to reflect the orphan instances of
   -- External. It's true that Home1 will get rebuilt if the orphans
   -- of External, but we also need to make sure Home2 gets rebuilt
   -- as well.  See #12733 for more details.
   let orph_mods :: [Module]
orph_mods
        = (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod) -- Note [Do not update EPS with your own hi-boot]
        ([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [Module]
dep_orphs Dependencies
sorted_deps
   [Fingerprint]
dep_orphan_hashes <- HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes HscEnv
hsc_env [Module]
orph_mods

   -- Note [Do not update EPS with your own hi-boot]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   -- (See also Trac #10182).  When your hs-boot file includes an orphan
   -- instance declaration, you may find that the dep_orphs of a module you
   -- import contains reference to yourself.  DO NOT actually load this module
   -- or add it to the orphan hashes: you're going to provide the orphan
   -- instances yourself, no need to consult hs-boot; if you do load the
   -- interface into EPS, you will see a duplicate orphan instance.

   Fingerprint
orphan_hash <- (BinHandle -> Name -> IO ())
-> ([Name], [IfaceRule], [IfaceFamInst]) -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint (OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env)
                                     ((IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun [IfaceClsInst]
orph_insts, [IfaceRule]
orph_rules, [IfaceFamInst]
orph_fis)

   -- the export list hash doesn't depend on the fingerprints of
   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
   Fingerprint
export_hash <- (BinHandle -> Name -> IO ())
-> ([AvailInfo], Fingerprint, [Fingerprint],
    [(InstalledUnitId, Bool)], [Module], IfaceTrustInfo)
-> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (ModIface -> [AvailInfo]
mi_exports ModIface
iface0,
                       Fingerprint
orphan_hash,
                       [Fingerprint]
dep_orphan_hashes,
                       Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs (ModIface -> Dependencies
mi_deps ModIface
iface0),
                       -- See Note [Export hash depends on non-orphan family instances]
                       Dependencies -> [Module]
dep_finsts (ModIface -> Dependencies
mi_deps ModIface
iface0),
                        -- dep_pkgs: see "Package Version Changes" on
                        -- wiki/Commentary/Compiler/RecompilationAvoidance
                       ModIface -> IfaceTrustInfo
mi_trust ModIface
iface0)
                        -- Make sure change of Safe Haskell mode causes recomp.

   -- Note [Export hash depends on non-orphan family instances]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   --
   -- Suppose we have:
   --
   --   module A where
   --       type instance F Int = Bool
   --
   --   module B where
   --       import A
   --
   --   module C where
   --       import B
   --
   -- The family instance consistency check for C depends on the dep_finsts of
   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need
   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
   -- the exports of B, because C always considers them when checking
   -- consistency.
   --
   -- A full discussion is in #12723.
   --
   -- We do NOT need to hash dep_orphs, because this is implied by
   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
   -- because there is no eager consistency check as there is with type families
   -- (also we didn't store it anywhere!)
   --

   -- put the declarations in a canonical order, sorted by OccName
   let sorted_decls :: [(Fingerprint, IfaceDecl)]
sorted_decls = Map OccName (Fingerprint, IfaceDecl) -> [(Fingerprint, IfaceDecl)]
forall k a. Map k a -> [a]
Map.elems (Map OccName (Fingerprint, IfaceDecl)
 -> [(Fingerprint, IfaceDecl)])
-> Map OccName (Fingerprint, IfaceDecl)
-> [(Fingerprint, IfaceDecl)]
forall a b. (a -> b) -> a -> b
$ [(OccName, (Fingerprint, IfaceDecl))]
-> Map OccName (Fingerprint, IfaceDecl)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(OccName, (Fingerprint, IfaceDecl))]
 -> Map OccName (Fingerprint, IfaceDecl))
-> [(OccName, (Fingerprint, IfaceDecl))]
-> Map OccName (Fingerprint, IfaceDecl)
forall a b. (a -> b) -> a -> b
$
                          [(IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
d, (Fingerprint, IfaceDecl)
e) | e :: (Fingerprint, IfaceDecl)
e@(_, d :: IfaceDecl
d) <- [(Fingerprint, IfaceDecl)]
decls_w_hashes]

   -- the flag hash depends on:
   --   - (some of) dflags
   -- it returns two hashes, one that shouldn't change
   -- the abi hash and one that should
   Fingerprint
flag_hash <- DynFlags
-> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags DynFlags
dflags Module
this_mod BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
opt_hash <- DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintOptFlags DynFlags
dflags BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
hpc_hash <- DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintHpcFlags DynFlags
dflags BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
plugin_hash <- HscEnv -> IO Fingerprint
fingerprintPlugins HscEnv
hsc_env

   -- the ABI hash depends on:
   --   - decls
   --   - export list
   --   - orphans
   --   - deprecations
   --   - flag abi hash
   Fingerprint
mod_hash <- (BinHandle -> Name -> IO ())
-> ([Fingerprint], Fingerprint, Warnings) -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (((Fingerprint, IfaceDecl) -> Fingerprint)
-> [(Fingerprint, IfaceDecl)] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint, IfaceDecl) -> Fingerprint
forall a b. (a, b) -> a
fst [(Fingerprint, IfaceDecl)]
sorted_decls,
                       Fingerprint
export_hash,  -- includes orphan_hash
                       ModIface -> Warnings
mi_warns ModIface
iface0)

   -- The interface hash depends on:
   --   - the ABI hash, plus
   --   - the module level annotations,
   --   - usages
   --   - deps (home and external packages, dependent files)
   --   - hpc
   Fingerprint
iface_hash <- (BinHandle -> Name -> IO ())
-> (Fingerprint, [AnnPayload], [Usage], Dependencies, Bool)
-> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (Fingerprint
mod_hash,
                       OccName -> [AnnPayload]
ann_fn (FilePath -> OccName
mkVarOcc "module"),  -- See mkIfaceAnnCache
                       ModIface -> [Usage]
mi_usages ModIface
iface0,
                       Dependencies
sorted_deps,
                       ModIface -> Bool
mi_hpc ModIface
iface0)

   let
    no_change_at_all :: Bool
no_change_at_all = Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just Fingerprint
iface_hash Maybe Fingerprint -> Maybe Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Fingerprint
mb_old_fingerprint

    final_iface :: ModIface
final_iface = ModIface
iface0 {
                mi_mod_hash :: Fingerprint
mi_mod_hash    = Fingerprint
mod_hash,
                mi_iface_hash :: Fingerprint
mi_iface_hash  = Fingerprint
iface_hash,
                mi_exp_hash :: Fingerprint
mi_exp_hash    = Fingerprint
export_hash,
                mi_orphan_hash :: Fingerprint
mi_orphan_hash = Fingerprint
orphan_hash,
                mi_flag_hash :: Fingerprint
mi_flag_hash   = Fingerprint
flag_hash,
                mi_opt_hash :: Fingerprint
mi_opt_hash    = Fingerprint
opt_hash,
                mi_hpc_hash :: Fingerprint
mi_hpc_hash    = Fingerprint
hpc_hash,
                mi_plugin_hash :: Fingerprint
mi_plugin_hash = Fingerprint
plugin_hash,
                mi_orphan :: Bool
mi_orphan      = Bool -> Bool
not (   (IfaceRule -> Bool) -> [IfaceRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all IfaceRule -> Bool
ifRuleAuto [IfaceRule]
orph_rules
                                           -- See Note [Orphans and auto-generated rules]
                                      Bool -> Bool -> Bool
&& [IfaceClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceClsInst]
orph_insts
                                      Bool -> Bool -> Bool
&& [IfaceFamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceFamInst]
orph_fis),
                mi_finsts :: Bool
mi_finsts      = Bool -> Bool
not (Bool -> Bool)
-> ([IfaceFamInst] -> Bool) -> [IfaceFamInst] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IfaceFamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([IfaceFamInst] -> Bool) -> [IfaceFamInst] -> Bool
forall a b. (a -> b) -> a -> b
$ ModIface -> [IfaceFamInst]
mi_fam_insts ModIface
iface0,
                mi_decls :: [(Fingerprint, IfaceDecl)]
mi_decls       = [(Fingerprint, IfaceDecl)]
sorted_decls,
                mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn     = OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
local_env }
   --
   (ModIface, Bool) -> IO (ModIface, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
final_iface, Bool
no_change_at_all)

  where
    this_mod :: Module
this_mod = ModIface -> Module
mi_module ModIface
iface0
    semantic_mod :: Module
semantic_mod = ModIface -> Module
mi_semantic_module ModIface
iface0
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    (non_orph_insts :: OccEnv [IfaceClsInst]
non_orph_insts, orph_insts :: [IfaceClsInst]
orph_insts) = (IfaceClsInst -> IsOrphan)
-> [IfaceClsInst] -> (OccEnv [IfaceClsInst], [IfaceClsInst])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceClsInst -> IsOrphan
ifInstOrph    (ModIface -> [IfaceClsInst]
mi_insts ModIface
iface0)
    (non_orph_rules :: OccEnv [IfaceRule]
non_orph_rules, orph_rules :: [IfaceRule]
orph_rules) = (IfaceRule -> IsOrphan)
-> [IfaceRule] -> (OccEnv [IfaceRule], [IfaceRule])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceRule -> IsOrphan
ifRuleOrph    (ModIface -> [IfaceRule]
mi_rules ModIface
iface0)
    (non_orph_fis :: OccEnv [IfaceFamInst]
non_orph_fis,   orph_fis :: [IfaceFamInst]
orph_fis)   = (IfaceFamInst -> IsOrphan)
-> [IfaceFamInst] -> (OccEnv [IfaceFamInst], [IfaceFamInst])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceFamInst -> IsOrphan
ifFamInstOrph (ModIface -> [IfaceFamInst]
mi_fam_insts ModIface
iface0)
    fix_fn :: OccName -> Maybe Fixity
fix_fn = ModIface -> OccName -> Maybe Fixity
mi_fix_fn ModIface
iface0
    ann_fn :: OccName -> [AnnPayload]
ann_fn = [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache (ModIface -> [IfaceAnnotation]
mi_anns ModIface
iface0)

-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
-- (in particular, the orphan modules which are transitively imported by the
-- current module).
--
-- Q: Why do we need the hash at all, doesn't the list of transitively
-- imported orphan modules suffice?
--
-- A: If one of our transitive imports adds a new orphan instance, our
-- export hash must change so that modules which import us rebuild.  If we just
-- hashed the [Module], the hash would not change even when a new instance was
-- added to a module that already had an orphan instance.
--
-- Q: Why don't we just hash the orphan hashes of our direct dependencies?
-- Why the full transitive closure?
--
-- A: Suppose we have these modules:
--
--      module A where
--          instance Show (a -> b) where
--      module B where
--          import A -- **
--      module C where
--          import A
--          import B
--
-- Whether or not we add or remove the import to A in B affects the
-- orphan hash of B.  But it shouldn't really affect the orphan hash
-- of C.  If we hashed only direct dependencies, there would be no
-- way to tell that the net effect was a wash, and we'd be forced
-- to recompile C and everything else.
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env :: HscEnv
hsc_env mods :: [Module]
mods = do
  ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
  let
    hpt :: HomePackageTable
hpt        = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    pit :: PackageIfaceTable
pit        = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
    dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    get_orph_hash :: Module -> IO Fingerprint
get_orph_hash mod :: Module
mod =
          case DynFlags
-> HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule DynFlags
dflags HomePackageTable
hpt PackageIfaceTable
pit Module
mod of
            Just iface :: ModIface
iface -> Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> Fingerprint
mi_orphan_hash ModIface
iface)
            Nothing    -> do -- similar to 'mkHashFun'
                ModIface
iface <- HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
                            (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface (FilePath -> SDoc
text "getOrphanHashes") Module
mod WhereFrom
ImportBySystem
                Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> Fingerprint
mi_orphan_hash ModIface
iface)

  --
  (Module -> IO Fingerprint) -> [Module] -> IO [Fingerprint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Module -> IO Fingerprint
get_orph_hash [Module]
mods


sortDependencies :: Dependencies -> Dependencies
sortDependencies :: Dependencies -> Dependencies
sortDependencies d :: Dependencies
d
 = Deps :: [(ModuleName, Bool)]
-> [(InstalledUnitId, Bool)]
-> [Module]
-> [Module]
-> [ModuleName]
-> Dependencies
Deps { dep_mods :: [(ModuleName, Bool)]
dep_mods   = ((ModuleName, Bool) -> (ModuleName, Bool) -> Ordering)
-> [(ModuleName, Bool)] -> [(ModuleName, Bool)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RuleName -> RuleName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RuleName -> RuleName -> Ordering)
-> ((ModuleName, Bool) -> RuleName)
-> (ModuleName, Bool)
-> (ModuleName, Bool)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ModuleName -> RuleName
moduleNameFS(ModuleName -> RuleName)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> RuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst)) (Dependencies -> [(ModuleName, Bool)]
dep_mods Dependencies
d),
          dep_pkgs :: [(InstalledUnitId, Bool)]
dep_pkgs   = ((InstalledUnitId, Bool) -> (InstalledUnitId, Bool) -> Ordering)
-> [(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (InstalledUnitId -> InstalledUnitId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (InstalledUnitId -> InstalledUnitId -> Ordering)
-> ((InstalledUnitId, Bool) -> InstalledUnitId)
-> (InstalledUnitId, Bool)
-> (InstalledUnitId, Bool)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst) (Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs Dependencies
d),
          dep_orphs :: [Module]
dep_orphs  = (Module -> Module -> Ordering) -> [Module] -> [Module]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Module -> Module -> Ordering
stableModuleCmp (Dependencies -> [Module]
dep_orphs Dependencies
d),
          dep_finsts :: [Module]
dep_finsts = (Module -> Module -> Ordering) -> [Module] -> [Module]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Module -> Module -> Ordering
stableModuleCmp (Dependencies -> [Module]
dep_finsts Dependencies
d),
          dep_plgins :: [ModuleName]
dep_plgins = (ModuleName -> ModuleName -> Ordering)
-> [ModuleName] -> [ModuleName]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RuleName -> RuleName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RuleName -> RuleName -> Ordering)
-> (ModuleName -> RuleName) -> ModuleName -> ModuleName -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ModuleName -> RuleName
moduleNameFS) (Dependencies -> [ModuleName]
dep_plgins Dependencies
d) }

-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache anns :: [IfaceAnnotation]
anns
  = \n :: OccName
n -> OccEnv [AnnPayload] -> OccName -> Maybe [AnnPayload]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [AnnPayload]
env OccName
n Maybe [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a. Maybe a -> a -> a
`orElse` []
  where
    pair :: IfaceAnnotation -> (OccName, [AnnPayload])
pair (IfaceAnnotation target :: IfaceAnnTarget
target value :: AnnPayload
value) =
      (case IfaceAnnTarget
target of
          NamedTarget occn :: OccName
occn -> OccName
occn
          ModuleTarget _   -> FilePath -> OccName
mkVarOcc "module"
      , [AnnPayload
value])
    -- flipping (++), so the first argument is always short
    env :: OccEnv [AnnPayload]
env = ([AnnPayload] -> [AnnPayload] -> [AnnPayload])
-> [(OccName, [AnnPayload])] -> OccEnv [AnnPayload]
forall a. (a -> a -> a) -> [(OccName, a)] -> OccEnv a
mkOccEnv_C (([AnnPayload] -> [AnnPayload] -> [AnnPayload])
-> [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a. [a] -> [a] -> [a]
(++)) ((IfaceAnnotation -> (OccName, [AnnPayload]))
-> [IfaceAnnotation] -> [(OccName, [AnnPayload])]
forall a b. (a -> b) -> [a] -> [b]
map IfaceAnnotation -> (OccName, [AnnPayload])
pair [IfaceAnnotation]
anns)

{-
************************************************************************
*                                                                      *
          The ABI of an IfaceDecl
*                                                                      *
************************************************************************

Note [The ABI of an IfaceDecl]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:

   (a) the full name of the identifier (inc. module and package,
       because these are used to construct the symbol name by which
       the identifier is known externally).

   (b) the declaration itself, as exposed to clients.  That is, the
       definition of an Id is included in the fingerprint only if
       it is made available as an unfolding in the interface.

   (c) the fixity of the identifier (if it exists)
   (d) for Ids: rules
   (e) for classes: instances, fixity & rules for methods
   (f) for datatypes: instances, fixity & rules for constrs

Items (c)-(f) are not stored in the IfaceDecl, but instead appear
elsewhere in the interface file.  But they are *fingerprinted* with
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
-}

type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)

data IfaceDeclExtras
  = IfaceIdExtras IfaceIdExtras

  | IfaceDataExtras
       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)
       [IfaceInstABI]           -- Local class and family instances of this tycon
                                -- See Note [Orphans] in InstEnv
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations

  | IfaceClassExtras
       (Maybe Fixity)           -- Fixity of the class itself (if it exists)
       [IfaceInstABI]           -- Local instances of this class *or*
                                --   of its associated data types
                                -- See Note [Orphans] in InstEnv
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
       [IfExtName]              -- Default methods. If a module
                                -- mentions a class, then it can
                                -- instantiate the class and thereby
                                -- use the default methods, so we must
                                -- include these in the fingerprint of
                                -- a class.

  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]

  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]

  | IfaceOtherDeclExtras

data IfaceIdExtras
  = IdExtras
       (Maybe Fixity)           -- Fixity of the Id (if it exists)
       [IfaceRule]              -- Rules for the Id
       [AnnPayload]             -- Annotations for the Id

-- When hashing a class or family instance, we hash only the
-- DFunId or CoAxiom, because that depends on all the
-- information about the instance.
--
type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance

abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl :: IfaceDecl
decl, _) = IfaceDecl
decl

cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 :: IfaceDeclABI
abi1 abi2 :: IfaceDeclABI
abi2 = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName (IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi1) OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare`
                         IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName (IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi2)

freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod :: Module
_mod, decl :: IfaceDecl
decl, extras :: IfaceDeclExtras
extras) =
  IfaceDecl -> NameSet
freeNamesIfDecl IfaceDecl
decl NameSet -> NameSet -> NameSet
`unionNameSet` IfaceDeclExtras -> NameSet
freeNamesDeclExtras IfaceDeclExtras
extras

freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras id_extras :: IfaceIdExtras
id_extras)
  = IfaceIdExtras -> NameSet
freeNamesIdExtras IfaceIdExtras
id_extras
freeNamesDeclExtras (IfaceDataExtras  _ insts :: [Name]
insts _ subs :: [IfaceIdExtras]
subs)
  = [NameSet] -> NameSet
unionNameSets ([Name] -> NameSet
mkNameSet [Name]
insts NameSet -> [NameSet] -> [NameSet]
forall a. a -> [a] -> [a]
: (IfaceIdExtras -> NameSet) -> [IfaceIdExtras] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> NameSet
freeNamesIdExtras [IfaceIdExtras]
subs)
freeNamesDeclExtras (IfaceClassExtras _ insts :: [Name]
insts _ subs :: [IfaceIdExtras]
subs defms :: [Name]
defms)
  = [NameSet] -> NameSet
unionNameSets ([NameSet] -> NameSet) -> [NameSet] -> NameSet
forall a b. (a -> b) -> a -> b
$
      [Name] -> NameSet
mkNameSet [Name]
insts NameSet -> [NameSet] -> [NameSet]
forall a. a -> [a] -> [a]
: [Name] -> NameSet
mkNameSet [Name]
defms NameSet -> [NameSet] -> [NameSet]
forall a. a -> [a] -> [a]
: (IfaceIdExtras -> NameSet) -> [IfaceIdExtras] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> NameSet
freeNamesIdExtras [IfaceIdExtras]
subs
freeNamesDeclExtras (IfaceSynonymExtras _ _)
  = NameSet
emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras _ insts :: [Name]
insts _)
  = [Name] -> NameSet
mkNameSet [Name]
insts
freeNamesDeclExtras IfaceOtherDeclExtras
  = NameSet
emptyNameSet

freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras (IdExtras _ rules :: [IfaceRule]
rules _) = [NameSet] -> NameSet
unionNameSets ((IfaceRule -> NameSet) -> [IfaceRule] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceRule -> NameSet
freeNamesIfRule [IfaceRule]
rules)

instance Outputable IfaceDeclExtras where
  ppr :: IfaceDeclExtras -> SDoc
ppr IfaceOtherDeclExtras       = SDoc
Outputable.empty
  ppr (IfaceIdExtras  extras :: IfaceIdExtras
extras)    = IfaceIdExtras -> SDoc
ppr_id_extras IfaceIdExtras
extras
  ppr (IfaceSynonymExtras fix :: Maybe Fixity
fix anns :: [AnnPayload]
anns) = [SDoc] -> SDoc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns]
  ppr (IfaceFamilyExtras fix :: Maybe Fixity
fix finsts :: [Name]
finsts anns :: [AnnPayload]
anns) = [SDoc] -> SDoc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
finsts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns]
  ppr (IfaceDataExtras fix :: Maybe Fixity
fix insts :: [Name]
insts anns :: [AnnPayload]
anns stuff :: [IfaceIdExtras]
stuff) = [SDoc] -> SDoc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
ppr_insts [Name]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
                                                [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff]
  ppr (IfaceClassExtras fix :: Maybe Fixity
fix insts :: [Name]
insts anns :: [AnnPayload]
anns stuff :: [IfaceIdExtras]
stuff defms :: [Name]
defms) =
    [SDoc] -> SDoc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
ppr_insts [Name]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
          [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff, [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
defms]

ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts :: [Name] -> SDoc
ppr_insts _ = FilePath -> SDoc
text "<insts>"

ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s stuff :: [IfaceIdExtras]
stuff = [SDoc] -> SDoc
vcat ((IfaceIdExtras -> SDoc) -> [IfaceIdExtras] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> SDoc
ppr_id_extras [IfaceIdExtras]
stuff)

ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras (IdExtras fix :: Maybe Fixity
fix rules :: [IfaceRule]
rules anns :: [AnnPayload]
anns) = Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((IfaceRule -> SDoc) -> [IfaceRule] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map IfaceRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceRule]
rules) SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((AnnPayload -> SDoc) -> [AnnPayload] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map AnnPayload -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns)

-- This instance is used only to compute fingerprints
instance Binary IfaceDeclExtras where
  get :: BinHandle -> IO IfaceDeclExtras
get _bh :: BinHandle
_bh = FilePath -> IO IfaceDeclExtras
forall a. FilePath -> a
panic "no get for IfaceDeclExtras"
  put_ :: BinHandle -> IfaceDeclExtras -> IO ()
put_ bh :: BinHandle
bh (IfaceIdExtras extras :: IfaceIdExtras
extras) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1; BinHandle -> IfaceIdExtras -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceIdExtras
extras
  put_ bh :: BinHandle
bh (IfaceDataExtras fix :: Maybe Fixity
fix insts :: [Name]
insts anns :: [AnnPayload]
anns cons :: [IfaceIdExtras]
cons) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
insts; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns; BinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceIdExtras]
cons
  put_ bh :: BinHandle
bh (IfaceClassExtras fix :: Maybe Fixity
fix insts :: [Name]
insts anns :: [AnnPayload]
anns methods :: [IfaceIdExtras]
methods defms :: [Name]
defms) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3
   BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix
   BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
insts
   BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
   BinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceIdExtras]
methods
   BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
defms
  put_ bh :: BinHandle
bh (IfaceSynonymExtras fix :: Maybe Fixity
fix anns :: [AnnPayload]
anns) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 4; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
  put_ bh :: BinHandle
bh (IfaceFamilyExtras fix :: Maybe Fixity
fix finsts :: [Name]
finsts anns :: [AnnPayload]
anns) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 5; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
finsts; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
  put_ bh :: BinHandle
bh IfaceOtherDeclExtras = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 6

instance Binary IfaceIdExtras where
  get :: BinHandle -> IO IfaceIdExtras
get _bh :: BinHandle
_bh = FilePath -> IO IfaceIdExtras
forall a. FilePath -> a
panic "no get for IfaceIdExtras"
  put_ :: BinHandle -> IfaceIdExtras -> IO ()
put_ bh :: BinHandle
bh (IdExtras fix :: Maybe Fixity
fix rules :: [IfaceRule]
rules anns :: [AnnPayload]
anns)= do { BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [IfaceRule] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceRule]
rules; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns }

declExtras :: (OccName -> Maybe Fixity)
           -> (OccName -> [AnnPayload])
           -> OccEnv [IfaceRule]
           -> OccEnv [IfaceClsInst]
           -> OccEnv [IfaceFamInst]
           -> OccEnv IfExtName          -- lookup default method names
           -> IfaceDecl
           -> IfaceDeclExtras

declExtras :: (OccName -> Maybe Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv Name
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn :: OccName -> Maybe Fixity
fix_fn ann_fn :: OccName -> [AnnPayload]
ann_fn rule_env :: OccEnv [IfaceRule]
rule_env inst_env :: OccEnv [IfaceClsInst]
inst_env fi_env :: OccEnv [IfaceFamInst]
fi_env dm_env :: OccEnv Name
dm_env decl :: IfaceDecl
decl
  = case IfaceDecl
decl of
      IfaceId{} -> IfaceIdExtras -> IfaceDeclExtras
IfaceIdExtras (OccName -> IfaceIdExtras
id_extras OccName
n)
      IfaceData{ifCons :: IfaceDecl -> IfaceConDecls
ifCons=IfaceConDecls
cons} ->
                     Maybe Fixity
-> [Name] -> [AnnPayload] -> [IfaceIdExtras] -> IfaceDeclExtras
IfaceDataExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                        ((IfaceFamInst -> Name) -> [IfaceFamInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> Name
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                         (IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun         (OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env OccName
n))
                        (OccName -> [AnnPayload]
ann_fn OccName
n)
                        ((IfaceConDecl -> IfaceIdExtras)
-> [IfaceConDecl] -> [IfaceIdExtras]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> IfaceIdExtras
id_extras (OccName -> IfaceIdExtras)
-> (IfaceConDecl -> OccName) -> IfaceConDecl -> IfaceIdExtras
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Name -> OccName)
-> (IfaceConDecl -> Name) -> IfaceConDecl -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceConDecl -> Name
ifConName) (IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfaceConDecls
cons))
      IfaceClass{ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfConcreteClass { ifSigs :: IfaceClassBody -> [IfaceClassOp]
ifSigs=[IfaceClassOp]
sigs, ifATs :: IfaceClassBody -> [IfaceAT]
ifATs=[IfaceAT]
ats }} ->
                     Maybe Fixity
-> [Name]
-> [AnnPayload]
-> [IfaceIdExtras]
-> [Name]
-> IfaceDeclExtras
IfaceClassExtras (OccName -> Maybe Fixity
fix_fn OccName
n) [Name]
insts (OccName -> [AnnPayload]
ann_fn OccName
n) [IfaceIdExtras]
meths [Name]
defms
          where
            insts :: [Name]
insts = ((IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun ([IfaceClsInst] -> [Name]) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((IfaceAT -> [IfaceClsInst]) -> [IfaceAT] -> [IfaceClsInst]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IfaceAT -> [IfaceClsInst]
at_extras [IfaceAT]
ats)
                                    [IfaceClsInst] -> [IfaceClsInst] -> [IfaceClsInst]
forall a. [a] -> [a] -> [a]
++ OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env OccName
n)
                           -- Include instances of the associated types
                           -- as well as instances of the class (Trac #5147)
            meths :: [IfaceIdExtras]
meths = [OccName -> IfaceIdExtras
id_extras (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
op) | IfaceClassOp op :: Name
op _ _ <- [IfaceClassOp]
sigs]
            -- Names of all the default methods (see Note [default method Name])
            defms :: [Name]
defms = [ Name
dmName
                    | IfaceClassOp bndr :: Name
bndr _ (Just _) <- [IfaceClassOp]
sigs
                    , let dmOcc :: OccName
dmOcc = OccName -> OccName
mkDefaultMethodOcc (Name -> OccName
nameOccName Name
bndr)
                    , Just dmName :: Name
dmName <- [OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
dm_env OccName
dmOcc] ]
      IfaceSynonym{} -> Maybe Fixity -> [AnnPayload] -> IfaceDeclExtras
IfaceSynonymExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                                           (OccName -> [AnnPayload]
ann_fn OccName
n)
      IfaceFamily{} -> Maybe Fixity -> [Name] -> [AnnPayload] -> IfaceDeclExtras
IfaceFamilyExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                        ((IfaceFamInst -> Name) -> [IfaceFamInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> Name
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n))
                        (OccName -> [AnnPayload]
ann_fn OccName
n)
      _other :: IfaceDecl
_other -> IfaceDeclExtras
IfaceOtherDeclExtras
  where
        n :: OccName
n = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl
        id_extras :: OccName -> IfaceIdExtras
id_extras occ :: OccName
occ = Maybe Fixity -> [IfaceRule] -> [AnnPayload] -> IfaceIdExtras
IdExtras (OccName -> Maybe Fixity
fix_fn OccName
occ) (OccEnv [IfaceRule] -> OccName -> [IfaceRule]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceRule]
rule_env OccName
occ) (OccName -> [AnnPayload]
ann_fn OccName
occ)
        at_extras :: IfaceAT -> [IfaceClsInst]
at_extras (IfaceAT decl :: IfaceDecl
decl _) = OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl)


{- Note [default method Name] (see also #15970)

The Names for the default methods aren't available in the IfaceSyn.

* We originally start with a DefMethInfo from the class, contain a
  Name for the default method

* We turn that into IfaceSyn as a DefMethSpec which lacks a Name
  entirely. Why? Because the Name can be derived from the method name
  (in TcIface), so doesn't need to be serialised into the interface
  file.

But now we have to get the Name back, because the class declaration's
fingerprint needs to depend on it (this was the bug in #15970).  This
is done in a slightly convoluted way:

* Then, in addFingerprints we build a map that maps OccNames to Names

* We pass that map to declExtras which laboriously looks up in the map
  (using the derived occurrence name) to recover the Name we have just
  thrown away.
-}

lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env :: OccEnv [v]
env k :: OccName
k = OccEnv [v] -> OccName -> Maybe [v]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [v]
env OccName
k Maybe [v] -> [v] -> [v]
forall a. Maybe a -> a -> a
`orElse` []

{-
-- for testing: use the md5sum command to generate fingerprints and
-- compare the results against our built-in version.
  fp' <- oldMD5 dflags bh
  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
               else return fp

oldMD5 dflags bh = do
  tmp <- newTempName dflags CurrentModule "bin"
  writeBinMem bh tmp
  tmp2 <- newTempName dflags CurrentModule "md5"
  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
  r <- system cmd
  case r of
    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
    ExitSuccess -> do
        hash_str <- readFile tmp2
        return $! readHexFingerprint hash_str
-}

----------------------
-- mkOrphMap partitions instance decls or rules into
--      (a) an OccEnv for ones that are not orphans,
--          mapping the local OccName to a list of its decls
--      (b) a list of orphan decls
mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
          -> [decl]             -- Sorted into canonical order
          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
                                --      each sublist in canonical order
              [decl])           -- Orphan decls; in canonical order
mkOrphMap :: (decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap get_key :: decl -> IsOrphan
get_key decls :: [decl]
decls
  = ((OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl]))
-> (OccEnv [decl], [decl]) -> [decl] -> (OccEnv [decl], [decl])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl])
go (OccEnv [decl]
forall a. OccEnv a
emptyOccEnv, []) [decl]
decls
  where
    go :: (OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl])
go (non_orphs :: OccEnv [decl]
non_orphs, orphs :: [decl]
orphs) d :: decl
d
        | NotOrphan occ :: OccName
occ <- decl -> IsOrphan
get_key decl
d
        = ((decl -> [decl] -> [decl])
-> (decl -> [decl])
-> OccEnv [decl]
-> OccName
-> decl
-> OccEnv [decl]
forall a b.
(a -> b -> b) -> (a -> b) -> OccEnv b -> OccName -> a -> OccEnv b
extendOccEnv_Acc (:) decl -> [decl]
forall a. a -> [a]
singleton OccEnv [decl]
non_orphs OccName
occ decl
d, [decl]
orphs)
        | Bool
otherwise = (OccEnv [decl]
non_orphs, decl
ddecl -> [decl] -> [decl]
forall a. a -> [a] -> [a]
:[decl]
orphs)

{-
************************************************************************
*                                                                      *
       COMPLETE Pragmas
*                                                                      *
************************************************************************
-}

mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig (CompleteMatch cls :: [Name]
cls tc :: Name
tc) = [Name] -> Name -> IfaceCompleteMatch
IfaceCompleteMatch [Name]
cls Name
tc


{-
************************************************************************
*                                                                      *
       Keeping track of what we've slurped, and fingerprints
*                                                                      *
************************************************************************
-}


mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation (Annotation { ann_target :: Annotation -> CoreAnnTarget
ann_target = CoreAnnTarget
target, ann_value :: Annotation -> AnnPayload
ann_value = AnnPayload
payload })
  = IfaceAnnotation :: IfaceAnnTarget -> AnnPayload -> IfaceAnnotation
IfaceAnnotation {
        ifAnnotatedTarget :: IfaceAnnTarget
ifAnnotatedTarget = (Name -> OccName) -> CoreAnnTarget -> IfaceAnnTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> OccName
nameOccName CoreAnnTarget
target,
        ifAnnotatedValue :: AnnPayload
ifAnnotatedValue = AnnPayload
payload
    }

mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical
mkIfaceExports :: [AvailInfo] -> [AvailInfo]
mkIfaceExports exports :: [AvailInfo]
exports
  = (AvailInfo -> AvailInfo -> Ordering) -> [AvailInfo] -> [AvailInfo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy AvailInfo -> AvailInfo -> Ordering
stableAvailCmp ((AvailInfo -> AvailInfo) -> [AvailInfo] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map AvailInfo -> AvailInfo
sort_subs [AvailInfo]
exports)
  where
    sort_subs :: AvailInfo -> AvailInfo
    sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n :: Name
n) = Name -> AvailInfo
Avail Name
n
    sort_subs (AvailTC n :: Name
n [] fs :: [FieldLabel]
fs) = Name -> [Name] -> [FieldLabel] -> AvailInfo
AvailTC Name
n [] ([FieldLabel] -> [FieldLabel]
sort_flds [FieldLabel]
fs)
    sort_subs (AvailTC n :: Name
n (m :: Name
m:ms :: [Name]
ms) fs :: [FieldLabel]
fs)
       | Name
nName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==Name
m      = Name -> [Name] -> [FieldLabel] -> AvailInfo
AvailTC Name
n (Name
mName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Name -> Name -> Ordering
stableNameCmp [Name]
ms) ([FieldLabel] -> [FieldLabel]
sort_flds [FieldLabel]
fs)
       | Bool
otherwise = Name -> [Name] -> [FieldLabel] -> AvailInfo
AvailTC Name
n ((Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Name -> Name -> Ordering
stableNameCmp (Name
mName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ms)) ([FieldLabel] -> [FieldLabel]
sort_flds [FieldLabel]
fs)
       -- Maintain the AvailTC Invariant

    sort_flds :: [FieldLabel] -> [FieldLabel]
sort_flds = (FieldLabel -> FieldLabel -> Ordering)
-> [FieldLabel] -> [FieldLabel]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name -> Name -> Ordering
stableNameCmp (Name -> Name -> Ordering)
-> (FieldLabel -> Name) -> FieldLabel -> FieldLabel -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector)

{-
Note [Original module]
~~~~~~~~~~~~~~~~~~~~~
Consider this:
        module X where { data family T }
        module Y( T(..) ) where { import X; data instance T Int = MkT Int }
The exported Avail from Y will look like
        X.T{X.T, Y.MkT}
That is, in Y,
  - only MkT is brought into scope by the data instance;
  - but the parent (used for grouping and naming in T(..) exports) is X.T
  - and in this case we export X.T too

In the result of MkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.

Note [Internal used_names]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Most of the used_names are External Names, but we can have Internal
Names too: see Note [Binders in Template Haskell] in Convert, and
Trac #5362 for an example.  Such Names are always
  - Such Names are always for locally-defined things, for which we
    don't gather usage info, so we can just ignore them in ent_map
  - They are always System Names, hence the assert, just as a double check.


************************************************************************
*                                                                      *
        Load the old interface file for this module (unless
        we have it already), and check whether it is up to date
*                                                                      *
************************************************************************
-}

data RecompileRequired
  = UpToDate
       -- ^ everything is up to date, recompilation is not required
  | MustCompile
       -- ^ The .hs file has been touched, or the .o/.hi file does not exist
  | RecompBecause String
       -- ^ The .o/.hi files are up to date, but something else has changed
       -- to force recompilation; the String says what (one-line summary)
   deriving RecompileRequired -> RecompileRequired -> Bool
(RecompileRequired -> RecompileRequired -> Bool)
-> (RecompileRequired -> RecompileRequired -> Bool)
-> Eq RecompileRequired
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecompileRequired -> RecompileRequired -> Bool
$c/= :: RecompileRequired -> RecompileRequired -> Bool
== :: RecompileRequired -> RecompileRequired -> Bool
$c== :: RecompileRequired -> RecompileRequired -> Bool
Eq

instance Semigroup RecompileRequired where
  UpToDate <> :: RecompileRequired -> RecompileRequired -> RecompileRequired
<> r :: RecompileRequired
r = RecompileRequired
r
  mc :: RecompileRequired
mc <> _       = RecompileRequired
mc

instance Monoid RecompileRequired where
  mempty :: RecompileRequired
mempty = RecompileRequired
UpToDate

recompileRequired :: RecompileRequired -> Bool
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = Bool
False
recompileRequired _ = Bool
True



-- | Top level function to check if the version of an old interface file
-- is equivalent to the current source file the user asked us to compile.
-- If the same, we can avoid recompilation. We return a tuple where the
-- first element is a bool saying if we should recompile the object file
-- and the second is maybe the interface file, where Nothng means to
-- rebuild the interface file not use the exisitng one.
checkOldIface
  :: HscEnv
  -> ModSummary
  -> SourceModified
  -> Maybe ModIface         -- Old interface from compilation manager, if any
  -> IO (RecompileRequired, Maybe ModIface)

checkOldIface :: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary source_modified :: SourceModified
source_modified maybe_iface :: Maybe ModIface
maybe_iface
  = do  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        DynFlags -> FilePath -> IO ()
showPass DynFlags
dflags (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Checking old interface for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
              (DynFlags -> Module -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
showPpr DynFlags
dflags (Module -> FilePath) -> Module -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
mod_summary) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
              " (use -ddump-hi-diffs for more details)"
        SDoc
-> HscEnv
-> IfG (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text "checkOldIface") HscEnv
hsc_env (IfG (RecompileRequired, Maybe ModIface)
 -> IO (RecompileRequired, Maybe ModIface))
-> IfG (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$
            HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
maybe_iface

check_old_iface
  :: HscEnv
  -> ModSummary
  -> SourceModified
  -> Maybe ModIface
  -> IfG (RecompileRequired, Maybe ModIface)

check_old_iface :: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary src_modified :: SourceModified
src_modified maybe_iface :: Maybe ModIface
maybe_iface
  = let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        getIface :: IOEnv (Env m n) (Maybe ModIface)
getIface =
            case Maybe ModIface
maybe_iface of
                Just _  -> do
                    SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "We already have the old interface for" SDoc -> SDoc -> SDoc
<+>
                      Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
mod_summary))
                    Maybe ModIface -> IOEnv (Env m n) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
maybe_iface
                Nothing -> IOEnv (Env m n) (Maybe ModIface)
forall gbl lcl. IOEnv (Env gbl lcl) (Maybe ModIface)
loadIface

        loadIface :: IOEnv (Env gbl lcl) (Maybe ModIface)
loadIface = do
             let iface_path :: FilePath
iface_path = ModSummary -> FilePath
msHiFilePath ModSummary
mod_summary
             MaybeErr SDoc ModIface
read_result <- Module -> FilePath -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)
forall gbl lcl.
Module -> FilePath -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)
readIface (ModSummary -> Module
ms_mod ModSummary
mod_summary) FilePath
iface_path
             case MaybeErr SDoc ModIface
read_result of
                 Failed err :: SDoc
err -> do
                     SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "FYI: cannot read old interface file:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 SDoc
err)
                     SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (FilePath -> SDoc
text "Old interface file was invalid:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 SDoc
err)
                     Maybe ModIface -> IOEnv (Env gbl lcl) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
                 Succeeded iface :: ModIface
iface -> do
                     SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "Read the interface file" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
iface_path)
                     Maybe ModIface -> IOEnv (Env gbl lcl) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModIface -> IOEnv (Env gbl lcl) (Maybe ModIface))
-> Maybe ModIface -> IOEnv (Env gbl lcl) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface

        src_changed :: Bool
src_changed
            | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) = Bool
True
            | SourceModified
SourceModified <- SourceModified
src_modified = Bool
True
            | Bool
otherwise = Bool
False
    in do
        Bool -> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
src_changed (IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ())
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$
            SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text "Source file changed or recompilation check turned off")

        case Bool
src_changed of
            -- If the source has changed and we're in interactive mode,
            -- avoid reading an interface; just return the one we might
            -- have been supplied with.
            True | Bool -> Bool
not (HscTarget -> Bool
isObjectTarget (HscTarget -> Bool) -> HscTarget -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> HscTarget
hscTarget DynFlags
dflags) ->
                (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
maybe_iface)

            -- Try and read the old interface for the current module
            -- from the .hi file left from the last time we compiled it
            True -> do
                Maybe ModIface
maybe_iface' <- IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall gbl lcl. IOEnv (Env gbl lcl) (Maybe ModIface)
getIface
                (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
maybe_iface')

            False -> do
                Maybe ModIface
maybe_iface' <- IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall gbl lcl. IOEnv (Env gbl lcl) (Maybe ModIface)
getIface
                case Maybe ModIface
maybe_iface' of
                    -- We can't retrieve the iface
                    Nothing    -> (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
forall a. Maybe a
Nothing)

                    -- We have got the old iface; check its versions
                    -- even in the SourceUnmodifiedAndStable case we
                    -- should check versions because some packages
                    -- might have changed or gone away.
                    Just iface :: ModIface
iface -> HscEnv
-> ModSummary
-> ModIface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface

-- | Check if a module is still the same 'version'.
--
-- This function is called in the recompilation checker after we have
-- determined that the module M being checked hasn't had any changes
-- to its source file since we last compiled M. So at this point in general
-- two things may have changed that mean we should recompile M:
--   * The interface export by a dependency of M has changed.
--   * The compiler flags specified this time for M have changed
--     in a manner that is significant for recompilation.
-- We return not just if we should recompile the object file but also
-- if we should rebuild the interface file.
checkVersions :: HscEnv
              -> ModSummary
              -> ModIface       -- Old interface
              -> IfG (RecompileRequired, Maybe ModIface)
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary iface :: ModIface
iface
  = do { SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (FilePath -> SDoc
text "Considering whether compilation is required for" SDoc -> SDoc -> SDoc
<+>
                        Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
mi_module ModIface
iface) SDoc -> SDoc -> SDoc
<> SDoc
colon)

       -- readIface will have verified that the InstalledUnitId matches,
       -- but we ALSO must make sure the instantiation matches up.  See
       -- test case bkpcabal04!
       ; if Module -> UnitId
moduleUnitId (ModIface -> Module
mi_module ModIface
iface) UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause "-this-unit-id changed", Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> ModIface -> IfG RecompileRequired
checkHsig ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> IfG RecompileRequired
checkHie ModSummary
mod_summary
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {


       -- Source code unchanged and no errors yet... carry on
       --
       -- First put the dependent-module info, read from the old
       -- interface, into the envt, so that when we look for
       -- interfaces we look for the right one (.hi or .hi-boot)
       --
       -- It's just temporary because either the usage check will succeed
       -- (in which case we are done with this module) or it'll fail (in which
       -- case we'll compile the module from scratch anyhow).
       --
       -- We do this regardless of compilation mode, although in --make mode
       -- all the dependent modules should be in the HPT already, so it's
       -- quite redundant
       ; (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env IfGblEnv ()) ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ((ExternalPackageState -> ExternalPackageState)
 -> IOEnv (Env IfGblEnv ()) ())
-> (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ \eps :: ExternalPackageState
eps  -> ExternalPackageState
eps { eps_is_boot :: ModuleNameEnv (ModuleName, Bool)
eps_is_boot = ModuleNameEnv (ModuleName, Bool)
mod_deps }
       ; RecompileRequired
recomp <- [IfG RecompileRequired] -> IfG RecompileRequired
checkList [UnitId -> Usage -> IfG RecompileRequired
checkModUsage UnitId
this_pkg Usage
u | Usage
u <- ModIface -> [Usage]
mi_usages ModIface
iface]
       ; (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface)
    }}}}}}}}}}
  where
    this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
    -- This is a bit of a hack really
    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
    mod_deps :: ModuleNameEnv (ModuleName, Bool)
mod_deps = [(ModuleName, Bool)] -> ModuleNameEnv (ModuleName, Bool)
mkModDeps (Dependencies -> [(ModuleName, Bool)]
dep_mods (ModIface -> Dependencies
mi_deps ModIface
iface))

-- | Check if any plugins are requesting recompilation
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins hsc :: HscEnv
hsc iface :: ModIface
iface = IO RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IfG RecompileRequired)
-> IO RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
  Fingerprint
new_fingerprint <- HscEnv -> IO Fingerprint
fingerprintPlugins HscEnv
hsc
  let old_fingerprint :: Fingerprint
old_fingerprint = ModIface -> Fingerprint
mi_plugin_hash ModIface
iface
  PluginRecompile
pr <- [PluginRecompile] -> PluginRecompile
forall a. Monoid a => [a] -> a
mconcat ([PluginRecompile] -> PluginRecompile)
-> IO [PluginRecompile] -> IO PluginRecompile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PluginWithArgs -> IO PluginRecompile)
-> [PluginWithArgs] -> IO [PluginRecompile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' (DynFlags -> [PluginWithArgs]
plugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc))
  RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$
    Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired Fingerprint
old_fingerprint Fingerprint
new_fingerprint PluginRecompile
pr

fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins hsc_env :: HscEnv
hsc_env = do
  [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' ([PluginWithArgs] -> IO Fingerprint)
-> [PluginWithArgs] -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags -> [PluginWithArgs]
plugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' plugins :: [PluginWithArgs]
plugins = do
  PluginRecompile
res <- [PluginRecompile] -> PluginRecompile
forall a. Monoid a => [a] -> a
mconcat ([PluginRecompile] -> PluginRecompile)
-> IO [PluginRecompile] -> IO PluginRecompile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PluginWithArgs -> IO PluginRecompile)
-> [PluginWithArgs] -> IO [PluginRecompile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' [PluginWithArgs]
plugins
  Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ case PluginRecompile
res of
      NoForceRecompile ->  FilePath -> Fingerprint
fingerprintString "NoForceRecompile"
      ForceRecompile   -> FilePath -> Fingerprint
fingerprintString "ForceRecompile"
      -- is the chance of collision worth worrying about?
      -- An alternative is to fingerprintFingerprints [fingerprintString
      -- "maybeRecompile", fp]
      (MaybeRecompile fp :: Fingerprint
fp) -> Fingerprint
fp


pluginRecompileToRecompileRequired
    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired old_fp :: Fingerprint
old_fp new_fp :: Fingerprint
new_fp pr :: PluginRecompile
pr
  | Fingerprint
old_fp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_fp =
    case PluginRecompile
pr of
      NoForceRecompile  -> RecompileRequired
UpToDate

      -- we already checked the fingerprint above so a mismatch is not possible
      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
      MaybeRecompile _  -> RecompileRequired
UpToDate

      -- when we have an impure plugin in the stack we have to unconditionally
      -- recompile since it might integrate all sorts of crazy IO results into
      -- its compilation output.
      ForceRecompile    -> FilePath -> RecompileRequired
RecompBecause "Impure plugin forced recompilation"

  | Fingerprint
old_fp Fingerprint -> [Fingerprint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fingerprint]
magic_fingerprints Bool -> Bool -> Bool
||
    Fingerprint
new_fp Fingerprint -> [Fingerprint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fingerprint]
magic_fingerprints
    -- The fingerprints do not match either the old or new one is a magic
    -- fingerprint. This happens when non-pure plugins are added for the first
    -- time or when we go from one recompilation strategy to another: (force ->
    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
    --
    -- For example when we go from from ForceRecomp to NoForceRecomp
    -- recompilation is triggered since the old impure plugins could have
    -- changed the build output which is now back to normal.
    = FilePath -> RecompileRequired
RecompBecause "Plugins changed"

  | Bool
otherwise =
    let reason :: FilePath
reason = "Plugin fingerprint changed" in
    case PluginRecompile
pr of
      -- even though a plugin is forcing recompilation the fingerprint changed
      -- which would cause recompilation anyways so we report the fingerprint
      -- change instead.
      ForceRecompile   -> FilePath -> RecompileRequired
RecompBecause FilePath
reason

      _                -> FilePath -> RecompileRequired
RecompBecause FilePath
reason

 where
   magic_fingerprints :: [Fingerprint]
magic_fingerprints =
       [ FilePath -> Fingerprint
fingerprintString "NoForceRecompile"
       , FilePath -> Fingerprint
fingerprintString "ForceRecompile"
       ]


-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig mod_summary :: ModSummary
mod_summary iface :: ModIface
iface = do
    DynFlags
dflags <- IOEnv (Env IfGblEnv ()) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        inner_mod :: Module
inner_mod = DynFlags -> ModuleName -> Module
canonicalizeHomeModule DynFlags
dflags (Module -> ModuleName
moduleName Module
outer_mod)
    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
    case Module
inner_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModIface -> Module
mi_semantic_module ModIface
iface of
        True -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "implementing module unchanged")
        False -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause "implementing module changed")

-- | Check if @.hie@ file is out of date or missing.
checkHie :: ModSummary -> IfG RecompileRequired
checkHie :: ModSummary -> IfG RecompileRequired
checkHie mod_summary :: ModSummary
mod_summary = do
    DynFlags
dflags <- IOEnv (Env IfGblEnv ()) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let hie_date_opt :: Maybe UTCTime
hie_date_opt = ModSummary -> Maybe UTCTime
ms_hie_date ModSummary
mod_summary
        hs_date :: UTCTime
hs_date = ModSummary -> UTCTime
ms_hs_date ModSummary
mod_summary
    RecompileRequired -> IfG RecompileRequired
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecompileRequired -> IfG RecompileRequired)
-> RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ case GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags of
               False -> RecompileRequired
UpToDate
               True -> case Maybe UTCTime
hie_date_opt of
                           Nothing -> FilePath -> RecompileRequired
RecompBecause "HIE file is missing"
                           Just hie_date :: UTCTime
hie_date
                               | UTCTime
hie_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
hs_date
                               -> FilePath -> RecompileRequired
RecompBecause "HIE file is out of date"
                               | Bool
otherwise
                               -> RecompileRequired
UpToDate

-- | Check the flags haven't changed
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash hsc_env :: HscEnv
hsc_env iface :: ModIface
iface = do
    let old_hash :: Fingerprint
old_hash = ModIface -> Fingerprint
mi_flag_hash ModIface
iface
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                             (ModIface -> Module
mi_module ModIface
iface)
                                             BinHandle -> Name -> IO ()
putNameLiterally
    case Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash of
        True  -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "Module flags unchanged")
        False -> FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash "flags changed"
                     (FilePath -> SDoc
text "  Module flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- | Check the optimisation flags haven't changed
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash hsc_env :: HscEnv
hsc_env iface :: ModIface
iface = do
    let old_hash :: Fingerprint
old_hash = ModIface -> Fingerprint
mi_opt_hash ModIface
iface
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintOptFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               BinHandle -> Name -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "Optimisation flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreOptimChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "Optimisation flags changed; ignoring")
       | Bool
otherwise
         -> FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash "Optimisation flags changed"
                     (FilePath -> SDoc
text "  Optimisation flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- | Check the HPC flags haven't changed
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash hsc_env :: HscEnv
hsc_env iface :: ModIface
iface = do
    let old_hash :: Fingerprint
old_hash = ModIface -> Fingerprint
mi_hpc_hash ModIface
iface
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintHpcFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               BinHandle -> Name -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "HPC flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreHpcChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "HPC flags changed; ignoring")
       | Bool
otherwise
         -> FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash "HPC flags changed"
                     (FilePath -> SDoc
text "  HPC flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- Check that the set of signatures we are merging in match.
-- If the -unit-id flags change, this can change too.
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures mod_summary :: ModSummary
mod_summary iface :: ModIface
iface = do
    DynFlags
dflags <- IOEnv (Env IfGblEnv ()) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let old_merged :: [Module]
old_merged = [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort [ Module
mod | UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod } <- ModIface -> [Usage]
mi_usages ModIface
iface ]
        new_merged :: [Module]
new_merged = case ModuleName -> Map ModuleName [IndefModule] -> Maybe [IndefModule]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary)
                                     (PackageState -> Map ModuleName [IndefModule]
requirementContext (DynFlags -> PackageState
pkgState DynFlags
dflags)) of
                        Nothing -> []
                        Just r :: [IndefModule]
r -> [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort ([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ (IndefModule -> Module) -> [IndefModule] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> IndefModule -> Module
indefModuleToModule DynFlags
dflags) [IndefModule]
r
    if [Module]
old_merged [Module] -> [Module] -> Bool
forall a. Eq a => a -> a -> Bool
== [Module]
new_merged
        then SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "signatures to merge in unchanged" SDoc -> SDoc -> SDoc
$$ [Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Module]
new_merged)
        else RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause "signatures to merge in changed")

-- If the direct imports of this module are resolved to targets that
-- are not among the dependencies of the previous interface file,
-- then we definitely need to recompile.  This catches cases like
--   - an exposed package has been upgraded
--   - we are compiling with different package flags
--   - a home module that was shadowing a package module has been removed
--   - a new home module has been added that shadows a package module
-- See bug #1372.
--
-- Returns (RecompBecause <textual reason>) if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env :: HscEnv
hsc_env summary :: ModSummary
summary iface :: ModIface
iface
 = [IfG RecompileRequired] -> IfG RecompileRequired
checkList (((Maybe RuleName, GenLocated SrcSpan ModuleName)
 -> IfG RecompileRequired)
-> [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
-> [IfG RecompileRequired]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe RuleName, GenLocated SrcSpan ModuleName)
-> IfG RecompileRequired
forall l m n.
(Maybe RuleName, GenLocated l ModuleName)
-> IOEnv (Env m n) RecompileRequired
dep_missing (ModSummary -> [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
summary [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
-> [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
-> [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [(Maybe RuleName, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary))
  where
   prev_dep_mods :: [(ModuleName, Bool)]
prev_dep_mods = Dependencies -> [(ModuleName, Bool)]
dep_mods (ModIface -> Dependencies
mi_deps ModIface
iface)
   prev_dep_plgn :: [ModuleName]
prev_dep_plgn = Dependencies -> [ModuleName]
dep_plgins (ModIface -> Dependencies
mi_deps ModIface
iface)
   prev_dep_pkgs :: [(InstalledUnitId, Bool)]
prev_dep_pkgs = Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs (ModIface -> Dependencies
mi_deps ModIface
iface)

   this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

   dep_missing :: (Maybe RuleName, GenLocated l ModuleName)
-> IOEnv (Env m n) RecompileRequired
dep_missing (mb_pkg :: Maybe RuleName
mb_pkg, L _ mod :: ModuleName
mod) = do
     FindResult
find_res <- IO FindResult -> IOEnv (Env m n) FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> IOEnv (Env m n) FindResult)
-> IO FindResult -> IOEnv (Env m n) FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe RuleName -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod (Maybe RuleName
mb_pkg)
     let reason :: FilePath
reason = ModuleName -> FilePath
moduleNameString ModuleName
mod FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " changed"
     case FindResult
find_res of
        Found _ mod :: Module
mod
          | UnitId
pkg UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
this_pkg
           -> if Module -> ModuleName
moduleName Module
mod ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((ModuleName, Bool) -> ModuleName)
-> [(ModuleName, Bool)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst [(ModuleName, Bool)]
prev_dep_mods [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
prev_dep_plgn
                 then do SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf m n ()) -> SDoc -> TcRnIf m n ()
forall a b. (a -> b) -> a -> b
$
                           FilePath -> SDoc
text "imported module " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<>
                           FilePath -> SDoc
text " not among previous dependencies"
                         RecompileRequired -> IOEnv (Env m n) RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause FilePath
reason)
                 else
                         RecompileRequired -> IOEnv (Env m n) RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
          | Bool
otherwise
           -> if UnitId -> InstalledUnitId
toInstalledUnitId UnitId
pkg InstalledUnitId -> [InstalledUnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst [(InstalledUnitId, Bool)]
prev_dep_pkgs)
                 then do SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf m n ()) -> SDoc -> TcRnIf m n ()
forall a b. (a -> b) -> a -> b
$
                           FilePath -> SDoc
text "imported module " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<>
                           FilePath -> SDoc
text " is from package " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg) SDoc -> SDoc -> SDoc
<>
                           FilePath -> SDoc
text ", which is not among previous dependencies"
                         RecompileRequired -> IOEnv (Env m n) RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause FilePath
reason)
                 else
                         RecompileRequired -> IOEnv (Env m n) RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
           where pkg :: UnitId
pkg = Module -> UnitId
moduleUnitId Module
mod
        _otherwise :: FindResult
_otherwise  -> RecompileRequired -> IOEnv (Env m n) RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause FilePath
reason)

needInterface :: Module -> (ModIface -> IfG RecompileRequired)
              -> IfG RecompileRequired
needInterface :: Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface mod :: Module
mod continue :: ModIface -> IfG RecompileRequired
continue
  = do  -- Load the imported interface if possible
    let doc_str :: SDoc
doc_str = [SDoc] -> SDoc
sep [FilePath -> SDoc
text "need version info for", Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod]
    SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (FilePath -> SDoc
text "Checking usages for module" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)

    MaybeErr SDoc ModIface
mb_iface <- SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface SDoc
doc_str Module
mod WhereFrom
ImportBySystem
        -- Load the interface, but don't complain on failure;
        -- Instead, get an Either back which we can test

    case MaybeErr SDoc ModIface
mb_iface of
      Failed _ -> do
        SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs ([SDoc] -> SDoc
sep [FilePath -> SDoc
text "Couldn't load interface for module",
                           Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod])
        RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
MustCompile
                  -- Couldn't find or parse a module mentioned in the
                  -- old interface file.  Don't complain: it might
                  -- just be that the current module doesn't need that
                  -- import and it's been deleted
      Succeeded iface :: ModIface
iface -> ModIface -> IfG RecompileRequired
continue ModIface
iface

-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
checkModUsage _this_pkg :: UnitId
_this_pkg UsagePackageModule{
                                usg_mod :: Usage -> Module
usg_mod = Module
mod,
                                usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash }
  = Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \iface :: ModIface
iface -> do
    let reason :: FilePath
reason = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
moduleName Module
mod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " changed"
    FilePath -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint FilePath
reason Fingerprint
old_mod_hash (ModIface -> Fingerprint
mi_mod_hash ModIface
iface)
        -- We only track the ABI hash of package modules, rather than
        -- individual entity usages, so if the ABI hash changes we must
        -- recompile.  This is safe but may entail more recompilation when
        -- a dependent package has changed.

checkModUsage _ UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod, usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash }
  = Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \iface :: ModIface
iface -> do
    let reason :: FilePath
reason = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
moduleName Module
mod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " changed (raw)"
    FilePath -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint FilePath
reason Fingerprint
old_mod_hash (ModIface -> Fingerprint
mi_mod_hash ModIface
iface)

checkModUsage this_pkg :: UnitId
this_pkg UsageHomeModule{
                                usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name,
                                usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash,
                                usg_exports :: Usage -> Maybe Fingerprint
usg_exports = Maybe Fingerprint
maybe_old_export_hash,
                                usg_entities :: Usage -> [(OccName, Fingerprint)]
usg_entities = [(OccName, Fingerprint)]
old_decl_hash }
  = do
    let mod :: Module
mod = UnitId -> ModuleName -> Module
mkModule UnitId
this_pkg ModuleName
mod_name
    Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \iface :: ModIface
iface -> do

    let
        new_mod_hash :: Fingerprint
new_mod_hash    = ModIface -> Fingerprint
mi_mod_hash    ModIface
iface
        new_decl_hash :: OccName -> Maybe (OccName, Fingerprint)
new_decl_hash   = ModIface -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn     ModIface
iface
        new_export_hash :: Fingerprint
new_export_hash = ModIface -> Fingerprint
mi_exp_hash    ModIface
iface

        reason :: FilePath
reason = ModuleName -> FilePath
moduleNameString ModuleName
mod_name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " changed"

        -- CHECK MODULE
    RecompileRequired
recompile <- FilePath -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint FilePath
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
    if Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile)
      then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
      else do

        -- CHECK EXPORT LIST
        FilePath
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IfG RecompileRequired
-> IfG RecompileRequired
checkMaybeHash FilePath
reason Maybe Fingerprint
maybe_old_export_hash Fingerprint
new_export_hash
            (FilePath -> SDoc
text "  Export list changed") (IfG RecompileRequired -> IfG RecompileRequired)
-> IfG RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ do

        -- CHECK ITEMS ONE BY ONE
        RecompileRequired
recompile <- [IfG RecompileRequired] -> IfG RecompileRequired
checkList [ FilePath
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage FilePath
reason OccName -> Maybe (OccName, Fingerprint)
new_decl_hash (OccName, Fingerprint)
u
                               | (OccName, Fingerprint)
u <- [(OccName, Fingerprint)]
old_decl_hash]
        if RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile
          then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recompile     -- This one failed, so just bail out now
          else SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "  Great!  The bits I use are up to date")


checkModUsage _this_pkg :: UnitId
_this_pkg UsageFile{ usg_file_path :: Usage -> FilePath
usg_file_path = FilePath
file,
                                   usg_file_hash :: Usage -> Fingerprint
usg_file_hash = Fingerprint
old_hash } =
  IO RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IfG RecompileRequired)
-> IO RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$
    (IOException -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO IOException -> IO RecompileRequired
forall p. p -> IO RecompileRequired
handle (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
      Fingerprint
new_hash <- FilePath -> IO Fingerprint
getFileHash FilePath
file
      if (Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_hash)
         then RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp
         else RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
 where
   recomp :: RecompileRequired
recomp = FilePath -> RecompileRequired
RecompBecause (FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " changed")
   handle :: p -> IO RecompileRequired
handle =
#if defined(DEBUG)
       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
#else
       \_ -> RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp -- if we can't find the file, just recompile, don't fail
#endif

------------------------
checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
                       -> IfG RecompileRequired
checkModuleFingerprint :: FilePath -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint reason :: FilePath
reason old_mod_hash :: Fingerprint
old_mod_hash new_mod_hash :: Fingerprint
new_mod_hash
  | Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_mod_hash
  = SDoc -> IfG RecompileRequired
up_to_date (FilePath -> SDoc
text "Module fingerprint unchanged")

  | Bool
otherwise
  = FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash FilePath
reason (FilePath -> SDoc
text "  Module fingerprint has changed")
                     Fingerprint
old_mod_hash Fingerprint
new_mod_hash

------------------------
checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
               -> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash :: FilePath
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IfG RecompileRequired
-> IfG RecompileRequired
checkMaybeHash reason :: FilePath
reason maybe_old_hash :: Maybe Fingerprint
maybe_old_hash new_hash :: Fingerprint
new_hash doc :: SDoc
doc continue :: IfG RecompileRequired
continue
  | Just hash :: Fingerprint
hash <- Maybe Fingerprint
maybe_old_hash, Fingerprint
hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_hash
  = FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash FilePath
reason SDoc
doc Fingerprint
hash Fingerprint
new_hash
  | Bool
otherwise
  = IfG RecompileRequired
continue

------------------------
checkEntityUsage :: String
                 -> (OccName -> Maybe (OccName, Fingerprint))
                 -> (OccName, Fingerprint)
                 -> IfG RecompileRequired
checkEntityUsage :: FilePath
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage reason :: FilePath
reason new_hash :: OccName -> Maybe (OccName, Fingerprint)
new_hash (name :: OccName
name,old_hash :: Fingerprint
old_hash)
  = case OccName -> Maybe (OccName, Fingerprint)
new_hash OccName
name of

        Nothing       ->        -- We used it before, but it ain't there now
                          FilePath -> SDoc -> IfG RecompileRequired
out_of_date FilePath
reason ([SDoc] -> SDoc
sep [FilePath -> SDoc
text "No longer exported:", OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name])

        Just (_, new_hash :: Fingerprint
new_hash)      -- It's there, but is it up to date?
          | Fingerprint
new_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_hash -> do SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (FilePath -> SDoc
text "  Up to date" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash))
                                       RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
          | Bool
otherwise            -> FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash FilePath
reason (FilePath -> SDoc
text "  Out of date:" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name)
                                                     Fingerprint
old_hash Fingerprint
new_hash

up_to_date :: SDoc -> IfG RecompileRequired
up_to_date :: SDoc -> IfG RecompileRequired
up_to_date  msg :: SDoc
msg = SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs SDoc
msg IOEnv (Env IfGblEnv ()) ()
-> IfG RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate

out_of_date :: String -> SDoc -> IfG RecompileRequired
out_of_date :: FilePath -> SDoc -> IfG RecompileRequired
out_of_date reason :: FilePath
reason msg :: SDoc
msg = SDoc -> IOEnv (Env IfGblEnv ()) ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs SDoc
msg IOEnv (Env IfGblEnv ()) ()
-> IfG RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RecompileRequired
RecompBecause FilePath
reason)

out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash :: FilePath
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash reason :: FilePath
reason msg :: SDoc
msg old_hash :: Fingerprint
old_hash new_hash :: Fingerprint
new_hash
  = FilePath -> SDoc -> IfG RecompileRequired
out_of_date FilePath
reason ([SDoc] -> SDoc
hsep [SDoc
msg, Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
old_hash, FilePath -> SDoc
text "->", Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash])

----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
checkList []             = RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
checkList (check :: IfG RecompileRequired
check:checks :: [IfG RecompileRequired]
checks) = do RecompileRequired
recompile <- IfG RecompileRequired
check
                              if RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile
                                then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recompile
                                else [IfG RecompileRequired] -> IfG RecompileRequired
checkList [IfG RecompileRequired]
checks

{-
************************************************************************
*                                                                      *
                Converting things to their Iface equivalents
*                                                                      *
************************************************************************
-}

tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl (AnId id :: Id
id)      = Id -> IfaceDecl
idToIfaceDecl Id
id
tyThingToIfaceDecl (ATyCon tycon :: TyCon
tycon) = (TidyEnv, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd (TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
tyConToIfaceDecl TidyEnv
emptyTidyEnv TyCon
tycon)
tyThingToIfaceDecl (ACoAxiom ax :: CoAxiom Branched
ax)  = CoAxiom Branched -> IfaceDecl
forall (br :: BranchFlag). CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl CoAxiom Branched
ax
tyThingToIfaceDecl (AConLike cl :: ConLike
cl)  = case ConLike
cl of
    RealDataCon dc :: DataCon
dc -> DataCon -> IfaceDecl
dataConToIfaceDecl DataCon
dc -- for ppr purposes only
    PatSynCon ps :: PatSyn
ps   -> PatSyn -> IfaceDecl
patSynToIfaceDecl PatSyn
ps

--------------------------
idToIfaceDecl :: Id -> IfaceDecl
-- The Id is already tidied, so that locally-bound names
-- (lambdas, for-alls) already have non-clashing OccNames
-- We can't tidy it here, locally, because it may have
-- free variables in its type or IdInfo
idToIfaceDecl :: Id -> IfaceDecl
idToIfaceDecl id :: Id
id
  = IfaceId :: Name -> IfaceType -> IfaceIdDetails -> IfaceIdInfo -> IfaceDecl
IfaceId { ifName :: Name
ifName      = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id,
              ifType :: IfaceType
ifType      = Type -> IfaceType
toIfaceType (Id -> Type
idType Id
id),
              ifIdDetails :: IfaceIdDetails
ifIdDetails = IdDetails -> IfaceIdDetails
toIfaceIdDetails (Id -> IdDetails
idDetails Id
id),
              ifIdInfo :: IfaceIdInfo
ifIdInfo    = IdInfo -> IfaceIdInfo
toIfaceIdInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id) }

--------------------------
dataConToIfaceDecl :: DataCon -> IfaceDecl
dataConToIfaceDecl :: DataCon -> IfaceDecl
dataConToIfaceDecl dataCon :: DataCon
dataCon
  = IfaceId :: Name -> IfaceType -> IfaceIdDetails -> IfaceIdInfo -> IfaceDecl
IfaceId { ifName :: Name
ifName      = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dataCon,
              ifType :: IfaceType
ifType      = Type -> IfaceType
toIfaceType (DataCon -> Type
dataConUserType DataCon
dataCon),
              ifIdDetails :: IfaceIdDetails
ifIdDetails = IfaceIdDetails
IfVanillaId,
              ifIdInfo :: IfaceIdInfo
ifIdInfo    = IfaceIdInfo
NoInfo }

--------------------------
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
-- We *do* tidy Axioms, because they are not (and cannot
-- conveniently be) built in tidy form
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl ax :: CoAxiom br
ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
tycon, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches
                               , co_ax_role :: forall (br :: BranchFlag). CoAxiom br -> Role
co_ax_role = Role
role })
 = IfaceAxiom :: Name -> IfaceTyCon -> Role -> [IfaceAxBranch] -> IfaceDecl
IfaceAxiom { ifName :: Name
ifName       = CoAxiom br -> Name
forall a. NamedThing a => a -> Name
getName CoAxiom br
ax
              , ifTyCon :: IfaceTyCon
ifTyCon      = TyCon -> IfaceTyCon
toIfaceTyCon TyCon
tycon
              , ifRole :: Role
ifRole       = Role
role
              , ifAxBranches :: [IfaceAxBranch]
ifAxBranches = (CoAxBranch -> IfaceAxBranch) -> [CoAxBranch] -> [IfaceAxBranch]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch TyCon
tycon
                                     ((CoAxBranch -> [Type]) -> [CoAxBranch] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map CoAxBranch -> [Type]
coAxBranchLHS [CoAxBranch]
branch_list))
                                   [CoAxBranch]
branch_list }
 where
   branch_list :: [CoAxBranch]
branch_list = Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches

-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
-- to incompatible indices
-- See Note [Storing compatibility] in CoAxiom
coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch tc :: TyCon
tc lhs_s :: [[Type]]
lhs_s
                        branch :: CoAxBranch
branch@(CoAxBranch { cab_incomps :: CoAxBranch -> [CoAxBranch]
cab_incomps = [CoAxBranch]
incomps })
  = (TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' TyCon
tc CoAxBranch
branch) { ifaxbIncomps :: [Int]
ifaxbIncomps = [Int]
iface_incomps }
  where
    iface_incomps :: [Int]
iface_incomps = (CoAxBranch -> Int) -> [CoAxBranch] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe Int -> Int
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust "iface_incomps"
                        (Maybe Int -> Int)
-> (CoAxBranch -> Maybe Int) -> CoAxBranch -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((([Type] -> Bool) -> [[Type]] -> Maybe Int)
-> [[Type]] -> ([Type] -> Bool) -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Type] -> Bool) -> [[Type]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex [[Type]]
lhs_s
                          (([Type] -> Bool) -> Maybe Int)
-> ([Type] -> [Type] -> Bool) -> [Type] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [Type] -> Bool
eqTypes)
                        ([Type] -> Maybe Int)
-> (CoAxBranch -> [Type]) -> CoAxBranch -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoAxBranch -> [Type]
coAxBranchLHS) [CoAxBranch]
incomps

-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' tc :: TyCon
tc (CoAxBranch { cab_tvs :: CoAxBranch -> [Id]
cab_tvs = [Id]
tvs, cab_cvs :: CoAxBranch -> [Id]
cab_cvs = [Id]
cvs
                                        , cab_eta_tvs :: CoAxBranch -> [Id]
cab_eta_tvs = [Id]
eta_tvs
                                        , cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs
                                        , cab_roles :: CoAxBranch -> [Role]
cab_roles = [Role]
roles, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs })
  = IfaceAxBranch :: [IfaceTvBndr]
-> [IfaceTvBndr]
-> [IfaceTvBndr]
-> IfaceAppArgs
-> [Role]
-> IfaceType
-> [Int]
-> IfaceAxBranch
IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
ifaxbTyVars    = [Id] -> [IfaceTvBndr]
toIfaceTvBndrs [Id]
tvs
                  , ifaxbCoVars :: [IfaceTvBndr]
ifaxbCoVars    = (Id -> IfaceTvBndr) -> [Id] -> [IfaceTvBndr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> IfaceTvBndr
toIfaceIdBndr [Id]
cvs
                  , ifaxbEtaTyVars :: [IfaceTvBndr]
ifaxbEtaTyVars = [Id] -> [IfaceTvBndr]
toIfaceTvBndrs [Id]
eta_tvs
                  , ifaxbLHS :: IfaceAppArgs
ifaxbLHS       = TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs TyCon
tc [Type]
lhs
                  , ifaxbRoles :: [Role]
ifaxbRoles     = [Role]
roles
                  , ifaxbRHS :: IfaceType
ifaxbRHS       = Type -> IfaceType
toIfaceType Type
rhs
                  , ifaxbIncomps :: [Int]
ifaxbIncomps   = [] }

-----------------
tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
-- We *do* tidy TyCons, because they are not (and cannot
-- conveniently be) built in tidy form
-- The returned TidyEnv is the one after tidying the tyConTyVars
tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
tyConToIfaceDecl env :: TidyEnv
env tycon :: TyCon
tycon
  | Just clas :: Class
clas <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tycon
  = TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl TidyEnv
env Class
clas

  | Just syn_rhs :: Type
syn_rhs <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tycon
  = ( TidyEnv
tc_env1
    , IfaceSynonym :: Name
-> [Role]
-> [IfaceTyConBinder]
-> IfaceType
-> IfaceType
-> IfaceDecl
IfaceSynonym { ifName :: Name
ifName    = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tycon,
                     ifRoles :: [Role]
ifRoles   = TyCon -> [Role]
tyConRoles TyCon
tycon,
                     ifSynRhs :: IfaceType
ifSynRhs  = Type -> IfaceType
if_syn_type Type
syn_rhs,
                     ifBinders :: [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
if_binders,
                     ifResKind :: IfaceType
ifResKind = IfaceType
if_res_kind
                   })

  | Just fam_flav :: FamTyConFlav
fam_flav <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tycon
  = ( TidyEnv
tc_env1
    , IfaceFamily :: Name
-> Maybe RuleName
-> [IfaceTyConBinder]
-> IfaceType
-> IfaceFamTyConFlav
-> Injectivity
-> IfaceDecl
IfaceFamily { ifName :: Name
ifName    = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tycon,
                    ifResVar :: Maybe RuleName
ifResVar  = Maybe RuleName
if_res_var,
                    ifFamFlav :: IfaceFamTyConFlav
ifFamFlav = FamTyConFlav -> IfaceFamTyConFlav
to_if_fam_flav FamTyConFlav
fam_flav,
                    ifBinders :: [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
if_binders,
                    ifResKind :: IfaceType
ifResKind = IfaceType
if_res_kind,
                    ifFamInj :: Injectivity
ifFamInj  = TyCon -> Injectivity
tyConInjectivityInfo TyCon
tycon
                  })

  | TyCon -> Bool
isAlgTyCon TyCon
tycon
  = ( TidyEnv
tc_env1
    , IfaceData :: Name
-> [IfaceTyConBinder]
-> IfaceType
-> Maybe CType
-> [Role]
-> IfaceContext
-> IfaceConDecls
-> Bool
-> IfaceTyConParent
-> IfaceDecl
IfaceData { ifName :: Name
ifName    = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tycon,
                  ifBinders :: [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
if_binders,
                  ifResKind :: IfaceType
ifResKind = IfaceType
if_res_kind,
                  ifCType :: Maybe CType
ifCType   = TyCon -> Maybe CType
tyConCType TyCon
tycon,
                  ifRoles :: [Role]
ifRoles   = TyCon -> [Role]
tyConRoles TyCon
tycon,
                  ifCtxt :: IfaceContext
ifCtxt    = TidyEnv -> [Type] -> IfaceContext
tidyToIfaceContext TidyEnv
tc_env1 (TyCon -> [Type]
tyConStupidTheta TyCon
tycon),
                  ifCons :: IfaceConDecls
ifCons    = AlgTyConRhs -> IfaceConDecls
ifaceConDecls (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tycon),
                  ifGadtSyntax :: Bool
ifGadtSyntax = TyCon -> Bool
isGadtSyntaxTyCon TyCon
tycon,
                  ifParent :: IfaceTyConParent
ifParent  = IfaceTyConParent
parent })

  | Bool
otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
  -- We only convert these TyCons to IfaceTyCons when we are
  -- just about to pretty-print them, not because we are going
  -- to put them into interface files
  = ( TidyEnv
env
    , IfaceData :: Name
-> [IfaceTyConBinder]
-> IfaceType
-> Maybe CType
-> [Role]
-> IfaceContext
-> IfaceConDecls
-> Bool
-> IfaceTyConParent
-> IfaceDecl
IfaceData { ifName :: Name
ifName       = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tycon,
                  ifBinders :: [IfaceTyConBinder]
ifBinders    = [IfaceTyConBinder]
if_binders,
                  ifResKind :: IfaceType
ifResKind    = IfaceType
if_res_kind,
                  ifCType :: Maybe CType
ifCType      = Maybe CType
forall a. Maybe a
Nothing,
                  ifRoles :: [Role]
ifRoles      = TyCon -> [Role]
tyConRoles TyCon
tycon,
                  ifCtxt :: IfaceContext
ifCtxt       = [],
                  ifCons :: IfaceConDecls
ifCons       = [IfaceConDecl] -> IfaceConDecls
IfDataTyCon [],
                  ifGadtSyntax :: Bool
ifGadtSyntax = Bool
False,
                  ifParent :: IfaceTyConParent
ifParent     = IfaceTyConParent
IfNoParent })
  where
    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
    -- an error.
    (tc_env1 :: TidyEnv
tc_env1, tc_binders :: [TyConBinder]
tc_binders) = TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders TidyEnv
env (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
    tc_tyvars :: [Id]
tc_tyvars      = [TyConBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_binders
    if_binders :: [IfaceTyConBinder]
if_binders     = [TyConBinder] -> [IfaceTyConBinder]
forall vis. [VarBndr Id vis] -> [VarBndr IfaceBndr vis]
toIfaceTyCoVarBinders [TyConBinder]
tc_binders
                     -- No tidying of the binders; they are already tidy
    if_res_kind :: IfaceType
if_res_kind    = TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
tc_env1 (TyCon -> Type
tyConResKind TyCon
tycon)
    if_syn_type :: Type -> IfaceType
if_syn_type ty :: Type
ty = TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
tc_env1 Type
ty
    if_res_var :: Maybe RuleName
if_res_var     = Name -> RuleName
forall a. NamedThing a => a -> RuleName
getOccFS (Name -> RuleName) -> Maybe Name -> Maybe RuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TyCon -> Maybe Name
tyConFamilyResVar_maybe TyCon
tycon

    parent :: IfaceTyConParent
parent = case TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
tycon of
               Just (tc :: TyCon
tc, ty :: [Type]
ty, ax :: CoAxiom Unbranched
ax) -> Name -> IfaceTyCon -> IfaceAppArgs -> IfaceTyConParent
IfDataInstance (CoAxiom Unbranched -> Name
forall (br :: BranchFlag). CoAxiom br -> Name
coAxiomName CoAxiom Unbranched
ax)
                                                   (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
tc)
                                                   (TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
tidyToIfaceTcArgs TidyEnv
tc_env1 TyCon
tc [Type]
ty)
               Nothing           -> IfaceTyConParent
IfNoParent

    to_if_fam_flav :: FamTyConFlav -> IfaceFamTyConFlav
to_if_fam_flav OpenSynFamilyTyCon             = IfaceFamTyConFlav
IfaceOpenSynFamilyTyCon
    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceFamTyConFlav
IfaceAbstractClosedSynFamilyTyCon
    to_if_fam_flav (DataFamilyTyCon {})           = IfaceFamTyConFlav
IfaceDataFamilyTyCon
    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceFamTyConFlav
IfaceBuiltInSynFamTyCon
    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = Maybe (Name, [IfaceAxBranch]) -> IfaceFamTyConFlav
IfaceClosedSynFamilyTyCon Maybe (Name, [IfaceAxBranch])
forall a. Maybe a
Nothing
    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax :: CoAxiom Branched
ax))
      = Maybe (Name, [IfaceAxBranch]) -> IfaceFamTyConFlav
IfaceClosedSynFamilyTyCon ((Name, [IfaceAxBranch]) -> Maybe (Name, [IfaceAxBranch])
forall a. a -> Maybe a
Just (Name
axn, [IfaceAxBranch]
ibr))
      where defs :: [CoAxBranch]
defs = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches (Branches Branched -> [CoAxBranch])
-> Branches Branched -> [CoAxBranch]
forall a b. (a -> b) -> a -> b
$ CoAxiom Branched -> Branches Branched
forall (br :: BranchFlag). CoAxiom br -> Branches br
coAxiomBranches CoAxiom Branched
ax
            ibr :: [IfaceAxBranch]
ibr  = (CoAxBranch -> IfaceAxBranch) -> [CoAxBranch] -> [IfaceAxBranch]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' TyCon
tycon) [CoAxBranch]
defs
            axn :: Name
axn  = CoAxiom Branched -> Name
forall (br :: BranchFlag). CoAxiom br -> Name
coAxiomName CoAxiom Branched
ax

    ifaceConDecls :: AlgTyConRhs -> IfaceConDecls
ifaceConDecls (NewTyCon { data_con :: AlgTyConRhs -> DataCon
data_con = DataCon
con })    = IfaceConDecl -> IfaceConDecls
IfNewTyCon  (DataCon -> IfaceConDecl
ifaceConDecl DataCon
con)
    ifaceConDecls (DataTyCon { data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
cons }) = [IfaceConDecl] -> IfaceConDecls
IfDataTyCon ((DataCon -> IfaceConDecl) -> [DataCon] -> [IfaceConDecl]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> IfaceConDecl
ifaceConDecl [DataCon]
cons)
    ifaceConDecls (TupleTyCon { data_con :: AlgTyConRhs -> DataCon
data_con = DataCon
con })  = [IfaceConDecl] -> IfaceConDecls
IfDataTyCon [DataCon -> IfaceConDecl
ifaceConDecl DataCon
con]
    ifaceConDecls (SumTyCon { data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
cons })  = [IfaceConDecl] -> IfaceConDecls
IfDataTyCon ((DataCon -> IfaceConDecl) -> [DataCon] -> [IfaceConDecl]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> IfaceConDecl
ifaceConDecl [DataCon]
cons)
    ifaceConDecls AbstractTyCon                    = IfaceConDecls
IfAbstractTyCon
        -- The AbstractTyCon case happens when a TyCon has been trimmed
        -- during tidying.
        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
        -- for GHCi, when browsing a module, in which case the
        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
        -- (Tuple declarations are not serialised into interface files.)

    ifaceConDecl :: DataCon -> IfaceConDecl
ifaceConDecl data_con :: DataCon
data_con
        = IfCon :: Name
-> Bool
-> Bool
-> [IfaceBndr]
-> [IfaceForAllBndr]
-> [IfaceTvBndr]
-> IfaceContext
-> IfaceContext
-> [FieldLabel]
-> [IfaceBang]
-> [IfaceSrcBang]
-> IfaceConDecl
IfCon   { ifConName :: Name
ifConName    = DataCon -> Name
dataConName DataCon
data_con,
                    ifConInfix :: Bool
ifConInfix   = DataCon -> Bool
dataConIsInfix DataCon
data_con,
                    ifConWrapper :: Bool
ifConWrapper = Maybe Id -> Bool
forall a. Maybe a -> Bool
isJust (DataCon -> Maybe Id
dataConWrapId_maybe DataCon
data_con),
                    ifConExTCvs :: [IfaceBndr]
ifConExTCvs  = (Id -> IfaceBndr) -> [Id] -> [IfaceBndr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> IfaceBndr
toIfaceBndr [Id]
ex_tvs',
                    ifConUserTvBinders :: [IfaceForAllBndr]
ifConUserTvBinders = (TyCoVarBinder -> IfaceForAllBndr)
-> [TyCoVarBinder] -> [IfaceForAllBndr]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVarBinder -> IfaceForAllBndr
toIfaceForAllBndr [TyCoVarBinder]
user_bndrs',
                    ifConEqSpec :: [IfaceTvBndr]
ifConEqSpec  = (EqSpec -> IfaceTvBndr) -> [EqSpec] -> [IfaceTvBndr]
forall a b. (a -> b) -> [a] -> [b]
map ((Id, Type) -> IfaceTvBndr
to_eq_spec ((Id, Type) -> IfaceTvBndr)
-> (EqSpec -> (Id, Type)) -> EqSpec -> IfaceTvBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EqSpec -> (Id, Type)
eqSpecPair) [EqSpec]
eq_spec,
                    ifConCtxt :: IfaceContext
ifConCtxt    = TidyEnv -> [Type] -> IfaceContext
tidyToIfaceContext TidyEnv
con_env2 [Type]
theta,
                    ifConArgTys :: IfaceContext
ifConArgTys  = (Type -> IfaceType) -> [Type] -> IfaceContext
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
con_env2) [Type]
arg_tys,
                    ifConFields :: [FieldLabel]
ifConFields  = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con,
                    ifConStricts :: [IfaceBang]
ifConStricts = (HsImplBang -> IfaceBang) -> [HsImplBang] -> [IfaceBang]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang TidyEnv
con_env2)
                                       (DataCon -> [HsImplBang]
dataConImplBangs DataCon
data_con),
                    ifConSrcStricts :: [IfaceSrcBang]
ifConSrcStricts = (HsSrcBang -> IfaceSrcBang) -> [HsSrcBang] -> [IfaceSrcBang]
forall a b. (a -> b) -> [a] -> [b]
map HsSrcBang -> IfaceSrcBang
toIfaceSrcBang
                                          (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
data_con)}
        where
          (univ_tvs :: [Id]
univ_tvs, ex_tvs :: [Id]
ex_tvs, eq_spec :: [EqSpec]
eq_spec, theta :: [Type]
theta, arg_tys :: [Type]
arg_tys, _)
            = DataCon -> ([Id], [Id], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
data_con
          user_bndrs :: [TyCoVarBinder]
user_bndrs = DataCon -> [TyCoVarBinder]
dataConUserTyVarBinders DataCon
data_con

          -- Tidy the univ_tvs of the data constructor to be identical
          -- to the tyConTyVars of the type constructor.  This means
          -- (a) we don't need to redundantly put them into the interface file
          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
          --     we know that the type variables will line up
          -- The latter (b) is important because we pretty-print type constructors
          -- by converting to IfaceSyn and pretty-printing that
          con_env1 :: TidyEnv
con_env1 = (TidyEnv -> TidyOccEnv
forall a b. (a, b) -> a
fst TidyEnv
tc_env1, [(Id, Id)] -> VarEnv Id
forall a. [(Id, a)] -> VarEnv a
mkVarEnv (FilePath -> [Id] -> [Id] -> [(Id, Id)]
forall a b. FilePath -> [a] -> [b] -> [(a, b)]
zipEqual "ifaceConDecl" [Id]
univ_tvs [Id]
tc_tyvars))
                     -- A bit grimy, perhaps, but it's simple!

          (con_env2 :: TidyEnv
con_env2, ex_tvs' :: [Id]
ex_tvs') = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyVarBndrs TidyEnv
con_env1 [Id]
ex_tvs
          user_bndrs' :: [TyCoVarBinder]
user_bndrs' = (TyCoVarBinder -> TyCoVarBinder)
-> [TyCoVarBinder] -> [TyCoVarBinder]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> TyCoVarBinder -> TyCoVarBinder
tidyUserTyCoVarBinder TidyEnv
con_env2) [TyCoVarBinder]
user_bndrs
          to_eq_spec :: (Id, Type) -> IfaceTvBndr
to_eq_spec (tv :: Id
tv,ty :: Type
ty) = (TidyEnv -> Id -> RuleName
tidyTyVar TidyEnv
con_env2 Id
tv, TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
con_env2 Type
ty)

          -- By this point, we have tidied every universal and existential
          -- tyvar. Because of the dcUserTyCoVarBinders invariant
          -- (see Note [DataCon user type variable binders]), *every*
          -- user-written tyvar must be contained in the substitution that
          -- tidying produced. Therefore, tidying the user-written tyvars is a
          -- simple matter of looking up each variable in the substitution,
          -- which tidyTyCoVarOcc accomplishes.
          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
tidyUserTyCoVarBinder env :: TidyEnv
env (Bndr tv :: Id
tv vis :: ArgFlag
vis) =
            Id -> ArgFlag -> TyCoVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr (TidyEnv -> Id -> Id
tidyTyCoVarOcc TidyEnv
env Id
tv) ArgFlag
vis

classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env :: TidyEnv
env clas :: Class
clas
  = ( TidyEnv
env1
    , IfaceClass :: Name
-> [Role]
-> [IfaceTyConBinder]
-> [FunDep RuleName]
-> IfaceClassBody
-> IfaceDecl
IfaceClass { ifName :: Name
ifName   = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tycon,
                   ifRoles :: [Role]
ifRoles  = TyCon -> [Role]
tyConRoles (Class -> TyCon
classTyCon Class
clas),
                   ifBinders :: [IfaceTyConBinder]
ifBinders = [TyConBinder] -> [IfaceTyConBinder]
forall vis. [VarBndr Id vis] -> [VarBndr IfaceBndr vis]
toIfaceTyCoVarBinders [TyConBinder]
tc_binders,
                   ifBody :: IfaceClassBody
ifBody   = IfaceClassBody
body,
                   ifFDs :: [FunDep RuleName]
ifFDs    = (([Id], [Id]) -> FunDep RuleName)
-> [([Id], [Id])] -> [FunDep RuleName]
forall a b. (a -> b) -> [a] -> [b]
map ([Id], [Id]) -> FunDep RuleName
toIfaceFD [([Id], [Id])]
clas_fds })
  where
    (_, clas_fds :: [([Id], [Id])]
clas_fds, sc_theta :: [Type]
sc_theta, _, clas_ats :: [ClassATItem]
clas_ats, op_stuff :: [ClassOpItem]
op_stuff)
      = Class
-> ([Id], [([Id], [Id])], [Type], [Id], [ClassATItem],
    [ClassOpItem])
classExtraBigSig Class
clas
    tycon :: TyCon
tycon = Class -> TyCon
classTyCon Class
clas

    body :: IfaceClassBody
body | TyCon -> Bool
isAbstractTyCon TyCon
tycon = IfaceClassBody
IfAbstractClass
         | Bool
otherwise
         = IfConcreteClass :: IfaceContext
-> [IfaceAT]
-> [IfaceClassOp]
-> BooleanFormula RuleName
-> IfaceClassBody
IfConcreteClass {
                ifClassCtxt :: IfaceContext
ifClassCtxt   = TidyEnv -> [Type] -> IfaceContext
tidyToIfaceContext TidyEnv
env1 [Type]
sc_theta,
                ifATs :: [IfaceAT]
ifATs    = (ClassATItem -> IfaceAT) -> [ClassATItem] -> [IfaceAT]
forall a b. (a -> b) -> [a] -> [b]
map ClassATItem -> IfaceAT
toIfaceAT [ClassATItem]
clas_ats,
                ifSigs :: [IfaceClassOp]
ifSigs   = (ClassOpItem -> IfaceClassOp) -> [ClassOpItem] -> [IfaceClassOp]
forall a b. (a -> b) -> [a] -> [b]
map ClassOpItem -> IfaceClassOp
toIfaceClassOp [ClassOpItem]
op_stuff,
                ifMinDef :: BooleanFormula RuleName
ifMinDef = (Name -> RuleName)
-> BooleanFormula Name -> BooleanFormula RuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> RuleName
forall a. NamedThing a => a -> RuleName
getOccFS (Class -> BooleanFormula Name
classMinimalDef Class
clas)
            }

    (env1 :: TidyEnv
env1, tc_binders :: [TyConBinder]
tc_binders) = TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders TidyEnv
env (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)

    toIfaceAT :: ClassATItem -> IfaceAT
    toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc :: TyCon
tc def :: Maybe (Type, SrcSpan)
def)
      = IfaceDecl -> Maybe IfaceType -> IfaceAT
IfaceAT IfaceDecl
if_decl (((Type, SrcSpan) -> IfaceType)
-> Maybe (Type, SrcSpan) -> Maybe IfaceType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
env2 (Type -> IfaceType)
-> ((Type, SrcSpan) -> Type) -> (Type, SrcSpan) -> IfaceType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, SrcSpan) -> Type
forall a b. (a, b) -> a
fst) Maybe (Type, SrcSpan)
def)
      where
        (env2 :: TidyEnv
env2, if_decl :: IfaceDecl
if_decl) = TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
tyConToIfaceDecl TidyEnv
env1 TyCon
tc

    toIfaceClassOp :: ClassOpItem -> IfaceClassOp
toIfaceClassOp (sel_id :: Id
sel_id, def_meth :: Maybe (Name, DefMethSpec Type)
def_meth)
        = ASSERT( sel_tyvars == binderVars tc_binders )
          Name -> IfaceType -> Maybe (DefMethSpec IfaceType) -> IfaceClassOp
IfaceClassOp (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
sel_id)
                       (TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
env1 Type
op_ty)
                       (((Name, DefMethSpec Type) -> DefMethSpec IfaceType)
-> Maybe (Name, DefMethSpec Type) -> Maybe (DefMethSpec IfaceType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, DefMethSpec Type) -> DefMethSpec IfaceType
toDmSpec Maybe (Name, DefMethSpec Type)
def_meth)
        where
                -- Be careful when splitting the type, because of things
                -- like         class Foo a where
                --                op :: (?x :: String) => a -> a
                -- and          class Baz a where
                --                op :: (Ord a) => a -> a
          (sel_tyvars :: [Id]
sel_tyvars, rho_ty :: Type
rho_ty) = Type -> ([Id], Type)
splitForAllTys (Id -> Type
idType Id
sel_id)
          op_ty :: Type
op_ty                = Type -> Type
funResultTy Type
rho_ty

    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
toDmSpec (_, VanillaDM)       = DefMethSpec IfaceType
forall ty. DefMethSpec ty
VanillaDM
    toDmSpec (_, GenericDM dm_ty :: Type
dm_ty) = IfaceType -> DefMethSpec IfaceType
forall ty. ty -> DefMethSpec ty
GenericDM (TidyEnv -> Type -> IfaceType
tidyToIfaceType TidyEnv
env1 Type
dm_ty)

    toIfaceFD :: ([Id], [Id]) -> FunDep RuleName
toIfaceFD (tvs1 :: [Id]
tvs1, tvs2 :: [Id]
tvs2) = ((Id -> RuleName) -> [Id] -> [RuleName]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Id -> RuleName
tidyTyVar TidyEnv
env1) [Id]
tvs1
                             ,(Id -> RuleName) -> [Id] -> [RuleName]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Id -> RuleName
tidyTyVar TidyEnv
env1) [Id]
tvs2)

--------------------------

tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
-- If the type variable "binder" is in scope, don't re-bind it
-- In a class decl, for example, the ATD binders mention
-- (amd must mention) the class tyvars
tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
tidyTyConBinder env :: TidyEnv
env@(_, subst :: VarEnv Id
subst) tvb :: TyConBinder
tvb@(Bndr tv :: Id
tv vis :: TyConBndrVis
vis)
 = case VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
subst Id
tv of
     Just tv' :: Id
tv' -> (TidyEnv
env,  Id -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
tv' TyConBndrVis
vis)
     Nothing  -> TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
forall vis. TidyEnv -> VarBndr Id vis -> (TidyEnv, VarBndr Id vis)
tidyTyCoVarBinder TidyEnv
env TyConBinder
tvb

tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = (TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder))
-> TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
tidyTyConBinder

tidyTyVar :: TidyEnv -> TyVar -> FastString
tidyTyVar :: TidyEnv -> Id -> RuleName
tidyTyVar (_, subst :: VarEnv Id
subst) tv :: Id
tv = Id -> RuleName
toIfaceTyVar (VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
subst Id
tv Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
tv)

--------------------------
instanceToIfaceInst :: ClsInst -> IfaceClsInst
instanceToIfaceInst :: ClsInst -> IfaceClsInst
instanceToIfaceInst (ClsInst { is_dfun :: ClsInst -> Id
is_dfun = Id
dfun_id, is_flag :: ClsInst -> OverlapFlag
is_flag = OverlapFlag
oflag
                             , is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_name, is_cls :: ClsInst -> Class
is_cls = Class
cls
                             , is_tcs :: ClsInst -> [Maybe Name]
is_tcs = [Maybe Name]
mb_tcs
                             , is_orphan :: ClsInst -> IsOrphan
is_orphan = IsOrphan
orph })
  = ASSERT( cls_name == className cls )
    IfaceClsInst :: Name
-> [Maybe IfaceTyCon]
-> Name
-> OverlapFlag
-> IsOrphan
-> IfaceClsInst
IfaceClsInst { ifDFun :: Name
ifDFun    = Name
dfun_name,
                ifOFlag :: OverlapFlag
ifOFlag   = OverlapFlag
oflag,
                ifInstCls :: Name
ifInstCls = Name
cls_name,
                ifInstTys :: [Maybe IfaceTyCon]
ifInstTys = (Maybe Name -> Maybe IfaceTyCon)
-> [Maybe Name] -> [Maybe IfaceTyCon]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Name -> Maybe IfaceTyCon
do_rough [Maybe Name]
mb_tcs,
                ifInstOrph :: IsOrphan
ifInstOrph = IsOrphan
orph }
  where
    do_rough :: Maybe Name -> Maybe IfaceTyCon
do_rough Nothing  = Maybe IfaceTyCon
forall a. Maybe a
Nothing
    do_rough (Just n :: Name
n) = IfaceTyCon -> Maybe IfaceTyCon
forall a. a -> Maybe a
Just (Name -> IfaceTyCon
toIfaceTyCon_name Name
n)

    dfun_name :: Name
dfun_name = Id -> Name
idName Id
dfun_id


--------------------------
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst (FamInst { fi_axiom :: FamInst -> CoAxiom Unbranched
fi_axiom    = CoAxiom Unbranched
axiom,
                                 fi_fam :: FamInst -> Name
fi_fam      = Name
fam,
                                 fi_tcs :: FamInst -> [Maybe Name]
fi_tcs      = [Maybe Name]
roughs })
  = IfaceFamInst :: Name -> [Maybe IfaceTyCon] -> Name -> IsOrphan -> IfaceFamInst
IfaceFamInst { ifFamInstAxiom :: Name
ifFamInstAxiom    = CoAxiom Unbranched -> Name
forall (br :: BranchFlag). CoAxiom br -> Name
coAxiomName CoAxiom Unbranched
axiom
                 , ifFamInstFam :: Name
ifFamInstFam      = Name
fam
                 , ifFamInstTys :: [Maybe IfaceTyCon]
ifFamInstTys      = (Maybe Name -> Maybe IfaceTyCon)
-> [Maybe Name] -> [Maybe IfaceTyCon]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Name -> Maybe IfaceTyCon
do_rough [Maybe Name]
roughs
                 , ifFamInstOrph :: IsOrphan
ifFamInstOrph     = IsOrphan
orph }
  where
    do_rough :: Maybe Name -> Maybe IfaceTyCon
do_rough Nothing  = Maybe IfaceTyCon
forall a. Maybe a
Nothing
    do_rough (Just n :: Name
n) = IfaceTyCon -> Maybe IfaceTyCon
forall a. a -> Maybe a
Just (Name -> IfaceTyCon
toIfaceTyCon_name Name
n)

    fam_decl :: Name
fam_decl = TyCon -> Name
tyConName (TyCon -> Name) -> TyCon -> Name
forall a b. (a -> b) -> a -> b
$ CoAxiom Unbranched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Unbranched
axiom
    mod :: Module
mod = ASSERT( isExternalName (coAxiomName axiom) )
          HasDebugCallStack => Name -> Module
Name -> Module
nameModule (CoAxiom Unbranched -> Name
forall (br :: BranchFlag). CoAxiom br -> Name
coAxiomName CoAxiom Unbranched
axiom)
    is_local :: Name -> Bool
is_local name :: Name
name = Module -> Name -> Bool
nameIsLocalOrFrom Module
mod Name
name

    lhs_names :: NameSet
lhs_names = (Name -> Bool) -> NameSet -> NameSet
filterNameSet Name -> Bool
is_local (CoAxiom Unbranched -> NameSet
forall (br :: BranchFlag). CoAxiom br -> NameSet
orphNamesOfCoCon CoAxiom Unbranched
axiom)

    orph :: IsOrphan
orph | Name -> Bool
is_local Name
fam_decl
         = OccName -> IsOrphan
NotOrphan (Name -> OccName
nameOccName Name
fam_decl)
         | Bool
otherwise
         = NameSet -> IsOrphan
chooseOrphanAnchor NameSet
lhs_names

--------------------------
coreRuleToIfaceRule :: CoreRule -> IfaceRule
coreRuleToIfaceRule :: CoreRule -> IfaceRule
coreRuleToIfaceRule (BuiltinRule { ru_fn :: CoreRule -> Name
ru_fn = Name
fn})
  = FilePath -> SDoc -> IfaceRule -> IfaceRule
forall a. FilePath -> SDoc -> a -> a
pprTrace "toHsRule: builtin" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn) (IfaceRule -> IfaceRule) -> IfaceRule -> IfaceRule
forall a b. (a -> b) -> a -> b
$
    Name -> IfaceRule
bogusIfaceRule Name
fn

coreRuleToIfaceRule (Rule { ru_name :: CoreRule -> RuleName
ru_name = RuleName
name, ru_fn :: CoreRule -> Name
ru_fn = Name
fn,
                            ru_act :: CoreRule -> Activation
ru_act = Activation
act, ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs,
                            ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs,
                            ru_orphan :: CoreRule -> IsOrphan
ru_orphan = IsOrphan
orph, ru_auto :: CoreRule -> Bool
ru_auto = Bool
auto })
  = IfaceRule :: RuleName
-> Activation
-> [IfaceBndr]
-> Name
-> [IfaceExpr]
-> IfaceExpr
-> Bool
-> IsOrphan
-> IfaceRule
IfaceRule { ifRuleName :: RuleName
ifRuleName  = RuleName
name, ifActivation :: Activation
ifActivation = Activation
act,
                ifRuleBndrs :: [IfaceBndr]
ifRuleBndrs = (Id -> IfaceBndr) -> [Id] -> [IfaceBndr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> IfaceBndr
toIfaceBndr [Id]
bndrs,
                ifRuleHead :: Name
ifRuleHead  = Name
fn,
                ifRuleArgs :: [IfaceExpr]
ifRuleArgs  = (CoreExpr -> IfaceExpr) -> [CoreExpr] -> [IfaceExpr]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> IfaceExpr
do_arg [CoreExpr]
args,
                ifRuleRhs :: IfaceExpr
ifRuleRhs   = CoreExpr -> IfaceExpr
toIfaceExpr CoreExpr
rhs,
                ifRuleAuto :: Bool
ifRuleAuto  = Bool
auto,
                ifRuleOrph :: IsOrphan
ifRuleOrph  = IsOrphan
orph }
  where
        -- For type args we must remove synonyms from the outermost
        -- level.  Reason: so that when we read it back in we'll
        -- construct the same ru_rough field as we have right now;
        -- see tcIfaceRule
    do_arg :: CoreExpr -> IfaceExpr
do_arg (Type ty :: Type
ty)     = IfaceType -> IfaceExpr
IfaceType (Type -> IfaceType
toIfaceType (Type -> Type
deNoteType Type
ty))
    do_arg (Coercion co :: Coercion
co) = IfaceCoercion -> IfaceExpr
IfaceCo   (Coercion -> IfaceCoercion
toIfaceCoercion Coercion
co)
    do_arg arg :: CoreExpr
arg           = CoreExpr -> IfaceExpr
toIfaceExpr CoreExpr
arg

bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name :: Name
id_name
  = IfaceRule :: RuleName
-> Activation
-> [IfaceBndr]
-> Name
-> [IfaceExpr]
-> IfaceExpr
-> Bool
-> IsOrphan
-> IfaceRule
IfaceRule { ifRuleName :: RuleName
ifRuleName = FilePath -> RuleName
fsLit "bogus", ifActivation :: Activation
ifActivation = Activation
NeverActive,
        ifRuleBndrs :: [IfaceBndr]
ifRuleBndrs = [], ifRuleHead :: Name
ifRuleHead = Name
id_name, ifRuleArgs :: [IfaceExpr]
ifRuleArgs = [],
        ifRuleRhs :: IfaceExpr
ifRuleRhs = Name -> IfaceExpr
IfaceExt Name
id_name, ifRuleOrph :: IsOrphan
ifRuleOrph = IsOrphan
IsOrphan,
        ifRuleAuto :: Bool
ifRuleAuto = Bool
True }