{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}

-- | Module for detecting if recompilation is required
module GHC.Iface.Recomp
   ( checkOldIface
   , RecompileRequired(..)
   , needsRecompileBecause
   , recompThen
   , MaybeValidated(..)
   , outOfDateItemBecause
   , RecompReason (..)
   , CompileReason(..)
   , recompileRequired
   , addFingerprints
   , mkSelfRecomp
   )
where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Driver.Backend
import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Plugins


import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
import GHC.Iface.Recomp.Types
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags
import GHC.Iface.Env

import GHC.Core
import GHC.Tc.Utils.Monad
import GHC.Hs

import GHC.Data.Graph.Directed
import GHC.Data.Maybe

import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
import GHC.Utils.Logger
import GHC.Utils.Constants (debugIsOn)

import GHC.Types.Annotations
import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
import GHC.Types.Unique.Map
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.Deps

import Control.Monad
import Control.Monad.Trans.State
import Data.List (sortBy, sort, sortOn)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import Data.Either

--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
import Data.Bifunctor
import GHC.Iface.Errors.Ppr
import Data.Functor

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

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

 https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance

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
-}

data RecompileRequired
  -- | everything is up to date, recompilation is not required
  = UpToDate
  -- | Need to compile the module
  | NeedsRecompile !CompileReason
   deriving (RecompileRequired -> RecompileRequired -> Bool
(RecompileRequired -> RecompileRequired -> Bool)
-> (RecompileRequired -> RecompileRequired -> Bool)
-> Eq RecompileRequired
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecompileRequired -> RecompileRequired -> Bool
== :: RecompileRequired -> RecompileRequired -> Bool
$c/= :: RecompileRequired -> RecompileRequired -> Bool
/= :: RecompileRequired -> RecompileRequired -> Bool
Eq)

needsRecompileBecause :: RecompReason -> RecompileRequired
needsRecompileBecause :: RecompReason -> RecompileRequired
needsRecompileBecause = CompileReason -> RecompileRequired
NeedsRecompile (CompileReason -> RecompileRequired)
-> (RecompReason -> CompileReason)
-> RecompReason
-> RecompileRequired
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecompReason -> CompileReason
RecompBecause

data MaybeValidated a
  -- | The item contained is validated to be up to date
  = UpToDateItem a
  -- | The item is are absent altogether or out of date, for the reason given.
  | OutOfDateItem
      !CompileReason
      -- ^ the reason we need to recompile.
      (Maybe a)
      -- ^ The old item, if it exists
  deriving ((forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b)
-> (forall a b. a -> MaybeValidated b -> MaybeValidated a)
-> Functor MaybeValidated
forall a b. a -> MaybeValidated b -> MaybeValidated a
forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
fmap :: forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
$c<$ :: forall a b. a -> MaybeValidated b -> MaybeValidated a
<$ :: forall a b. a -> MaybeValidated b -> MaybeValidated a
Functor)

instance Outputable a => Outputable (MaybeValidated a) where
  ppr :: MaybeValidated a -> SDoc
ppr (UpToDateItem a
a) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UpToDate" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a
  ppr (OutOfDateItem CompileReason
r Maybe a
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OutOfDate: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CompileReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompileReason
r

outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause :: forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
reason Maybe a
item = CompileReason -> Maybe a -> MaybeValidated a
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem (RecompReason -> CompileReason
RecompBecause RecompReason
reason) Maybe a
item

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

instance Outputable RecompileRequired where
  ppr :: RecompileRequired -> SDoc
ppr RecompileRequired
UpToDate = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UpToDate"
  ppr (NeedsRecompile CompileReason
reason) = CompileReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompileReason
reason

instance Outputable CompileReason where
  ppr :: CompileReason -> SDoc
ppr CompileReason
MustCompile = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MustCompile"
  ppr (RecompBecause RecompReason
r) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RecompBecause" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
r

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

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

data RecompReason
  = UnitDepRemoved UnitId
  | ModulePackageChanged FastString
  | SourceFileChanged
  | NoSelfRecompInfo
  | ThisUnitIdChanged
  | ImpurePlugin
  | PluginsChanged
  | PluginFingerprintChanged
  | ModuleInstChanged
  | HieMissing
  | HieOutdated
  | SigsMergeChanged
  | ModuleChanged ModuleName
  | ModuleRemoved (UnitId, ModuleName)
  | ModuleAdded (UnitId, ModuleName)
  | ModuleChangedRaw ModuleName
  | ModuleChangedIface ModuleName
  | FileChanged FilePath
  | CustomReason String
  | FlagsChanged
  | LinkFlagsChanged
  | OptimFlagsChanged
  | HpcFlagsChanged
  | MissingBytecode
  | MissingObjectFile
  | MissingDynObjectFile
  | MissingDynHiFile
  | MismatchedDynHiFile
  | ObjectsChanged
  | LibraryChanged
  | THWithJS
  deriving (RecompReason -> RecompReason -> Bool
(RecompReason -> RecompReason -> Bool)
-> (RecompReason -> RecompReason -> Bool) -> Eq RecompReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecompReason -> RecompReason -> Bool
== :: RecompReason -> RecompReason -> Bool
$c/= :: RecompReason -> RecompReason -> Bool
/= :: RecompReason -> RecompReason -> Bool
Eq)


instance Outputable RecompReason where
  ppr :: RecompReason -> SDoc
ppr = \case
    UnitDepRemoved UnitId
uid       -> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"removed"
    ModulePackageChanged FastString
s   -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package changed"
    RecompReason
SourceFileChanged        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Source file changed"
    RecompReason
NoSelfRecompInfo         -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Old interface lacks recompilation info"
    RecompReason
ThisUnitIdChanged        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-this-unit-id changed"
    RecompReason
ImpurePlugin             -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Impure plugin forced recompilation"
    RecompReason
PluginsChanged           -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Plugins changed"
    RecompReason
PluginFingerprintChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Plugin fingerprint changed"
    RecompReason
ModuleInstChanged        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Implementing module changed"
    RecompReason
HieMissing               -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HIE file is missing"
    RecompReason
HieOutdated              -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HIE file is out of date"
    RecompReason
SigsMergeChanged         -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signatures to merge in changed"
    ModuleChanged ModuleName
m          -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed"
    ModuleChangedRaw ModuleName
m       -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed (raw)"
    ModuleChangedIface ModuleName
m     -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed (interface)"
    ModuleRemoved (UnitId
_uid, ModuleName
m)   -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"removed"
    ModuleAdded (UnitId
_uid, ModuleName
m)     -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"added"
    FileChanged String
fp           -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
fp SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed"
    CustomReason String
s           -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
s
    RecompReason
FlagsChanged             -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Flags changed"
    RecompReason
LinkFlagsChanged         -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Flags changed"
    RecompReason
OptimFlagsChanged        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Optimisation flags changed"
    RecompReason
HpcFlagsChanged          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HPC flags changed"
    RecompReason
MissingBytecode          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing bytecode"
    RecompReason
MissingObjectFile        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing object file"
    RecompReason
MissingDynObjectFile     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing dynamic object file"
    RecompReason
MissingDynHiFile         -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing dynamic interface file"
    RecompReason
MismatchedDynHiFile     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Mismatched dynamic interface file"
    RecompReason
ObjectsChanged          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Objects changed"
    RecompReason
LibraryChanged          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Library changed"
    RecompReason
THWithJS                -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"JS backend always recompiles modules using Template Haskell for now (#23013)"

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

recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired
recompThen :: forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
recompThen m RecompileRequired
ma m RecompileRequired
mb = m RecompileRequired
ma m RecompileRequired
-> (RecompileRequired -> m RecompileRequired)
-> m RecompileRequired
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  RecompileRequired
UpToDate              -> m RecompileRequired
mb
  rr :: RecompileRequired
rr@(NeedsRecompile CompileReason
_) -> RecompileRequired -> m RecompileRequired
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecompileRequired
rr

checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired
checkList :: forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList = \case
  []               -> RecompileRequired -> m RecompileRequired
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
  (m RecompileRequired
check : [m RecompileRequired]
checks) -> m RecompileRequired
check m RecompileRequired -> m RecompileRequired -> m RecompileRequired
forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
`recompThen` [m RecompileRequired] -> m RecompileRequired
forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList [m RecompileRequired]
checks

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

-- | 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 on the outside whether the interface file is up to date, providing
-- evidence that is with a `ModIface`. In the case that it isn't, we may also
-- return a found or provided `ModIface`. Why we don't always return the old
-- one, if it exists, is unclear to me, except that I tried it and some tests
-- failed (see #18205).
checkOldIface
  :: HscEnv
  -> ModSummary
  -> Maybe ModIface         -- Old interface from compilation manager, if any
  -> IO (MaybeValidated ModIface)

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

check_old_iface
  :: HscEnv
  -> ModSummary
  -> Maybe ModIface
  -> IfG (MaybeValidated ModIface)

check_old_iface :: HscEnv
-> ModSummary -> Maybe ModIface -> IfG (MaybeValidated ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
maybe_iface
  = let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        getIface :: IO (Maybe ModIface)
getIface =
            case Maybe ModIface
maybe_iface of
                Just {}  -> do
                    Logger -> SDoc -> IO ()
trace_if Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"We already have the old interface for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                      Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
mod_summary))
                    Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
maybe_iface
                Maybe ModIface
Nothing -> DynFlags -> String -> IO (Maybe ModIface)
loadIface DynFlags
dflags (ModSummary -> String
msHiFilePath ModSummary
mod_summary)

        loadIface :: DynFlags -> String -> IO (Maybe ModIface)
loadIface DynFlags
read_dflags String
iface_path = do
             let ncu :: NameCache
ncu        = HscEnv -> NameCache
hsc_NC HscEnv
hsc_env
             read_result <- DynFlags
-> NameCache
-> Module
-> String
-> IO (MaybeErr ReadInterfaceError ModIface)
readIface DynFlags
read_dflags NameCache
ncu (ModSummary -> Module
ms_mod ModSummary
mod_summary) String
iface_path
             case read_result of
                 Failed ReadInterfaceError
err -> do
                     let msg :: SDoc
msg = ReadInterfaceError -> SDoc
readInterfaceErrorDiagnostic ReadInterfaceError
err
                     Logger -> SDoc -> IO ()
trace_if Logger
logger
                       (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FYI: cannot read old interface file:"
                              , Int -> SDoc -> SDoc
nest Int
4 SDoc
msg ]
                     Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                       [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Old interface file was invalid:"
                            , Int -> SDoc -> SDoc
nest Int
4 SDoc
msg ]
                     Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
                 Succeeded ModIface
iface -> do
                     Logger -> SDoc -> IO ()
trace_if Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Read the interface file" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
iface_path)
                     Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModIface -> IO (Maybe ModIface))
-> Maybe ModIface -> IO (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface
        check_dyn_hi :: ModIface
                  -> IfG (MaybeValidated ModIface)
                  -> IfG (MaybeValidated ModIface)
        check_dyn_hi :: ModIface
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
check_dyn_hi ModIface
normal_iface IfG (MaybeValidated ModIface)
recomp_check | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags = do
          res <- IfG (MaybeValidated ModIface)
recomp_check
          case res of
            UpToDateItem ModIface
_ -> do
              maybe_dyn_iface <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO (Maybe ModIface)
loadIface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) (ModSummary -> String
msDynHiFilePath ModSummary
mod_summary)
              case maybe_dyn_iface of
                Maybe ModIface
Nothing -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingDynHiFile Maybe ModIface
forall a. Maybe a
Nothing
                Just ModIface
dyn_iface | ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_iface_hash ModIface
dyn_iface
                                    Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_iface_hash ModIface
normal_iface
                  -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MismatchedDynHiFile Maybe ModIface
forall a. Maybe a
Nothing
                Just {} -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeValidated ModIface
res
            MaybeValidated ModIface
_ -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeValidated ModIface
res
        check_dyn_hi ModIface
_ IfG (MaybeValidated ModIface)
recomp_check = IfG (MaybeValidated ModIface)
recomp_check


        src_changed :: Bool
src_changed
            | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags    = 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
$
            IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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.
            Bool
True | Bool -> Bool
not (Backend -> Bool
backendWritesFiles (Backend -> Bool) -> Backend -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
dflags) ->
                MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
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
            Bool
True -> do
                maybe_iface' <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ModIface)
getIface
                return $ OutOfDateItem MustCompile maybe_iface'

            Bool
False -> do
                maybe_iface' <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ModIface)
getIface
                case maybe_iface' of
                    -- We can't retrieve the iface
                    Maybe ModIface
Nothing    -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
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 ModIface
iface ->
                      case ModIface -> Maybe IfaceSelfRecomp
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe IfaceSelfRecomp
mi_self_recomp_info ModIface
iface of
                        Maybe IfaceSelfRecomp
Nothing -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
NoSelfRecompInfo Maybe ModIface
forall a. Maybe a
Nothing
                        Just IfaceSelfRecomp
sr_info -> ModIface
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
check_dyn_hi ModIface
iface (IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface))
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> ModIface
-> IfaceSelfRecomp
-> IfG (MaybeValidated ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface IfaceSelfRecomp
sr_info

-- | 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
              -> IfaceSelfRecomp
              -> IfG (MaybeValidated ModIface)
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfaceSelfRecomp
-> IfG (MaybeValidated ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface IfaceSelfRecomp
self_recomp
  = do { IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger
                        (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Considering whether compilation is required for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                        Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)

       -- readIface will have verified that the UnitId matches,
       -- but we ALSO must make sure the instantiation matches up.  See
       -- test case bkpcabal04!
       ; hsc_env <- TcRnIf IfGblEnv () HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; if mi_sr_src_hash self_recomp /= ms_hs_hash mod_summary
            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {
       ; if not (isHomeModule home_unit (mi_module iface))
            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {
       ; recomp <- liftIO $ checkFlagHash hsc_env (mi_module iface) self_recomp
                             `recompThen` checkOptimHash hsc_env self_recomp
                             `recompThen` checkHpcHash hsc_env self_recomp
                             `recompThen` checkMergedSignatures hsc_env mod_summary self_recomp
                             `recompThen` checkHsig logger home_unit mod_summary iface
                             `recompThen` pure (checkHie dflags mod_summary)
       ; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe ModIface
forall a. Maybe a
Nothing ; RecompileRequired
_ -> do {
       ; recomp <- HscEnv
-> ModSummary
-> ModIface
-> IOEnv (Env IfGblEnv ()) RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
       ; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) ; RecompileRequired
_ -> do {
       ; recomp <- Plugins
-> IfaceSelfRecomp -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) IfaceSelfRecomp
self_recomp
       ; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe ModIface
forall a. Maybe a
Nothing ; RecompileRequired
_ -> 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).

       Bool -> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))) (IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ())
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ do {
          ; (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
$ \ExternalPackageState
eps  -> ExternalPackageState
eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }
       }
       ; recomp <- [IOEnv (Env IfGblEnv ()) RecompileRequired]
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList [FinderCache -> Usage -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkModUsage (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) Usage
u
                             | Usage
u <- IfaceSelfRecomp -> [Usage]
mi_sr_usages IfaceSelfRecomp
self_recomp]
       ; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) ; RecompileRequired
_ -> do {
       ; MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> MaybeValidated ModIface
forall a. a -> MaybeValidated a
UpToDateItem ModIface
iface
    }}}}}}}
  where
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env



-- | Check if any plugins are requesting recompilation
checkPlugins :: Plugins -> IfaceSelfRecomp -> IfG RecompileRequired
checkPlugins :: Plugins
-> IfaceSelfRecomp -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkPlugins Plugins
plugins IfaceSelfRecomp
self_recomp = IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
  recomp <- Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins
  let new_fingerprint = PluginRecompile -> Fingerprint
fingerprintPluginRecompile PluginRecompile
recomp
  let old_fingerprint = IfaceSelfRecomp -> Fingerprint
mi_sr_plugin_hash IfaceSelfRecomp
self_recomp
  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp

recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins = [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' (Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins)

fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins Plugins
plugins = PluginRecompile -> Fingerprint
fingerprintPluginRecompile (PluginRecompile -> Fingerprint)
-> IO PluginRecompile -> IO Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins

fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile PluginRecompile
recomp = case PluginRecompile
recomp of
  PluginRecompile
NoForceRecompile  -> String -> Fingerprint
fingerprintString String
"NoForceRecompile"
  PluginRecompile
ForceRecompile    -> String -> Fingerprint
fingerprintString String
"ForceRecompile"
  -- is the chance of collision worth worrying about?
  -- An alternative is to fingerprintFingerprints [fingerprintString
  -- "maybeRecompile", fp]
  MaybeRecompile Fingerprint
fp -> Fingerprint
fp


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

      -- we already checked the fingerprint above so a mismatch is not possible
      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
      MaybeRecompile Fingerprint
_  -> 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.
      PluginRecompile
ForceRecompile    -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
ImpurePlugin

  | Fingerprint
old_fp Fingerprint -> [Fingerprint] -> Bool
forall a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 ForceRecomp to NoForceRecomp
    -- recompilation is triggered since the old impure plugins could have
    -- changed the build output which is now back to normal.
    = RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginsChanged

  | Bool
otherwise =
    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.
      PluginRecompile
ForceRecompile   -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginFingerprintChanged

      PluginRecompile
_                -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginFingerprintChanged

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


-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
checkHsig :: Logger
-> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
checkHsig Logger
logger HomeUnit
home_unit ModSummary
mod_summary ModIface
iface = do
    let outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod)
    Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod)
    case Module
inner_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module ModIface
iface of
        Bool
True -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"implementing module unchanged")
        Bool
False -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
ModuleInstChanged

-- | Check if @.hie@ file is out of date or missing.
checkHie :: DynFlags -> ModSummary -> RecompileRequired
checkHie :: DynFlags -> ModSummary -> RecompileRequired
checkHie DynFlags
dflags ModSummary
mod_summary =
    let hie_date_opt :: Maybe UTCTime
hie_date_opt = ModSummary -> Maybe UTCTime
ms_hie_date ModSummary
mod_summary
        hi_date :: Maybe UTCTime
hi_date = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
mod_summary
    in if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags)
      then RecompileRequired
UpToDate
      else case (Maybe UTCTime
hie_date_opt, Maybe UTCTime
hi_date) of
             (Maybe UTCTime
Nothing, Maybe UTCTime
_) -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
HieMissing
             (Just UTCTime
hie_date, Just UTCTime
hi_date)
                 | UTCTime
hie_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
hi_date
                 -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
HieOutdated
             (Maybe UTCTime, Maybe UTCTime)
_ -> RecompileRequired
UpToDate

-- | Check the flags haven't changed
checkFlagHash :: HscEnv -> Module -> IfaceSelfRecomp -> IO RecompileRequired
checkFlagHash :: HscEnv -> Module -> IfaceSelfRecomp -> IO RecompileRequired
checkFlagHash HscEnv
hsc_env Module
iface_mod IfaceSelfRecomp
self_recomp = do
    let logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let FingerprintWithValue Fingerprint
old_fp Maybe IfaceDynFlags
old_flags = IfaceSelfRecomp -> FingerprintWithValue IfaceDynFlags
mi_sr_flag_hash IfaceSelfRecomp
self_recomp
    let (Fingerprint
new_fp, IfaceDynFlags
new_flags) = HscEnv
-> Module
-> (WriteBinHandle -> IfExtName -> IO ())
-> (Fingerprint, IfaceDynFlags)
fingerprintDynFlags HscEnv
hsc_env Module
iface_mod WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
    if Fingerprint
old_fp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_fp
      then Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module flags unchanged")
      else do
        -- Do not perform this computation unless -ddump-hi-diffs is on
        let diffs :: IO [SDoc]
diffs = case Maybe IfaceDynFlags
old_flags of
                      Maybe IfaceDynFlags
Nothing -> [SDoc] -> IO [SDoc]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SDoc
missingExtraFlagInfo]
                      Just IfaceDynFlags
old_flags -> IfaceDynFlags -> IfaceDynFlags -> IO [SDoc]
checkIfaceFlags IfaceDynFlags
old_flags IfaceDynFlags
new_flags
        Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
FlagsChanged (([SDoc] -> SDoc) -> IO [SDoc] -> IO SDoc
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat IO [SDoc]
diffs)


checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc]
checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc]
checkIfaceFlags (IfaceDynFlags Maybe (Maybe String)
a1 IfaceTrustInfo
a2 Maybe IfaceLanguage
a3 [IfaceExtension]
a4 IfaceCppOptions
a5 IfaceCppOptions
a6 IfaceCppOptions
a7 [String]
a8 Maybe IfaceProfAuto
a9 [IfaceGeneralFlag]
a10 [IfaceGeneralFlag]
a11 Bool
a12 Int
a13 [CallerCcFilter]
a14)
                (IfaceDynFlags Maybe (Maybe String)
b1 IfaceTrustInfo
b2 Maybe IfaceLanguage
b3 [IfaceExtension]
b4 IfaceCppOptions
b5 IfaceCppOptions
b6 IfaceCppOptions
b7 [String]
b8 Maybe IfaceProfAuto
b9 [IfaceGeneralFlag]
b10 [IfaceGeneralFlag]
b11 Bool
b12 Int
b13 [CallerCcFilter]
b14) =
  (StateT [SDoc] IO () -> [SDoc] -> IO [SDoc])
-> [SDoc] -> StateT [SDoc] IO () -> IO [SDoc]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [SDoc] IO () -> [SDoc] -> IO [SDoc]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT [] (StateT [SDoc] IO () -> IO [SDoc])
-> StateT [SDoc] IO () -> IO [SDoc]
forall a b. (a -> b) -> a -> b
$ do
    String
-> (Maybe (Maybe String) -> SDoc)
-> Maybe (Maybe String)
-> Maybe (Maybe String)
-> StateT [SDoc] IO ()
forall {t} {m :: * -> *} {a}.
(Binary t, Monad m, IsDoc a, IsLine a) =>
String -> (t -> a) -> t -> t -> StateT [a] m ()
check_one String
"main is" (Maybe (Maybe SDoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Maybe (Maybe SDoc) -> SDoc)
-> (Maybe (Maybe String) -> Maybe (Maybe SDoc))
-> Maybe (Maybe String)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Maybe SDoc)
-> Maybe (Maybe String) -> Maybe (Maybe SDoc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> SDoc) -> Maybe String -> Maybe SDoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall doc. IsLine doc => String -> doc
text @SDoc))) Maybe (Maybe String)
a1 Maybe (Maybe String)
b1
    String -> IfaceTrustInfo -> IfaceTrustInfo -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"safemode" IfaceTrustInfo
a2 IfaceTrustInfo
b2
    String
-> Maybe IfaceLanguage
-> Maybe IfaceLanguage
-> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"lang"  Maybe IfaceLanguage
a3 Maybe IfaceLanguage
b3
    String
-> [IfaceExtension] -> [IfaceExtension] -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"exts" [IfaceExtension]
a4 [IfaceExtension]
b4
    String -> IfaceCppOptions -> IfaceCppOptions -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"cpp option" IfaceCppOptions
a5 IfaceCppOptions
b5
    String -> IfaceCppOptions -> IfaceCppOptions -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"js option" IfaceCppOptions
a6 IfaceCppOptions
b6
    String -> IfaceCppOptions -> IfaceCppOptions -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"cmm option" IfaceCppOptions
a7 IfaceCppOptions
b7
    String
-> ([String] -> SDoc)
-> [String]
-> [String]
-> StateT [SDoc] IO ()
forall {t} {m :: * -> *} {a}.
(Binary t, Monad m, IsDoc a, IsLine a) =>
String -> (t -> a) -> t -> t -> StateT [a] m ()
check_one String
"paths" ([SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([SDoc] -> SDoc) -> ([String] -> [SDoc]) -> [String] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (forall doc. IsLine doc => String -> doc
text @SDoc)) [String]
a8 [String]
b8
    String
-> Maybe IfaceProfAuto
-> Maybe IfaceProfAuto
-> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"prof" Maybe IfaceProfAuto
a9 Maybe IfaceProfAuto
b9
    String
-> [IfaceGeneralFlag] -> [IfaceGeneralFlag] -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"ticky" [IfaceGeneralFlag]
a10 [IfaceGeneralFlag]
b10
    String
-> [IfaceGeneralFlag] -> [IfaceGeneralFlag] -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"codegen" [IfaceGeneralFlag]
a11 [IfaceGeneralFlag]
b11
    String -> Bool -> Bool -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"fat iface" Bool
a12 Bool
b12
    String -> Int -> Int -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"debug level" Int
a13 Int
b13
    String
-> [CallerCcFilter] -> [CallerCcFilter] -> StateT [SDoc] IO ()
forall {t} {m :: * -> *}.
(Binary t, Monad m, Outputable t) =>
String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
"caller cc filter" [CallerCcFilter]
a14 [CallerCcFilter]
b14
  where
    diffSimple :: (t -> doc) -> t -> t -> doc
diffSimple t -> doc
p t
a t
b = [doc] -> doc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> doc
forall doc. IsLine doc => String -> doc
text String
"before:" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> t -> doc
p t
a
                           , String -> doc
forall doc. IsLine doc => String -> doc
text String
"after:" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> t -> doc
p t
b ]

    check_one_simple :: String -> t -> t -> StateT [SDoc] m ()
check_one_simple String
s t
a t
b = String -> (t -> SDoc) -> t -> t -> StateT [SDoc] m ()
forall {t} {m :: * -> *} {a}.
(Binary t, Monad m, IsDoc a, IsLine a) =>
String -> (t -> a) -> t -> t -> StateT [a] m ()
check_one String
s t -> SDoc
forall a. Outputable a => a -> SDoc
ppr t
a t
b

    check_one :: String -> (t -> a) -> t -> t -> StateT [a] m ()
check_one String
s t -> a
p t
a t
b = do
      let a' :: Fingerprint
a' = (WriteBinHandle -> IfExtName -> IO ()) -> t -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally t
a
      let b' :: Fingerprint
b' = (WriteBinHandle -> IfExtName -> IO ()) -> t -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally t
b
      if Fingerprint
a' Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
b' then () -> StateT [a] m ()
forall a. a -> StateT [a] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else ([a] -> [a]) -> StateT [a] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (([ String -> a
forall doc. IsLine doc => String -> doc
text String
s a -> a -> a
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> a
forall doc. IsLine doc => String -> doc
text String
"flags changed"] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [(t -> a) -> t -> t -> a
forall {doc} {t}.
(IsDoc doc, IsLine doc) =>
(t -> doc) -> t -> t -> doc
diffSimple t -> a
p t
a t
b]) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++)

-- | Check the optimisation flags haven't changed
checkOptimHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired
checkOptimHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired
checkOptimHash HscEnv
hsc_env IfaceSelfRecomp
iface = do
    let logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let old_hash :: Fingerprint
old_hash = IfaceSelfRecomp -> Fingerprint
mi_sr_opt_hash IfaceSelfRecomp
iface
    let !new_hash :: Fingerprint
new_hash = DynFlags -> (WriteBinHandle -> IfExtName -> IO ()) -> Fingerprint
fingerprintOptFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Optimisation flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreOptimChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Optimisation flags changed; ignoring")
       | Bool
otherwise
         -> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
OptimFlagsChanged
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Optimisation flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- | Check the HPC flags haven't changed
checkHpcHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired
checkHpcHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired
checkHpcHash HscEnv
hsc_env IfaceSelfRecomp
self_recomp = do
    let logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let old_hash :: Fingerprint
old_hash = IfaceSelfRecomp -> Fingerprint
mi_sr_hpc_hash IfaceSelfRecomp
self_recomp
    let !new_hash :: Fingerprint
new_hash = DynFlags -> (WriteBinHandle -> IfExtName -> IO ()) -> Fingerprint
fingerprintHpcFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HPC flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreHpcChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HPC flags changed; ignoring")
       | Bool
otherwise
         -> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
HpcFlagsChanged
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  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 :: HscEnv -> ModSummary -> IfaceSelfRecomp -> IO RecompileRequired
checkMergedSignatures :: HscEnv -> ModSummary -> IfaceSelfRecomp -> IO RecompileRequired
checkMergedSignatures HscEnv
hsc_env ModSummary
mod_summary IfaceSelfRecomp
self_recomp = do
    let logger :: Logger
logger     = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let unit_state :: UnitState
unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    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 } <- IfaceSelfRecomp -> [Usage]
mi_sr_usages IfaceSelfRecomp
self_recomp ]
        new_merged :: [Module]
new_merged = case UniqMap ModuleName [InstantiatedModule]
-> ModuleName -> Maybe [InstantiatedModule]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UniqMap ModuleName [InstantiatedModule]
requirementContext UnitState
unit_state)
                          (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
                        Maybe [InstantiatedModule]
Nothing -> []
                        Just [InstantiatedModule]
r -> [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort ([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ (InstantiatedModule -> Module) -> [InstantiatedModule] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> InstantiatedModule -> Module
instModuleToModule UnitState
unit_state) [InstantiatedModule]
r
    if [Module]
old_merged [Module] -> [Module] -> Bool
forall a. Eq a => a -> a -> Bool
== [Module]
new_merged
        then Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"signatures to merge in unchanged" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Module]
new_merged)
        else RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
SigsMergeChanged

-- 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 <reason>) if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies :: HscEnv
-> ModSummary
-> ModIface
-> IOEnv (Env IfGblEnv ()) RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
summary ModIface
iface
 = do
    res_normal <- (ModuleName -> PkgQual -> IO FindResult)
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IfG
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall t l.
(ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
classify_import (HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env) (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps ModSummary
summary [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary)
    res_plugin <- classify_import (\ModuleName
mod PkgQual
_ -> FinderCache
-> FinderOpts
-> UnitState
-> Maybe HomeUnit
-> ModuleName
-> IO FindResult
findPluginModule FinderCache
fc FinderOpts
fopts UnitState
units Maybe HomeUnit
mhome_unit ModuleName
mod) (ms_plugin_imps summary)
    case sequence (res_normal ++ res_plugin) of
      Left CompileReason
recomp -> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
recomp
      Right [Either (UnitId, ModuleName) (FastString, UnitId)]
es -> do
        let ([(UnitId, ModuleName)]
hs, [(FastString, UnitId)]
ps) = [Either (UnitId, ModuleName) (FastString, UnitId)]
-> ([(UnitId, ModuleName)], [(FastString, UnitId)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (UnitId, ModuleName) (FastString, UnitId)]
es
        IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$
          [(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods ([(UnitId, ModuleName)] -> [(UnitId, ModuleName)]
forall a. Ord a => [a] -> [a]
sort [(UnitId, ModuleName)]
hs) [(UnitId, ModuleName)]
prev_dep_mods
          IO RecompileRequired
-> IO RecompileRequired -> IO RecompileRequired
forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
`recompThen`
            let allPkgDeps :: [(FastString, UnitId)]
allPkgDeps = ((FastString, UnitId) -> (FastString, UnitId) -> Ordering)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FastString, UnitId) -> UnitId)
-> (FastString, UnitId) -> (FastString, UnitId) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd) ([(FastString, UnitId)] -> [(FastString, UnitId)])
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a b. (a -> b) -> a -> b
$ ((FastString, UnitId) -> UnitId)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd [(FastString, UnitId)]
ps
            in [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages [(FastString, UnitId)]
allPkgDeps [UnitId]
prev_dep_pkgs
 where

   classify_import :: (ModuleName -> t -> IO FindResult)
                      -> [(t, GenLocated l ModuleName)]
                    -> IfG
                       [Either
                          CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
   classify_import :: forall t l.
(ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
classify_import ModuleName -> t -> IO FindResult
find_import [(t, GenLocated l ModuleName)]
imports =
    IO
  [Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-> IfG
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [Either
      CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
 -> IfG
      [Either
         CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))])
-> IO
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-> IfG
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall a b. (a -> b) -> a -> b
$ ((t, GenLocated l ModuleName)
 -> IO
      (Either
         CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))))
-> [(t, GenLocated l ModuleName)]
-> IO
     [Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(t
mb_pkg, L l
_ ModuleName
mod) ->
           let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged ModuleName
mod
           in RecompReason
-> FindResult
-> Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
classify RecompReason
reason (FindResult
 -> Either
      CompileReason (Either (UnitId, ModuleName) (FastString, UnitId)))
-> IO FindResult
-> IO
     (Either
        CompileReason (Either (UnitId, ModuleName) (FastString, UnitId)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> t -> IO FindResult
find_import ModuleName
mod t
mb_pkg)
           [(t, GenLocated l ModuleName)]
imports
   dflags :: DynFlags
dflags        = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
   fopts :: FinderOpts
fopts         = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
   logger :: Logger
logger        = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
   fc :: FinderCache
fc            = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
   mhome_unit :: Maybe HomeUnit
mhome_unit    = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
   all_home_units :: Set UnitId
all_home_units = HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
   units :: UnitState
units         = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
   prev_dep_mods :: [(UnitId, ModuleName)]
prev_dep_mods = ((UnitId, ModuleNameWithIsBoot) -> (UnitId, ModuleName))
-> [(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleNameWithIsBoot -> ModuleName)
-> (UnitId, ModuleNameWithIsBoot) -> (UnitId, ModuleName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod) ([(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)])
-> [(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)]
forall a b. (a -> b) -> a -> b
$ Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a. Set a -> [a]
Set.toAscList (Set (UnitId, ModuleNameWithIsBoot)
 -> [(UnitId, ModuleNameWithIsBoot)])
-> Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a b. (a -> b) -> a -> b
$ Dependencies -> Set (UnitId, ModuleNameWithIsBoot)
dep_direct_mods (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
   prev_dep_pkgs :: [UnitId]
prev_dep_pkgs = Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toAscList (Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Dependencies -> Set UnitId
dep_direct_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface))
                                            (Dependencies -> Set UnitId
dep_plugin_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)))

   classify :: RecompReason
-> FindResult
-> Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
classify RecompReason
_ (Found ModLocation
_ Module
mod)
    | (Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod) UnitId -> Set UnitId -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set UnitId
all_home_units = Either (UnitId, ModuleName) (FastString, UnitId)
-> Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. b -> Either a b
Right ((UnitId, ModuleName)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. a -> Either a b
Left ((Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod), Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
    | Bool
otherwise = Either (UnitId, ModuleName) (FastString, UnitId)
-> Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. b -> Either a b
Right ((FastString, UnitId)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. b -> Either a b
Right (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod), Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod))
   classify RecompReason
reason FindResult
_ = CompileReason
-> Either
     CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. a -> Either a b
Left (RecompReason -> CompileReason
RecompBecause RecompReason
reason)

   check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
   check_mods :: [(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
   check_mods [] ((UnitId, ModuleName)
old:[(UnitId, ModuleName)]
_) = do
     -- This case can happen when a module is change from HPT to package import
     Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"module no longer" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ((UnitId, ModuleName) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId, ModuleName)
old) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in dependencies"

     RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ (UnitId, ModuleName) -> RecompReason
ModuleRemoved (UnitId, ModuleName)
old
   check_mods ((UnitId, ModuleName)
new:[(UnitId, ModuleName)]
news) [(UnitId, ModuleName)]
olds
    | Just ((UnitId, ModuleName)
old, [(UnitId, ModuleName)]
olds') <- [(UnitId, ModuleName)]
-> Maybe ((UnitId, ModuleName), [(UnitId, ModuleName)])
forall a. [a] -> Maybe (a, [a])
uncons [(UnitId, ModuleName)]
olds
    , (UnitId, ModuleName)
new (UnitId, ModuleName) -> (UnitId, ModuleName) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnitId, ModuleName)
old = [(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods (((UnitId, ModuleName) -> Bool)
-> [(UnitId, ModuleName)] -> [(UnitId, ModuleName)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((UnitId, ModuleName) -> (UnitId, ModuleName) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnitId, ModuleName)
new) [(UnitId, ModuleName)]
news) [(UnitId, ModuleName)]
olds'
    | Bool
otherwise = do
        Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imported module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes ((UnitId, ModuleName) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId, ModuleName)
new) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" not among previous dependencies"
        RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ (UnitId, ModuleName) -> RecompReason
ModuleAdded (UnitId, ModuleName)
new

   check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
   check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages [] [] = RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
   check_packages [] (UnitId
old:[UnitId]
_) = do
     Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
old) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"no longer in dependencies"
     RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ UnitId -> RecompReason
UnitDepRemoved UnitId
old
   check_packages ((FastString
new_name, UnitId
new_unit):[(FastString, UnitId)]
news) [UnitId]
olds
    | Just (UnitId
old, [UnitId]
olds') <- [UnitId] -> Maybe (UnitId, [UnitId])
forall a. [a] -> Maybe (a, [a])
uncons [UnitId]
olds
    , UnitId
new_unit UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
old = [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages (((FastString, UnitId) -> Bool)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
new_unit) (UnitId -> Bool)
-> ((FastString, UnitId) -> UnitId) -> (FastString, UnitId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd) [(FastString, UnitId)]
news) [UnitId]
olds'
    | Bool
otherwise = do
        Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imported package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
new_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
new_unit SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not among previous dependencies"
        RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ FastString -> RecompReason
ModulePackageChanged FastString
new_name


needInterface :: Module -> (ModIface -> IO RecompileRequired)
             -> IfG RecompileRequired
needInterface :: Module
-> (ModIface -> IO RecompileRequired)
-> IOEnv (Env IfGblEnv ()) RecompileRequired
needInterface Module
mod ModIface -> IO RecompileRequired
continue
  = do
      mb_recomp <- String -> Module -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
tryGetModIface
        String
"need version info for"
        Module
mod
      case mb_recomp of
        Maybe ModIface
Nothing -> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile
        Just ModIface
iface -> IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ ModIface -> IO RecompileRequired
continue ModIface
iface

tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface :: String -> Module -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
tryGetModIface String
doc_msg Module
mod
  = do  -- Load the imported interface if possible
    logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    let doc_str = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
doc_msg, Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod]
    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))

    mb_iface <- loadInterface doc_str mod ImportBySystem
        -- Load the interface, but don't complain on failure;
        -- Instead, get an Either back which we can test

    case mb_iface of
      Failed MissingInterfaceError
_ -> do
        IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Couldn't load interface for module", Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod])
        Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
                  -- 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 ModIface
iface -> Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just 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 :: FinderCache -> Usage -> IfG RecompileRequired
checkModUsage :: FinderCache -> Usage -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkModUsage FinderCache
_ UsagePackageModule{
                                usg_mod :: Usage -> Module
usg_mod = Module
mod,
                                usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash } = do
  logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  needInterface mod $ \ModIface
iface -> do
    let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
    Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
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 FinderCache
_ UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod, usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash } = do
  logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  needInterface mod $ \ModIface
iface -> do
    let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChangedRaw (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
    Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash (ModIface -> Fingerprint
mi_mod_hash ModIface
iface)
checkModUsage FinderCache
_  UsageHomeModuleInterface{ usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name
                                                 , usg_unit_id :: Usage -> UnitId
usg_unit_id = UnitId
uid
                                                 , usg_iface_hash :: Usage -> Fingerprint
usg_iface_hash = Fingerprint
old_mod_hash } = do
  let mod :: Module
mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
uid)) ModuleName
mod_name
  logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  needInterface mod $ \ModIface
iface -> do
    let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChangedIface ModuleName
mod_name
    Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash (ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_iface_hash ModIface
iface)

checkModUsage FinderCache
_ UsageHomeModule{
                                usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name,
                                usg_unit_id :: Usage -> UnitId
usg_unit_id  = UnitId
uid,
                                usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash,
                                usg_exports :: Usage -> Maybe HomeModImport
usg_exports  = Maybe HomeModImport
maybe_imported_exports,
                                usg_entities :: Usage -> [(OccName, Fingerprint)]
usg_entities = [(OccName, Fingerprint)]
old_decl_hash }
  = do
    let mod :: Module
mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
uid)) ModuleName
mod_name
    logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    needInterface mod $ \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)
forall (phase :: ModIfacePhase).
ModIface_ phase -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn  ModIface
iface
         reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

     IO RecompileRequired -> IO RecompileRequired
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
           -- CHECK MODULE
       recompile <- Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
       if not (recompileRequired recompile)
         then return UpToDate
         else checkList
           [ -- CHECK EXPORT LIST; see Note [When to recompile when export lists change?]
             checkHomeModImport logger reason maybe_imported_exports iface
           , -- CHECK USED ITEMS ONE BY ONE
             checkList [ checkEntityUsage logger reason new_decl_hash u
                       | u <- old_decl_hash]
           , up_to_date logger (text "  Great!  The bits I use are up to date")
           ]

checkModUsage FinderCache
fc UsageFile{ usg_file_path :: Usage -> FastString
usg_file_path = FastString
file,
                            usg_file_hash :: Usage -> Fingerprint
usg_file_hash = Fingerprint
old_hash,
                            usg_file_label :: Usage -> Maybe String
usg_file_label = Maybe String
mlabel } =
  IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) 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
handler (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
      new_hash <- FinderCache -> String -> IO Fingerprint
lookupFileCache FinderCache
fc (String -> IO Fingerprint) -> String -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
file
      if (old_hash /= new_hash)
         then return recomp
         else return UpToDate
 where
   reason :: RecompReason
reason = String -> RecompReason
FileChanged (String -> RecompReason) -> String -> RecompReason
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
file
   recomp :: RecompileRequired
recomp  = RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe RecompReason -> RecompReason
forall a. a -> Maybe a -> a
fromMaybe RecompReason
reason (Maybe RecompReason -> RecompReason)
-> Maybe RecompReason -> RecompReason
forall a b. (a -> b) -> a -> b
$ (String -> RecompReason) -> Maybe String -> Maybe RecompReason
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> RecompReason
CustomReason Maybe String
mlabel
   handler :: IOException -> IO RecompileRequired
handler = if Bool
debugIsOn
      then \IOException
e -> String -> SDoc -> IO RecompileRequired -> IO RecompileRequired
forall a. String -> SDoc -> a -> a
pprTrace String
"UsageFile" (String -> SDoc
forall doc. IsLine doc => String -> doc
text (IOException -> String
forall a. Show a => a -> String
show IOException
e)) (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp
      else \IOException
_ -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp -- if we can't find the file, just recompile, don't fail

-- | We are importing a module whose exports have changed.
-- Does this require recompilation?
--
-- See Note [When to recompile when export lists change?]
checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired
checkHomeModImport :: Logger
-> RecompReason
-> Maybe HomeModImport
-> ModIface
-> IO RecompileRequired
checkHomeModImport Logger
_ RecompReason
_ Maybe HomeModImport
Nothing ModIface
_ = RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
checkHomeModImport Logger
logger RecompReason
reason
  (Just (HomeModImport Fingerprint
old_orphan_like_hash HomeModImportedAvails
old_avails))
  ModIface
iface
    -- (1) Orphans (of the module we are importing or of its dependencies)
    --     have changed: recompilation is required.
    --
    -- See Note [Orphan-like hash].
    | Fingerprint
old_orphan_like_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_orphan_like_hash
    = Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Orphan-likes changed")
        Fingerprint
old_orphan_like_hash Fingerprint
new_orphan_like_hash
    | Bool
otherwise
    -- (2) Is there a change in the set of entities we are importing?
    = case HomeModImportedAvails
old_avails of
        -- (a) Whole module import: recompile if the export hash
        -- of the module we are importing has changed.
        HMIA_Implicit Fingerprint
old_avails_hash
          | Fingerprint
old_avails_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_avails_hash
          -> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Export list changed")
               Fingerprint
old_orphan_like_hash Fingerprint
new_orphan_like_hash
          | Bool
otherwise
          -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
        -- (b) Explicit imports: recompile if there is a change in the
        --     set of imported items.
        HMIA_Explicit
         { hmia_imported_avails :: HomeModImportedAvails -> DetOrdAvails
hmia_imported_avails        = DetOrdAvails [IfaceExport]
imps
         , hmia_parents_with_implicits :: HomeModImportedAvails -> NameSet
hmia_parents_with_implicits = NameSet
parents_of_implicits
         } ->
          case [IfaceExport] -> NameSet -> [IfaceExport] -> [IfaceExport]
checkNewExportedAvails [IfaceExport]
new_exports NameSet
parents_of_implicits [IfaceExport]
imps of
            [] -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
            changes :: [IfaceExport]
changes@(IfaceExport
_:[IfaceExport]
_) ->
              do Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                   SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Export list changed")
                      Int
2 ([IfaceExport] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceExport]
changes)
                 RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
reason
  where
    new_orphan_like_hash :: Fingerprint
new_orphan_like_hash = ModIface -> Fingerprint
mi_orphan_like_hash ModIface
iface
    new_avails_hash :: Fingerprint
new_avails_hash      = ModIface -> Fingerprint
mi_export_avails_hash ModIface
iface
    new_exports :: [IfaceExport]
new_exports          = ModIface -> [IfaceExport]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceExport]
mi_exports ModIface
iface

-- | The exported avails of a module have changed. Should this cause recompilation
-- of a module that imports it?
--
-- This is only about export/import lists; checking for changes in the definitions
-- of used identifiers is done later (see 'checkEntityUsage').
--
-- See Note [When to recompile when export lists change?].
checkNewExportedAvails :: [AvailInfo] -> NameSet -> [AvailInfo] -> [AvailInfo]
checkNewExportedAvails :: [IfaceExport] -> NameSet -> [IfaceExport] -> [IfaceExport]
checkNewExportedAvails [IfaceExport]
new_avails NameSet
parents_of_implicits [IfaceExport]
imported_avails
  = (IfaceExport -> [IfaceExport]) -> [IfaceExport] -> [IfaceExport]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IfaceExport -> [IfaceExport]
go [IfaceExport]
imported_avails
  where
    go :: IfaceExport -> [IfaceExport]
go a :: IfaceExport
a@(Avail IfExtName
n) =
      case NameEnv IfaceExport -> IfExtName -> Maybe IfaceExport
forall a. NameEnv a -> IfExtName -> Maybe a
lookupNameEnv NameEnv IfaceExport
env IfExtName
n of
        Maybe IfaceExport
Nothing -> [IfaceExport
a]
        Just {} -> []
    go a :: IfaceExport
a@(AvailTC IfExtName
n [IfExtName]
ns) =
      case NameEnv IfaceExport -> IfExtName -> Maybe IfaceExport
forall a. NameEnv a -> IfExtName -> Maybe a
lookupNameEnv NameEnv IfaceExport
env IfExtName
n of
        Maybe IfaceExport
Nothing -> [IfaceExport
a]
        Just IfaceExport
a' ->
          case IfaceExport
a' of
            Avail {} -> [IfaceExport
a]
            AvailTC IfExtName
_ [IfExtName]
ns'
              | IfExtName
n IfExtName -> NameSet -> Bool
`elemNameSet` NameSet
parents_of_implicits
              ->
                -- We are dealing with an export item of the form @T(..)@.
                -- If the set of subordinate names has changed at all, we must
                -- recompile.
                if [IfExtName] -> NameSet
mkNameSet [IfExtName]
ns NameSet -> NameSet -> Bool
forall a. Eq a => a -> a -> Bool
== [IfExtName] -> NameSet
mkNameSet [IfExtName]
ns'
                then []
                else [IfaceExport
a]
              | Bool
otherwise
              ->
                -- We are dealing with an import item of the form @T(K,x,y)@.
                -- Just check that all the names we are explicitly importing
                -- continue to be exported. It's OK if T has more children
                -- than it used to.
                if (IfExtName -> Bool) -> [IfExtName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (IfExtName -> [IfExtName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IfExtName]
ns') [IfExtName]
ns
                then []
                else [IfaceExport
a]

    env :: NameEnv IfaceExport
env = [IfaceExport] -> NameEnv IfaceExport
availsToNameEnv [IfaceExport]
new_avails

{- Note [When to recompile when export lists change?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose module N imports module M, and the exports of M change. Does this
require recompiling N?

Suppose for example that we have:

  module M (foo) where
    foo = 3

  module N where
    import M
    bar = foo + 1
    baz = 2 * bar

If we add an identifier to the export list of M, we must recompile N because
this might introduce name clashes, e.g. changing M to:

  module M (foo, bar) where
    foo = 3
    bar = 7

will cause N to no longer compile because of a name clash involving 'bar'.

However, if N had an explicit import list:

  module N where
    import M(foo)
    bar = foo + 1
    baz = 2 * bar

then it *does not matter* that 'M' starts exporting 'bar'; 'N' is unaffected.

This justifies the following approach for deciding whether a change in exports
should lead to recompilation.

  (1) If the orphan instances exported by M change, or if the orphans of
      dependencies of M change, we must recompile N.
      See Note [Orphan-like hash]

  (2) Otherwise, look at all the import declarations that import M.

      (a) If there is a whole module import, or an "import hiding" import,
          then we must recompile N when the avails exported from M change
          (such a change is detected by using the 'mi_export_avails_hash').

      (b) Otherwise, all imports are explicit imports, but not every identifier
          is necessarily explicitly imported, as we might have an import of
          the form @import M(T(..))@.

          We proceed by comparing what we are importing from M against the
          new exports of M. We recompile unless the following two conditions
          are both satisfied:

            C1. Every explicitly imported identifier continues to be exported.
            C2. For every parent P in an import item of the form @P(..)@,
                the set of subordinates exported by P has not changed.

Note that this import check is done purely on the basis of the Names involved,
unlike the subsequent recompilation check done in 'checkEntityUsage' which
checks that the definitions of used identifiers have not changed.

Note [Orphan-like hash]
~~~~~~~~~~~~~~~~~~~~~~~
The orphan-like hash extends the orphan hash to include other entities that
also cause recompilation downstream upon changing.

The hash includes:

  (1) orphan class and family instances
  (2) exported named defaults (these are very similar to orphan instances)
  (3) non-orphan type family instances, including those of dependencies
  (4) the Safe Haskell safety of the module

Why do we need to do this? For (3), 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 (non-orphan) class
instances, because there is no eager consistency check as there is with type
families. For this reason, we don't currently store a hash of non-orphan class
instances.
-}

------------------------
checkModuleFingerprint
  :: Logger
  -> RecompReason
  -> Fingerprint
  -> Fingerprint
  -> IO RecompileRequired
checkModuleFingerprint :: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
  | Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_mod_hash
  = Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module fingerprint unchanged")

  | Bool
otherwise
  = Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Module fingerprint has changed")
                     Fingerprint
old_mod_hash Fingerprint
new_mod_hash

checkIfaceFingerprint
  :: Logger
  -> RecompReason
  -> Fingerprint
  -> Fingerprint
  -> IO RecompileRequired
checkIfaceFingerprint :: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
  | Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_mod_hash
  = Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface fingerprint unchanged")

  | Bool
otherwise
  = Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Iface fingerprint has changed")
                     Fingerprint
old_mod_hash Fingerprint
new_mod_hash

------------------------
checkEntityUsage :: Logger
                 -> RecompReason
                 -> (OccName -> Maybe (OccName, Fingerprint))
                 -> (OccName, Fingerprint)
                 -> IO RecompileRequired
checkEntityUsage :: Logger
-> RecompReason
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IO RecompileRequired
checkEntityUsage Logger
logger RecompReason
reason OccName -> Maybe (OccName, Fingerprint)
new_hash (OccName
name,Fingerprint
old_hash) = do
  case OccName -> Maybe (OccName, Fingerprint)
new_hash OccName
name of
    -- We used it before, but it ain't there now
    Maybe (OccName, Fingerprint)
Nothing       -> Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason (SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> IO SDoc) -> SDoc -> IO SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No longer exported:", OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name])
    -- It's there, but is it up to date?
    Just (OccName
_, Fingerprint
new_hash)
      | Fingerprint
new_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_hash
      -> do Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Up to date" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash))
            RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
      | Bool
otherwise
      -> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  Out of date:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name) Fingerprint
old_hash Fingerprint
new_hash

up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger SDoc
msg = Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger SDoc
msg IO () -> IO RecompileRequired -> IO RecompileRequired
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate

out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason IO SDoc
msg = Logger -> IO SDoc -> IO ()
trace_hi_diffs_io Logger
logger IO SDoc
msg IO () -> IO RecompileRequired -> IO RecompileRequired
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
reason)

out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
out_of_date_hash :: Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason SDoc
msg Fingerprint
old_hash Fingerprint
new_hash
  = Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason (SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> IO SDoc) -> SDoc -> IO SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [SDoc
msg, Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
old_hash, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->", Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash])

-- ---------------------------------------------------------------------------
-- 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.


Note [Fingerprinting recursive groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The fingerprinting of a single recursive group is a rather subtle affair, as
seen in #18733.

How not to fingerprint
----------------------

Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a
group in hash environment `hash_env0`:

 1. extend hash_env0, giving each declaration in the group the fingerprint 0
 2. use this environment to hash the declarations' ABIs, resulting in
    group_fingerprint
 3. produce the final hash environment by extending hash_env0, mapping each
    declaration of the group to group_fingerprint

However, this is wrong. Consider, for instance, a program like:

    data A = ARecu B | ABase String deriving (Show)
    data B = BRecu A | BBase Int deriving (Show)

    info :: B
    info = BBase 1

A consequence of (3) is that A and B will have the same fingerprint. This means
that if the user changes `info` to:

    info :: A
    info = ABase "hello"

The program's ABI fingerprint will not change despite `info`'s type, and
therefore ABI, being clearly different.

However, the incorrectness doesn't end there: (1) means that all recursive
occurrences of names within the group will be given the same fingerprint. This
means that the group's fingerprint won't change if we change an occurrence of A
to B.

Surprisingly, this bug (#18733) lurked for many years before being uncovered.

How we now fingerprint
----------------------

As seen above, the fingerprinting function must ensure that a groups
fingerprint captures the structure of within-group occurrences. The scheme that
we use is:

 0. To ensure determinism, sort the declarations into a stable order by
    declaration name

 1. Extend hash_env0, giving each declaration in the group a sequential
    fingerprint (e.g. 0, 1, 2, ...).

 2. Use this environment to hash the declarations' ABIs, resulting in
    group_fingerprint.

    Since we included the sequence number in step (1) programs identical up to
    transposition of recursive occurrences are distinguishable, avoiding the
    second issue mentioned above.

 3. Produce the final environment by extending hash_env, mapping each
    declaration of the group to the hash of (group_fingerprint, i), where
    i is the position of the declaration in the stable ordering.

    Including i in the hash ensures that the first issue noted above is
    avoided.

-}

-- | Compute the information needed for self-recompilation checking. This
-- information can be computed before the backend phase.
mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO IfaceSelfRecomp
mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO IfaceSelfRecomp
mkSelfRecomp HscEnv
hsc_env Module
this_mod Fingerprint
src_hash [Usage]
usages = do
      let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

      let dyn_flags_info :: (Fingerprint, IfaceDynFlags)
dyn_flags_info = HscEnv
-> Module
-> (WriteBinHandle -> IfExtName -> IO ())
-> (Fingerprint, IfaceDynFlags)
fingerprintDynFlags HscEnv
hsc_env Module
this_mod WriteBinHandle -> IfExtName -> IO ()
putNameLiterally

      let opt_hash :: Fingerprint
opt_hash = DynFlags -> (WriteBinHandle -> IfExtName -> IO ()) -> Fingerprint
fingerprintOptFlags DynFlags
dflags WriteBinHandle -> IfExtName -> IO ()
putNameLiterally

      let hpc_hash :: Fingerprint
hpc_hash = DynFlags -> (WriteBinHandle -> IfExtName -> IO ()) -> Fingerprint
fingerprintHpcFlags DynFlags
dflags WriteBinHandle -> IfExtName -> IO ()
putNameLiterally

      plugin_hash <- Plugins -> IO Fingerprint
fingerprintPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env)

      let include_detailed_flags (Fingerprint
flag_hash, IfaceDynFlags
flags) =
            if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteSelfRecompFlags DynFlags
dflags
              then Fingerprint
-> Maybe IfaceDynFlags -> FingerprintWithValue IfaceDynFlags
forall a. Fingerprint -> Maybe a -> FingerprintWithValue a
FingerprintWithValue Fingerprint
flag_hash (IfaceDynFlags -> Maybe IfaceDynFlags
forall a. a -> Maybe a
Just IfaceDynFlags
flags)
              else Fingerprint
-> Maybe IfaceDynFlags -> FingerprintWithValue IfaceDynFlags
forall a. Fingerprint -> Maybe a -> FingerprintWithValue a
FingerprintWithValue Fingerprint
flag_hash Maybe IfaceDynFlags
forall a. Maybe a
Nothing

      return (IfaceSelfRecomp
                { mi_sr_flag_hash = include_detailed_flags dyn_flags_info
                , mi_sr_hpc_hash = hpc_hash
                , mi_sr_opt_hash = opt_hash
                , mi_sr_plugin_hash = plugin_hash
                , mi_sr_src_hash = src_hash
                , mi_sr_usages = usages })

-- | Add fingerprints for top-level declarations to a 'ModIface'.
--
-- See Note [Fingerprinting IfaceDecls]
addFingerprints
        :: HscEnv
        -> PartialModIface
        -> IO ModIface
addFingerprints :: HscEnv -> PartialModIface -> IO ModIface
addFingerprints HscEnv
hsc_env PartialModIface
iface0 = do
  (abiHashes, caches, decls_w_hashes) <- HscEnv
-> IfaceModInfo
-> PartialIfacePublic
-> Dependencies
-> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)])
addAbiHashes HscEnv
hsc_env (PartialModIface -> IfaceModInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceModInfo
mi_mod_info PartialModIface
iface0) (PartialModIface -> PartialIfacePublic
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfacePublic_ phase
mi_public PartialModIface
iface0) (PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0)

   -- 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@(Fingerprint
_, IfaceDecl
d) <- [(Fingerprint, IfaceDecl)]
decls_w_hashes]

       -- This key is safe because mi_extra_decls contains tidied things.
      getOcc (IfGblTopBndr IfExtName
b) = IfExtName -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfExtName
b
      getOcc (IfLclTopBndr IfLclName
fs IfaceType
_ IfaceIdInfo
_ IfaceIdDetails
details) =
        case IfaceIdDetails
details of
          IfRecSelId { ifRecSelFirstCon :: IfaceIdDetails -> IfExtName
ifRecSelFirstCon = IfExtName
first_con }
            -> FastString -> FastString -> OccName
mkRecFieldOccFS (IfExtName -> FastString
forall a. NamedThing a => a -> FastString
getOccFS IfExtName
first_con) (IfLclName -> FastString
ifLclNameFS IfLclName
fs)
          IfaceIdDetails
_ -> FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
fs)

      binding_key (IfaceNonRec IfaceTopBndrInfo
b b
_) = OccName -> () -> IfaceBindingX () OccName
forall r b. b -> r -> IfaceBindingX r b
IfaceNonRec (IfaceTopBndrInfo -> OccName
getOcc IfaceTopBndrInfo
b) ()
      binding_key (IfaceRec [(IfaceTopBndrInfo, b)]
bs) = [(OccName, ())] -> IfaceBindingX () OccName
forall r b. [(b, r)] -> IfaceBindingX r b
IfaceRec (((IfaceTopBndrInfo, b) -> (OccName, ()))
-> [(IfaceTopBndrInfo, b)] -> [(OccName, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(IfaceTopBndrInfo
b, b
_) -> (IfaceTopBndrInfo -> OccName
getOcc IfaceTopBndrInfo
b, ())) [(IfaceTopBndrInfo, b)]
bs)

      sorted_extra_decls :: Maybe IfaceSimplifiedCore
      sorted_extra_decls = PartialModIface -> Maybe IfaceSimplifiedCore
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe IfaceSimplifiedCore
mi_simplified_core PartialModIface
iface0 Maybe IfaceSimplifiedCore
-> (IfaceSimplifiedCore -> IfaceSimplifiedCore)
-> Maybe IfaceSimplifiedCore
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \IfaceSimplifiedCore
simpl_core ->
         [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IfaceForeign -> IfaceSimplifiedCore
IfaceSimplifiedCore ((IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
 -> IfaceBindingX () OccName)
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
-> IfaceBindingX () OccName
forall {b}.
IfaceBindingX b IfaceTopBndrInfo -> IfaceBindingX () OccName
binding_key (IfaceSimplifiedCore
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_sc_extra_decls IfaceSimplifiedCore
simpl_core)) (IfaceSimplifiedCore -> IfaceForeign
mi_sc_foreign IfaceSimplifiedCore
simpl_core)

  -- The interface hash depends on:
  --   - the ABI hash, plus
  --   - the things which can affect whether a module is recompiled
  --   - the module level annotations,
  --   - deps (home and external packages, dependent files)
  let !iface_hash = (WriteBinHandle -> IfExtName -> IO ())
-> (Fingerprint, Maybe IfaceSelfRecomp, Dependencies)
-> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
                        (IfaceAbiHashes -> Fingerprint
mi_abi_mod_hash IfaceAbiHashes
abiHashes,
                         PartialModIface -> Maybe IfaceSelfRecomp
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe IfaceSelfRecomp
mi_self_recomp_info PartialModIface
iface0,
                         PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0)

  let final_iface = PartialModIface
-> Fingerprint
-> [(Fingerprint, IfaceDecl)]
-> Maybe IfaceSimplifiedCore
-> IfaceAbiHashes
-> IfaceCache
-> ModIface
completePartialModIface PartialModIface
iface0 Fingerprint
iface_hash
                     [(Fingerprint, IfaceDecl)]
sorted_decls Maybe IfaceSimplifiedCore
sorted_extra_decls IfaceAbiHashes
abiHashes IfaceCache
caches
   --
  return final_iface



-- The ABI hash should depend on everything in IfacePublic
-- This is however computed in a very convoluted way, so be careful your
-- addition ends up in the right place. In essence all this function does is
-- compute a hash of the arguments.
--
-- Why the convoluted way? Hashing individual declarations allows us to do fine-grained
-- recompilation checking for home package modules, which record precisely what they use
-- from each module.
addAbiHashes :: HscEnv -> IfaceModInfo -> PartialIfacePublic -> Dependencies -> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)])
addAbiHashes :: HscEnv
-> IfaceModInfo
-> PartialIfacePublic
-> Dependencies
-> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)])
addAbiHashes HscEnv
hsc_env IfaceModInfo
info
  PartialIfacePublic
iface_public
  Dependencies
deps = do
  eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
  let
      -- If you have arrived here by accident then congratulations,
      -- you have discovered the ABI hash. Your reward is to update the ABI hash to
      -- account for your change to the interface file. Omitting your field using a
      -- wildcard may lead to some unfortunate consequences.
      IfacePublic
        exports fixities warns anns decls
        defaults insts fam_insts rules
        trust _trust_pkg -- TODO: trust_pkg ignored
        complete
        _cache
        ()
          = iface_public
      -- And these fields of deps should be in IfacePublic, but in good time.
      Dependencies _ _ _ sig_mods trusted_pkgs boot_mods orph_mods fis_mods  = deps
      decl_warn_fn = Warnings GhcRn -> OccName -> Maybe (WarningTxt GhcRn)
forall p. Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceDeclWarnCache (IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings IfaceWarnings
warns)
      export_warn_fn = Warnings GhcRn -> IfExtName -> Maybe (WarningTxt GhcRn)
forall p. Warnings p -> IfExtName -> Maybe (WarningTxt p)
mkIfaceExportWarnCache (IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings (IfaceWarnings -> Warnings GhcRn)
-> IfaceWarnings -> Warnings GhcRn
forall a b. (a -> b) -> a -> b
$ IfaceWarnings
warns)
      fix_fn = [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache [(OccName, Fixity)]
fixities

      this_mod = IfaceModInfo -> Module
mi_mod_info_module IfaceModInfo
info
      semantic_mod = IfaceModInfo -> Module
mi_mod_info_semantic_module IfaceModInfo
info
      (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    insts
      (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    rules
      (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph fam_insts
      complete_matches = [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI]
mkIfaceCompleteMap [IfaceCompleteMatch]
complete
      ann_fn = [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload]
mkIfaceAnnCache [IfaceAnnotation]
anns

        -- 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
decl = (Module
this_mod, IfaceDecl
decl, IfaceDeclExtras
extras)
        where extras :: IfaceDeclExtras
extras = (OccName -> Maybe Fixity)
-> (AnnCacheKey -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv IfExtName
-> OccEnv [IfaceCompleteMatchABI]
-> IfaceDecl
-> IfaceDeclExtras
declExtras OccName -> Maybe Fixity
fix_fn AnnCacheKey -> [AnnPayload]
ann_fn OccEnv [IfaceRule]
non_orph_rules OccEnv [IfaceClsInst]
non_orph_insts
                                  OccEnv [IfaceFamInst]
non_orph_fis OccEnv IfExtName
top_lvl_name_env OccEnv [IfaceCompleteMatchABI]
complete_matches 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 =
         [(OccName, IfExtName)] -> OccEnv IfExtName
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [ (IfExtName -> OccName
nameOccName IfExtName
nm, IfExtName
nm)
                  | IfaceId { ifName :: IfaceDecl -> IfExtName
ifName = IfExtName
nm } <- [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
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 OccName IfaceDeclABI ]
      edges = [ IfaceDeclABI -> OccName -> [OccName] -> Node OccName IfaceDeclABI
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode IfaceDeclABI
abi (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl) [OccName]
out
               | IfaceDecl
decl <- [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
decls
               , let abi :: IfaceDeclABI
abi = IfaceDecl -> IfaceDeclABI
declABI IfaceDecl
decl
               , let out :: [OccName]
out = NameSet -> [OccName]
localOccs (NameSet -> [OccName]) -> NameSet -> [OccName]
forall a b. (a -> b) -> a -> b
$ IfaceDeclABI -> NameSet
freeNamesDeclABI IfaceDeclABI
abi
               ]

      name_module IfExtName
n = Bool -> SDoc -> Module -> Module
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (IfExtName -> Bool
isExternalName IfExtName
n) (IfExtName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfExtName
n) (HasDebugCallStack => IfExtName -> Module
IfExtName -> Module
nameModule IfExtName
n)
      localOccs =
         (IfExtName -> OccName) -> [IfExtName] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> OccName
getParent (OccName -> OccName)
-> (IfExtName -> OccName) -> IfExtName -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfExtName -> 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]
                        ([IfExtName] -> [OccName])
-> (NameSet -> [IfExtName]) -> NameSet -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IfExtName -> Bool) -> [IfExtName] -> [IfExtName]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
semantic_mod) (Module -> Bool) -> (IfExtName -> Module) -> IfExtName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfExtName -> Module
name_module)
                        ([IfExtName] -> [IfExtName])
-> (NameSet -> [IfExtName]) -> NameSet -> [IfExtName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSet -> [IfExtName]
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 GHC.Data.Graph.Directed.
          where getParent :: OccName -> OccName
                getParent :: OccName -> OccName
getParent 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 -> IfaceDecl -> OccEnv OccName)
-> OccEnv OccName -> [IfaceDecl] -> OccEnv OccName
forall b a. (b -> a -> b) -> b -> [a] -> b
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]
[IfaceDeclExts 'ModIfaceCore]
decls
          where extend :: OccEnv OccName -> IfaceDecl -> OccEnv OccName
extend OccEnv OccName
env 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 = [Node OccName IfaceDeclABI] -> [SCC IfaceDeclABI]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node OccName IfaceDeclABI]
edges

      global_hash_fn = HscEnv -> ExternalPackageState -> IfExtName -> 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)
                   -> WriteBinHandle -> Name -> IO  ()
      mk_put_name OccEnv (OccName, Fingerprint)
local_env WriteBinHandle
bh IfExtName
name
          | IfExtName -> Bool
isWiredInName IfExtName
name  =  WriteBinHandle -> IfExtName -> IO ()
putNameLiterally WriteBinHandle
bh IfExtName
name
           -- wired-in names don't have fingerprints
          | Bool
otherwise
          = Bool -> SDoc -> IO () -> IO ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (IfExtName -> Bool
isExternalName IfExtName
name) (IfExtName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfExtName
name) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            let hash :: IO Fingerprint
hash | HasDebugCallStack => IfExtName -> Module
IfExtName -> Module
nameModule IfExtName
name Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
semantic_mod =  IfExtName -> IO Fingerprint
global_hash_fn IfExtName
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
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
semantic_mod) = IfExtName -> IO Fingerprint
global_hash_fn IfExtName
name
                     | Bool
otherwise = Fingerprint -> IO Fingerprint
forall a. a -> IO a
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 (IfExtName -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfExtName
name)
                           Maybe (OccName, Fingerprint)
-> (OccName, Fingerprint) -> (OccName, Fingerprint)
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (OccName, Fingerprint)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"urk! lookup local fingerprint"
                                       (IfExtName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfExtName
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBinHandle -> Fingerprint -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
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)
local_env, [(Fingerprint, IfaceDecl)]
decls_w_hashes) (AcyclicSCC IfaceDeclABI
abi)
         = do let hash_fn :: WriteBinHandle -> IfExtName -> IO ()
hash_fn = OccEnv (OccName, Fingerprint)
-> WriteBinHandle -> IfExtName -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env
                  decl :: IfaceDecl
decl = IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi
               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
              let !hash :: Fingerprint
hash = (WriteBinHandle -> IfExtName -> IO ())
-> IfaceDeclABI -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
hash_fn IfaceDeclABI
abi
              env' <- OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env (Fingerprint
hash,IfaceDecl
decl)
              return (env', (hash,decl) : decls_w_hashes)

      fingerprint_group (OccEnv (OccName, Fingerprint)
local_env, [(Fingerprint, IfaceDecl)]
decls_w_hashes) (CyclicSCC [IfaceDeclABI]
abis)
          = 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
                   stable_decls :: [IfaceDecl]
stable_decls = (IfaceDeclABI -> IfaceDecl) -> [IfaceDeclABI] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map IfaceDeclABI -> IfaceDecl
abiDecl [IfaceDeclABI]
stable_abis
               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 ((Word64 -> Fingerprint) -> [Word64] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Fingerprint
mkRecFingerprint [Word64
0..]) [IfaceDecl]
stable_decls)
                -- See Note [Fingerprinting recursive groups]
               let hash_fn = OccEnv (OccName, Fingerprint)
-> WriteBinHandle -> IfExtName -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env1
               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
                -- put the cycle in a canonical order
               let !hash = (WriteBinHandle -> IfExtName -> IO ())
-> [IfaceDeclABI] -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
hash_fn [IfaceDeclABI]
stable_abis
               let pairs = [Fingerprint] -> [IfaceDecl] -> [(Fingerprint, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Word64 -> Fingerprint) -> [Word64] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint -> Word64 -> Fingerprint
bumpFingerprint Fingerprint
hash) [Word64
0..]) [IfaceDecl]
stable_decls
                -- See Note [Fingerprinting recursive groups]
               local_env2 <- foldM extend_hash_env local_env pairs
               return (local_env2, pairs ++ decls_w_hashes)

       -- Make a fingerprint from the ordinal position of a binding in its group.
      mkRecFingerprint :: Word64 -> Fingerprint
      mkRecFingerprint Word64
i = Word64 -> Word64 -> Fingerprint
Fingerprint Word64
0 Word64
i

      bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
      bumpFingerprint Fingerprint
fp Word64
n = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ Fingerprint
fp, Word64 -> Fingerprint
mkRecFingerprint Word64
n ]

       -- 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)
env0 (Fingerprint
hash,IfaceDecl
d) =
          OccEnv (OccName, Fingerprint) -> IO (OccEnv (OccName, Fingerprint))
forall a. a -> IO a
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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(OccName
b,Fingerprint
fp) 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, decls_w_hashes) <-
       foldM fingerprint_group (emptyOccEnv, []) groups

   -- 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.
   --
   -- NB: do not filter out non-home-package modules!
   -- See Note [Take into account non-home package orphan modules].
  let orph_mods_no_self
       = (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
$ [Module]
orph_mods
  dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods_no_self

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

  -- Hash of the transitive things in dependencies
  let !dep_hash = (WriteBinHandle -> IfExtName -> IO ())
-> ([ModuleName], Set (UnitId, ModuleNameWithIsBoot), Set UnitId,
    [Module])
-> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
                      ( [ModuleName]
sig_mods, Set (UnitId, ModuleNameWithIsBoot)
boot_mods
                      , Set UnitId
trusted_pkgs -- Trusted packages are like orphans
                      , [Module]
fis_mods     -- See Note [Orphan-like hash]
                      )

  -- The export list hash doesn't depend on the fingerprints of
  -- the Names it mentions, only the Names themselves, hence putNameLiterally.
  --
  -- As per Note [When to recompile when export lists change?], there are two
  -- separate considerations:
  --
  --  (1) If there is a change in exported orphan instances, we must recompile.
  --
  --      In fact, we must include slightly more items here than only the orphan
  --      instances defined in the current module; see Note [Orphan-like hash].
  --
  --  (2) If there is a change in the exported avails, this may or may not
  --      require recompilation downstream, depending on what is imported.
  --      In the case that the downstream module has a whole module import,
  --      then we recompile when any exports change, by looking at export_hash.
  let
    -- (1) Orphan-like information, see Note [Orphan-like hash].
    !orphan_like_hash =
        (WriteBinHandle -> IfExtName -> IO ())
-> (Fingerprint, Fingerprint, [Fingerprint], [IfaceDefault],
    IfaceTrustInfo)
-> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
          ( Fingerprint
orphan_hash, Fingerprint
dep_hash, [Fingerprint]
dep_orphan_hashes
          , [IfaceDefault]
defaults -- Changes in exported named defaults cause recompilation
          , IfaceTrustInfo
trust    -- Change of Safe Haskell mode causes recompilation
          )
    -- (2) Exported avails
    !exported_avails_hash = (WriteBinHandle -> IfExtName -> IO ())
-> [IfaceExport] -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally [IfaceExport]
exports

  -- the ABI hash depends on:
  --   - decls
  --   - export list
  --   - orphans
  --   - deprecations
  --   - flag abi hash
  let !mod_hash = (WriteBinHandle -> IfExtName -> IO ())
-> ([Fingerprint], Fingerprint, Fingerprint, [AnnPayload],
    IfaceWarnings)
-> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally
                      ([Fingerprint] -> [Fingerprint]
forall a. Ord a => [a] -> [a]
sort (((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)]
decls_w_hashes),
                       Fingerprint
exported_avails_hash,
                       Fingerprint
orphan_like_hash,  -- includes orphan_hash
                       AnnCacheKey -> [AnnPayload]
ann_fn AnnCacheKey
AnnModule,
                       IfaceWarnings
warns)

                      -- Surely the ABI depends on "module" annotations?
                      -- Also named defaults



  let
    final_iface_exts = IfaceAbiHashes
      { mi_abi_mod_hash :: Fingerprint
mi_abi_mod_hash       = Fingerprint
mod_hash
      , mi_abi_orphan :: Bool
mi_abi_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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceClsInst]
orph_insts
                                 Bool -> Bool -> Bool
&& [IfaceFamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceFamInst]
orph_fis)
      , mi_abi_finsts :: Bool
mi_abi_finsts         = Bool -> Bool
not ([IfaceFamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceFamInst]
fam_insts)
      , mi_abi_export_avails_hash :: Fingerprint
mi_abi_export_avails_hash = Fingerprint
exported_avails_hash
      , mi_abi_orphan_like_hash :: Fingerprint
mi_abi_orphan_like_hash   = Fingerprint
orphan_like_hash
      , mi_abi_orphan_hash :: Fingerprint
mi_abi_orphan_hash        = Fingerprint
orphan_hash
      }

    caches = IfaceCache
      { mi_cache_decl_warn_fn :: OccName -> Maybe (WarningTxt GhcRn)
mi_cache_decl_warn_fn = OccName -> Maybe (WarningTxt GhcRn)
decl_warn_fn
      , mi_cache_export_warn_fn :: IfExtName -> Maybe (WarningTxt GhcRn)
mi_cache_export_warn_fn = IfExtName -> Maybe (WarningTxt GhcRn)
export_warn_fn
      , mi_cache_fix_fn :: OccName -> Maybe Fixity
mi_cache_fix_fn = OccName -> Maybe Fixity
fix_fn
      , mi_cache_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_cache_hash_fn = OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
local_env
      }
  return (final_iface_exts, caches, decls_w_hashes)
  where

{- Note [Take into account non-home package orphan modules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to take into account all orphan modules, not just those that are from
the home package.

Historically, 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.

Note [Do not update EPS with your own hi-boot]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

See also #10182.
-}

-- | 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 HscEnv
hsc_env [Module]
mods = do
  let
    dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    ctx :: SDocContext
ctx        = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
    get_orph_hash :: Module -> IO Fingerprint
get_orph_hash Module
mod = do
          iface <- HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (IfM () (MaybeErr MissingInterfaceError ModIface)
    -> IfG ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IfG ModIface
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
                            (IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall lcl.
SDoc
-> Module
-> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
loadInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"getOrphanHashes") Module
mod WhereFrom
ImportBySystem
          return (mi_orphan_hash iface)

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


{-
************************************************************************
*                                                                      *
          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 GHC.Core.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 GHC.Core.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]

  | IfacePatSynExtras (Maybe Fixity) [IfaceCompleteMatchABI] -- ^ COMPLETE pragmas that this PatSyn appears in

  | IfaceOtherDeclExtras

data IfaceIdExtras
  = IdExtras
       (Maybe Fixity)           -- Fixity of the Id (if it exists)
       [IfaceRule]              -- Rules for the Id
       [AnnPayload]             -- Annotations for the Id
       [IfaceCompleteMatchABI]  -- See Note [Fingerprinting complete matches] for why this is in IdExtras

-- 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

-- See Note [Fingerprinting complete matches]
type IfaceCompleteMatchABI = (Fingerprint, Maybe IfExtName)

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

cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames IfaceDeclABI
abi1 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 (Module
_mod, IfaceDecl
decl, IfaceDeclExtras
extras) =
  IfaceDecl -> NameSet
freeNamesIfDecl IfaceDecl
decl NameSet -> NameSet -> NameSet
`unionNameSet` IfaceDeclExtras -> NameSet
freeNamesDeclExtras IfaceDeclExtras
extras

freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras IfaceIdExtras
id_extras)
  = IfaceIdExtras -> NameSet
freeNamesIdExtras IfaceIdExtras
id_extras
freeNamesDeclExtras (IfaceDataExtras  Maybe Fixity
_ [IfExtName]
insts [AnnPayload]
_ [IfaceIdExtras]
subs)
  = [NameSet] -> NameSet
unionNameSets ([IfExtName] -> NameSet
mkNameSet [IfExtName]
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 Maybe Fixity
_ [IfExtName]
insts [AnnPayload]
_ [IfaceIdExtras]
subs [IfExtName]
defms)
  = [NameSet] -> NameSet
unionNameSets ([NameSet] -> NameSet) -> [NameSet] -> NameSet
forall a b. (a -> b) -> a -> b
$
      [IfExtName] -> NameSet
mkNameSet [IfExtName]
insts NameSet -> [NameSet] -> [NameSet]
forall a. a -> [a] -> [a]
: [IfExtName] -> NameSet
mkNameSet [IfExtName]
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 Maybe Fixity
_ [AnnPayload]
_)
  = NameSet
emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras Maybe Fixity
_ [IfExtName]
insts [AnnPayload]
_)
  = [IfExtName] -> NameSet
mkNameSet [IfExtName]
insts
freeNamesDeclExtras (IfacePatSynExtras Maybe Fixity
_ [IfaceCompleteMatchABI]
complete)
  = [NameSet] -> NameSet
unionNameSets ((IfaceCompleteMatchABI -> NameSet)
-> [IfaceCompleteMatchABI] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceCompleteMatchABI -> NameSet
freeNamesIfaceCompleteABI [IfaceCompleteMatchABI]
complete)
freeNamesDeclExtras IfaceDeclExtras
IfaceOtherDeclExtras
  = NameSet
emptyNameSet

freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras (IdExtras Maybe Fixity
_ [IfaceRule]
rules [AnnPayload]
_ [IfaceCompleteMatchABI]
complete) =
  [NameSet] -> NameSet
unionNameSets ((IfaceRule -> NameSet) -> [IfaceRule] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceRule -> NameSet
freeNamesIfRule [IfaceRule]
rules [NameSet] -> [NameSet] -> [NameSet]
forall a. [a] -> [a] -> [a]
++ (IfaceCompleteMatchABI -> NameSet)
-> [IfaceCompleteMatchABI] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map IfaceCompleteMatchABI -> NameSet
freeNamesIfaceCompleteABI [IfaceCompleteMatchABI]
complete)

-- | Extract free names from a COMPLETE pragma ABI
freeNamesIfaceCompleteABI :: IfaceCompleteMatchABI -> NameSet
freeNamesIfaceCompleteABI :: IfaceCompleteMatchABI -> NameSet
freeNamesIfaceCompleteABI (Fingerprint
_, Maybe IfExtName
mb_ty) = case Maybe IfExtName
mb_ty of
  Maybe IfExtName
Nothing -> NameSet
emptyNameSet
  Just IfExtName
ty -> IfExtName -> NameSet
unitNameSet IfExtName
ty


instance Outputable IfaceDeclExtras where
  ppr :: IfaceDeclExtras -> SDoc
ppr IfaceDeclExtras
IfaceOtherDeclExtras       = SDoc
forall doc. IsOutput doc => doc
Outputable.empty
  ppr (IfaceIdExtras  IfaceIdExtras
extras)    = IfaceIdExtras -> SDoc
ppr_id_extras IfaceIdExtras
extras
  ppr (IfaceSynonymExtras Maybe Fixity
fix [AnnPayload]
anns) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 Maybe Fixity
fix [IfExtName]
finsts [AnnPayload]
anns) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [IfExtName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfExtName]
finsts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns]
  ppr (IfaceDataExtras Maybe Fixity
fix [IfExtName]
insts [AnnPayload]
anns [IfaceIdExtras]
stuff)
                    = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [IfExtName] -> SDoc
ppr_insts [IfExtName]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
                            [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff]
  ppr (IfaceClassExtras Maybe Fixity
fix [IfExtName]
insts [AnnPayload]
anns [IfaceIdExtras]
stuff [IfExtName]
defms) =
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [IfExtName] -> SDoc
ppr_insts [IfExtName]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
          [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff, [IfExtName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfExtName]
defms]
  ppr (IfacePatSynExtras Maybe Fixity
fix [IfaceCompleteMatchABI]
complete) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [IfaceCompleteMatchABI] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceCompleteMatchABI]
complete]

ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts :: [IfExtName] -> SDoc
ppr_insts [IfExtName]
_ = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<insts>"

ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 Maybe Fixity
fix [IfaceRule]
rules [AnnPayload]
anns [IfaceCompleteMatchABI]
complete) = Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((AnnPayload -> SDoc) -> [AnnPayload] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map AnnPayload -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((IfaceCompleteMatchABI -> SDoc)
-> [IfaceCompleteMatchABI] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map IfaceCompleteMatchABI -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceCompleteMatchABI]
complete)

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

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

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

declExtras :: (OccName -> Maybe Fixity)
-> (AnnCacheKey -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv IfExtName
-> OccEnv [IfaceCompleteMatchABI]
-> IfaceDecl
-> IfaceDeclExtras
declExtras OccName -> Maybe Fixity
fix_fn AnnCacheKey -> [AnnPayload]
ann_fn OccEnv [IfaceRule]
rule_env OccEnv [IfaceClsInst]
inst_env OccEnv [IfaceFamInst]
fi_env OccEnv IfExtName
dm_env OccEnv [IfaceCompleteMatchABI]
complete_env 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
-> [IfExtName]
-> [AnnPayload]
-> [IfaceIdExtras]
-> IfaceDeclExtras
IfaceDataExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                        ((IfaceFamInst -> IfExtName) -> [IfaceFamInst] -> [IfExtName]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> IfExtName
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n) [IfExtName] -> [IfExtName] -> [IfExtName]
forall a. [a] -> [a] -> [a]
++
                         (IfaceClsInst -> IfExtName) -> [IfaceClsInst] -> [IfExtName]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> IfExtName
ifDFun         (OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env OccName
n))
                        (AnnCacheKey -> [AnnPayload]
ann_fn (OccName -> AnnCacheKey
AnnOccName 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
. IfExtName -> OccName
forall name. HasOccName name => name -> OccName
occName (IfExtName -> OccName)
-> (IfaceConDecl -> IfExtName) -> IfaceConDecl -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceConDecl -> IfExtName
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
-> [IfExtName]
-> [AnnPayload]
-> [IfaceIdExtras]
-> [IfExtName]
-> IfaceDeclExtras
IfaceClassExtras (OccName -> Maybe Fixity
fix_fn OccName
n) [IfExtName]
insts (AnnCacheKey -> [AnnPayload]
ann_fn (OccName -> AnnCacheKey
AnnOccName OccName
n)) [IfaceIdExtras]
meths [IfExtName]
defms
          where
            insts :: [IfExtName]
insts = ((IfaceClsInst -> IfExtName) -> [IfaceClsInst] -> [IfExtName]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> IfExtName
ifDFun ([IfaceClsInst] -> [IfExtName]) -> [IfaceClsInst] -> [IfExtName]
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 (#5147)
            meths :: [IfaceIdExtras]
meths = [OccName -> IfaceIdExtras
id_extras (IfExtName -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfExtName
op) | IfaceClassOp IfExtName
op IfaceType
_ Maybe (DefMethSpec IfaceType)
_ <- [IfaceClassOp]
sigs]
            -- Names of all the default methods (see Note [default method Name])
            defms :: [IfExtName]
defms = [ IfExtName
dmName
                    | IfaceClassOp IfExtName
bndr IfaceType
_ (Just DefMethSpec IfaceType
_) <- [IfaceClassOp]
sigs
                    , let dmOcc :: OccName
dmOcc = OccName -> OccName
mkDefaultMethodOcc (IfExtName -> OccName
nameOccName IfExtName
bndr)
                    , Just IfExtName
dmName <- [OccEnv IfExtName -> OccName -> Maybe IfExtName
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv IfExtName
dm_env OccName
dmOcc] ]
      IfaceSynonym{} -> Maybe Fixity -> [AnnPayload] -> IfaceDeclExtras
IfaceSynonymExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                                           (AnnCacheKey -> [AnnPayload]
ann_fn (OccName -> AnnCacheKey
AnnOccName OccName
n))
      IfaceFamily{} -> Maybe Fixity -> [IfExtName] -> [AnnPayload] -> IfaceDeclExtras
IfaceFamilyExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
                        ((IfaceFamInst -> IfExtName) -> [IfaceFamInst] -> [IfExtName]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> IfExtName
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n))
                        (AnnCacheKey -> [AnnPayload]
ann_fn (OccName -> AnnCacheKey
AnnOccName OccName
n))
      IfacePatSyn{} -> Maybe Fixity -> [IfaceCompleteMatchABI] -> IfaceDeclExtras
IfacePatSynExtras (OccName -> Maybe Fixity
fix_fn OccName
n) (OccName -> [IfaceCompleteMatchABI]
lookup_complete_match OccName
n)
      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 OccName
occ = Maybe Fixity
-> [IfaceRule]
-> [AnnPayload]
-> [IfaceCompleteMatchABI]
-> 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) (AnnCacheKey -> [AnnPayload]
ann_fn (OccName -> AnnCacheKey
AnnOccName OccName
occ)) (OccName -> [IfaceCompleteMatchABI]
lookup_complete_match OccName
occ)
        at_extras :: IfaceAT -> [IfaceClsInst]
at_extras (IfaceAT IfaceDecl
decl Maybe IfaceType
_) = 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)

        lookup_complete_match :: OccName -> [IfaceCompleteMatchABI]
lookup_complete_match OccName
occ = OccEnv [IfaceCompleteMatchABI]
-> OccName -> [IfaceCompleteMatchABI]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceCompleteMatchABI]
complete_env OccName
occ

{- Note [default method Name] (see also #15970)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Names for the default methods aren't available in Iface syntax.

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

* We turn that into Iface syntax as a DefMethSpec which lacks a Name
  entirely. Why? Because the Name can be derived from the method name
  (in GHC.IfaceToCore), 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 :: forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [v]
env 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 :: forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap decl -> IsOrphan
get_key [decl]
decls
  = ((OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl]))
-> (OccEnv [decl], [decl]) -> [decl] -> (OccEnv [decl], [decl])
forall b a. (b -> a -> b) -> b -> [a] -> b
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 (OccEnv [decl]
non_orphs, [decl]
orphs) decl
d
        | NotOrphan 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]
Utils.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)

-- -----------------------------------------------------------------------------
-- 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 -> IfExtName -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps IfExtName
name
  | Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
orig_mod
  = Module -> IO Fingerprint
lookup (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
orig_mod))
  | Bool
otherwise
  = Module -> IO Fingerprint
lookup Module
orig_mod
  where
      home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      hpt :: HomeUnitGraph
hpt = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
      pit :: PackageIfaceTable
pit = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
      ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
      occ :: OccName
occ = IfExtName -> OccName
nameOccName IfExtName
name
      orig_mod :: Module
orig_mod = HasDebugCallStack => IfExtName -> Module
IfExtName -> Module
nameModule IfExtName
name
      lookup :: Module -> IO Fingerprint
lookup Module
mod = do
        Bool -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (IfExtName -> Bool
isExternalName IfExtName
name) (IfExtName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfExtName
name)
        iface <- HomeUnitGraph -> PackageIfaceTable -> Module -> IO (Maybe ModIface)
lookupIfaceByModule HomeUnitGraph
hpt PackageIfaceTable
pit Module
mod IO (Maybe ModIface)
-> (Maybe ModIface -> IO ModIface) -> IO ModIface
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just ModIface
iface -> ModIface -> IO ModIface
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
                  Maybe ModIface
Nothing ->
                      -- 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.
                      HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (IfM () (MaybeErr MissingInterfaceError ModIface)
    -> IfG ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IfG ModIface
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
                          (IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow
                            -- If you try and load interfaces when dynamic-too
                            -- enabled then it attempts to load the dyn_hi and hi
                            -- interface files. Backpack doesn't really care about
                            -- dynamic object files as it isn't doing any code
                            -- generation so -dynamic-too is turned off.
                            -- Some tests fail without doing this (such as T16219),
                            -- but they fail because dyn_hi files are not found for
                            -- one of the dependencies (because they are deliberately turned off)
                            -- Why is this check turned off here? That is unclear but
                            -- just one of the many horrible hacks in the backpack
                            -- implementation.
                          (IfM () (MaybeErr MissingInterfaceError ModIface)
 -> IfM () (MaybeErr MissingInterfaceError ModIface))
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall lcl.
SDoc
-> Module
-> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
loadInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookupVers2") Module
mod WhereFrom
ImportBySystem
        return $ snd (mi_hash_fn iface occ `orElse`
                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))

{- Note [Fingerprinting complete matches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The presence or absence of COMPLETE pragmas influences the programs we generate,
and not just error messages, because pattern fallibility information feeds into
the desugaring of do notation (e.g. whether to use 'fail' from 'MonadFail').

As far as recompilation checking is concerned, there are two questions we need
to answer:

  Usage: When is a COMPLETE pragma used?
  Fingerprinting: What is the Fingerprint of a COMPLETE pragma, i.e. when
                  do we consider a COMPLETE pragma to have changed?

Usage

  There isn't a straightforward way to compute which COMPLETE pragmas are
  "used" during pattern-match checking. So we have to come up with a conservative
  approximation.

  The most conservative option is to consider a COMPLETE pragma to always be
  used, much like we treat orphan class instances today. This means that any
  change at all would require recompilation.

  A slightly finer grained option, which is what is currently implemented, is to
  consider a COMPLETE pragma to be used only when the importing module actually
  mentions at least one of the constructors in the COMPLETE pragma.

  Tested in: RecompCompletePragma

Fingerprinting

  Most conservatively, the fingerprint of a COMPLETE pragma would be the hash of
  all the constructors it mentions (together with the hash of the result TyCon,
  if any).

  However, for the purposes of the pattern-match checker, we only really care
  about the Names of the constructors in a COMPLETE pragma; it doesn't matter
  what the definitions of the constructors are. The above criterion would
  pessimistically lead to recompilation in the following scenario:

    module M where
      pattern MyJust :: a -> Maybe a
      pattern MyJust a = Just a
      pattern MyNothing :: Maybe a
      pattern MyNothing = Nothing
      {-# COMPLETE MyJust, MyNothing #-}

    module N where
      import M
      f :: Maybe Int -> Int
      f (MyJust x) = x; f _ = 0

  In this example, if we change the definition of the 'MyNothing' pattern, then
  we will recompile 'M', because 'N' uses the 'MyJust' constructor, 'MyJust'
  appears in the imported {-# COMPLETE MyJust, MyNothing #-} pragma, and
  'MyNothing' has changed.

  However, this is needless: the RHS of the pattern synonym declaration for
  'MyNothing' is completely irrelevant to 'N'. So, to avoid this extraneous
  recompilation, we implement the following finer-grained criterion: the
  Fingerprint of a COMPLETE pragma is the hash of the 'Name's of the mentioned
  constructors (hashed together with the Fingerprint of the result TyCon, if any).

  Tested in: RecompCompleteIndependence.
-}

-- | Make a map from OccNames of pattern synonyms or data constructors to a list
-- of COMPLETE pragmas relevant for that OccName.
-- See Note [Fingerprinting complete matches]
mkIfaceCompleteMap :: [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI]
mkIfaceCompleteMap :: [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI]
mkIfaceCompleteMap [IfaceCompleteMatch]
complete =
  ([IfaceCompleteMatchABI]
 -> [IfaceCompleteMatchABI] -> [IfaceCompleteMatchABI])
-> [(OccName, [IfaceCompleteMatchABI])]
-> OccEnv [IfaceCompleteMatchABI]
forall a. (a -> a -> a) -> [(OccName, a)] -> OccEnv a
mkOccEnv_C [IfaceCompleteMatchABI]
-> [IfaceCompleteMatchABI] -> [IfaceCompleteMatchABI]
forall a. [a] -> [a] -> [a]
(++) ([(OccName, [IfaceCompleteMatchABI])]
 -> OccEnv [IfaceCompleteMatchABI])
-> [(OccName, [IfaceCompleteMatchABI])]
-> OccEnv [IfaceCompleteMatchABI]
forall a b. (a -> b) -> a -> b
$
    (IfaceCompleteMatch -> [(OccName, [IfaceCompleteMatchABI])])
-> [IfaceCompleteMatch] -> [(OccName, [IfaceCompleteMatchABI])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\m :: IfaceCompleteMatch
m@(IfaceCompleteMatch [IfExtName]
syns Maybe IfExtName
_) ->
                  let complete_abi :: IfaceCompleteMatchABI
complete_abi = IfaceCompleteMatch -> IfaceCompleteMatchABI
mkIfaceCompleteMatchABI IfaceCompleteMatch
m
                  in [(IfExtName -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfExtName
syn, [IfaceCompleteMatchABI
complete_abi]) | IfExtName
syn <- [IfExtName]
syns]
    ) [IfaceCompleteMatch]
complete
  where
    mkIfaceCompleteMatchABI :: IfaceCompleteMatch -> IfaceCompleteMatchABI
mkIfaceCompleteMatchABI (IfaceCompleteMatch [IfExtName]
syns Maybe IfExtName
ty) =
      ((WriteBinHandle -> IfExtName -> IO ())
-> [IfExtName] -> Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> IfExtName -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> IfExtName -> IO ()
putNameLiterally [IfExtName]
syns, Maybe IfExtName
ty)

data AnnCacheKey = AnnModule | AnnOccName OccName

-- | Creates cached lookup for the 'mi_anns' field of ModIface
mkIfaceAnnCache :: [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload]
mkIfaceAnnCache :: [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload]
mkIfaceAnnCache [IfaceAnnotation]
anns
  = \AnnCacheKey
n -> case AnnCacheKey
n of
            AnnCacheKey
AnnModule -> [AnnPayload]
module_anns
            AnnOccName OccName
occn -> OccEnv [AnnPayload] -> OccName -> Maybe [AnnPayload]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [AnnPayload]
env OccName
occn Maybe [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a. Maybe a -> a -> a
`orElse` []
  where
    ([AnnPayload]
module_anns, [(OccName, [AnnPayload])]
occ_anns) = [Either AnnPayload (OccName, [AnnPayload])]
-> ([AnnPayload], [(OccName, [AnnPayload])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either AnnPayload (OccName, [AnnPayload])]
 -> ([AnnPayload], [(OccName, [AnnPayload])]))
-> [Either AnnPayload (OccName, [AnnPayload])]
-> ([AnnPayload], [(OccName, [AnnPayload])])
forall a b. (a -> b) -> a -> b
$ (IfaceAnnotation -> Either AnnPayload (OccName, [AnnPayload]))
-> [IfaceAnnotation] -> [Either AnnPayload (OccName, [AnnPayload])]
forall a b. (a -> b) -> [a] -> [b]
map IfaceAnnotation -> Either AnnPayload (OccName, [AnnPayload])
classify [IfaceAnnotation]
anns
    classify :: IfaceAnnotation -> Either AnnPayload (OccName, [AnnPayload])
classify (IfaceAnnotation IfaceAnnTarget
target AnnPayload
value) =
      case IfaceAnnTarget
target of
          NamedTarget OccName
occn -> (OccName, [AnnPayload])
-> Either AnnPayload (OccName, [AnnPayload])
forall a b. b -> Either a b
Right (OccName
occn, [AnnPayload
value])
          ModuleTarget Module
_   -> AnnPayload -> Either AnnPayload (OccName, [AnnPayload])
forall a b. a -> Either a b
Left 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]
(++)) [(OccName, [AnnPayload])]
occ_anns