{-
(c) The University of Glasgow, 2006

\section[GHC.Driver.Types]{Types for the per-module compiler}
-}

{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}

-- | Types for the per-module compiler
module GHC.Driver.Types (
        -- * compilation state
        HscEnv(..), hscEPS,
        FinderCache, FindResult(..), InstalledFindResult(..),
        Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,
        HscStatus(..),

        -- * ModuleGraph
        ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG,
        mgModSummaries, mgElemModule, mgLookupModule,
        needsTemplateHaskellOrQQ, mgBootModules,

        -- * Hsc monad
        Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc,

        -- * Information about modules
        ModDetails(..), emptyModDetails,
        ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
        ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),
        ForeignSrcLang(..),
        phaseForeignLanguage,

        ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps,
        home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary,
        msHsFilePath, msHiFilePath, msObjFilePath,
        SourceModified(..), isTemplateHaskellOrQQNonBoot,

        -- * Information about the module being compiled
        -- (re-exported from GHC.Driver.Phases)
        HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString,


        -- * State relating to modules in this package
        HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
        lookupHpt, eltsHpt, filterHpt, allHpt, anyHpt, mapHpt, delFromHpt,
        addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
        hptCompleteSigs,
        hptInstances, hptRules, pprHPT,

        -- * State relating to known packages
        ExternalPackageState(..), EpsStats(..), addEpsInStats,
        PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
        lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,

        PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
        PackageCompleteMatchMap,

        mkSOName, mkHsSOName, soExt,

        -- * Metaprogramming
        MetaRequest(..),
        MetaResult, -- data constructors not exported to ensure correct response type
        metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW,
        MetaHook,

        -- * Annotations
        prepareAnnotations,

        -- * Interactive context
        InteractiveContext(..), emptyInteractiveContext,
        icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,
        extendInteractiveContext, extendInteractiveContextWithIds,
        substInteractiveContext,
        setInteractivePrintName, icInteractiveModule,
        InteractiveImport(..), setInteractivePackage,
        mkPrintUnqualified, pprModulePrefix,
        mkQualPackage, mkQualModule, pkgQual,

        -- * Interfaces
        ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..),
        mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
        emptyIfaceWarnCache, mi_boot, mi_fix,
        mi_semantic_module,
        mi_free_holes,
        renameFreeHoles,

        -- * Fixity
        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,

        -- * TyThings and type environments
        TyThing(..),  tyThingAvailInfo,
        tyThingTyCon, tyThingDataCon, tyThingConLike,
        tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars,
        implicitTyThings, implicitTyConThings, implicitClassThings,
        isImplicitTyThing,

        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
        typeEnvFromEntities, mkTypeEnvWithImplicits,
        extendTypeEnv, extendTypeEnvList,
        extendTypeEnvWithIds, plusTypeEnv,
        lookupTypeEnv,
        typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
        typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,

        -- * MonadThings
        MonadThings(..),

        -- * Information on imports and exports
        WhetherHasOrphans, IsBootInterface(..), Usage(..),
        Dependencies(..), noDependencies,
        updNameCache,
        IfaceExport,

        -- * Warnings
        Warnings(..), WarningTxt(..), plusWarns,

        -- * Linker stuff
        Linkable(..), isObjectLinkable, linkableObjs,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,

        -- * Program coverage
        HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,

        -- * Breakpoints
        ModBreaks (..), emptyModBreaks,

        -- * Safe Haskell information
        IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
        trustInfoToNum, numToTrustInfo, IsSafeImport,

        -- * result of the parser
        HsParsedModule(..),

        -- * Compilation errors and warnings
        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
        throwOneError, throwErrors, handleSourceError,
        handleFlagWarnings, printOrThrowWarnings,

        -- * COMPLETE signature
        CompleteMatch(..), CompleteMatchMap,
        mkCompleteMatchMap, extendCompleteMatchMap,

        -- * Exstensible Iface fields
        ExtensibleFields(..), FieldName,
        emptyExtensibleFields,
        readField, readIfaceField, readIfaceFieldWith,
        writeField, writeIfaceField, writeIfaceFieldWith,
        deleteField, deleteIfaceField,
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.ByteCode.Types
import GHC.Runtime.Eval.Types ( Resume )
import GHC.Runtime.Interpreter.Types (Interp)
import GHC.ForeignSrcLang

import GHC.Types.Unique.FM
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Avail
import GHC.Unit
import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )
import GHC.Core.FamInstEnv
import GHC.Core         ( CoreProgram, RuleBase, CoreRule )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Var.Set
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..))
import GHC.Core.Type

import GHC.Parser.Annotation    ( ApiAnns )
import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Builtin.Names ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
import GHC.Builtin.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session
import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )
import GHC.Driver.Phases
   ( Phase, HscSource(..), hscSourceString
   , isHsBootOrSig, isHsigFile )
import qualified GHC.Driver.Phases as Phase
import GHC.Types.Basic
import GHC.Iface.Syntax
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.DFM
import GHC.Data.FastString
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
import GHC.Utils.Monad
import GHC.Data.Bag
import GHC.Utils.Binary
import GHC.Utils.Error
import GHC.Types.Name.Cache
import GHC.Platform
import GHC.Utils.Misc
import GHC.Types.Unique.DSet
import GHC.Serialized   ( Serialized )
import qualified GHC.LanguageExtensions as LangExt

import Foreign
import Control.Monad    ( guard, liftM, ap, forM, forM_, replicateM )
import Data.IORef
import Data.Map         ( Map )
import qualified Data.Map as Map
import Data.Time
import GHC.Utils.Exception
import System.FilePath
import Control.DeepSeq
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
import Control.Monad.Catch as MC (MonadCatch, catch)

-- -----------------------------------------------------------------------------
-- Compilation state
-- -----------------------------------------------------------------------------

-- | Status of a compilation to hard-code
data HscStatus
    -- | Nothing to do.
    = HscNotGeneratingCode ModIface ModDetails
    -- | Nothing to do because code already exists.
    | HscUpToDate ModIface ModDetails
    -- | Update boot file result.
    | HscUpdateBoot ModIface ModDetails
    -- | Generate signature file (backpack)
    | HscUpdateSig ModIface ModDetails
    -- | Recompile this module.
    | HscRecomp
        { HscStatus -> CgGuts
hscs_guts       :: CgGuts
          -- ^ Information for the code generator.
        , HscStatus -> ModLocation
hscs_mod_location :: !ModLocation
          -- ^ Module info
        , HscStatus -> PartialModIface
hscs_partial_iface  :: !PartialModIface
          -- ^ Partial interface
        , HscStatus -> Maybe Fingerprint
hscs_old_iface_hash :: !(Maybe Fingerprint)
          -- ^ Old interface hash for this compilation, if an old interface file
          -- exists. Pass to `hscMaybeWriteIface` when writing the interface to
          -- avoid updating the existing interface when the interface isn't
          -- changed.
        , HscStatus -> DynFlags
hscs_iface_dflags :: !DynFlags
          -- ^ Generate final iface using this DynFlags.
          -- FIXME (osa): I don't understand why this is necessary, but I spent
          -- almost two days trying to figure this out and I couldn't .. perhaps
          -- someone who understands this code better will remove this later.
        }
-- Should HscStatus contain the HomeModInfo?
-- All places where we return a status we also return a HomeModInfo.

-- -----------------------------------------------------------------------------
-- The Hsc monad: Passing an environment and warning state

newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
    deriving ((forall a b. (a -> b) -> Hsc a -> Hsc b)
-> (forall a b. a -> Hsc b -> Hsc a) -> Functor Hsc
forall a b. a -> Hsc b -> Hsc a
forall a b. (a -> b) -> Hsc a -> Hsc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Hsc b -> Hsc a
$c<$ :: forall a b. a -> Hsc b -> Hsc a
fmap :: forall a b. (a -> b) -> Hsc a -> Hsc b
$cfmap :: forall a b. (a -> b) -> Hsc a -> Hsc b
Functor)

instance Applicative Hsc where
    pure :: forall a. a -> Hsc a
pure a
a = (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a)
-> (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w -> (a, WarningMessages) -> IO (a, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, WarningMessages
w)
    <*> :: forall a b. Hsc (a -> b) -> Hsc a -> Hsc b
(<*>) = Hsc (a -> b) -> Hsc a -> Hsc b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Hsc where
    Hsc HscEnv -> WarningMessages -> IO (a, WarningMessages)
m >>= :: forall a b. Hsc a -> (a -> Hsc b) -> Hsc b
>>= a -> Hsc b
k = (HscEnv -> WarningMessages -> IO (b, WarningMessages)) -> Hsc b
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (b, WarningMessages)) -> Hsc b)
-> (HscEnv -> WarningMessages -> IO (b, WarningMessages)) -> Hsc b
forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> do (a
a, WarningMessages
w1) <- HscEnv -> WarningMessages -> IO (a, WarningMessages)
m HscEnv
e WarningMessages
w
                                   case a -> Hsc b
k a
a of
                                       Hsc HscEnv -> WarningMessages -> IO (b, WarningMessages)
k' -> HscEnv -> WarningMessages -> IO (b, WarningMessages)
k' HscEnv
e WarningMessages
w1

instance MonadIO Hsc where
    liftIO :: forall a. IO a -> Hsc a
liftIO IO a
io = (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a)
-> (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w -> do a
a <- IO a
io; (a, WarningMessages) -> IO (a, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, WarningMessages
w)

instance HasDynFlags Hsc where
    getDynFlags :: Hsc DynFlags
getDynFlags = (HscEnv -> WarningMessages -> IO (DynFlags, WarningMessages))
-> Hsc DynFlags
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (DynFlags, WarningMessages))
 -> Hsc DynFlags)
-> (HscEnv -> WarningMessages -> IO (DynFlags, WarningMessages))
-> Hsc DynFlags
forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> (DynFlags, WarningMessages) -> IO (DynFlags, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> DynFlags
hsc_dflags HscEnv
e, WarningMessages
w)

runHsc :: HscEnv -> Hsc a -> IO a
runHsc :: forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc) = do
    (a
a, WarningMessages
w) <- HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc HscEnv
hsc_env WarningMessages
forall a. Bag a
emptyBag
    DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) WarningMessages
w
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env = HscEnv
hsc_env{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
interactive_dflags }
  where
    interactive_dflags :: DynFlags
interactive_dflags = InteractiveContext -> DynFlags
ic_dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)

runInteractiveHsc :: HscEnv -> Hsc a -> IO a
-- A variant of runHsc that switches in the DynFlags from the
-- InteractiveContext before running the Hsc computation.
runInteractiveHsc :: forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env = HscEnv -> Hsc a -> IO a
forall a. HscEnv -> Hsc a -> IO a
runHsc (HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env)

-- -----------------------------------------------------------------------------
-- Source Errors

-- When the compiler (GHC.Driver.Main) discovers errors, it throws an
-- exception in the IO monad.

mkSrcErr :: ErrorMessages -> SourceError
mkSrcErr :: WarningMessages -> SourceError
mkSrcErr = WarningMessages -> SourceError
SourceError

srcErrorMessages :: SourceError -> ErrorMessages
srcErrorMessages :: SourceError -> WarningMessages
srcErrorMessages (SourceError WarningMessages
msgs) = WarningMessages
msgs

mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
msg = FieldName -> GhcApiError
GhcApiError (DynFlags -> SDoc -> FieldName
showSDoc DynFlags
dflags SDoc
msg)

throwErrors :: MonadIO io => ErrorMessages -> io a
throwErrors :: forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors = IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> io a)
-> (WarningMessages -> IO a) -> WarningMessages -> io a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO a
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO a)
-> (WarningMessages -> SourceError) -> WarningMessages -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr

throwOneError :: MonadIO io => ErrMsg -> io a
throwOneError :: forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError = WarningMessages -> io a
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> io a)
-> (ErrMsg -> WarningMessages) -> ErrMsg -> io a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag

-- | A source error is an error that is caused by one or more errors in the
-- source code.  A 'SourceError' is thrown by many functions in the
-- compilation pipeline.  Inside GHC these errors are merely printed via
-- 'log_action', but API clients may treat them differently, for example,
-- insert them into a list box.  If you want the default behaviour, use the
-- idiom:
--
-- > handleSourceError printExceptionAndWarnings $ do
-- >   ... api calls that may fail ...
--
-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.
-- This list may be empty if the compiler failed due to @-Werror@
-- ('Opt_WarnIsError').
--
-- See 'printExceptionAndWarnings' for more information on what to take care
-- of when writing a custom error handler.
newtype SourceError = SourceError ErrorMessages

instance Show SourceError where
  show :: SourceError -> FieldName
show (SourceError WarningMessages
msgs) = [FieldName] -> FieldName
unlines ([FieldName] -> FieldName)
-> (WarningMessages -> [FieldName]) -> WarningMessages -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrMsg -> FieldName) -> [ErrMsg] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> FieldName
forall a. Show a => a -> FieldName
show ([ErrMsg] -> [FieldName])
-> (WarningMessages -> [ErrMsg]) -> WarningMessages -> [FieldName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (WarningMessages -> FieldName) -> WarningMessages -> FieldName
forall a b. (a -> b) -> a -> b
$ WarningMessages
msgs

instance Exception SourceError

-- | Perform the given action and call the exception handler if the action
-- throws a 'SourceError'.  See 'SourceError' for more information.
handleSourceError :: (MonadCatch m) =>
                     (SourceError -> m a) -- ^ exception handler
                  -> m a -- ^ action to perform
                  -> m a
handleSourceError :: forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m a
handler m a
act =
  m a -> (SourceError -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MC.catch m a
act (\(SourceError
e :: SourceError) -> SourceError -> m a
handler SourceError
e)

-- | An error thrown if the GHC API is used in an incorrect fashion.
newtype GhcApiError = GhcApiError String

instance Show GhcApiError where
  show :: GhcApiError -> FieldName
show (GhcApiError FieldName
msg) = FieldName
msg

instance Exception GhcApiError

-- | Given a bag of warnings, turn them into an exception if
-- -Werror is enabled, or print them out otherwise.
printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings :: DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings DynFlags
dflags WarningMessages
warns = do
  let (Bool
make_error, WarningMessages
warns') =
        (Bool -> ErrMsg -> (Bool, ErrMsg))
-> Bool -> WarningMessages -> (Bool, WarningMessages)
forall acc x y.
(acc -> x -> (acc, y)) -> acc -> Bag x -> (acc, Bag y)
mapAccumBagL
          (\Bool
make_err ErrMsg
warn ->
            case DynFlags -> ErrMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags ErrMsg
warn of
              Maybe (Maybe WarningFlag)
Nothing ->
                (Bool
make_err, ErrMsg
warn)
              Just Maybe WarningFlag
err_reason ->
                (Bool
True, ErrMsg
warn{ errMsgSeverity :: Severity
errMsgSeverity = Severity
SevError
                           , errMsgReason :: WarnReason
errMsgReason = Maybe WarningFlag -> WarnReason
ErrReason Maybe WarningFlag
err_reason
                           }))
          Bool
False WarningMessages
warns
  if Bool
make_error
    then SourceError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (WarningMessages -> SourceError
mkSrcErr WarningMessages
warns')
    else DynFlags -> WarningMessages -> IO ()
printBagOfErrors DynFlags
dflags WarningMessages
warns

handleFlagWarnings :: DynFlags -> [Warn] -> IO ()
handleFlagWarnings :: DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags [Warn]
warns = do
  let warns' :: [Warn]
warns' = (Warn -> Bool) -> [Warn] -> [Warn]
forall a. (a -> Bool) -> [a] -> [a]
filter (DynFlags -> WarnReason -> Bool
shouldPrintWarning DynFlags
dflags (WarnReason -> Bool) -> (Warn -> WarnReason) -> Warn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warn -> WarnReason
warnReason)  [Warn]
warns

      -- It would be nicer if warns :: [Located MsgDoc], but that
      -- has circular import problems.
      bag :: WarningMessages
bag = [ErrMsg] -> WarningMessages
forall a. [a] -> Bag a
listToBag [ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags SrcSpan
loc (FieldName -> SDoc
text FieldName
warn)
                      | Warn WarnReason
_ (L SrcSpan
loc FieldName
warn) <- [Warn]
warns' ]

  DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings DynFlags
dflags WarningMessages
bag

-- Given a warn reason, check to see if it's associated -W opt is enabled
shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool
shouldPrintWarning :: DynFlags -> WarnReason -> Bool
shouldPrintWarning DynFlags
dflags WarnReason
ReasonDeprecatedFlag
  = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnDeprecatedFlags DynFlags
dflags
shouldPrintWarning DynFlags
dflags WarnReason
ReasonUnrecognisedFlag
  = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnrecognisedWarningFlags DynFlags
dflags
shouldPrintWarning DynFlags
_ WarnReason
_
  = Bool
True

{-
************************************************************************
*                                                                      *
\subsection{HscEnv}
*                                                                      *
************************************************************************
-}

-- | HscEnv is like 'Session', except that some of the fields are immutable.
-- An HscEnv is used to compile a single module from plain Haskell source
-- code (after preprocessing) to either C, assembly or C--. It's also used
-- to store the dynamic linker state to allow for multiple linkers in the
-- same address space.
-- Things like the module graph don't change during a single compilation.
--
-- Historical note: \"hsc\" used to be the name of the compiler binary,
-- when there was a separate driver and compiler.  To compile a single
-- module, the driver would invoke hsc on the source code... so nowadays
-- we think of hsc as the layer of the compiler that deals with compiling
-- a single module.
data HscEnv
  = HscEnv {
        HscEnv -> DynFlags
hsc_dflags :: DynFlags,
                -- ^ The dynamic flag settings

        HscEnv -> [Target]
hsc_targets :: [Target],
                -- ^ The targets (or roots) of the current session

        HscEnv -> ModuleGraph
hsc_mod_graph :: ModuleGraph,
                -- ^ The module graph of the current session

        HscEnv -> InteractiveContext
hsc_IC :: InteractiveContext,
                -- ^ The context for evaluating interactive statements

        HscEnv -> HomePackageTable
hsc_HPT    :: HomePackageTable,
                -- ^ The home package table describes already-compiled
                -- home-package modules, /excluding/ the module we
                -- are compiling right now.
                -- (In one-shot mode the current module is the only
                -- home-package module, so hsc_HPT is empty.  All other
                -- modules count as \"external-package\" modules.
                -- However, even in GHCi mode, hi-boot interfaces are
                -- demand-loaded into the external-package table.)
                --
                -- 'hsc_HPT' is not mutable because we only demand-load
                -- external packages; the home package is eagerly
                -- loaded, module by module, by the compilation manager.
                --
                -- The HPT may contain modules compiled earlier by @--make@
                -- but not actually below the current module in the dependency
                -- graph.
                --
                -- (This changes a previous invariant: changed Jan 05.)

        HscEnv -> IORef ExternalPackageState
hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),
                -- ^ Information about the currently loaded external packages.
                -- This is mutable because packages will be demand-loaded during
                -- a compilation run as required.

        HscEnv -> IORef NameCache
hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),
                -- ^ As with 'hsc_EPS', this is side-effected by compiling to
                -- reflect sucking in interface files.  They cache the state of
                -- external interface files, in effect.

        HscEnv -> IORef FinderCache
hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),
                -- ^ The cached result of performing finding in the file system

        HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
                -- ^ Used for one-shot compilation only, to initialise
                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for
                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]

        , HscEnv -> Maybe Interp
hsc_interp :: Maybe Interp
                -- ^ target code interpreter (if any) to use for TH and GHCi.
                -- See Note [Target code interpreter]

        , HscEnv -> DynLinker
hsc_dynLinker :: DynLinker
                -- ^ dynamic linker.

 }

{-

Note [Target code interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Template Haskell and GHCi use an interpreter to execute code that is built for
the compiler target platform (= code host platform) on the compiler host
platform (= code build platform).

The internal interpreter can be used when both platforms are the same and when
the built code is compatible with the compiler itself (same way, etc.). This
interpreter is not always available: for instance stage1 compiler doesn't have
it because there might be an ABI mismatch between the code objects (built by
stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).

In most cases, an external interpreter can be used instead: it runs in a
separate process and it communicates with the compiler via a two-way message
passing channel. The process is lazily spawned to avoid overhead when it is not
used.

The target code interpreter to use can be selected per session via the
`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in
which case Template Haskell and GHCi will fail to run. The interpreter to use is
configured via command-line flags (in `GHC.setSessionDynFlags`).


-}

-- Note [hsc_type_env_var hack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- hsc_type_env_var is used to initialize tcg_type_env_var, and
-- eventually it is the mutable variable that is queried from
-- if_rec_types to get a TypeEnv.  So, clearly, it's something
-- related to knot-tying (see Note [Tying the knot]).
-- hsc_type_env_var is used in two places: initTcRn (where
-- it initializes tcg_type_env_var) and initIfaceCheck
-- (where it initializes if_rec_types).
--
-- But why do we need a way to feed a mutable variable in?  Why
-- can't we just initialize tcg_type_env_var when we start
-- typechecking?  The problem is we need to knot-tie the
-- EPS, and we may start adding things to the EPS before type
-- checking starts.
--
-- Here is a concrete example. Suppose we are running
-- "ghc -c A.hs", and we have this file system state:
--
--  A.hs-boot   A.hi-boot **up to date**
--  B.hs        B.hi      **up to date**
--  A.hs        A.hi      **stale**
--
-- The first thing we do is run checkOldIface on A.hi.
-- checkOldIface will call loadInterface on B.hi so it can
-- get its hands on the fingerprints, to find out if A.hi
-- needs recompilation.  But loadInterface also populates
-- the EPS!  And so if compilation turns out to be necessary,
-- as it is in this case, the thunks we put into the EPS for
-- B.hi need to have the correct if_rec_types mutable variable
-- to query.
--
-- If the mutable variable is only allocated WHEN we start
-- typechecking, then that's too late: we can't get the
-- information to the thunks.  So we need to pre-commit
-- to a type variable in 'hscIncrementalCompile' BEFORE we
-- check the old interface.
--
-- This is all a massive hack because arguably checkOldIface
-- should not populate the EPS. But that's a refactor for
-- another day.

-- | Retrieve the ExternalPackageState cache.
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env = IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)

-- | A compilation target.
--
-- A target may be supplied with the actual text of the
-- module.  If so, use this instead of the file contents (this
-- is for use in an IDE where the file hasn't been saved by
-- the user yet).
data Target
  = Target {
      Target -> TargetId
targetId           :: !TargetId, -- ^ module or filename
      Target -> Bool
targetAllowObjCode :: !Bool,     -- ^ object code allowed?
      Target -> Maybe (InputFileBuffer, UTCTime)
targetContents     :: !(Maybe (InputFileBuffer, UTCTime))
      -- ^ Optional in-memory buffer containing the source code GHC should
      -- use for this target instead of reading it from disk.
      --
      -- Since GHC version 8.10 modules which require preprocessors such as
      -- Literate Haskell or CPP to run are also supported.
      --
      -- If a corresponding source file does not exist on disk this will
      -- result in a 'SourceError' exception if @targetId = TargetModule _@
      -- is used. However together with @targetId = TargetFile _@ GHC will
      -- not complain about the file missing.
    }

data TargetId
  = TargetModule ModuleName
        -- ^ A module name: search for the file
  | TargetFile FilePath (Maybe Phase)
        -- ^ A filename: preprocess & parse it to find the module name.
        -- If specified, the Phase indicates how to compile this file
        -- (which phase to start from).  Nothing indicates the starting phase
        -- should be determined from the suffix of the filename.
  deriving TargetId -> TargetId -> Bool
(TargetId -> TargetId -> Bool)
-> (TargetId -> TargetId -> Bool) -> Eq TargetId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetId -> TargetId -> Bool
$c/= :: TargetId -> TargetId -> Bool
== :: TargetId -> TargetId -> Bool
$c== :: TargetId -> TargetId -> Bool
Eq

type InputFileBuffer = StringBuffer

pprTarget :: Target -> SDoc
pprTarget :: Target -> SDoc
pprTarget (Target TargetId
id Bool
obj Maybe (InputFileBuffer, UTCTime)
_) =
    (if Bool
obj then Char -> SDoc
char Char
'*' else SDoc
empty) SDoc -> SDoc -> SDoc
<> TargetId -> SDoc
pprTargetId TargetId
id

instance Outputable Target where
    ppr :: Target -> SDoc
ppr = Target -> SDoc
pprTarget

pprTargetId :: TargetId -> SDoc
pprTargetId :: TargetId -> SDoc
pprTargetId (TargetModule ModuleName
m) = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m
pprTargetId (TargetFile FieldName
f Maybe Phase
_) = FieldName -> SDoc
text FieldName
f

instance Outputable TargetId where
    ppr :: TargetId -> SDoc
ppr = TargetId -> SDoc
pprTargetId

{-
************************************************************************
*                                                                      *
\subsection{Package and Module Tables}
*                                                                      *
************************************************************************
-}

-- | Helps us find information about modules in the home package
type HomePackageTable  = DModuleNameEnv HomeModInfo
        -- Domain = modules in the home package that have been fully compiled
        -- "home" unit id cached here for convenience

-- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface
        -- Domain = modules in the imported packages

-- | Constructs an empty HomePackageTable
emptyHomePackageTable :: HomePackageTable
emptyHomePackageTable :: HomePackageTable
emptyHomePackageTable  = HomePackageTable
forall key elt. UniqDFM key elt
emptyUDFM

-- | Constructs an empty PackageIfaceTable
emptyPackageIfaceTable :: PackageIfaceTable
emptyPackageIfaceTable :: PackageIfaceTable
emptyPackageIfaceTable = PackageIfaceTable
forall a. ModuleEnv a
emptyModuleEnv

pprHPT :: HomePackageTable -> SDoc
-- A bit arbitrary for now
pprHPT :: HomePackageTable -> SDoc
pprHPT HomePackageTable
hpt = HomePackageTable -> ([HomeModInfo] -> SDoc) -> SDoc
forall key a. UniqDFM key a -> ([a] -> SDoc) -> SDoc
pprUDFM HomePackageTable
hpt (([HomeModInfo] -> SDoc) -> SDoc)
-> ([HomeModInfo] -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \[HomeModInfo]
hms ->
    [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hm)))
              Int
2 (TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModDetails -> TypeEnv
md_types (HomeModInfo -> ModDetails
hm_details HomeModInfo
hm)))
         | HomeModInfo
hm <- [HomeModInfo]
hms ]

lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt = HomePackageTable -> ModuleName -> Maybe HomeModInfo
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM

lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly = HomePackageTable -> Unique -> Maybe HomeModInfo
forall key elt. UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly

eltsHpt :: HomePackageTable -> [HomeModInfo]
eltsHpt :: HomePackageTable -> [HomeModInfo]
eltsHpt = HomePackageTable -> [HomeModInfo]
forall key elt. UniqDFM key elt -> [elt]
eltsUDFM

filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt = (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
forall elt key. (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM

allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt = (HomeModInfo -> Bool) -> HomePackageTable -> Bool
forall elt key. (elt -> Bool) -> UniqDFM key elt -> Bool
allUDFM

anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool
anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool
anyHpt = (HomeModInfo -> Bool) -> HomePackageTable -> Bool
forall elt key. (elt -> Bool) -> UniqDFM key elt -> Bool
anyUDFM

mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable
mapHpt :: (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
mapHpt = (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
forall elt1 elt2 key.
(elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
mapUDFM

delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt = HomePackageTable -> ModuleName -> HomePackageTable
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> UniqDFM key elt
delFromUDFM

addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM

addListToHpt
  :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
forall key elt.
Uniquable key =>
UniqDFM key elt -> [(key, elt)] -> UniqDFM key elt
addListToUDFM

listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt = [(ModuleName, HomeModInfo)] -> HomePackageTable
forall key elt. Uniquable key => [(key, elt)] -> UniqDFM key elt
listToUDFM

lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
-- The HPT is indexed by ModuleName, not Module,
-- we must check for a hit on the right Module
lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod
  = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) of
      Just HomeModInfo
hm | ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hm) Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
mod -> HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
hm
      Maybe HomeModInfo
_otherwise                               -> Maybe HomeModInfo
forall a. Maybe a
Nothing

-- | Information about modules in the package being compiled
data HomeModInfo
  = HomeModInfo {
      HomeModInfo -> ModIface
hm_iface    :: !ModIface,
        -- ^ The basic loaded interface file: every loaded module has one of
        -- these, even if it is imported from another package
      HomeModInfo -> ModDetails
hm_details  :: !ModDetails,
        -- ^ Extra information that has been created from the 'ModIface' for
        -- the module, typically during typechecking
      HomeModInfo -> Maybe Linkable
hm_linkable :: !(Maybe Linkable)
        -- ^ The actual artifact we would like to link to access things in
        -- this module.
        --
        -- 'hm_linkable' might be Nothing:
        --
        --   1. If this is an .hs-boot module
        --
        --   2. Temporarily during compilation if we pruned away
        --      the old linkable because it was out of date.
        --
        -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields
        -- in the 'HomePackageTable' will be @Just@.
        --
        -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the
        -- 'HomeModInfo' by building a new 'ModDetails' from the old
        -- 'ModIface' (only).
    }

-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
        :: HomePackageTable
        -> PackageIfaceTable
        -> Module
        -> Maybe ModIface
lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit Module
mod
  = case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
       Just HomeModInfo
hm -> ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just (HomeModInfo -> ModIface
hm_iface HomeModInfo
hm)
       Maybe HomeModInfo
Nothing -> PackageIfaceTable -> Module -> Maybe ModIface
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv PackageIfaceTable
pit Module
mod

-- If the module does come from the home package, why do we look in the PIT as well?
-- (a) In OneShot mode, even home-package modules accumulate in the PIT
-- (b) Even in Batch (--make) mode, there is *one* case where a home-package
--     module is in the PIT, namely GHC.Prim when compiling the base package.
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
-- of its own, but it doesn't seem worth the bother.

hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = (HomeModInfo -> [CompleteMatch]) -> HscEnv -> [CompleteMatch]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings  (ModDetails -> [CompleteMatch]
md_complete_sigs (ModDetails -> [CompleteMatch])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [CompleteMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details)

-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
-- Used in @tcRnImports@, to select the instances that are in the
-- transitive closure of imports from the currently compiled module.
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env ModuleName -> Bool
want_this_module
  = let ([[ClsInst]]
insts, [[FamInst]]
famInsts) = [([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]]))
-> [([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ ((HomeModInfo -> [([ClsInst], [FamInst])])
 -> HscEnv -> [([ClsInst], [FamInst])])
-> HscEnv
-> (HomeModInfo -> [([ClsInst], [FamInst])])
-> [([ClsInst], [FamInst])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeModInfo -> [([ClsInst], [FamInst])])
-> HscEnv -> [([ClsInst], [FamInst])]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env ((HomeModInfo -> [([ClsInst], [FamInst])])
 -> [([ClsInst], [FamInst])])
-> (HomeModInfo -> [([ClsInst], [FamInst])])
-> [([ClsInst], [FamInst])]
forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModuleName -> Bool
want_this_module (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info))))
                let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                ([ClsInst], [FamInst]) -> [([ClsInst], [FamInst])]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> [ClsInst]
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
    in ([[ClsInst]] -> [ClsInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClsInst]]
insts, [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)

-- | Get rules from modules "below" this one (in the dependency sense)
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules = (HomeModInfo -> [CoreRule])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [CoreRule]
md_rules (ModDetails -> [CoreRule])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [CoreRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False


-- | Get annotations from modules "below" this one (in the dependency sense)
hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env (Just [ModuleNameWithIsBoot]
deps) = (HomeModInfo -> [Annotation])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [Annotation]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [Annotation]
md_anns (ModDetails -> [Annotation])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False HscEnv
hsc_env [ModuleNameWithIsBoot]
deps
hptAnns HscEnv
hsc_env Maybe [ModuleNameWithIsBoot]
Nothing = (HomeModInfo -> [Annotation]) -> HscEnv -> [Annotation]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [Annotation]
md_anns (ModDetails -> [Annotation])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) HscEnv
hsc_env

hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings :: forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HomeModInfo -> [a]
extract HscEnv
hsc_env = (HomeModInfo -> [a]) -> [HomeModInfo] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HomeModInfo -> [a]
extract (HomePackageTable -> [HomeModInfo]
eltsHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env))

-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs :: forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs HomeModInfo -> [a]
extract Bool
include_hi_boot HscEnv
hsc_env [ModuleNameWithIsBoot]
deps
  | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = []

  | Bool
otherwise
  = let hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    in
    [ a
thing
    |   -- Find each non-hi-boot module below me
      GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } <- [ModuleNameWithIsBoot]
deps
    , Bool
include_hi_boot Bool -> Bool -> Bool
|| (IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)

        -- unsavoury: when compiling the base package with --make, we
        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
        -- be in the HPT, because we never compile it; it's in the EPT
        -- instead. ToDo: clean up, and remove this slightly bogus filter:
    , ModuleName
mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM

        -- Look it up in the HPT
    , let things :: [a]
things = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod of
                    Just HomeModInfo
info -> HomeModInfo -> [a]
extract HomeModInfo
info
                    Maybe HomeModInfo
Nothing -> FieldName -> SDoc -> [a] -> [a]
forall a. FieldName -> SDoc -> a -> a
pprTrace FieldName
"WARNING in hptSomeThingsBelowUs" SDoc
msg []
          msg :: SDoc
msg = [SDoc] -> SDoc
vcat [FieldName -> SDoc
text FieldName
"missing module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod,
                      FieldName -> SDoc
text FieldName
"Probable cause: out-of-date interface files"]
                        -- This really shouldn't happen, but see #962

        -- And get its dfuns
    , a
thing <- [a]
things ]


{-
************************************************************************
*                                                                      *
\subsection{Metaprogramming}
*                                                                      *
************************************************************************
-}

-- | The supported metaprogramming result types
data MetaRequest
  = MetaE  (LHsExpr GhcPs   -> MetaResult)
  | MetaP  (LPat GhcPs      -> MetaResult)
  | MetaT  (LHsType GhcPs   -> MetaResult)
  | MetaD  ([LHsDecl GhcPs] -> MetaResult)
  | MetaAW (Serialized     -> MetaResult)

-- | data constructors not exported to ensure correct result type
data MetaResult
  = MetaResE  { MetaResult -> LHsExpr GhcPs
unMetaResE  :: LHsExpr GhcPs   }
  | MetaResP  { MetaResult -> LPat GhcPs
unMetaResP  :: LPat GhcPs      }
  | MetaResT  { MetaResult -> LHsType GhcPs
unMetaResT  :: LHsType GhcPs   }
  | MetaResD  { MetaResult -> [LHsDecl GhcPs]
unMetaResD  :: [LHsDecl GhcPs] }
  | MetaResAW { MetaResult -> Serialized
unMetaResAW :: Serialized        }

type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult

metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE MetaHook f
h = (MetaResult -> LHsExpr GhcPs) -> f MetaResult -> f (LHsExpr GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> LHsExpr GhcPs
unMetaResE (f MetaResult -> f (LHsExpr GhcPs))
-> (LHsExpr GhcTc -> f MetaResult)
-> LHsExpr GhcTc
-> f (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LHsExpr GhcPs -> MetaResult) -> MetaRequest
MetaE LHsExpr GhcPs -> MetaResult
MetaResE)

metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP MetaHook f
h = (MetaResult -> Located (Pat GhcPs))
-> f MetaResult -> f (Located (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> Located (Pat GhcPs)
MetaResult -> LPat GhcPs
unMetaResP (f MetaResult -> f (Located (Pat GhcPs)))
-> (LHsExpr GhcTc -> f MetaResult)
-> LHsExpr GhcTc
-> f (Located (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LPat GhcPs -> MetaResult) -> MetaRequest
MetaP LPat GhcPs -> MetaResult
MetaResP)

metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT MetaHook f
h = (MetaResult -> LHsType GhcPs) -> f MetaResult -> f (LHsType GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> LHsType GhcPs
unMetaResT (f MetaResult -> f (LHsType GhcPs))
-> (LHsExpr GhcTc -> f MetaResult)
-> LHsExpr GhcTc
-> f (LHsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LHsType GhcPs -> MetaResult) -> MetaRequest
MetaT LHsType GhcPs -> MetaResult
MetaResT)

metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD MetaHook f
h = (MetaResult -> [LHsDecl GhcPs])
-> f MetaResult -> f [LHsDecl GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> [LHsDecl GhcPs]
unMetaResD (f MetaResult -> f [LHsDecl GhcPs])
-> (LHsExpr GhcTc -> f MetaResult)
-> LHsExpr GhcTc
-> f [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h (([LHsDecl GhcPs] -> MetaResult) -> MetaRequest
MetaD [LHsDecl GhcPs] -> MetaResult
MetaResD)

metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW MetaHook f
h = (MetaResult -> Serialized) -> f MetaResult -> f Serialized
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> Serialized
unMetaResAW (f MetaResult -> f Serialized)
-> (LHsExpr GhcTc -> f MetaResult) -> LHsExpr GhcTc -> f Serialized
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((Serialized -> MetaResult) -> MetaRequest
MetaAW Serialized -> MetaResult
MetaResAW)

{-
************************************************************************
*                                                                      *
\subsection{Dealing with Annotations}
*                                                                      *
************************************************************************
-}

-- | Deal with gathering annotations in from all possible places
--   and combining them into a single 'AnnEnv'
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env Maybe ModGuts
mb_guts = do
    ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
    let -- Extract annotations from the module being compiled if supplied one
        mb_this_module_anns :: Maybe AnnEnv
mb_this_module_anns = (ModGuts -> AnnEnv) -> Maybe ModGuts -> Maybe AnnEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (ModGuts -> [Annotation]) -> ModGuts -> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Annotation]
mg_anns) Maybe ModGuts
mb_guts
        -- Extract dependencies of the module if we are supplied one,
        -- otherwise load annotations from all home package table
        -- entries regardless of dependency ordering.
        home_pkg_anns :: AnnEnv
home_pkg_anns  = ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (Maybe [ModuleNameWithIsBoot] -> [Annotation])
-> Maybe [ModuleNameWithIsBoot]
-> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env) (Maybe [ModuleNameWithIsBoot] -> AnnEnv)
-> Maybe [ModuleNameWithIsBoot] -> AnnEnv
forall a b. (a -> b) -> a -> b
$ (ModGuts -> [ModuleNameWithIsBoot])
-> Maybe ModGuts -> Maybe [ModuleNameWithIsBoot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dependencies -> [ModuleNameWithIsBoot]
dep_mods (Dependencies -> [ModuleNameWithIsBoot])
-> (ModGuts -> Dependencies) -> ModGuts -> [ModuleNameWithIsBoot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
mg_deps) Maybe ModGuts
mb_guts
        other_pkg_anns :: AnnEnv
other_pkg_anns = ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps
        ann_env :: AnnEnv
ann_env        = (AnnEnv -> AnnEnv -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a. (a -> a -> a) -> [a] -> a
foldl1' AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv ([AnnEnv] -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a b. (a -> b) -> a -> b
$ [Maybe AnnEnv] -> [AnnEnv]
forall a. [Maybe a] -> [a]
catMaybes [Maybe AnnEnv
mb_this_module_anns,
                                                         AnnEnv -> Maybe AnnEnv
forall a. a -> Maybe a
Just AnnEnv
home_pkg_anns,
                                                         AnnEnv -> Maybe AnnEnv
forall a. a -> Maybe a
Just AnnEnv
other_pkg_anns]
    AnnEnv -> IO AnnEnv
forall (m :: * -> *) a. Monad m => a -> m a
return AnnEnv
ann_env

{-
************************************************************************
*                                                                      *
\subsection{The Finder cache}
*                                                                      *
************************************************************************
-}

-- | The 'FinderCache' maps modules to the result of
-- searching for that module. It records the results of searching for
-- modules along the search path. On @:load@, we flush the entire
-- contents of this cache.
--
type FinderCache = InstalledModuleEnv InstalledFindResult

data InstalledFindResult
  = InstalledFound ModLocation InstalledModule
  | InstalledNoPackage UnitId
  | InstalledNotFound [FilePath] (Maybe UnitId)

-- | The result of searching for an imported module.
--
-- NB: FindResult manages both user source-import lookups
-- (which can result in 'Module') as well as direct imports
-- for interfaces (which always result in 'InstalledModule').
data FindResult
  = Found ModLocation Module
        -- ^ The module was found
  | NoPackage Unit
        -- ^ The requested unit was not found
  | FoundMultiple [(Module, ModuleOrigin)]
        -- ^ _Error_: both in multiple packages

        -- | Not found
  | NotFound
      { FindResult -> [FieldName]
fr_paths       :: [FilePath]       -- ^ Places where I looked

      , FindResult -> Maybe Unit
fr_pkg         :: Maybe Unit       -- ^ Just p => module is in this unit's
                                           --   manifest, but couldn't find the
                                           --   .hi file

      , FindResult -> [Unit]
fr_mods_hidden :: [Unit]           -- ^ Module is in these units,
                                           --   but the *module* is hidden

      , FindResult -> [Unit]
fr_pkgs_hidden :: [Unit]           -- ^ Module is in these units,
                                           --   but the *unit* is hidden

        -- | Module is in these units, but it is unusable
      , FindResult -> [(Unit, UnusableUnitReason)]
fr_unusables   :: [(Unit, UnusableUnitReason)]

      , FindResult -> [ModuleSuggestion]
fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules
      }

{-
************************************************************************
*                                                                      *
\subsection{Symbol tables and Module details}
*                                                                      *
************************************************************************
-}

{- Note [Interface file stages]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Interface files have two possible stages.

* A partial stage built from the result of the core pipeline.
* A fully instantiated form. Which also includes fingerprints and
  potentially information provided by backends.

We can build a full interface file two ways:
* Directly from a partial one:
  Then we omit backend information and mostly compute fingerprints.
* From a partial one + information produced by a backend.
  Then we store the provided information and fingerprint both.
-}

type PartialModIface = ModIface_ 'ModIfaceCore
type ModIface = ModIface_ 'ModIfaceFinal

-- | Extends a PartialModIface with information which is either:
-- * Computed after codegen
-- * Or computed just before writing the iface to disk. (Hashes)
-- In order to fully instantiate it.
data ModIfaceBackend = ModIfaceBackend
  { ModIfaceBackend -> Fingerprint
mi_iface_hash :: !Fingerprint
    -- ^ Hash of the whole interface
  , ModIfaceBackend -> Fingerprint
mi_mod_hash :: !Fingerprint
    -- ^ Hash of the ABI only
  , ModIfaceBackend -> Fingerprint
mi_flag_hash :: !Fingerprint
    -- ^ Hash of the important flags used when compiling the module, excluding
    -- optimisation flags
  , ModIfaceBackend -> Fingerprint
mi_opt_hash :: !Fingerprint
    -- ^ Hash of optimisation flags
  , ModIfaceBackend -> Fingerprint
mi_hpc_hash :: !Fingerprint
    -- ^ Hash of hpc flags
  , ModIfaceBackend -> Fingerprint
mi_plugin_hash :: !Fingerprint
    -- ^ Hash of plugins
  , ModIfaceBackend -> Bool
mi_orphan :: !WhetherHasOrphans
    -- ^ Whether this module has orphans
  , ModIfaceBackend -> Bool
mi_finsts :: !WhetherHasFamInst
    -- ^ Whether this module has family instances. See Note [The type family
    -- instance consistency story].
  , ModIfaceBackend -> Fingerprint
mi_exp_hash :: !Fingerprint
    -- ^ Hash of export list
  , ModIfaceBackend -> Fingerprint
mi_orphan_hash :: !Fingerprint
    -- ^ Hash for orphan rules, class and family instances combined

    -- Cached environments for easy lookup. These are computed (lazily) from
    -- other fields and are not put into the interface file.
    -- Not really produced by the backend but there is no need to create them
    -- any earlier.
  , ModIfaceBackend -> OccName -> Maybe WarningTxt
mi_warn_fn :: !(OccName -> Maybe WarningTxt)
    -- ^ Cached lookup for 'mi_warns'
  , ModIfaceBackend -> OccName -> Maybe Fixity
mi_fix_fn :: !(OccName -> Maybe Fixity)
    -- ^ Cached lookup for 'mi_fixities'
  , ModIfaceBackend -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))
    -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that
    -- the thing isn't in decls. It's useful to know that when seeing if we are
    -- up to date wrt. the old interface. The 'OccName' is the parent of the
    -- name, if it has one.
  }

data ModIfacePhase
  = ModIfaceCore
  -- ^ Partial interface built based on output of core pipeline.
  | ModIfaceFinal

-- | Selects a IfaceDecl representation.
-- For fully instantiated interfaces we also maintain
-- a fingerprint, which is used for recompilation checks.
type family IfaceDeclExts (phase :: ModIfacePhase) where
  IfaceDeclExts 'ModIfaceCore = IfaceDecl
  IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)

type family IfaceBackendExts (phase :: ModIfacePhase) where
  IfaceBackendExts 'ModIfaceCore = ()
  IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend



-- | A 'ModIface' plus a 'ModDetails' summarises everything we know
-- about a compiled module.  The 'ModIface' is the stuff *before* linking,
-- and can be written out to an interface file. The 'ModDetails is after
-- linking and can be completely recovered from just the 'ModIface'.
--
-- When we read an interface file, we also construct a 'ModIface' from it,
-- except that we explicitly make the 'mi_decls' and a few other fields empty;
-- as when reading we consolidate the declarations etc. into a number of indexed
-- maps and environments in the 'ExternalPackageState'.
data ModIface_ (phase :: ModIfacePhase)
  = ModIface {
        forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module     :: !Module,             -- ^ Name of the module we are for
        forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Module
mi_sig_of     :: !(Maybe Module),     -- ^ Are we a sig of another mod?

        forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src    :: !HscSource,          -- ^ Boot? Signature?

        forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps     :: Dependencies,
                -- ^ The dependencies of the module.  This is
                -- consulted for directly-imported modules, but not
                -- for anything else (hence lazy)

        forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages   :: [Usage],
                -- ^ Usages; kept sorted so that it's easy to decide
                -- whether to write a new iface file (changing usages
                -- doesn't affect the hash of this module)
                -- NOT STRICT!  we read this field lazily from the interface file
                -- It is *only* consulted by the recompilation checker

        forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceExport]
mi_exports  :: ![IfaceExport],
                -- ^ Exports
                -- Kept sorted by (mod,occ), to make version comparisons easier
                -- Records the modules that are the declaration points for things
                -- exported by this module, and the 'OccName's of those things


        forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th  :: !Bool,
                -- ^ Module required TH splices when it was compiled.
                -- This disables recompilation avoidance (see #481).

        forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities :: [(OccName,Fixity)],
                -- ^ Fixities
                -- NOT STRICT!  we read this field lazily from the interface file

        forall (phase :: ModIfacePhase). ModIface_ phase -> Warnings
mi_warns    :: Warnings,
                -- ^ Warnings
                -- NOT STRICT!  we read this field lazily from the interface file

        forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
mi_anns     :: [IfaceAnnotation],
                -- ^ Annotations
                -- NOT STRICT!  we read this field lazily from the interface file


        forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls    :: [IfaceDeclExts phase],
                -- ^ Type, class and variable declarations
                -- The hash of an Id changes if its fixity or deprecations change
                --      (as well as its type of course)
                -- Ditto data constructors, class operations, except that
                -- the hash of the parent class/tycon changes

        forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals  :: !(Maybe GlobalRdrEnv),
                -- ^ Binds all the things defined at the top level in
                -- the /original source/ code for this module. which
                -- is NOT the same as mi_exports, nor mi_decls (which
                -- may contains declarations for things not actually
                -- defined by the user).  Used for GHCi and for inspecting
                -- the contents of modules via the GHC API only.
                --
                -- (We need the source file to figure out the
                -- top-level environment, if we didn't compile this module
                -- from source then this field contains @Nothing@).
                --
                -- Strictly speaking this field should live in the
                -- 'HomeModInfo', but that leads to more plumbing.

                -- Instance declarations and rules
        forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceClsInst]
mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance
        forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceFamInst]
mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
        forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceRule]
mi_rules       :: [IfaceRule],     -- ^ Sorted rules

        forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_hpc       :: !AnyHpcUsage,
                -- ^ True if this program uses Hpc at any point in the program.

        forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust     :: !IfaceTrustInfo,
                -- ^ Safe Haskell Trust information for this module.

        forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_trust_pkg :: !Bool,
                -- ^ Do we require the package this module resides in be trusted
                -- to trust this module? This is used for the situation where a
                -- module is Safe (so doesn't require the package be trusted
                -- itself) but imports some trustworthy modules from its own
                -- package (which does require its own package be trusted).
                -- See Note [Trust Own Package] in GHC.Rename.Names
        forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceCompleteMatch]
mi_complete_sigs :: [IfaceCompleteMatch],

        forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr :: Maybe HsDocString,
                -- ^ Module header.

        forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs :: DeclDocMap,
                -- ^ Docs on declarations.

        forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs :: ArgDocMap,
                -- ^ Docs on arguments.

        forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts :: !(IfaceBackendExts phase),
                -- ^ Either `()` or `ModIfaceBackend` for
                -- a fully instantiated interface.

        forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields :: ExtensibleFields
                -- ^ Additional optional fields, where the Map key represents
                -- the field name, resulting in a (size, serialized data) pair.
                -- Because the data is intended to be serialized through the
                -- internal `Binary` class (increasing compatibility with types
                -- using `Name` and `FastString`, such as HIE), this format is
                -- chosen over `ByteString`s.
     }

-- | Old-style accessor for whether or not the ModIface came from an hs-boot
-- file.
mi_boot :: ModIface -> IsBootInterface
mi_boot :: ModIface -> IsBootInterface
mi_boot ModIface
iface = if ModIface -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src ModIface
iface HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
    then IsBootInterface
IsBoot
    else IsBootInterface
NotBoot

-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
mi_fix :: ModIface -> OccName -> Fixity
mi_fix :: ModIface -> OccName -> Fixity
mi_fix ModIface
iface OccName
name = ModIfaceBackend -> OccName -> Maybe Fixity
mi_fix_fn (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface) OccName
name Maybe Fixity -> Fixity -> Fixity
forall a. Maybe a -> a -> a
`orElse` Fixity
defaultFixity

-- | The semantic module for this interface; e.g., if it's a interface
-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'
-- will be @<A>@.
mi_semantic_module :: ModIface_ a -> Module
mi_semantic_module :: forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module ModIface_ a
iface = case ModIface_ a -> Maybe Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Module
mi_sig_of ModIface_ a
iface of
                            Maybe Module
Nothing -> ModIface_ a -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ a
iface
                            Just Module
mod -> Module
mod

-- | The "precise" free holes, e.g., the signatures that this
-- 'ModIface' depends on.
mi_free_holes :: ModIface -> UniqDSet ModuleName
mi_free_holes :: ModIface -> UniqDSet ModuleName
mi_free_holes ModIface
iface =
  case Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) of
    (InstalledModule
_, Just InstantiatedModule
indef)
        -- A mini-hack: we rely on the fact that 'renameFreeHoles'
        -- drops things that aren't holes.
        -> UniqDSet ModuleName
-> [(ModuleName, Module)] -> UniqDSet ModuleName
renameFreeHoles ([ModuleName] -> UniqDSet ModuleName
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ModuleName]
cands) (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts (InstantiatedModule -> GenInstantiatedUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit InstantiatedModule
indef))
    (InstalledModule, Maybe InstantiatedModule)
_   -> UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet
  where
    cands :: [ModuleName]
cands = (ModuleNameWithIsBoot -> ModuleName)
-> [ModuleNameWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([ModuleNameWithIsBoot] -> [ModuleName])
-> [ModuleNameWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [ModuleNameWithIsBoot]
dep_mods (Dependencies -> [ModuleNameWithIsBoot])
-> Dependencies -> [ModuleNameWithIsBoot]
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface

-- | Given a set of free holes, and a unit identifier, rename
-- the free holes according to the instantiation of the unit
-- identifier.  For example, if we have A and B free, and
-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free
-- holes are just C.
renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName
renameFreeHoles :: UniqDSet ModuleName
-> [(ModuleName, Module)] -> UniqDSet ModuleName
renameFreeHoles UniqDSet ModuleName
fhs [(ModuleName, Module)]
insts =
    [UniqDSet ModuleName] -> UniqDSet ModuleName
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets ((ModuleName -> UniqDSet ModuleName)
-> [ModuleName] -> [UniqDSet ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> UniqDSet ModuleName
lookup_impl (UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ModuleName
fhs))
  where
    hmap :: UniqFM ModuleName Module
hmap = [(ModuleName, Module)] -> UniqFM ModuleName Module
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts
    lookup_impl :: ModuleName -> UniqDSet ModuleName
lookup_impl ModuleName
mod_name
        | Just Module
mod <- UniqFM ModuleName Module -> ModuleName -> Maybe Module
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName Module
hmap ModuleName
mod_name = Module -> UniqDSet ModuleName
forall u. GenModule (GenUnit u) -> UniqDSet ModuleName
moduleFreeHoles Module
mod
        -- It wasn't actually a hole
        | Bool
otherwise                           = UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet

instance Binary ModIface where
   put_ :: BinHandle -> ModIface -> IO ()
put_ BinHandle
bh (ModIface {
                 mi_module :: forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module    = Module
mod,
                 mi_sig_of :: forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Module
mi_sig_of    = Maybe Module
sig_of,
                 mi_hsc_src :: forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src   = HscSource
hsc_src,
                 mi_deps :: forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps      = Dependencies
deps,
                 mi_usages :: forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages    = [Usage]
usages,
                 mi_exports :: forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceExport]
mi_exports   = [IfaceExport]
exports,
                 mi_used_th :: forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th   = Bool
used_th,
                 mi_fixities :: forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities  = [(OccName, Fixity)]
fixities,
                 mi_warns :: forall (phase :: ModIfacePhase). ModIface_ phase -> Warnings
mi_warns     = Warnings
warns,
                 mi_anns :: forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
mi_anns      = [IfaceAnnotation]
anns,
                 mi_decls :: forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls     = [IfaceDeclExts 'ModIfaceFinal]
decls,
                 mi_insts :: forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceClsInst]
mi_insts     = [IfaceClsInst]
insts,
                 mi_fam_insts :: forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceFamInst]
mi_fam_insts = [IfaceFamInst]
fam_insts,
                 mi_rules :: forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceRule]
mi_rules     = [IfaceRule]
rules,
                 mi_hpc :: forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_hpc       = Bool
hpc_info,
                 mi_trust :: forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust     = IfaceTrustInfo
trust,
                 mi_trust_pkg :: forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_trust_pkg = Bool
trust_pkg,
                 mi_complete_sigs :: forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceCompleteMatch]
mi_complete_sigs = [IfaceCompleteMatch]
complete_sigs,
                 mi_doc_hdr :: forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr   = Maybe HsDocString
doc_hdr,
                 mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap
decl_docs,
                 mi_arg_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs  = ArgDocMap
arg_docs,
                 mi_ext_fields :: forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields = ExtensibleFields
_ext_fields, -- Don't `put_` this in the instance so we
                                              -- can deal with it's pointer in the header
                                              -- when we write the actual file
                 mi_final_exts :: forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts = ModIfaceBackend {
                   mi_iface_hash :: ModIfaceBackend -> Fingerprint
mi_iface_hash = Fingerprint
iface_hash,
                   mi_mod_hash :: ModIfaceBackend -> Fingerprint
mi_mod_hash = Fingerprint
mod_hash,
                   mi_flag_hash :: ModIfaceBackend -> Fingerprint
mi_flag_hash = Fingerprint
flag_hash,
                   mi_opt_hash :: ModIfaceBackend -> Fingerprint
mi_opt_hash = Fingerprint
opt_hash,
                   mi_hpc_hash :: ModIfaceBackend -> Fingerprint
mi_hpc_hash = Fingerprint
hpc_hash,
                   mi_plugin_hash :: ModIfaceBackend -> Fingerprint
mi_plugin_hash = Fingerprint
plugin_hash,
                   mi_orphan :: ModIfaceBackend -> Bool
mi_orphan = Bool
orphan,
                   mi_finsts :: ModIfaceBackend -> Bool
mi_finsts = Bool
hasFamInsts,
                   mi_exp_hash :: ModIfaceBackend -> Fingerprint
mi_exp_hash = Fingerprint
exp_hash,
                   mi_orphan_hash :: ModIfaceBackend -> Fingerprint
mi_orphan_hash = Fingerprint
orphan_hash
                 }}) = do
        BinHandle -> Module -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Module
mod
        BinHandle -> Maybe Module -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Module
sig_of
        BinHandle -> HscSource -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh HscSource
hsc_src
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
iface_hash
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
mod_hash
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
flag_hash
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
opt_hash
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
hpc_hash
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
plugin_hash
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
orphan
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
hasFamInsts
        BinHandle -> Dependencies -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh Dependencies
deps
        BinHandle -> [Usage] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [Usage]
usages
        BinHandle -> [IfaceExport] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceExport]
exports
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
exp_hash
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
used_th
        BinHandle -> [(OccName, Fixity)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [(OccName, Fixity)]
fixities
        BinHandle -> Warnings -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh Warnings
warns
        BinHandle -> [IfaceAnnotation] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [IfaceAnnotation]
anns
        BinHandle -> [(Fingerprint, IfaceDecl)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [(Fingerprint, IfaceDecl)]
[IfaceDeclExts 'ModIfaceFinal]
decls
        BinHandle -> [IfaceClsInst] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceClsInst]
insts
        BinHandle -> [IfaceFamInst] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceFamInst]
fam_insts
        BinHandle -> [IfaceRule] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [IfaceRule]
rules
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
orphan_hash
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
hpc_info
        BinHandle -> IfaceTrustInfo -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceTrustInfo
trust
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
trust_pkg
        BinHandle -> [IfaceCompleteMatch] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceCompleteMatch]
complete_sigs
        BinHandle -> Maybe HsDocString -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh Maybe HsDocString
doc_hdr
        BinHandle -> DeclDocMap -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh DeclDocMap
decl_docs
        BinHandle -> ArgDocMap -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh ArgDocMap
arg_docs

   get :: BinHandle -> IO ModIface
get BinHandle
bh = do
        Module
mod         <- BinHandle -> IO Module
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Maybe Module
sig_of      <- BinHandle -> IO (Maybe Module)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        HscSource
hsc_src     <- BinHandle -> IO HscSource
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
iface_hash  <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
mod_hash    <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
flag_hash   <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
opt_hash    <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
hpc_hash    <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
plugin_hash <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
orphan      <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
hasFamInsts <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Dependencies
deps        <- BinHandle -> IO Dependencies
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        [Usage]
usages      <- {-# SCC "bin_usages" #-} BinHandle -> IO [Usage]
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        [IfaceExport]
exports     <- {-# SCC "bin_exports" #-} BinHandle -> IO [IfaceExport]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Fingerprint
exp_hash    <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
used_th     <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [(OccName, Fixity)]
fixities    <- {-# SCC "bin_fixities" #-} BinHandle -> IO [(OccName, Fixity)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Warnings
warns       <- {-# SCC "bin_warns" #-} BinHandle -> IO Warnings
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        [IfaceAnnotation]
anns        <- {-# SCC "bin_anns" #-} BinHandle -> IO [IfaceAnnotation]
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        [(Fingerprint, IfaceDecl)]
decls       <- {-# SCC "bin_tycldecls" #-} BinHandle -> IO [(Fingerprint, IfaceDecl)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [IfaceClsInst]
insts       <- {-# SCC "bin_insts" #-} BinHandle -> IO [IfaceClsInst]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [IfaceFamInst]
fam_insts   <- {-# SCC "bin_fam_insts" #-} BinHandle -> IO [IfaceFamInst]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [IfaceRule]
rules       <- {-# SCC "bin_rules" #-} BinHandle -> IO [IfaceRule]
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        Fingerprint
orphan_hash <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
hpc_info    <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        IfaceTrustInfo
trust       <- BinHandle -> IO IfaceTrustInfo
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
trust_pkg   <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [IfaceCompleteMatch]
complete_sigs <- BinHandle -> IO [IfaceCompleteMatch]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Maybe HsDocString
doc_hdr     <- BinHandle -> IO (Maybe HsDocString)
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        DeclDocMap
decl_docs   <- BinHandle -> IO DeclDocMap
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        ArgDocMap
arg_docs    <- BinHandle -> IO ArgDocMap
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
        ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface :: forall (phase :: ModIfacePhase).
Module
-> Maybe Module
-> HscSource
-> Dependencies
-> [Usage]
-> [IfaceExport]
-> Bool
-> [(OccName, Fixity)]
-> Warnings
-> [IfaceAnnotation]
-> [IfaceDeclExts phase]
-> Maybe GlobalRdrEnv
-> [IfaceClsInst]
-> [IfaceFamInst]
-> [IfaceRule]
-> Bool
-> IfaceTrustInfo
-> Bool
-> [IfaceCompleteMatch]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> IfaceBackendExts phase
-> ExtensibleFields
-> ModIface_ phase
ModIface {
                 mi_module :: Module
mi_module      = Module
mod,
                 mi_sig_of :: Maybe Module
mi_sig_of      = Maybe Module
sig_of,
                 mi_hsc_src :: HscSource
mi_hsc_src     = HscSource
hsc_src,
                 mi_deps :: Dependencies
mi_deps        = Dependencies
deps,
                 mi_usages :: [Usage]
mi_usages      = [Usage]
usages,
                 mi_exports :: [IfaceExport]
mi_exports     = [IfaceExport]
exports,
                 mi_used_th :: Bool
mi_used_th     = Bool
used_th,
                 mi_anns :: [IfaceAnnotation]
mi_anns        = [IfaceAnnotation]
anns,
                 mi_fixities :: [(OccName, Fixity)]
mi_fixities    = [(OccName, Fixity)]
fixities,
                 mi_warns :: Warnings
mi_warns       = Warnings
warns,
                 mi_decls :: [IfaceDeclExts 'ModIfaceFinal]
mi_decls       = [(Fingerprint, IfaceDecl)]
[IfaceDeclExts 'ModIfaceFinal]
decls,
                 mi_globals :: Maybe GlobalRdrEnv
mi_globals     = Maybe GlobalRdrEnv
forall a. Maybe a
Nothing,
                 mi_insts :: [IfaceClsInst]
mi_insts       = [IfaceClsInst]
insts,
                 mi_fam_insts :: [IfaceFamInst]
mi_fam_insts   = [IfaceFamInst]
fam_insts,
                 mi_rules :: [IfaceRule]
mi_rules       = [IfaceRule]
rules,
                 mi_hpc :: Bool
mi_hpc         = Bool
hpc_info,
                 mi_trust :: IfaceTrustInfo
mi_trust       = IfaceTrustInfo
trust,
                 mi_trust_pkg :: Bool
mi_trust_pkg   = Bool
trust_pkg,
                        -- And build the cached values
                 mi_complete_sigs :: [IfaceCompleteMatch]
mi_complete_sigs = [IfaceCompleteMatch]
complete_sigs,
                 mi_doc_hdr :: Maybe HsDocString
mi_doc_hdr     = Maybe HsDocString
doc_hdr,
                 mi_decl_docs :: DeclDocMap
mi_decl_docs   = DeclDocMap
decl_docs,
                 mi_arg_docs :: ArgDocMap
mi_arg_docs    = ArgDocMap
arg_docs,
                 mi_ext_fields :: ExtensibleFields
mi_ext_fields  = ExtensibleFields
emptyExtensibleFields, -- placeholder because this is dealt
                                                         -- with specially when the file is read
                 mi_final_exts :: IfaceBackendExts 'ModIfaceFinal
mi_final_exts = ModIfaceBackend :: Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Bool
-> Bool
-> Fingerprint
-> Fingerprint
-> (OccName -> Maybe WarningTxt)
-> (OccName -> Maybe Fixity)
-> (OccName -> Maybe (OccName, Fingerprint))
-> ModIfaceBackend
ModIfaceBackend {
                   mi_iface_hash :: Fingerprint
mi_iface_hash = Fingerprint
iface_hash,
                   mi_mod_hash :: Fingerprint
mi_mod_hash = Fingerprint
mod_hash,
                   mi_flag_hash :: Fingerprint
mi_flag_hash = Fingerprint
flag_hash,
                   mi_opt_hash :: Fingerprint
mi_opt_hash = Fingerprint
opt_hash,
                   mi_hpc_hash :: Fingerprint
mi_hpc_hash = Fingerprint
hpc_hash,
                   mi_plugin_hash :: Fingerprint
mi_plugin_hash = Fingerprint
plugin_hash,
                   mi_orphan :: Bool
mi_orphan = Bool
orphan,
                   mi_finsts :: Bool
mi_finsts = Bool
hasFamInsts,
                   mi_exp_hash :: Fingerprint
mi_exp_hash = Fingerprint
exp_hash,
                   mi_orphan_hash :: Fingerprint
mi_orphan_hash = Fingerprint
orphan_hash,
                   mi_warn_fn :: OccName -> Maybe WarningTxt
mi_warn_fn = Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache Warnings
warns,
                   mi_fix_fn :: OccName -> Maybe Fixity
mi_fix_fn = [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache [(OccName, Fixity)]
fixities,
                   mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn = [(Fingerprint, IfaceDecl)]
-> OccName -> Maybe (OccName, Fingerprint)
mkIfaceHashCache [(Fingerprint, IfaceDecl)]
decls
                 }})

-- | The original names declared of a certain module that are exported
type IfaceExport = AvailInfo

emptyPartialModIface :: Module -> PartialModIface
emptyPartialModIface :: Module -> PartialModIface
emptyPartialModIface Module
mod
  = ModIface :: forall (phase :: ModIfacePhase).
Module
-> Maybe Module
-> HscSource
-> Dependencies
-> [Usage]
-> [IfaceExport]
-> Bool
-> [(OccName, Fixity)]
-> Warnings
-> [IfaceAnnotation]
-> [IfaceDeclExts phase]
-> Maybe GlobalRdrEnv
-> [IfaceClsInst]
-> [IfaceFamInst]
-> [IfaceRule]
-> Bool
-> IfaceTrustInfo
-> Bool
-> [IfaceCompleteMatch]
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> IfaceBackendExts phase
-> ExtensibleFields
-> ModIface_ phase
ModIface { mi_module :: Module
mi_module      = Module
mod,
               mi_sig_of :: Maybe Module
mi_sig_of      = Maybe Module
forall a. Maybe a
Nothing,
               mi_hsc_src :: HscSource
mi_hsc_src     = HscSource
HsSrcFile,
               mi_deps :: Dependencies
mi_deps        = Dependencies
noDependencies,
               mi_usages :: [Usage]
mi_usages      = [],
               mi_exports :: [IfaceExport]
mi_exports     = [],
               mi_used_th :: Bool
mi_used_th     = Bool
False,
               mi_fixities :: [(OccName, Fixity)]
mi_fixities    = [],
               mi_warns :: Warnings
mi_warns       = Warnings
NoWarnings,
               mi_anns :: [IfaceAnnotation]
mi_anns        = [],
               mi_insts :: [IfaceClsInst]
mi_insts       = [],
               mi_fam_insts :: [IfaceFamInst]
mi_fam_insts   = [],
               mi_rules :: [IfaceRule]
mi_rules       = [],
               mi_decls :: [IfaceDeclExts 'ModIfaceCore]
mi_decls       = [],
               mi_globals :: Maybe GlobalRdrEnv
mi_globals     = Maybe GlobalRdrEnv
forall a. Maybe a
Nothing,
               mi_hpc :: Bool
mi_hpc         = Bool
False,
               mi_trust :: IfaceTrustInfo
mi_trust       = IfaceTrustInfo
noIfaceTrustInfo,
               mi_trust_pkg :: Bool
mi_trust_pkg   = Bool
False,
               mi_complete_sigs :: [IfaceCompleteMatch]
mi_complete_sigs = [],
               mi_doc_hdr :: Maybe HsDocString
mi_doc_hdr     = Maybe HsDocString
forall a. Maybe a
Nothing,
               mi_decl_docs :: DeclDocMap
mi_decl_docs   = DeclDocMap
emptyDeclDocMap,
               mi_arg_docs :: ArgDocMap
mi_arg_docs    = ArgDocMap
emptyArgDocMap,
               mi_final_exts :: IfaceBackendExts 'ModIfaceCore
mi_final_exts  = (),
               mi_ext_fields :: ExtensibleFields
mi_ext_fields  = ExtensibleFields
emptyExtensibleFields
             }

emptyFullModIface :: Module -> ModIface
emptyFullModIface :: Module -> ModIface
emptyFullModIface Module
mod =
    (Module -> PartialModIface
emptyPartialModIface Module
mod)
      { mi_decls :: [IfaceDeclExts 'ModIfaceFinal]
mi_decls = []
      , mi_final_exts :: IfaceBackendExts 'ModIfaceFinal
mi_final_exts = ModIfaceBackend :: Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Fingerprint
-> Bool
-> Bool
-> Fingerprint
-> Fingerprint
-> (OccName -> Maybe WarningTxt)
-> (OccName -> Maybe Fixity)
-> (OccName -> Maybe (OccName, Fingerprint))
-> ModIfaceBackend
ModIfaceBackend
        { mi_iface_hash :: Fingerprint
mi_iface_hash = Fingerprint
fingerprint0,
          mi_mod_hash :: Fingerprint
mi_mod_hash = Fingerprint
fingerprint0,
          mi_flag_hash :: Fingerprint
mi_flag_hash = Fingerprint
fingerprint0,
          mi_opt_hash :: Fingerprint
mi_opt_hash = Fingerprint
fingerprint0,
          mi_hpc_hash :: Fingerprint
mi_hpc_hash = Fingerprint
fingerprint0,
          mi_plugin_hash :: Fingerprint
mi_plugin_hash = Fingerprint
fingerprint0,
          mi_orphan :: Bool
mi_orphan = Bool
False,
          mi_finsts :: Bool
mi_finsts = Bool
False,
          mi_exp_hash :: Fingerprint
mi_exp_hash = Fingerprint
fingerprint0,
          mi_orphan_hash :: Fingerprint
mi_orphan_hash = Fingerprint
fingerprint0,
          mi_warn_fn :: OccName -> Maybe WarningTxt
mi_warn_fn = OccName -> Maybe WarningTxt
emptyIfaceWarnCache,
          mi_fix_fn :: OccName -> Maybe Fixity
mi_fix_fn = OccName -> Maybe Fixity
emptyIfaceFixCache,
          mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn = OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache } }

-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
                 -> (OccName -> Maybe (OccName, Fingerprint))
mkIfaceHashCache :: [(Fingerprint, IfaceDecl)]
-> OccName -> Maybe (OccName, Fingerprint)
mkIfaceHashCache [(Fingerprint, IfaceDecl)]
pairs
  = \OccName
occ -> OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
env OccName
occ
  where
    env :: OccEnv (OccName, Fingerprint)
env = (OccEnv (OccName, Fingerprint)
 -> (Fingerprint, IfaceDecl) -> OccEnv (OccName, Fingerprint))
-> OccEnv (OccName, Fingerprint)
-> [(Fingerprint, IfaceDecl)]
-> OccEnv (OccName, Fingerprint)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> OccEnv (OccName, Fingerprint)
add_decl OccEnv (OccName, Fingerprint)
forall a. OccEnv a
emptyOccEnv [(Fingerprint, IfaceDecl)]
pairs
    add_decl :: OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> OccEnv (OccName, Fingerprint)
add_decl OccEnv (OccName, Fingerprint)
env0 (Fingerprint
v,IfaceDecl
d) = (OccEnv (OccName, Fingerprint)
 -> (OccName, Fingerprint) -> OccEnv (OccName, Fingerprint))
-> OccEnv (OccName, Fingerprint)
-> [(OccName, Fingerprint)]
-> OccEnv (OccName, Fingerprint)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OccEnv (OccName, Fingerprint)
-> (OccName, Fingerprint) -> OccEnv (OccName, Fingerprint)
forall {b}.
OccEnv (OccName, b) -> (OccName, b) -> OccEnv (OccName, b)
add OccEnv (OccName, Fingerprint)
env0 (Fingerprint -> IfaceDecl -> [(OccName, Fingerprint)]
ifaceDeclFingerprints Fingerprint
v IfaceDecl
d)
      where
        add :: OccEnv (OccName, b) -> (OccName, b) -> OccEnv (OccName, b)
add OccEnv (OccName, b)
env0 (OccName
occ,b
hash) = OccEnv (OccName, b)
-> OccName -> (OccName, b) -> OccEnv (OccName, b)
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv (OccName, b)
env0 OccName
occ (OccName
occ,b
hash)

emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache OccName
_occ = Maybe (OccName, Fingerprint)
forall a. Maybe a
Nothing


-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
-- for home modules only. Information relating to packages will be loaded into
-- global environments in 'ExternalPackageState'.
data ModDetails
  = ModDetails {
        -- The next two fields are created by the typechecker
        ModDetails -> [IfaceExport]
md_exports   :: [AvailInfo],
        ModDetails -> TypeEnv
md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module
                                        -- Includes Ids, TyCons, PatSyns
        ModDetails -> [ClsInst]
md_insts     :: ![ClsInst],     -- ^ 'DFunId's for the instances in this module
        ModDetails -> [FamInst]
md_fam_insts :: ![FamInst],
        ModDetails -> [CoreRule]
md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
        ModDetails -> [Annotation]
md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
                                        -- they only annotate things also declared in this module
        ModDetails -> [CompleteMatch]
md_complete_sigs :: [CompleteMatch]
          -- ^ Complete match pragmas for this module
     }

-- | Constructs an empty ModDetails
emptyModDetails :: ModDetails
emptyModDetails :: ModDetails
emptyModDetails
  = ModDetails :: [IfaceExport]
-> TypeEnv
-> [ClsInst]
-> [FamInst]
-> [CoreRule]
-> [Annotation]
-> [CompleteMatch]
-> ModDetails
ModDetails { md_types :: TypeEnv
md_types     = TypeEnv
emptyTypeEnv,
                 md_exports :: [IfaceExport]
md_exports   = [],
                 md_insts :: [ClsInst]
md_insts     = [],
                 md_rules :: [CoreRule]
md_rules     = [],
                 md_fam_insts :: [FamInst]
md_fam_insts = [],
                 md_anns :: [Annotation]
md_anns      = [],
                 md_complete_sigs :: [CompleteMatch]
md_complete_sigs = [] }

-- | Records the modules directly imported by a module for extracting e.g.
-- usage information, and also to give better error message
type ImportedMods = ModuleEnv [ImportedBy]

-- | If a module was "imported" by the user, we associate it with
-- more detailed usage information 'ImportedModsVal'; a module
-- imported by the system only gets used for usage information.
data ImportedBy
    = ImportedByUser ImportedModsVal
    | ImportedBySystem

importedByUser :: [ImportedBy] -> [ImportedModsVal]
importedByUser :: [ImportedBy] -> [ImportedModsVal]
importedByUser (ImportedByUser ImportedModsVal
imv : [ImportedBy]
bys) = ImportedModsVal
imv ImportedModsVal -> [ImportedModsVal] -> [ImportedModsVal]
forall a. a -> [a] -> [a]
: [ImportedBy] -> [ImportedModsVal]
importedByUser [ImportedBy]
bys
importedByUser (ImportedBy
ImportedBySystem   : [ImportedBy]
bys) =       [ImportedBy] -> [ImportedModsVal]
importedByUser [ImportedBy]
bys
importedByUser [] = []

data ImportedModsVal
 = ImportedModsVal {
        ImportedModsVal -> ModuleName
imv_name :: ModuleName,          -- ^ The name the module is imported with
        ImportedModsVal -> SrcSpan
imv_span :: SrcSpan,             -- ^ the source span of the whole import
        ImportedModsVal -> Bool
imv_is_safe :: IsSafeImport,     -- ^ whether this is a safe import
        ImportedModsVal -> Bool
imv_is_hiding :: Bool,           -- ^ whether this is an "hiding" import
        ImportedModsVal -> GlobalRdrEnv
imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide
          -- NB. BangPattern here: otherwise this leaks. (#15111)
        ImportedModsVal -> Bool
imv_qualified :: Bool            -- ^ whether this is a qualified import
        }

-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now.  Once it is compiled, a 'ModIface' and
-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
  = ModGuts {
        ModGuts -> Module
mg_module    :: !Module,         -- ^ Module being compiled
        ModGuts -> HscSource
mg_hsc_src   :: HscSource,       -- ^ Whether it's an hs-boot module
        ModGuts -> SrcSpan
mg_loc       :: SrcSpan,         -- ^ For error messages from inner passes
        ModGuts -> [IfaceExport]
mg_exports   :: ![AvailInfo],    -- ^ What it exports
        ModGuts -> Dependencies
mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or
                                         -- otherwise
        ModGuts -> [Usage]
mg_usages    :: ![Usage],        -- ^ What was used?  Used for interfaces.

        ModGuts -> Bool
mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?
        ModGuts -> GlobalRdrEnv
mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment

        -- These fields all describe the things **declared in this module**
        ModGuts -> FixityEnv
mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module.
                                         -- Used for creating interface files.
        ModGuts -> [TyCon]
mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
                                         -- (includes TyCons for classes)
        ModGuts -> [ClsInst]
mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module
        ModGuts -> [FamInst]
mg_fam_insts :: ![FamInst],
                                         -- ^ Family instances declared in this module
        ModGuts -> [PatSyn]
mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module
        ModGuts -> [CoreRule]
mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains
                                         -- See Note [Overall plumbing for rules] in "GHC.Core.Rules"
        ModGuts -> CoreProgram
mg_binds     :: !CoreProgram,    -- ^ Bindings for this module
        ModGuts -> ForeignStubs
mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module
        ModGuts -> [(ForeignSrcLang, FieldName)]
mg_foreign_files :: ![(ForeignSrcLang, FilePath)],
        -- ^ Files to be compiled with the C compiler
        ModGuts -> Warnings
mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
        ModGuts -> [Annotation]
mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
        ModGuts -> [CompleteMatch]
mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
        ModGuts -> HpcInfo
mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module
        ModGuts -> Maybe ModBreaks
mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module

                        -- The next two fields are unusual, because they give instance
                        -- environments for *all* modules in the home package, including
                        -- this module, rather than for *just* this module.
                        -- Reason: when looking up an instance we don't want to have to
                        --         look at each module in the home package in turn
        ModGuts -> InstEnv
mg_inst_env     :: InstEnv,             -- ^ Class instance environment for
                                                -- /home-package/ modules (including this
                                                -- one); c.f. 'tcg_inst_env'
        ModGuts -> FamInstEnv
mg_fam_inst_env :: FamInstEnv,          -- ^ Type-family instance environment for
                                                -- /home-package/ modules (including this
                                                -- one); c.f. 'tcg_fam_inst_env'

        ModGuts -> SafeHaskellMode
mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode
        ModGuts -> Bool
mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our
                                                -- own package for Safe Haskell?
                                                -- See Note [Trust Own Package]
                                                -- in "GHC.Rename.Names"

        ModGuts -> Maybe HsDocString
mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.
        ModGuts -> DeclDocMap
mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.
        ModGuts -> ArgDocMap
mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.
    }

-- The ModGuts takes on several slightly different forms:
--
-- After simplification, the following fields change slightly:
--      mg_rules        Orphan rules only (local ones now attached to binds)
--      mg_binds        With rules attached

---------------------------------------------------------
-- The Tidy pass forks the information about this module:
--      * one lot goes to interface file generation (ModIface)
--        and later compilations (ModDetails)
--      * the other lot goes to code generation (CgGuts)

-- | A restricted form of 'ModGuts' for code generation purposes
data CgGuts
  = CgGuts {
        CgGuts -> Module
cg_module    :: !Module,
                -- ^ Module being compiled

        CgGuts -> [TyCon]
cg_tycons    :: [TyCon],
                -- ^ Algebraic data types (including ones that started
                -- life as classes); generate constructors and info
                -- tables. Includes newtypes, just for the benefit of
                -- External Core

        CgGuts -> CoreProgram
cg_binds     :: CoreProgram,
                -- ^ The tidied main bindings, including
                -- previously-implicit bindings for record and class
                -- selectors, and data constructor wrappers.  But *not*
                -- data constructor workers; reason: we regard them
                -- as part of the code-gen of tycons

        CgGuts -> ForeignStubs
cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs
        CgGuts -> [(ForeignSrcLang, FieldName)]
cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
        CgGuts -> [UnitId]
cg_dep_pkgs  :: ![UnitId], -- ^ Dependent packages, used to
                                            -- generate #includes for C code gen
        CgGuts -> HpcInfo
cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information
        CgGuts -> Maybe ModBreaks
cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
        CgGuts -> [SptEntry]
cg_spt_entries :: [SptEntry]
                -- ^ Static pointer table entries for static forms defined in
                -- the module.
                -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"
    }

-----------------------------------
-- | Foreign export stubs
data ForeignStubs
  = NoStubs
      -- ^ We don't have any stubs
  | ForeignStubs SDoc SDoc
      -- ^ There are some stubs. Parameters:
      --
      --  1) Header file prototypes for
      --     "foreign exported" functions
      --
      --  2) C stubs to use when calling
      --     "foreign exported" functions

appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
appendStubC ForeignStubs
NoStubs            SDoc
c_code = SDoc -> SDoc -> ForeignStubs
ForeignStubs SDoc
empty SDoc
c_code
appendStubC (ForeignStubs SDoc
h SDoc
c) SDoc
c_code = SDoc -> SDoc -> ForeignStubs
ForeignStubs SDoc
h (SDoc
c SDoc -> SDoc -> SDoc
$$ SDoc
c_code)

{-
************************************************************************
*                                                                      *
                The interactive context
*                                                                      *
************************************************************************

Note [The interactive package]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type, class, and value declarations at the command prompt are treated
as if they were defined in modules
   interactive:Ghci1
   interactive:Ghci2
   ...etc...
with each bunch of declarations using a new module, all sharing a
common package 'interactive' (see Module.interactiveUnitId, and
GHC.Builtin.Names.mkInteractiveModule).

This scheme deals well with shadowing.  For example:

   ghci> data T = A
   ghci> data T = B
   ghci> :i A
   data Ghci1.T = A  -- Defined at <interactive>:2:10

Here we must display info about constructor A, but its type T has been
shadowed by the second declaration.  But it has a respectable
qualified name (Ghci1.T), and its source location says where it was
defined.

So the main invariant continues to hold, that in any session an
original name M.T only refers to one unique thing.  (In a previous
iteration both the T's above were called :Interactive.T, albeit with
different uniques, which gave rise to all sorts of trouble.)

The details are a bit tricky though:

 * The field ic_mod_index counts which Ghci module we've got up to.
   It is incremented when extending ic_tythings

 * ic_tythings contains only things from the 'interactive' package.

 * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go
   in the Home Package Table (HPT).  When you say :load, that's when we
   extend the HPT.

 * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'.
   It stays as 'main' (or whatever -this-unit-id says), and is the
   package to which :load'ed modules are added to.

 * So how do we arrange that declarations at the command prompt get to
   be in the 'interactive' package?  Simply by setting the tcg_mod
   field of the TcGblEnv to "interactive:Ghci1".  This is done by the
   call to initTc in initTcInteractive, which in turn get the module
   from it 'icInteractiveModule' field of the interactive context.

   The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.

 * The main trickiness is that the type environment (tcg_type_env) and
   fixity envt (tcg_fix_env), now contain entities from all the
   interactive-package modules (Ghci1, Ghci2, ...) together, rather
   than just a single module as is usually the case.  So you can't use
   "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs
   the HPT/PTE.  This is a change, but not a problem provided you
   know.

* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields
  of the TcGblEnv, which collect "things defined in this module", all
  refer to stuff define in a single GHCi command, *not* all the commands
  so far.

  In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from
  all GhciN modules, which makes sense -- they are all "home package"
  modules.


Note [Interactively-bound Ids in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Ids bound by previous Stmts in GHCi are currently
        a) GlobalIds, with
        b) An External Name, like Ghci4.foo
           See Note [The interactive package] above
        c) A tidied type

 (a) They must be GlobalIds (not LocalIds) otherwise when we come to
     compile an expression using these ids later, the byte code
     generator will consider the occurrences to be free rather than
     global.

 (b) Having an External Name is important because of Note
     [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName

 (c) Their types are tidied. This is important, because :info may ask
     to look at them, and :info expects the things it looks up to have
     tidy types

Where do interactively-bound Ids come from?

  - GHCi REPL Stmts   e.g.
         ghci> let foo x = x+1
    These start with an Internal Name because a Stmt is a local
    construct, so the renamer naturally builds an Internal name for
    each of its binders.  Then in tcRnStmt they are externalised via
    GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo.

  - Ids bound by the debugger etc have Names constructed by
    GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by
    mkVanillaGlobal or mkVanillaGlobalWithInfo.  So again, they are
    all Global, External.

  - TyCons, Classes, and Ids bound by other top-level declarations in
    GHCi (eg foreign import, record selectors) also get External
    Names, with Ghci9 (or 8, or 7, etc) as the module name.


Note [ic_tythings]
~~~~~~~~~~~~~~~~~~
The ic_tythings field contains
  * The TyThings declared by the user at the command prompt
    (eg Ids, TyCons, Classes)

  * The user-visible Ids that arise from such things, which
    *don't* come from 'implicitTyThings', notably:
       - record selectors
       - class ops
    The implicitTyThings are readily obtained from the TyThings
    but record selectors etc are not

It does *not* contain
  * DFunIds (they can be gotten from ic_instances)
  * CoAxioms (ditto)

See also Note [Interactively-bound Ids in GHCi]

Note [Override identical instances in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you declare a new instance in GHCi that is identical to a previous one,
we simply override the previous one; we don't regard it as overlapping.
e.g.    Prelude> data T = A | B
        Prelude> instance Eq T where ...
        Prelude> instance Eq T where ...   -- This one overrides

It's exactly the same for type-family instances.  See #7102
-}

-- | Interactive context, recording information about the state of the
-- context in which statements are executed in a GHCi session.
data InteractiveContext
  = InteractiveContext {
         InteractiveContext -> DynFlags
ic_dflags     :: DynFlags,
             -- ^ The 'DynFlags' used to evaluate interactive expressions
             -- and statements.

         InteractiveContext -> Int
ic_mod_index :: Int,
             -- ^ Each GHCi stmt or declaration brings some new things into
             -- scope. We give them names like interactive:Ghci9.T,
             -- where the ic_index is the '9'.  The ic_mod_index is
             -- incremented whenever we add something to ic_tythings
             -- See Note [The interactive package]

         InteractiveContext -> [InteractiveImport]
ic_imports :: [InteractiveImport],
             -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with
             -- these imports
             --
             -- This field is only stored here so that the client
             -- can retrieve it with GHC.getContext. GHC itself doesn't
             -- use it, but does reset it to empty sometimes (such
             -- as before a GHC.load). The context is set with GHC.setContext.

         InteractiveContext -> [TyThing]
ic_tythings   :: [TyThing],
             -- ^ TyThings defined by the user, in reverse order of
             -- definition (ie most recent at the front)
             -- See Note [ic_tythings]

         InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env :: GlobalRdrEnv,
             -- ^ The cached 'GlobalRdrEnv', built by
             -- 'GHC.Runtime.Eval.setContext' and updated regularly
             -- It contains everything in scope at the command line,
             -- including everything in ic_tythings

         InteractiveContext -> ([ClsInst], [FamInst])
ic_instances  :: ([ClsInst], [FamInst]),
             -- ^ All instances and family instances created during
             -- this session.  These are grabbed en masse after each
             -- update to be sure that proper overlapping is retained.
             -- That is, rather than re-check the overlapping each
             -- time we update the context, we just take the results
             -- from the instance code that already does that.

         InteractiveContext -> FixityEnv
ic_fix_env :: FixityEnv,
            -- ^ Fixities declared in let statements

         InteractiveContext -> Maybe [Type]
ic_default :: Maybe [Type],
             -- ^ The current default types, set by a 'default' declaration

          InteractiveContext -> [Resume]
ic_resume :: [Resume],
             -- ^ The stack of breakpoint contexts

         InteractiveContext -> Name
ic_monad      :: Name,
             -- ^ The monad that GHCi is executing in

         InteractiveContext -> Name
ic_int_print  :: Name,
             -- ^ The function that is used for printing results
             -- of expressions in ghci and -e mode.

         InteractiveContext -> Maybe FieldName
ic_cwd :: Maybe FilePath
             -- virtual CWD of the program
    }

data InteractiveImport
  = IIDecl (ImportDecl GhcPs)
      -- ^ Bring the exports of a particular module
      -- (filtered by an import decl) into scope

  | IIModule ModuleName
      -- ^ Bring into scope the entire top-level envt of
      -- of this module, including the things imported
      -- into it.


-- | Constructs an empty InteractiveContext.
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
  = InteractiveContext :: DynFlags
-> Int
-> [InteractiveImport]
-> [TyThing]
-> GlobalRdrEnv
-> ([ClsInst], [FamInst])
-> FixityEnv
-> Maybe [Type]
-> [Resume]
-> Name
-> Name
-> Maybe FieldName
-> InteractiveContext
InteractiveContext {
       ic_dflags :: DynFlags
ic_dflags     = DynFlags
dflags,
       ic_imports :: [InteractiveImport]
ic_imports    = [],
       ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
emptyGlobalRdrEnv,
       ic_mod_index :: Int
ic_mod_index  = Int
1,
       ic_tythings :: [TyThing]
ic_tythings   = [],
       ic_instances :: ([ClsInst], [FamInst])
ic_instances  = ([],[]),
       ic_fix_env :: FixityEnv
ic_fix_env    = FixityEnv
forall a. NameEnv a
emptyNameEnv,
       ic_monad :: Name
ic_monad      = Name
ioTyConName,  -- IO monad by default
       ic_int_print :: Name
ic_int_print  = Name
printName,    -- System.IO.print by default
       ic_default :: Maybe [Type]
ic_default    = Maybe [Type]
forall a. Maybe a
Nothing,
       ic_resume :: [Resume]
ic_resume     = [],
       ic_cwd :: Maybe FieldName
ic_cwd        = Maybe FieldName
forall a. Maybe a
Nothing }

icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule (InteractiveContext { ic_mod_index :: InteractiveContext -> Int
ic_mod_index = Int
index })
  = Int -> Module
mkInteractiveModule Int
index

-- | This function returns the list of visible TyThings (useful for
-- e.g. showBindings)
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs = InteractiveContext -> [TyThing]
ic_tythings

-- | Get the PrintUnqualified function based on the flags and this InteractiveContext
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
icPrintUnqual DynFlags
dflags InteractiveContext{ ic_rn_gbl_env :: InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
grenv } =
    DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
grenv

-- | extendInteractiveContext is called with new TyThings recently defined to update the
-- InteractiveContext to include them.  Ids are easily removed when shadowed,
-- but Classes and TyCons are not.  Some work could be done to determine
-- whether they are entirely shadowed, but as you could still have references
-- to them (e.g. instances for classes or values of the type for TyCons), it's
-- not clear whether removing them is even the appropriate behavior.
extendInteractiveContext :: InteractiveContext
                         -> [TyThing]
                         -> [ClsInst] -> [FamInst]
                         -> Maybe [Type]
                         -> FixityEnv
                         -> InteractiveContext
extendInteractiveContext :: InteractiveContext
-> [TyThing]
-> [ClsInst]
-> [FamInst]
-> Maybe [Type]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
new_cls_insts [FamInst]
new_fam_insts Maybe [Type]
defaults FixityEnv
fix_env
  = InteractiveContext
ictxt { ic_mod_index :: Int
ic_mod_index  = InteractiveContext -> Int
ic_mod_index InteractiveContext
ictxt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                            -- Always bump this; even instances should create
                            -- a new mod_index (#9426)
          , ic_tythings :: [TyThing]
ic_tythings   = [TyThing]
new_tythings [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ [TyThing]
old_tythings
          , ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ictxt GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` [TyThing]
new_tythings
          , ic_instances :: ([ClsInst], [FamInst])
ic_instances  = ( [ClsInst]
new_cls_insts [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ [ClsInst]
old_cls_insts
                            , [FamInst]
new_fam_insts [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
fam_insts )
                            -- we don't shadow old family instances (#7102),
                            -- so don't need to remove them here
          , ic_default :: Maybe [Type]
ic_default    = Maybe [Type]
defaults
          , ic_fix_env :: FixityEnv
ic_fix_env    = FixityEnv
fix_env  -- See Note [Fixity declarations in GHCi]
          }
  where
    new_ids :: [Id]
new_ids = [Id
id | AnId Id
id <- [TyThing]
new_tythings]
    old_tythings :: [TyThing]
old_tythings = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id] -> TyThing -> Bool
shadowed_by [Id]
new_ids) (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)

    -- Discard old instances that have been fully overridden
    -- See Note [Override identical instances in GHCi]
    ([ClsInst]
cls_insts, [FamInst]
fam_insts) = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
ictxt
    old_cls_insts :: [ClsInst]
old_cls_insts = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (\ClsInst
i -> (ClsInst -> Bool) -> [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
i) [ClsInst]
new_cls_insts) [ClsInst]
cls_insts

extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
-- Just a specialised version
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt [Id]
new_ids
  | [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
new_ids = InteractiveContext
ictxt
  | Bool
otherwise    = InteractiveContext
ictxt { ic_mod_index :: Int
ic_mod_index  = InteractiveContext -> Int
ic_mod_index InteractiveContext
ictxt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                         , ic_tythings :: [TyThing]
ic_tythings   = [TyThing]
new_tythings [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ [TyThing]
old_tythings
                         , ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ictxt GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` [TyThing]
new_tythings }
  where
    new_tythings :: [TyThing]
new_tythings = (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
new_ids
    old_tythings :: [TyThing]
old_tythings = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id] -> TyThing -> Bool
shadowed_by [Id]
new_ids) (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)

shadowed_by :: [Id] -> TyThing -> Bool
shadowed_by :: [Id] -> TyThing -> Bool
shadowed_by [Id]
ids = TyThing -> Bool
shadowed
  where
    shadowed :: TyThing -> Bool
shadowed TyThing
id = TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyThing
id OccName -> OccSet -> Bool
`elemOccSet` OccSet
new_occs
    new_occs :: OccSet
new_occs = [OccName] -> OccSet
mkOccSet ((Id -> OccName) -> [Id] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName [Id]
ids)

-- | Set the 'DynFlags.homeUnitId' to 'interactive'
setInteractivePackage :: HscEnv -> HscEnv
setInteractivePackage :: HscEnv -> HscEnv
setInteractivePackage HscEnv
hsc_env
   = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                { homeUnitId :: UnitId
homeUnitId = UnitId
interactiveUnitId } }

setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName InteractiveContext
ic Name
n = InteractiveContext
ic{ic_int_print :: Name
ic_int_print = Name
n}

    -- ToDo: should not add Ids to the gbl env here

-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing
-- later ones, and shadowing existing entries in the GlobalRdrEnv.
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv GlobalRdrEnv
env [TyThing]
tythings
  = (TyThing -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyThing -> GlobalRdrEnv -> GlobalRdrEnv
add GlobalRdrEnv
env [TyThing]
tythings  -- Foldr makes things in the front of
                            -- the list shadow things at the back
  where
    -- One at a time, to ensure each shadows the previous ones
    add :: TyThing -> GlobalRdrEnv -> GlobalRdrEnv
add TyThing
thing GlobalRdrEnv
env
       | TyThing -> Bool
is_sub_bndr TyThing
thing
       = GlobalRdrEnv
env
       | Bool
otherwise
       = (GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrElt] -> GlobalRdrEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv GlobalRdrEnv
env1 ((IfaceExport -> [GlobalRdrElt]) -> [IfaceExport] -> [GlobalRdrElt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IfaceExport -> [GlobalRdrElt]
localGREsFromAvail [IfaceExport]
avail)
       where
          env1 :: GlobalRdrEnv
env1  = GlobalRdrEnv -> [Name] -> GlobalRdrEnv
shadowNames GlobalRdrEnv
env ((IfaceExport -> [Name]) -> [IfaceExport] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IfaceExport -> [Name]
availNames [IfaceExport]
avail)
          avail :: [IfaceExport]
avail = TyThing -> [IfaceExport]
tyThingAvailInfo TyThing
thing

    -- Ugh! The new_tythings may include record selectors, since they
    -- are not implicit-ids, and must appear in the TypeEnv.  But they
    -- will also be brought into scope by the corresponding (ATyCon
    -- tc).  And we want the latter, because that has the correct
    -- parent (#10520)
    is_sub_bndr :: TyThing -> Bool
is_sub_bndr (AnId Id
f) = case Id -> IdDetails
idDetails Id
f of
                             RecSelId {}  -> Bool
True
                             ClassOpId {} -> Bool
True
                             IdDetails
_            -> Bool
False
    is_sub_bndr TyThing
_ = Bool
False

substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext ictxt :: InteractiveContext
ictxt@InteractiveContext{ ic_tythings :: InteractiveContext -> [TyThing]
ic_tythings = [TyThing]
tts } TCvSubst
subst
  | TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst = InteractiveContext
ictxt
  | Bool
otherwise             = InteractiveContext
ictxt { ic_tythings :: [TyThing]
ic_tythings = (TyThing -> TyThing) -> [TyThing] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> TyThing
subst_ty [TyThing]
tts }
  where
    subst_ty :: TyThing -> TyThing
subst_ty (AnId Id
id)
      = Id -> TyThing
AnId (Id -> TyThing) -> Id -> TyThing
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Id -> Id
updateIdTypeAndMult (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
subst) Id
id
      -- Variables in the interactive context *can* mention free type variables
      -- because of the runtime debugger. Otherwise you'd expect all
      -- variables bound in the interactive context to be closed.
    subst_ty TyThing
tt
      = TyThing
tt

instance Outputable InteractiveImport where
  ppr :: InteractiveImport -> SDoc
ppr (IIModule ModuleName
m) = Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m
  ppr (IIDecl ImportDecl GhcPs
d)   = ImportDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ImportDecl GhcPs
d

{-
************************************************************************
*                                                                      *
        Building a PrintUnqualified
*                                                                      *
************************************************************************

Note [Printing original names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deciding how to print names is pretty tricky.  We are given a name
P:M.T, where P is the package name, M is the defining module, and T is
the occurrence name, and we have to decide in which form to display
the name given a GlobalRdrEnv describing the current scope.

Ideally we want to display the name in the form in which it is in
scope.  However, the name might not be in scope at all, and that's
where it gets tricky.  Here are the cases:

 1. T uniquely maps to  P:M.T      --->  "T"      NameUnqual
 2. There is an X for which X.T
       uniquely maps to  P:M.T     --->  "X.T"    NameQual X
 3. There is no binding for "M.T"  --->  "M.T"    NameNotInScope1
 4. Otherwise                      --->  "P:M.T"  NameNotInScope2

(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at
all. In these cases we still want to refer to the name as "M.T", *but*
"M.T" might mean something else in the current scope (e.g. if there's
an "import X as M"), so to avoid confusion we avoid using "M.T" if
there's already a binding for it.  Instead we write P:M.T.

There's one further subtlety: in case (3), what if there are two
things around, P1:M.T and P2:M.T?  Then we don't want to print both of
them as M.T!  However only one of the modules P1:M and P2:M can be
exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix

Note [Printing unit ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the old days, original names were tied to PackageIds, which directly
corresponded to the entities that users wrote in Cabal files, and were perfectly
suitable for printing when we need to disambiguate packages.  However, with
instantiated units, the situation can be different: if the key is instantiated
with some holes, we should try to give the user some more useful information.
-}

-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
env = QueryQualifyName
-> (Module -> Bool) -> QueryQualifyPackage -> PrintUnqualified
QueryQualify QueryQualifyName
qual_name
                                             (DynFlags -> Module -> Bool
mkQualModule DynFlags
dflags)
                                             (UnitState -> QueryQualifyPackage
mkQualPackage UnitState
pkgs)
  where
  pkgs :: UnitState
pkgs = DynFlags -> UnitState
unitState DynFlags
dflags
  qual_name :: QueryQualifyName
qual_name Module
mod OccName
occ
        | [GlobalRdrElt
gre] <- [GlobalRdrElt]
unqual_gres
        , GlobalRdrElt -> Bool
right_name GlobalRdrElt
gre
        = QualifyName
NameUnqual   -- If there's a unique entity that's in scope
                       -- unqualified with 'occ' AND that entity is
                       -- the right one, then we can use the unqualified name

        | [] <- [GlobalRdrElt]
unqual_gres
        , (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
is_name [Name]
forceUnqualNames
        , Bool -> Bool
not (OccName -> Bool
isDerivedOccName OccName
occ)
        = QualifyName
NameUnqual   -- Don't qualify names that come from modules
                       -- that come with GHC, often appear in error messages,
                       -- but aren't typically in scope. Doing this does not
                       -- cause ambiguity, and it reduces the amount of
                       -- qualification in error messages thus improving
                       -- readability.
                       --
                       -- A motivating example is 'Constraint'. It's often not
                       -- in scope, but printing GHC.Prim.Constraint seems
                       -- overkill.

        | [GlobalRdrElt
gre] <- [GlobalRdrElt]
qual_gres
        = ModuleName -> QualifyName
NameQual (GlobalRdrElt -> ModuleName
greQualModName GlobalRdrElt
gre)

        | [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrElt]
qual_gres
        = if [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (ModuleName -> OccName -> RdrName
mkRdrQual (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) OccName
occ) GlobalRdrEnv
env)
          then QualifyName
NameNotInScope1
          else QualifyName
NameNotInScope2

        | Bool
otherwise
        = QualifyName
NameNotInScope1   -- Can happen if 'f' is bound twice in the module
                            -- Eg  f = True; g = 0; f = False
      where
        is_name :: Name -> Bool
        is_name :: Name -> Bool
is_name Name
name = ASSERT2( isExternalName name, ppr name )
                       HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
mod Bool -> Bool -> Bool
&& Name -> OccName
nameOccName Name
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ

        forceUnqualNames :: [Name]
        forceUnqualNames :: [Name]
forceUnqualNames =
          (TyCon -> Name) -> [TyCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
tyConName [ TyCon
constraintKindTyCon, TyCon
heqTyCon, TyCon
coercibleTyCon ]
          [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [ Name
eqTyConName ]

        right_name :: GlobalRdrElt -> Bool
right_name GlobalRdrElt
gre = Name -> Maybe Module
nameModule_maybe (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> Maybe Module
forall a. a -> Maybe a
Just Module
mod

        unqual_gres :: [GlobalRdrElt]
unqual_gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) GlobalRdrEnv
env
        qual_gres :: [GlobalRdrElt]
qual_gres   = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
right_name (GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
env OccName
occ)

    -- we can mention a module P:M without the P: qualifier iff
    -- "import M" would resolve unambiguously to P:M.  (if P is the
    -- current package we can just assume it is unqualified).

-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
mkQualModule :: DynFlags -> QueryQualifyModule
mkQualModule :: DynFlags -> Module -> Bool
mkQualModule DynFlags
dflags Module
mod
     | DynFlags -> Module -> Bool
isHomeModule DynFlags
dflags Module
mod = Bool
False

     | [(Module
_, UnitInfo
pkgconfig)] <- [(Module, UnitInfo)]
lookup,
       UnitInfo -> Unit
mkUnit UnitInfo
pkgconfig Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
        -- this says: we are given a module P:M, is there just one exposed package
        -- that exposes a module M, and is it package P?
     = Bool
False

     | Bool
otherwise = Bool
True
     where lookup :: [(Module, UnitInfo)]
lookup = UnitState -> ModuleName -> [(Module, UnitInfo)]
lookupModuleInAllUnits (DynFlags -> UnitState
unitState DynFlags
dflags) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
-- with a unit id if the package ID would be ambiguous.
mkQualPackage :: UnitState -> QueryQualifyPackage
mkQualPackage :: UnitState -> QueryQualifyPackage
mkQualPackage UnitState
pkgs Unit
uid
     | Unit
uid Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit Bool -> Bool -> Bool
|| Unit
uid Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Unit
interactiveUnit
        -- Skip the lookup if it's main, since it won't be in the package
        -- database!
     = Bool
False
     | Just PackageId
pkgid <- Maybe PackageId
mb_pkgid
     , UnitState -> PackageId -> [UnitInfo]
searchPackageId UnitState
pkgs PackageId
pkgid [UnitInfo] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1
        -- this says: we are given a package pkg-0.1@MMM, are there only one
        -- exposed packages whose package ID is pkg-0.1?
     = Bool
False
     | Bool
otherwise
     = Bool
True
     where mb_pkgid :: Maybe PackageId
mb_pkgid = (UnitInfo -> PackageId) -> Maybe UnitInfo -> Maybe PackageId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> PackageId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
unitPackageId (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs Unit
uid)

-- | A function which only qualifies package names if necessary; but
-- qualifies all other identifiers.
pkgQual :: UnitState -> PrintUnqualified
pkgQual :: UnitState -> PrintUnqualified
pkgQual UnitState
pkgs = PrintUnqualified
alwaysQualify { queryQualifyPackage :: QueryQualifyPackage
queryQualifyPackage = UnitState -> QueryQualifyPackage
mkQualPackage UnitState
pkgs }

{-
************************************************************************
*                                                                      *
                Implicit TyThings
*                                                                      *
************************************************************************

Note [Implicit TyThings]
~~~~~~~~~~~~~~~~~~~~~~~~
  DEFINITION: An "implicit" TyThing is one that does not have its own
  IfaceDecl in an interface file.  Instead, its binding in the type
  environment is created as part of typechecking the IfaceDecl for
  some other thing.

Examples:
  * All DataCons are implicit, because they are generated from the
    IfaceDecl for the data/newtype.  Ditto class methods.

  * Record selectors are *not* implicit, because they get their own
    free-standing IfaceDecl.

  * Associated data/type families are implicit because they are
    included in the IfaceDecl of the parent class.  (NB: the
    IfaceClass decl happens to use IfaceDecl recursively for the
    associated types, but that's irrelevant here.)

  * Dictionary function Ids are not implicit.

  * Axioms for newtypes are implicit (same as above), but axioms
    for data/type family instances are *not* implicit (like DFunIds).
-}

-- | Determine the 'TyThing's brought into scope by another 'TyThing'
-- /other/ than itself. For example, Id's don't have any implicit TyThings
-- as they just bring themselves into scope, but classes bring their
-- dictionary datatype, type constructor and some selector functions into
-- scope, just for a start!

-- N.B. the set of TyThings returned here *must* match the set of
-- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in 'GHC.Iface.Load.loadDecl' (see note [Tricky iface loop])
-- The order of the list does not matter.
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId Id
_)       = []
implicitTyThings (ACoAxiom CoAxiom Branched
_cc) = []
implicitTyThings (ATyCon TyCon
tc)    = TyCon -> [TyThing]
implicitTyConThings TyCon
tc
implicitTyThings (AConLike ConLike
cl)  = ConLike -> [TyThing]
implicitConLikeThings ConLike
cl

implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings (RealDataCon DataCon
dc)
  = DataCon -> [TyThing]
dataConImplicitTyThings DataCon
dc

implicitConLikeThings (PatSynCon {})
  = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher
        -- are not "implicit"; they are simply new top-level bindings,
        -- and they have their own declaration in an interface file
        -- Unless a record pat syn when there are implicit selectors
        -- They are still not included here as `implicitConLikeThings` is
        -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked
        -- by `tcTopValBinds`.

implicitClassThings :: Class -> [TyThing]
implicitClassThings :: Class -> [TyThing]
implicitClassThings Class
cl
  = -- Does not include default methods, because those Ids may have
    --    their own pragmas, unfoldings etc, not derived from the Class object

    -- associated types
    --    No recursive call for the classATs, because they
    --    are only the family decls; they have no implicit things
    (TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon (Class -> [TyCon]
classATs Class
cl) [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++

    -- superclass and operation selectors
    (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId (Class -> [Id]
classAllSelIds Class
cl)

implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings TyCon
tc
  = [TyThing]
class_stuff [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++
      -- fields (names of selectors)

      -- (possibly) implicit newtype axioms
      -- or type family axioms
    TyCon -> [TyThing]
implicitCoTyCon TyCon
tc [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++

      -- for each data constructor in order,
      --   the constructor, worker, and (possibly) wrapper
    [ TyThing
thing | DataCon
dc    <- TyCon -> [DataCon]
tyConDataCons TyCon
tc
            , TyThing
thing <- ConLike -> TyThing
AConLike (DataCon -> ConLike
RealDataCon DataCon
dc) TyThing -> [TyThing] -> [TyThing]
forall a. a -> [a] -> [a]
: DataCon -> [TyThing]
dataConImplicitTyThings DataCon
dc ]
      -- NB. record selectors are *not* implicit, they have fully-fledged
      -- bindings that pass through the compilation pipeline as normal.
  where
    class_stuff :: [TyThing]
class_stuff = case TyCon -> Maybe Class
tyConClass_maybe TyCon
tc of
        Maybe Class
Nothing -> []
        Just Class
cl -> Class -> [TyThing]
implicitClassThings Class
cl

-- For newtypes and closed type families (only) add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon TyCon
tc
  | Just CoAxiom Unbranched
co <- TyCon -> Maybe (CoAxiom Unbranched)
newTyConCo_maybe TyCon
tc = [CoAxiom Branched -> TyThing
ACoAxiom (CoAxiom Branched -> TyThing) -> CoAxiom Branched -> TyThing
forall a b. (a -> b) -> a -> b
$ CoAxiom Unbranched -> CoAxiom Branched
forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom CoAxiom Unbranched
co]
  | Just CoAxiom Branched
co <- TyCon -> Maybe (CoAxiom Branched)
isClosedSynFamilyTyConWithAxiom_maybe TyCon
tc
                                   = [CoAxiom Branched -> TyThing
ACoAxiom CoAxiom Branched
co]
  | Bool
otherwise                      = []

-- | Returns @True@ if there should be no interface-file declaration
-- for this thing on its own: either it is built-in, or it is part
-- of some other declaration, or it is generated implicitly by some
-- other declaration.
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing (AConLike ConLike
cl) = case ConLike
cl of
                                    RealDataCon {} -> Bool
True
                                    PatSynCon {}   -> Bool
False
isImplicitTyThing (AnId Id
id)     = Id -> Bool
isImplicitId Id
id
isImplicitTyThing (ATyCon TyCon
tc)   = TyCon -> Bool
isImplicitTyCon TyCon
tc
isImplicitTyThing (ACoAxiom CoAxiom Branched
ax) = CoAxiom Branched -> Bool
forall (br :: BranchFlag). CoAxiom br -> Bool
isImplicitCoAxiom CoAxiom Branched
ax

-- | tyThingParent_maybe x returns (Just p)
-- when pprTyThingInContext should print a declaration for p
-- (albeit with some "..." in it) when asked to show x
-- It returns the *immediate* parent.  So a datacon returns its tycon
-- but the tycon could be the associated type of a class, so it in turn
-- might have a parent.
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe (AConLike ConLike
cl) = case ConLike
cl of
    RealDataCon DataCon
dc  -> TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon (DataCon -> TyCon
dataConTyCon DataCon
dc))
    PatSynCon{}     -> Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe (ATyCon TyCon
tc)   = case TyCon -> Maybe TyCon
tyConAssoc_maybe TyCon
tc of
                                      Just TyCon
tc -> TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon TyCon
tc)
                                      Maybe TyCon
Nothing -> Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe (AnId Id
id)     = case Id -> IdDetails
idDetails Id
id of
                                      RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelData TyCon
tc } ->
                                          TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon TyCon
tc)
                                      ClassOpId Class
cls               ->
                                          TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon (Class -> TyCon
classTyCon Class
cls))
                                      IdDetails
_other                      -> Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe TyThing
_other = Maybe TyThing
forall a. Maybe a
Nothing

tyThingsTyCoVars :: [TyThing] -> TyCoVarSet
tyThingsTyCoVars :: [TyThing] -> TyCoVarSet
tyThingsTyCoVars [TyThing]
tts =
    [TyCoVarSet] -> TyCoVarSet
unionVarSets ([TyCoVarSet] -> TyCoVarSet) -> [TyCoVarSet] -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ (TyThing -> TyCoVarSet) -> [TyThing] -> [TyCoVarSet]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> TyCoVarSet
ttToVarSet [TyThing]
tts
    where
        ttToVarSet :: TyThing -> TyCoVarSet
ttToVarSet (AnId Id
id)     = Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
id
        ttToVarSet (AConLike ConLike
cl) = case ConLike
cl of
            RealDataCon DataCon
dc  -> Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ DataCon -> Type
dataConRepType DataCon
dc
            PatSynCon{}     -> TyCoVarSet
emptyVarSet
        ttToVarSet (ATyCon TyCon
tc)
          = case TyCon -> Maybe Class
tyConClass_maybe TyCon
tc of
              Just Class
cls -> ([Id] -> TyCoVarSet
mkVarSet ([Id] -> TyCoVarSet) -> (Class -> [Id]) -> Class -> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], [FunDep Id]) -> [Id]
forall a b. (a, b) -> a
fst (([Id], [FunDep Id]) -> [Id])
-> (Class -> ([Id], [FunDep Id])) -> Class -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> ([Id], [FunDep Id])
classTvsFds) Class
cls
              Maybe Class
Nothing  -> Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc
        ttToVarSet (ACoAxiom CoAxiom Branched
_)  = TyCoVarSet
emptyVarSet

-- | The Names that a TyThing should bring into scope.  Used to build
-- the GlobalRdrEnv for the InteractiveContext.
tyThingAvailInfo :: TyThing -> [AvailInfo]
tyThingAvailInfo :: TyThing -> [IfaceExport]
tyThingAvailInfo (ATyCon TyCon
t)
   = case TyCon -> Maybe Class
tyConClass_maybe TyCon
t of
        Just Class
c  -> [Name -> [Name] -> [FieldLabel] -> IfaceExport
AvailTC Name
n (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
forall a. NamedThing a => a -> Name
getName (Class -> [Id]
classMethods Class
c)
                                 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (TyCon -> Name) -> [TyCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Class -> [TyCon]
classATs Class
c))
                             [] ]
             where n :: Name
n = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
c
        Maybe Class
Nothing -> [Name -> [Name] -> [FieldLabel] -> IfaceExport
AvailTC Name
n (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Name
forall a. NamedThing a => a -> Name
getName [DataCon]
dcs) [FieldLabel]
flds]
             where n :: Name
n    = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
t
                   dcs :: [DataCon]
dcs  = TyCon -> [DataCon]
tyConDataCons TyCon
t
                   flds :: [FieldLabel]
flds = TyCon -> [FieldLabel]
tyConFieldLabels TyCon
t
tyThingAvailInfo (AConLike (PatSynCon PatSyn
p))
  = (Name -> IfaceExport) -> [Name] -> [IfaceExport]
forall a b. (a -> b) -> [a] -> [b]
map Name -> IfaceExport
avail ((PatSyn -> Name
forall a. NamedThing a => a -> Name
getName PatSyn
p) Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
p))
tyThingAvailInfo TyThing
t
   = [Name -> IfaceExport
avail (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
t)]

{-
************************************************************************
*                                                                      *
                TypeEnv
*                                                                      *
************************************************************************
-}

-- | A map from 'Name's to 'TyThing's, constructed by typechecking
-- local declarations or interface files
type TypeEnv = NameEnv TyThing

emptyTypeEnv    :: TypeEnv
typeEnvElts     :: TypeEnv -> [TyThing]
typeEnvTyCons   :: TypeEnv -> [TyCon]
typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]
typeEnvIds      :: TypeEnv -> [Id]
typeEnvPatSyns  :: TypeEnv -> [PatSyn]
typeEnvDataCons :: TypeEnv -> [DataCon]
typeEnvClasses  :: TypeEnv -> [Class]
lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing

emptyTypeEnv :: TypeEnv
emptyTypeEnv        = TypeEnv
forall a. NameEnv a
emptyNameEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvElts     TypeEnv
env = TypeEnv -> [TyThing]
forall a. NameEnv a -> [a]
nameEnvElts TypeEnv
env
typeEnvTyCons :: TypeEnv -> [TyCon]
typeEnvTyCons   TypeEnv
env = [TyCon
tc | ATyCon TyCon
tc   <- TypeEnv -> [TyThing]
typeEnvElts TypeEnv
env]
typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]
typeEnvCoAxioms TypeEnv
env = [CoAxiom Branched
ax | ACoAxiom CoAxiom Branched
ax <- TypeEnv -> [TyThing]
typeEnvElts TypeEnv
env]
typeEnvIds :: TypeEnv -> [Id]
typeEnvIds      TypeEnv
env = [Id
id | AnId Id
id     <- TypeEnv -> [TyThing]
typeEnvElts TypeEnv
env]
typeEnvPatSyns :: TypeEnv -> [PatSyn]
typeEnvPatSyns  TypeEnv
env = [PatSyn
ps | AConLike (PatSynCon PatSyn
ps) <- TypeEnv -> [TyThing]
typeEnvElts TypeEnv
env]
typeEnvDataCons :: TypeEnv -> [DataCon]
typeEnvDataCons TypeEnv
env = [DataCon
dc | AConLike (RealDataCon DataCon
dc) <- TypeEnv -> [TyThing]
typeEnvElts TypeEnv
env]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvClasses  TypeEnv
env = [Class
cl | TyCon
tc <- TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
env,
                            Just Class
cl <- [TyCon -> Maybe Class
tyConClass_maybe TyCon
tc]]

mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv [TyThing]
things = TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList TypeEnv
emptyTypeEnv [TyThing]
things

mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv
mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv
mkTypeEnvWithImplicits [TyThing]
things =
  [TyThing] -> TypeEnv
mkTypeEnv [TyThing]
things
    TypeEnv -> TypeEnv -> TypeEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
  [TyThing] -> TypeEnv
mkTypeEnv ((TyThing -> [TyThing]) -> [TyThing] -> [TyThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyThing -> [TyThing]
implicitTyThings [TyThing]
things)

typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
ids [TyCon]
tcs [FamInst]
famInsts =
  [TyThing] -> TypeEnv
mkTypeEnv (   (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
ids
             [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
all_tcs
             [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (TyCon -> [TyThing]) -> [TyCon] -> [TyThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [TyThing]
implicitTyConThings [TyCon]
all_tcs
             [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (FamInst -> TyThing) -> [FamInst] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (CoAxiom Branched -> TyThing
ACoAxiom (CoAxiom Branched -> TyThing)
-> (FamInst -> CoAxiom Branched) -> FamInst -> TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoAxiom Unbranched -> CoAxiom Branched
forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom (CoAxiom Unbranched -> CoAxiom Branched)
-> (FamInst -> CoAxiom Unbranched) -> FamInst -> CoAxiom Branched
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> CoAxiom Unbranched
famInstAxiom) [FamInst]
famInsts
            )
 where
  all_tcs :: [TyCon]
all_tcs = [TyCon]
tcs [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [FamInst] -> [TyCon]
famInstsRepTyCons [FamInst]
famInsts

lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv = TypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv

-- Extend the type environment
extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
extendTypeEnv TypeEnv
env TyThing
thing = TypeEnv -> Name -> TyThing -> TypeEnv
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv TypeEnv
env (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing) TyThing
thing

extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList TypeEnv
env [TyThing]
things = (TypeEnv -> TyThing -> TypeEnv) -> TypeEnv -> [TyThing] -> TypeEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeEnv -> TyThing -> TypeEnv
extendTypeEnv TypeEnv
env [TyThing]
things

extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds TypeEnv
env [Id]
ids
  = TypeEnv -> [(Name, TyThing)] -> TypeEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList TypeEnv
env [(Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id, Id -> TyThing
AnId Id
id) | Id
id <- [Id]
ids]

plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv TypeEnv
env1 TypeEnv
env2 = TypeEnv -> TypeEnv -> TypeEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv TypeEnv
env1 TypeEnv
env2

-- | Find the 'TyThing' for the given 'Name' by using all the resources
-- at our disposal: the compiled modules in the 'HomePackageTable' and the
-- compiled modules in other packages that live in 'PackageTypeEnv'. Note
-- that this does NOT look up the 'TyThing' in the module being compiled: you
-- have to do that yourself, if desired
lookupType :: DynFlags
           -> HomePackageTable
           -> PackageTypeEnv
           -> Name
           -> Maybe TyThing

lookupType :: DynFlags -> HomePackageTable -> TypeEnv -> Name -> Maybe TyThing
lookupType DynFlags
dflags HomePackageTable
hpt TypeEnv
pte Name
name
  | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode DynFlags
dflags)  -- in one-shot, we don't use the HPT
  = TypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TypeEnv
pte Name
name
  | Bool
otherwise
  = case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
       Just HomeModInfo
hm -> TypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (ModDetails -> TypeEnv
md_types (HomeModInfo -> ModDetails
hm_details HomeModInfo
hm)) Name
name
       Maybe HomeModInfo
Nothing -> TypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TypeEnv
pte Name
name
  where
    mod :: Module
mod = ASSERT2( isExternalName name, ppr name )
          if Name -> Bool
isHoleName Name
name
            then DynFlags -> ModuleName -> Module
mkHomeModule DynFlags
dflags (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name))
            else HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name

-- | As 'lookupType', but with a marginally easier-to-use interface
-- if you have a 'HscEnv'
lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv HscEnv
hsc_env Name
name = do
    ExternalPackageState
eps <- IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
    Maybe TyThing -> IO (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> IO (Maybe TyThing))
-> Maybe TyThing -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! DynFlags -> HomePackageTable -> TypeEnv -> Name -> Maybe TyThing
lookupType DynFlags
dflags HomePackageTable
hpt (ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps) Name
name
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env

-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise
tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon
tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon
tyThingTyCon (ATyCon TyCon
tc) = TyCon
tc
tyThingTyCon TyThing
other       = FieldName -> SDoc -> TyCon
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"tyThingTyCon" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched
tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched
tyThingCoAxiom (ACoAxiom CoAxiom Branched
ax) = CoAxiom Branched
ax
tyThingCoAxiom TyThing
other         = FieldName -> SDoc -> CoAxiom Branched
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"tyThingCoAxiom" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise
tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon
tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon
tyThingDataCon (AConLike (RealDataCon DataCon
dc)) = DataCon
dc
tyThingDataCon TyThing
other                       = FieldName -> SDoc -> DataCon
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"tyThingDataCon" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.
-- Panics otherwise
tyThingConLike :: HasDebugCallStack => TyThing -> ConLike
tyThingConLike :: HasDebugCallStack => TyThing -> ConLike
tyThingConLike (AConLike ConLike
dc) = ConLike
dc
tyThingConLike TyThing
other         = FieldName -> SDoc -> ConLike
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"tyThingConLike" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise
tyThingId :: HasDebugCallStack => TyThing -> Id
tyThingId :: HasDebugCallStack => TyThing -> Id
tyThingId (AnId Id
id)                   = Id
id
tyThingId (AConLike (RealDataCon DataCon
dc)) = DataCon -> Id
dataConWrapId DataCon
dc
tyThingId TyThing
other                       = FieldName -> SDoc -> Id
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"tyThingId" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

{-
************************************************************************
*                                                                      *
\subsection{MonadThings and friends}
*                                                                      *
************************************************************************
-}

-- | Class that abstracts out the common ability of the monads in GHC
-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides
-- a number of related convenience functions for accessing particular
-- kinds of 'TyThing'
class Monad m => MonadThings m where
        lookupThing :: Name -> m TyThing

        lookupId :: Name -> m Id
        lookupId = (TyThing -> Id) -> m TyThing -> m Id
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> Id
TyThing -> Id
tyThingId (m TyThing -> m Id) -> (Name -> m TyThing) -> Name -> m Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing

        lookupDataCon :: Name -> m DataCon
        lookupDataCon = (TyThing -> DataCon) -> m TyThing -> m DataCon
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (m TyThing -> m DataCon)
-> (Name -> m TyThing) -> Name -> m DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing

        lookupTyCon :: Name -> m TyCon
        lookupTyCon = (TyThing -> TyCon) -> m TyThing -> m TyCon
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> TyCon
TyThing -> TyCon
tyThingTyCon (m TyThing -> m TyCon) -> (Name -> m TyThing) -> Name -> m TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing

-- Instance used in GHC.HsToCore.Quote
instance MonadThings m => MonadThings (ReaderT s m) where
  lookupThing :: Name -> ReaderT s m TyThing
lookupThing = m TyThing -> ReaderT s m TyThing
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m TyThing -> ReaderT s m TyThing)
-> (Name -> m TyThing) -> Name -> ReaderT s m TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing

{-
************************************************************************
*                                                                      *
\subsection{Auxiliary types}
*                                                                      *
************************************************************************

These types are defined here because they are mentioned in ModDetails,
but they are mostly elaborated elsewhere
-}

------------------ Warnings -------------------------
-- | Warning information for a module
data Warnings
  = NoWarnings                          -- ^ Nothing deprecated
  | WarnAll WarningTxt                  -- ^ Whole module deprecated
  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated

     -- Only an OccName is needed because
     --    (1) a deprecation always applies to a binding
     --        defined in the module in which the deprecation appears.
     --    (2) deprecations are only reported outside the defining module.
     --        this is important because, otherwise, if we saw something like
     --
     --        {-# DEPRECATED f "" #-}
     --        f = ...
     --        h = f
     --        g = let f = undefined in f
     --
     --        we'd need more information than an OccName to know to say something
     --        about the use of f in h but not the use of the locally bound f in g
     --
     --        however, because we only report about deprecations from the outside,
     --        and a module can only export one value called f,
     --        an OccName suffices.
     --
     --        this is in contrast with fixity declarations, where we need to map
     --        a Name to its fixity declaration.
  deriving( Warnings -> Warnings -> Bool
(Warnings -> Warnings -> Bool)
-> (Warnings -> Warnings -> Bool) -> Eq Warnings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Warnings -> Warnings -> Bool
$c/= :: Warnings -> Warnings -> Bool
== :: Warnings -> Warnings -> Bool
$c== :: Warnings -> Warnings -> Bool
Eq )

instance Binary Warnings where
    put_ :: BinHandle -> Warnings -> IO ()
put_ BinHandle
bh Warnings
NoWarnings     = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    put_ BinHandle
bh (WarnAll WarningTxt
t) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            BinHandle -> WarningTxt -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh WarningTxt
t
    put_ BinHandle
bh (WarnSome [(OccName, WarningTxt)]
ts) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
            BinHandle -> [(OccName, WarningTxt)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [(OccName, WarningTxt)]
ts

    get :: BinHandle -> IO Warnings
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return Warnings
NoWarnings
              Word8
1 -> do WarningTxt
aa <- BinHandle -> IO WarningTxt
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningTxt -> Warnings
WarnAll WarningTxt
aa)
              Word8
_ -> do [(OccName, WarningTxt)]
aa <- BinHandle -> IO [(OccName, WarningTxt)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt)] -> Warnings
WarnSome [(OccName, WarningTxt)]
aa)

-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache Warnings
NoWarnings  = \OccName
_ -> Maybe WarningTxt
forall a. Maybe a
Nothing
mkIfaceWarnCache (WarnAll WarningTxt
t) = \OccName
_ -> WarningTxt -> Maybe WarningTxt
forall a. a -> Maybe a
Just WarningTxt
t
mkIfaceWarnCache (WarnSome [(OccName, WarningTxt)]
pairs) = OccEnv WarningTxt -> OccName -> Maybe WarningTxt
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv ([(OccName, WarningTxt)] -> OccEnv WarningTxt
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(OccName, WarningTxt)]
pairs)

emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache OccName
_ = Maybe WarningTxt
forall a. Maybe a
Nothing

plusWarns :: Warnings -> Warnings -> Warnings
plusWarns :: Warnings -> Warnings -> Warnings
plusWarns Warnings
d Warnings
NoWarnings = Warnings
d
plusWarns Warnings
NoWarnings Warnings
d = Warnings
d
plusWarns Warnings
_ (WarnAll WarningTxt
t) = WarningTxt -> Warnings
WarnAll WarningTxt
t
plusWarns (WarnAll WarningTxt
t) Warnings
_ = WarningTxt -> Warnings
WarnAll WarningTxt
t
plusWarns (WarnSome [(OccName, WarningTxt)]
v1) (WarnSome [(OccName, WarningTxt)]
v2) = [(OccName, WarningTxt)] -> Warnings
WarnSome ([(OccName, WarningTxt)]
v1 [(OccName, WarningTxt)]
-> [(OccName, WarningTxt)] -> [(OccName, WarningTxt)]
forall a. [a] -> [a] -> [a]
++ [(OccName, WarningTxt)]
v2)

-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'
mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache [(OccName, Fixity)]
pairs
  = \OccName
n -> OccEnv Fixity -> OccName -> Maybe Fixity
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Fixity
env OccName
n
  where
   env :: OccEnv Fixity
env = [(OccName, Fixity)] -> OccEnv Fixity
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(OccName, Fixity)]
pairs

emptyIfaceFixCache :: OccName -> Maybe Fixity
emptyIfaceFixCache :: OccName -> Maybe Fixity
emptyIfaceFixCache OccName
_ = Maybe Fixity
forall a. Maybe a
Nothing

-- | Fixity environment mapping names to their fixities
type FixityEnv = NameEnv FixItem

-- | Fixity information for an 'Name'. We keep the OccName in the range
-- so that we can generate an interface from it
data FixItem = FixItem OccName Fixity

instance Outputable FixItem where
  ppr :: FixItem -> SDoc
ppr (FixItem OccName
occ Fixity
fix) = Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
fix SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ

emptyFixityEnv :: FixityEnv
emptyFixityEnv :: FixityEnv
emptyFixityEnv = FixityEnv
forall a. NameEnv a
emptyNameEnv

lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity FixityEnv
env Name
n = case FixityEnv -> Name -> Maybe FixItem
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv FixityEnv
env Name
n of
                        Just (FixItem OccName
_ Fixity
fix) -> Fixity
fix
                        Maybe FixItem
Nothing         -> Fixity
defaultFixity

{-
************************************************************************
*                                                                      *
\subsection{WhatsImported}
*                                                                      *
************************************************************************
-}

-- | Records whether a module has orphans. An \"orphan\" is one of:
--
-- * An instance declaration in a module other than the definition
--   module for one of the type constructors or classes in the instance head
--
-- * A rewrite rule in a module other than the one defining
--   the function in the head of the rule
--
type WhetherHasOrphans   = Bool

-- | Does this module define family instances?
type WhetherHasFamInst = Bool

-- | Dependency information about ALL modules and packages below this one
-- in the import hierarchy.
--
-- Invariant: the dependencies of a module @M@ never includes @M@.
--
-- Invariant: none of the lists contain duplicates.
data Dependencies
  = Deps { Dependencies -> [ModuleNameWithIsBoot]
dep_mods   :: [ModuleNameWithIsBoot]
                        -- ^ All home-package modules transitively below this one
                        -- I.e. modules that this one imports, or that are in the
                        --      dep_mods of those directly-imported modules

         , Dependencies -> [(UnitId, Bool)]
dep_pkgs   :: [(UnitId, Bool)]
                        -- ^ All packages transitively below this module
                        -- I.e. packages to which this module's direct imports belong,
                        --      or that are in the dep_pkgs of those modules
                        -- The bool indicates if the package is required to be
                        -- trusted when the module is imported as a safe import
                        -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names

         , Dependencies -> [Module]
dep_orphs  :: [Module]
                        -- ^ Transitive closure of orphan modules (whether
                        -- home or external pkg).
                        --
                        -- (Possible optimization: don't include family
                        -- instance orphans as they are anyway included in
                        -- 'dep_finsts'.  But then be careful about code
                        -- which relies on dep_orphs having the complete list!)
                        -- This does NOT include us, unlike 'imp_orphs'.

         , Dependencies -> [Module]
dep_finsts :: [Module]
                        -- ^ Transitive closure of depended upon modules which
                        -- contain family instances (whether home or external).
                        -- This is used by 'checkFamInstConsistency'.  This
                        -- does NOT include us, unlike 'imp_finsts'. See Note
                        -- [The type family instance consistency story].

         , Dependencies -> [ModuleName]
dep_plgins :: [ModuleName]
                        -- ^ All the plugins used while compiling this module.
         }
  deriving( Dependencies -> Dependencies -> Bool
(Dependencies -> Dependencies -> Bool)
-> (Dependencies -> Dependencies -> Bool) -> Eq Dependencies
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dependencies -> Dependencies -> Bool
$c/= :: Dependencies -> Dependencies -> Bool
== :: Dependencies -> Dependencies -> Bool
$c== :: Dependencies -> Dependencies -> Bool
Eq )
        -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints
        -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.

instance Binary Dependencies where
    put_ :: BinHandle -> Dependencies -> IO ()
put_ BinHandle
bh Dependencies
deps = do BinHandle -> [ModuleNameWithIsBoot] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Dependencies -> [ModuleNameWithIsBoot]
dep_mods Dependencies
deps)
                      BinHandle -> [(UnitId, Bool)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Dependencies -> [(UnitId, Bool)]
dep_pkgs Dependencies
deps)
                      BinHandle -> [Module] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Dependencies -> [Module]
dep_orphs Dependencies
deps)
                      BinHandle -> [Module] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Dependencies -> [Module]
dep_finsts Dependencies
deps)
                      BinHandle -> [ModuleName] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Dependencies -> [ModuleName]
dep_plgins Dependencies
deps)

    get :: BinHandle -> IO Dependencies
get BinHandle
bh = do [ModuleNameWithIsBoot]
ms <- BinHandle -> IO [ModuleNameWithIsBoot]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                [(UnitId, Bool)]
ps <- BinHandle -> IO [(UnitId, Bool)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                [Module]
os <- BinHandle -> IO [Module]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                [Module]
fis <- BinHandle -> IO [Module]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                [ModuleName]
pl <- BinHandle -> IO [ModuleName]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                Dependencies -> IO Dependencies
forall (m :: * -> *) a. Monad m => a -> m a
return (Deps :: [ModuleNameWithIsBoot]
-> [(UnitId, Bool)]
-> [Module]
-> [Module]
-> [ModuleName]
-> Dependencies
Deps { dep_mods :: [ModuleNameWithIsBoot]
dep_mods = [ModuleNameWithIsBoot]
ms, dep_pkgs :: [(UnitId, Bool)]
dep_pkgs = [(UnitId, Bool)]
ps, dep_orphs :: [Module]
dep_orphs = [Module]
os,
                               dep_finsts :: [Module]
dep_finsts = [Module]
fis, dep_plgins :: [ModuleName]
dep_plgins = [ModuleName]
pl })

noDependencies :: Dependencies
noDependencies :: Dependencies
noDependencies = [ModuleNameWithIsBoot]
-> [(UnitId, Bool)]
-> [Module]
-> [Module]
-> [ModuleName]
-> Dependencies
Deps [] [] [] [] []

-- | Records modules for which changes may force recompilation of this module
-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
--
-- This differs from Dependencies.  A module X may be in the dep_mods of this
-- module (via an import chain) but if we don't use anything from X it won't
-- appear in our Usage
data Usage
  -- | Module from another package
  = UsagePackageModule {
        Usage -> Module
usg_mod      :: Module,
           -- ^ External package module depended on
        Usage -> Fingerprint
usg_mod_hash :: Fingerprint,
            -- ^ Cached module fingerprint
        Usage -> Bool
usg_safe :: IsSafeImport
            -- ^ Was this module imported as a safe import
    }
  -- | Module from the current package
  | UsageHomeModule {
        Usage -> ModuleName
usg_mod_name :: ModuleName,
            -- ^ Name of the module
        usg_mod_hash :: Fingerprint,
            -- ^ Cached module fingerprint
        Usage -> [(OccName, Fingerprint)]
usg_entities :: [(OccName,Fingerprint)],
            -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.
            -- NB: usages are for parent names only, e.g. type constructors
            -- but not the associated data constructors.
        Usage -> Maybe Fingerprint
usg_exports  :: Maybe Fingerprint,
            -- ^ Fingerprint for the export list of this module,
            -- if we directly imported it (and hence we depend on its export list)
        usg_safe :: IsSafeImport
            -- ^ Was this module imported as a safe import
    }                                           -- ^ Module from the current package
  -- | A file upon which the module depends, e.g. a CPP #include, or using TH's
  -- 'addDependentFile'
  | UsageFile {
        Usage -> FieldName
usg_file_path  :: FilePath,
        -- ^ External file dependency. From a CPP #include or TH
        -- addDependentFile. Should be absolute.
        Usage -> Fingerprint
usg_file_hash  :: Fingerprint
        -- ^ 'Fingerprint' of the file contents.

        -- Note: We don't consider things like modification timestamps
        -- here, because there's no reason to recompile if the actual
        -- contents don't change.  This previously lead to odd
        -- recompilation behaviors; see #8114
  }
  -- | A requirement which was merged into this one.
  | UsageMergedRequirement {
        usg_mod :: Module,
        usg_mod_hash :: Fingerprint
  }
    deriving( Usage -> Usage -> Bool
(Usage -> Usage -> Bool) -> (Usage -> Usage -> Bool) -> Eq Usage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Usage -> Usage -> Bool
$c/= :: Usage -> Usage -> Bool
== :: Usage -> Usage -> Bool
$c== :: Usage -> Usage -> Bool
Eq )
        -- The export list field is (Just v) if we depend on the export list:
        --      i.e. we imported the module directly, whether or not we
        --           enumerated the things we imported, or just imported
        --           everything
        -- We need to recompile if M's exports change, because
        -- if the import was    import M,       we might now have a name clash
        --                                      in the importing module.
        -- if the import was    import M(x)     M might no longer export x
        -- The only way we don't depend on the export list is if we have
        --                      import M()
        -- And of course, for modules that aren't imported directly we don't
        -- depend on their export lists

instance Binary Usage where
    put_ :: BinHandle -> Usage -> IO ()
put_ BinHandle
bh usg :: Usage
usg@UsagePackageModule{} = do
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
        BinHandle -> Module -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Module
usg_mod Usage
usg)
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Fingerprint
usg_mod_hash Usage
usg)
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Bool
usg_safe     Usage
usg)

    put_ BinHandle
bh usg :: Usage
usg@UsageHomeModule{} = do
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
        BinHandle -> ModuleName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> ModuleName
usg_mod_name Usage
usg)
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Fingerprint
usg_mod_hash Usage
usg)
        BinHandle -> Maybe Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Maybe Fingerprint
usg_exports  Usage
usg)
        BinHandle -> [(OccName, Fingerprint)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> [(OccName, Fingerprint)]
usg_entities Usage
usg)
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Bool
usg_safe     Usage
usg)

    put_ BinHandle
bh usg :: Usage
usg@UsageFile{} = do
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
        BinHandle -> FieldName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> FieldName
usg_file_path Usage
usg)
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Fingerprint
usg_file_hash Usage
usg)

    put_ BinHandle
bh usg :: Usage
usg@UsageMergedRequirement{} = do
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
        BinHandle -> Module -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Module
usg_mod      Usage
usg)
        BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Usage -> Fingerprint
usg_mod_hash Usage
usg)

    get :: BinHandle -> IO Usage
get BinHandle
bh = do
        Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
h of
          Word8
0 -> do
            Module
nm    <- BinHandle -> IO Module
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Fingerprint
mod   <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Bool
safe  <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Usage -> IO Usage
forall (m :: * -> *) a. Monad m => a -> m a
return UsagePackageModule :: Module -> Fingerprint -> Bool -> Usage
UsagePackageModule { usg_mod :: Module
usg_mod = Module
nm, usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
mod, usg_safe :: Bool
usg_safe = Bool
safe }
          Word8
1 -> do
            ModuleName
nm    <- BinHandle -> IO ModuleName
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Fingerprint
mod   <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Maybe Fingerprint
exps  <- BinHandle -> IO (Maybe Fingerprint)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            [(OccName, Fingerprint)]
ents  <- BinHandle -> IO [(OccName, Fingerprint)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Bool
safe  <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Usage -> IO Usage
forall (m :: * -> *) a. Monad m => a -> m a
return UsageHomeModule :: ModuleName
-> Fingerprint
-> [(OccName, Fingerprint)]
-> Maybe Fingerprint
-> Bool
-> Usage
UsageHomeModule { usg_mod_name :: ModuleName
usg_mod_name = ModuleName
nm, usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
mod,
                     usg_exports :: Maybe Fingerprint
usg_exports = Maybe Fingerprint
exps, usg_entities :: [(OccName, Fingerprint)]
usg_entities = [(OccName, Fingerprint)]
ents, usg_safe :: Bool
usg_safe = Bool
safe }
          Word8
2 -> do
            FieldName
fp   <- BinHandle -> IO FieldName
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Fingerprint
hash <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Usage -> IO Usage
forall (m :: * -> *) a. Monad m => a -> m a
return UsageFile :: FieldName -> Fingerprint -> Usage
UsageFile { usg_file_path :: FieldName
usg_file_path = FieldName
fp, usg_file_hash :: Fingerprint
usg_file_hash = Fingerprint
hash }
          Word8
3 -> do
            Module
mod <- BinHandle -> IO Module
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Fingerprint
hash <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Usage -> IO Usage
forall (m :: * -> *) a. Monad m => a -> m a
return UsageMergedRequirement :: Module -> Fingerprint -> Usage
UsageMergedRequirement { usg_mod :: Module
usg_mod = Module
mod, usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
hash }
          Word8
i -> FieldName -> IO Usage
forall a. HasCallStack => FieldName -> a
error (FieldName
"Binary.get(Usage): " FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> FieldName
forall a. Show a => a -> FieldName
show Word8
i)

{-
************************************************************************
*                                                                      *
                The External Package State
*                                                                      *
************************************************************************
-}

type PackageTypeEnv          = TypeEnv
type PackageRuleBase         = RuleBase
type PackageInstEnv          = InstEnv
type PackageFamInstEnv       = FamInstEnv
type PackageAnnEnv           = AnnEnv
type PackageCompleteMatchMap = CompleteMatchMap

-- | Information about other packages that we have slurped in by reading
-- their interface files
data ExternalPackageState
  = EPS {
        ExternalPackageState -> ModuleNameEnv ModuleNameWithIsBoot
eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),
                -- ^ In OneShot mode (only), home-package modules
                -- accumulate in the external package state, and are
                -- sucked in lazily.  For these home-pkg modules
                -- (only) we need to record which are boot modules.
                -- We set this field after loading all the
                -- explicitly-imported interfaces, but before doing
                -- anything else
                --
                -- The 'ModuleName' part is not necessary, but it's useful for
                -- debug prints, and it's convenient because this field comes
                -- direct from 'GHC.Tc.Utils.imp_dep_mods'

        ExternalPackageState -> PackageIfaceTable
eps_PIT :: !PackageIfaceTable,
                -- ^ The 'ModIface's for modules in external packages
                -- whose interfaces we have opened.
                -- The declarations in these interface files are held in the
                -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'
                -- fields of this record, not in the 'mi_decls' fields of the
                -- interface we have sucked in.
                --
                -- What /is/ in the PIT is:
                --
                -- * The Module
                --
                -- * Fingerprint info
                --
                -- * Its exports
                --
                -- * Fixities
                --
                -- * Deprecations and warnings

        ExternalPackageState -> InstalledModuleEnv (UniqDSet ModuleName)
eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),
                -- ^ Cache for 'mi_free_holes'.  Ordinarily, we can rely on
                -- the 'eps_PIT' for this information, EXCEPT that when
                -- we do dependency analysis, we need to look at the
                -- 'Dependencies' of our imports to determine what their
                -- precise free holes are ('moduleFreeHolesPrecise').  We
                -- don't want to repeatedly reread in the interface
                -- for every import, so cache it here.  When the PIT
                -- gets filled in we can drop these entries.

        ExternalPackageState -> TypeEnv
eps_PTE :: !PackageTypeEnv,
                -- ^ Result of typechecking all the external package
                -- interface files we have sucked in. The domain of
                -- the mapping is external-package modules

        ExternalPackageState -> InstEnv
eps_inst_env     :: !PackageInstEnv,   -- ^ The total 'InstEnv' accumulated
                                               -- from all the external-package modules
        ExternalPackageState -> FamInstEnv
eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated
                                               -- from all the external-package modules
        ExternalPackageState -> PackageRuleBase
eps_rule_base    :: !PackageRuleBase,  -- ^ The total 'RuleEnv' accumulated
                                               -- from all the external-package modules
        ExternalPackageState -> AnnEnv
eps_ann_env      :: !PackageAnnEnv,    -- ^ The total 'AnnEnv' accumulated
                                               -- from all the external-package modules
        ExternalPackageState -> PackageCompleteMatchMap
eps_complete_matches :: !PackageCompleteMatchMap,
                                  -- ^ The total 'CompleteMatchMap' accumulated
                                  -- from all the external-package modules

        ExternalPackageState -> ModuleEnv FamInstEnv
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
                                                         -- packages, keyed off the module that declared them

        ExternalPackageState -> EpsStats
eps_stats :: !EpsStats                 -- ^ Stastics about what was loaded from external packages
  }

-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.
-- \"In\" means stuff that is just /read/ from interface files,
-- \"Out\" means actually sucked in and type-checked
data EpsStats = EpsStats { EpsStats -> Int
n_ifaces_in
                         , EpsStats -> Int
n_decls_in, EpsStats -> Int
n_decls_out
                         , EpsStats -> Int
n_rules_in, EpsStats -> Int
n_rules_out
                         , EpsStats -> Int
n_insts_in, EpsStats -> Int
n_insts_out :: !Int }

addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats
-- ^ Add stats for one newly-read interface
addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats
addEpsInStats EpsStats
stats Int
n_decls Int
n_insts Int
n_rules
  = EpsStats
stats { n_ifaces_in :: Int
n_ifaces_in = EpsStats -> Int
n_ifaces_in EpsStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          , n_decls_in :: Int
n_decls_in  = EpsStats -> Int
n_decls_in EpsStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_decls
          , n_insts_in :: Int
n_insts_in  = EpsStats -> Int
n_insts_in EpsStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_insts
          , n_rules_in :: Int
n_rules_in  = EpsStats -> Int
n_rules_in EpsStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_rules }

{-
Names in a NameCache are always stored as a Global, and have the SrcLoc
of their binding locations.

Actually that's not quite right.  When we first encounter the original
name, we might not be at its binding site (e.g. we are reading an
interface file); so we give it 'noSrcLoc' then.  Later, when we find
its binding site, we fix it up.
-}

updNameCache :: IORef NameCache
             -> (NameCache -> (NameCache, c))  -- The updating function
             -> IO c
updNameCache :: forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache IORef NameCache
ncRef NameCache -> (NameCache, c)
upd_fn
  = IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
ncRef NameCache -> (NameCache, c)
upd_fn

mkSOName :: Platform -> FilePath -> FilePath
mkSOName :: Platform -> ShowS
mkSOName Platform
platform FieldName
root
    = case Platform -> OS
platformOS Platform
platform of
      OS
OSMinGW32 ->           FieldName
root  FieldName -> ShowS
<.> Platform -> FieldName
soExt Platform
platform
      OS
_         -> (FieldName
"lib" FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName
root) FieldName -> ShowS
<.> Platform -> FieldName
soExt Platform
platform

mkHsSOName :: Platform -> FilePath -> FilePath
mkHsSOName :: Platform -> ShowS
mkHsSOName Platform
platform FieldName
root = (FieldName
"lib" FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName
root) FieldName -> ShowS
<.> Platform -> FieldName
soExt Platform
platform

soExt :: Platform -> FilePath
soExt :: Platform -> FieldName
soExt Platform
platform
    = case Platform -> OS
platformOS Platform
platform of
      OS
OSDarwin  -> FieldName
"dylib"
      OS
OSMinGW32 -> FieldName
"dll"
      OS
_         -> FieldName
"so"

{-
************************************************************************
*                                                                      *
                The module graph and ModSummary type
        A ModSummary is a node in the compilation manager's
        dependency graph, and it's also passed to hscMain
*                                                                      *
************************************************************************
-}

-- | A ModuleGraph contains all the nodes from the home package (only).
-- There will be a node for each source module, plus a node for each hi-boot
-- module.
--
-- The graph is not necessarily stored in topologically-sorted order.  Use
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
  { ModuleGraph -> [ModSummary]
mg_mss :: [ModSummary]
  , ModuleGraph -> ModuleEnv ModSummary
mg_non_boot :: ModuleEnv ModSummary
    -- a map of all non-boot ModSummaries keyed by Modules
  , ModuleGraph -> ModuleSet
mg_boot :: ModuleSet
    -- a set of boot Modules
  , ModuleGraph -> Bool
mg_needs_th_or_qq :: !Bool
    -- does any of the modules in mg_mss require TemplateHaskell or
    -- QuasiQuotes?
  }

-- | Determines whether a set of modules requires Template Haskell or
-- Quasi Quotes
--
-- Note that if the session's 'DynFlags' enabled Template Haskell when
-- 'depanal' was called, then each module in the returned module graph will
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mg = ModuleGraph -> Bool
mg_needs_th_or_qq ModuleGraph
mg

-- | Map a function 'f' over all the 'ModSummaries'.
-- To preserve invariants 'f' can't change the isBoot status.
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG ModSummary -> ModSummary
f mg :: ModuleGraph
mg@ModuleGraph{Bool
[ModSummary]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModSummary]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModSummary]
..} = ModuleGraph
mg
  { mg_mss :: [ModSummary]
mg_mss = (ModSummary -> ModSummary) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModSummary
f [ModSummary]
mg_mss
  , mg_non_boot :: ModuleEnv ModSummary
mg_non_boot = (ModSummary -> ModSummary)
-> ModuleEnv ModSummary -> ModuleEnv ModSummary
forall a b. (a -> b) -> ModuleEnv a -> ModuleEnv b
mapModuleEnv ModSummary -> ModSummary
f ModuleEnv ModSummary
mg_non_boot
  }

mgBootModules :: ModuleGraph -> ModuleSet
mgBootModules :: ModuleGraph -> ModuleSet
mgBootModules ModuleGraph{Bool
[ModSummary]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModSummary]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModSummary]
..} = ModuleSet
mg_boot

mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries = ModuleGraph -> [ModSummary]
mg_mss

mgElemModule :: ModuleGraph -> Module -> Bool
mgElemModule :: ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph{Bool
[ModSummary]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModSummary]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModSummary]
..} Module
m = Module -> ModuleEnv ModSummary -> Bool
forall a. Module -> ModuleEnv a -> Bool
elemModuleEnv Module
m ModuleEnv ModSummary
mg_non_boot

-- | Look up a ModSummary in the ModuleGraph
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph{Bool
[ModSummary]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModSummary]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModSummary]
..} Module
m = ModuleEnv ModSummary -> Module -> Maybe ModSummary
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv ModSummary
mg_non_boot Module
m

emptyMG :: ModuleGraph
emptyMG :: ModuleGraph
emptyMG = [ModSummary]
-> ModuleEnv ModSummary -> ModuleSet -> Bool -> ModuleGraph
ModuleGraph [] ModuleEnv ModSummary
forall a. ModuleEnv a
emptyModuleEnv ModuleSet
emptyModuleSet Bool
False

isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms =
  (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TemplateHaskell (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)
    Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.QuasiQuotes (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)) Bool -> Bool -> Bool
&&
  (ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)

-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> ModSummary -> ModuleGraph
extendMG :: ModuleGraph -> ModSummary -> ModuleGraph
extendMG ModuleGraph{Bool
[ModSummary]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModSummary]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModSummary]
..} ModSummary
ms = ModuleGraph :: [ModSummary]
-> ModuleEnv ModSummary -> ModuleSet -> Bool -> ModuleGraph
ModuleGraph
  { mg_mss :: [ModSummary]
mg_mss = ModSummary
msModSummary -> [ModSummary] -> [ModSummary]
forall a. a -> [a] -> [a]
:[ModSummary]
mg_mss
  , mg_non_boot :: ModuleEnv ModSummary
mg_non_boot = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
      IsBootInterface
IsBoot -> ModuleEnv ModSummary
mg_non_boot
      IsBootInterface
NotBoot -> ModuleEnv ModSummary
-> Module -> ModSummary -> ModuleEnv ModSummary
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv ModSummary
mg_non_boot (ModSummary -> Module
ms_mod ModSummary
ms) ModSummary
ms
  , mg_boot :: ModuleSet
mg_boot = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
      IsBootInterface
NotBoot -> ModuleSet
mg_boot
      IsBootInterface
IsBoot -> ModuleSet -> Module -> ModuleSet
extendModuleSet ModuleSet
mg_boot (ModSummary -> Module
ms_mod ModSummary
ms)
  , mg_needs_th_or_qq :: Bool
mg_needs_th_or_qq = Bool
mg_needs_th_or_qq Bool -> Bool -> Bool
|| ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
  }

mkModuleGraph :: [ModSummary] -> ModuleGraph
mkModuleGraph :: [ModSummary] -> ModuleGraph
mkModuleGraph = (ModSummary -> ModuleGraph -> ModuleGraph)
-> ModuleGraph -> [ModSummary] -> ModuleGraph
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ModuleGraph -> ModSummary -> ModuleGraph)
-> ModSummary -> ModuleGraph -> ModuleGraph
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleGraph -> ModSummary -> ModuleGraph
extendMG) ModuleGraph
emptyMG

-- | A single node in a 'ModuleGraph'. The nodes of the module graph
-- are one of:
--
-- * A regular Haskell source module
-- * A hi-boot source module
--
data ModSummary
   = ModSummary {
        ModSummary -> Module
ms_mod          :: Module,
          -- ^ Identity of the module
        ModSummary -> HscSource
ms_hsc_src      :: HscSource,
          -- ^ The module source either plain Haskell or hs-boot
        ModSummary -> ModLocation
ms_location     :: ModLocation,
          -- ^ Location of the various files belonging to the module
        ModSummary -> UTCTime
ms_hs_date      :: UTCTime,
          -- ^ Timestamp of source file
        ModSummary -> Maybe UTCTime
ms_obj_date     :: Maybe UTCTime,
          -- ^ Timestamp of object, if we have one
        ModSummary -> Maybe UTCTime
ms_iface_date   :: Maybe UTCTime,
          -- ^ Timestamp of hi file, if we *only* are typechecking (it is
          -- 'Nothing' otherwise.
          -- See Note [Recompilation checking in -fno-code mode] and #9243
        ModSummary -> Maybe UTCTime
ms_hie_date   :: Maybe UTCTime,
          -- ^ Timestamp of hie file, if we have one
        ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps      :: [(Maybe FastString, Located ModuleName)],
          -- ^ Source imports of the module
        ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps :: [(Maybe FastString, Located ModuleName)],
          -- ^ Non-source imports of the module from the module *text*
        ModSummary -> Maybe HsParsedModule
ms_parsed_mod   :: Maybe HsParsedModule,
          -- ^ The parsed, nonrenamed source, if we have it.  This is also
          -- used to support "inline module syntax" in Backpack files.
        ModSummary -> FieldName
ms_hspp_file    :: FilePath,
          -- ^ Filename of preprocessed source file
        ModSummary -> DynFlags
ms_hspp_opts    :: DynFlags,
          -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@
          -- pragmas in the modules source code
        ModSummary -> Maybe InputFileBuffer
ms_hspp_buf     :: Maybe StringBuffer
          -- ^ The actual preprocessed source, if we have it
     }

ms_installed_mod :: ModSummary -> InstalledModule
ms_installed_mod :: ModSummary -> InstalledModule
ms_installed_mod = (InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst ((InstalledModule, Maybe InstantiatedModule) -> InstalledModule)
-> (ModSummary -> (InstalledModule, Maybe InstantiatedModule))
-> ModSummary
-> InstalledModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation (Module -> (InstalledModule, Maybe InstantiatedModule))
-> (ModSummary -> Module)
-> ModSummary
-> (InstalledModule, Maybe InstantiatedModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod

ms_mod_name :: ModSummary -> ModuleName
ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod

ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_imps ModSummary
ms =
  ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps ModSummary
ms [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++
  (ModuleName -> (Maybe FastString, Located ModuleName))
-> [ModuleName] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> (Maybe FastString, Located ModuleName)
forall {e} {a}. e -> (Maybe a, Located e)
mk_additional_import (DynFlags -> [ModuleName]
dynFlagDependencies (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms))
  where
    mk_additional_import :: e -> (Maybe a, Located e)
mk_additional_import e
mod_nm = (Maybe a
forall a. Maybe a
Nothing, e -> Located e
forall e. e -> Located e
noLoc e
mod_nm)

home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps [(Maybe FastString, Located ModuleName)]
imps = [ Located ModuleName
lmodname |  (Maybe FastString
mb_pkg, Located ModuleName
lmodname) <- [(Maybe FastString, Located ModuleName)]
imps,
                                  Maybe FastString -> Bool
isLocal Maybe FastString
mb_pkg ]
  where isLocal :: Maybe FastString -> Bool
isLocal Maybe FastString
Nothing = Bool
True
        isLocal (Just FastString
pkg) | FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName -> FastString
fsLit FieldName
"this" = Bool
True -- "this" is special
        isLocal Maybe FastString
_ = Bool
False

ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ModSummary
ms = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
ms [Located ModuleName]
-> [Located ModuleName] -> [Located ModuleName]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
ms)

-- | Like 'ms_home_imps', but for SOURCE imports.
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps = [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps ([(Maybe FastString, Located ModuleName)] -> [Located ModuleName])
-> (ModSummary -> [(Maybe FastString, Located ModuleName)])
-> ModSummary
-> [Located ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps

-- | All of the (possibly) home module imports from a
-- 'ModSummary'; that is to say, each of these module names
-- could be a home import if an appropriately named file
-- existed.  (This is in contrast to package qualified
-- imports, which are guaranteed not to be home imports.)
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps = [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps ([(Maybe FastString, Located ModuleName)] -> [Located ModuleName])
-> (ModSummary -> [(Maybe FastString, Located ModuleName)])
-> ModSummary
-> [Located ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_imps

-- The ModLocation contains both the original source filename and the
-- filename of the cleaned-up source file after all preprocessing has been
-- done.  The point is that the summariser will have to cpp/unlit/whatever
-- all files anyway, and there's no point in doing this twice -- just
-- park the result in a temp file, put the name of it in the location,
-- and let @compile@ read from that file on the way back up.

-- The ModLocation is stable over successive up-sweeps in GHCi, wheres
-- the ms_hs_date and imports can, of course, change

msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath
msHsFilePath :: ModSummary -> FieldName
msHsFilePath  ModSummary
ms = FieldName -> Maybe FieldName -> FieldName
forall a. HasCallStack => FieldName -> Maybe a -> a
expectJust FieldName
"msHsFilePath" (ModLocation -> Maybe FieldName
ml_hs_file  (ModSummary -> ModLocation
ms_location ModSummary
ms))
msHiFilePath :: ModSummary -> FieldName
msHiFilePath  ModSummary
ms = ModLocation -> FieldName
ml_hi_file  (ModSummary -> ModLocation
ms_location ModSummary
ms)
msObjFilePath :: ModSummary -> FieldName
msObjFilePath ModSummary
ms = ModLocation -> FieldName
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
ms)

msDynObjFilePath :: ModSummary -> DynFlags -> FilePath
msDynObjFilePath :: ModSummary -> DynFlags -> FieldName
msDynObjFilePath ModSummary
ms DynFlags
dflags = DynFlags -> ShowS
dynamicOutputFile DynFlags
dflags (ModSummary -> FieldName
msObjFilePath ModSummary
ms)

-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary ModSummary
ms = if ModSummary -> HscSource
ms_hsc_src ModSummary
ms HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile then IsBootInterface
IsBoot else IsBootInterface
NotBoot

instance Outputable ModSummary where
   ppr :: ModSummary -> SDoc
ppr ModSummary
ms
      = [SDoc] -> SDoc
sep [FieldName -> SDoc
text FieldName
"ModSummary {",
             Int -> SDoc -> SDoc
nest Int
3 ([SDoc] -> SDoc
sep [FieldName -> SDoc
text FieldName
"ms_hs_date = " SDoc -> SDoc -> SDoc
<> FieldName -> SDoc
text (UTCTime -> FieldName
forall a. Show a => a -> FieldName
show (ModSummary -> UTCTime
ms_hs_date ModSummary
ms)),
                          FieldName -> SDoc
text FieldName
"ms_mod =" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
ms)
                                SDoc -> SDoc -> SDoc
<> FieldName -> SDoc
text (HscSource -> FieldName
hscSourceString (ModSummary -> HscSource
ms_hsc_src ModSummary
ms)) SDoc -> SDoc -> SDoc
<> SDoc
comma,
                          FieldName -> SDoc
text FieldName
"ms_textual_imps =" SDoc -> SDoc -> SDoc
<+> [(Maybe FastString, Located ModuleName)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps ModSummary
ms),
                          FieldName -> SDoc
text FieldName
"ms_srcimps =" SDoc -> SDoc -> SDoc
<+> [(Maybe FastString, Located ModuleName)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps ModSummary
ms)]),
             Char -> SDoc
char Char
'}'
            ]

showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> FieldName
showModMsg DynFlags
dflags HscTarget
target Bool
recomp ModSummary
mod_summary = DynFlags -> SDoc -> FieldName
showSDoc DynFlags
dflags (SDoc -> FieldName) -> SDoc -> FieldName
forall a b. (a -> b) -> a -> b
$
   if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideSourcePaths DynFlags
dflags
      then FieldName -> SDoc
text FieldName
mod_str
      else [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
         [ FieldName -> SDoc
text (FieldName
mod_str FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> FieldName
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- FieldName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FieldName
mod_str)) Char
' ')
         , Char -> SDoc
char Char
'('
         , FieldName -> SDoc
text (ShowS
op ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ModSummary -> FieldName
msHsFilePath ModSummary
mod_summary) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
         if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags
            then [ FieldName -> SDoc
text FieldName
obj_file SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
                 , FieldName -> SDoc
text FieldName
dyn_file
                 , Char -> SDoc
char Char
')'
                 ]
            else [ FieldName -> SDoc
text FieldName
obj_file, Char -> SDoc
char Char
')' ]
  where
    op :: ShowS
op       = ShowS
normalise
    mod :: ModuleName
mod      = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod_summary)
    mod_str :: FieldName
mod_str  = DynFlags -> ModuleName -> FieldName
forall a. Outputable a => DynFlags -> a -> FieldName
showPpr DynFlags
dflags ModuleName
mod FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ HscSource -> FieldName
hscSourceString (ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary)
    dyn_file :: FieldName
dyn_file = ShowS
op ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags -> FieldName
msDynObjFilePath ModSummary
mod_summary DynFlags
dflags
    obj_file :: FieldName
obj_file = case HscTarget
target of
                HscTarget
HscInterpreted | Bool
recomp -> FieldName
"interpreted"
                HscTarget
HscNothing              -> FieldName
"nothing"
                HscTarget
_                       -> (ShowS
op ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ModSummary -> FieldName
msObjFilePath ModSummary
mod_summary)

{-
************************************************************************
*                                                                      *
\subsection{Recompilation}
*                                                                      *
************************************************************************
-}

-- | Indicates whether a given module's source has been modified since it
-- was last compiled.
data SourceModified
  = SourceModified
       -- ^ the source has been modified
  | SourceUnmodified
       -- ^ the source has not been modified.  Compilation may or may
       -- not be necessary, depending on whether any dependencies have
       -- changed since we last compiled.
  | SourceUnmodifiedAndStable
       -- ^ the source has not been modified, and furthermore all of
       -- its (transitive) dependencies are up to date; it definitely
       -- does not need to be recompiled.  This is important for two
       -- reasons: (a) we can omit the version check in checkOldIface,
       -- and (b) if the module used TH splices we don't need to force
       -- recompilation.

{-
************************************************************************
*                                                                      *
\subsection{Hpc Support}
*                                                                      *
************************************************************************
-}

-- | Information about a modules use of Haskell Program Coverage
data HpcInfo
  = HpcInfo
     { HpcInfo -> Int
hpcInfoTickCount :: Int
     , HpcInfo -> Int
hpcInfoHash      :: Int
     }
  | NoHpcInfo
     { HpcInfo -> Bool
hpcUsed          :: AnyHpcUsage  -- ^ Is hpc used anywhere on the module \*tree\*?
     }

-- | This is used to signal if one of my imports used HPC instrumentation
-- even if there is no module-local HPC usage
type AnyHpcUsage = Bool

emptyHpcInfo :: AnyHpcUsage -> HpcInfo
emptyHpcInfo :: Bool -> HpcInfo
emptyHpcInfo = Bool -> HpcInfo
NoHpcInfo

-- | Find out if HPC is used by this module or any of the modules
-- it depends upon
isHpcUsed :: HpcInfo -> AnyHpcUsage
isHpcUsed :: HpcInfo -> Bool
isHpcUsed (HpcInfo {})                   = Bool
True
isHpcUsed (NoHpcInfo { hpcUsed :: HpcInfo -> Bool
hpcUsed = Bool
used }) = Bool
used

{-
************************************************************************
*                                                                      *
\subsection{Safe Haskell Support}
*                                                                      *
************************************************************************

This stuff here is related to supporting the Safe Haskell extension,
primarily about storing under what trust type a module has been compiled.
-}

-- | Is an import a safe import?
type IsSafeImport = Bool

-- | Safe Haskell information for 'ModIface'
-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags
newtype IfaceTrustInfo = TrustInfo SafeHaskellMode

getSafeMode :: IfaceTrustInfo -> SafeHaskellMode
getSafeMode :: IfaceTrustInfo -> SafeHaskellMode
getSafeMode (TrustInfo SafeHaskellMode
x) = SafeHaskellMode
x

setSafeMode :: SafeHaskellMode -> IfaceTrustInfo
setSafeMode :: SafeHaskellMode -> IfaceTrustInfo
setSafeMode = SafeHaskellMode -> IfaceTrustInfo
TrustInfo

noIfaceTrustInfo :: IfaceTrustInfo
noIfaceTrustInfo :: IfaceTrustInfo
noIfaceTrustInfo = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_None

trustInfoToNum :: IfaceTrustInfo -> Word8
trustInfoToNum :: IfaceTrustInfo -> Word8
trustInfoToNum IfaceTrustInfo
it
  = case IfaceTrustInfo -> SafeHaskellMode
getSafeMode IfaceTrustInfo
it of
            SafeHaskellMode
Sf_None         -> Word8
0
            SafeHaskellMode
Sf_Unsafe       -> Word8
1
            SafeHaskellMode
Sf_Trustworthy  -> Word8
2
            SafeHaskellMode
Sf_Safe         -> Word8
3
            SafeHaskellMode
Sf_SafeInferred -> Word8
4
            SafeHaskellMode
Sf_Ignore       -> Word8
0

numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo Word8
0 = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_None
numToTrustInfo Word8
1 = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_Unsafe
numToTrustInfo Word8
2 = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_Trustworthy
numToTrustInfo Word8
3 = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_Safe
numToTrustInfo Word8
4 = SafeHaskellMode -> IfaceTrustInfo
setSafeMode SafeHaskellMode
Sf_SafeInferred
numToTrustInfo Word8
n = FieldName -> IfaceTrustInfo
forall a. HasCallStack => FieldName -> a
error (FieldName -> IfaceTrustInfo) -> FieldName -> IfaceTrustInfo
forall a b. (a -> b) -> a -> b
$ FieldName
"numToTrustInfo: bad input number! (" FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> FieldName
forall a. Show a => a -> FieldName
show Word8
n FieldName -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName
")"

instance Outputable IfaceTrustInfo where
    ppr :: IfaceTrustInfo -> SDoc
ppr (TrustInfo SafeHaskellMode
Sf_None)          = FieldName -> SDoc
text FieldName
"none"
    ppr (TrustInfo SafeHaskellMode
Sf_Ignore)        = FieldName -> SDoc
text FieldName
"none"
    ppr (TrustInfo SafeHaskellMode
Sf_Unsafe)        = FieldName -> SDoc
text FieldName
"unsafe"
    ppr (TrustInfo SafeHaskellMode
Sf_Trustworthy)   = FieldName -> SDoc
text FieldName
"trustworthy"
    ppr (TrustInfo SafeHaskellMode
Sf_Safe)          = FieldName -> SDoc
text FieldName
"safe"
    ppr (TrustInfo SafeHaskellMode
Sf_SafeInferred)  = FieldName -> SDoc
text FieldName
"safe-inferred"

instance Binary IfaceTrustInfo where
    put_ :: BinHandle -> IfaceTrustInfo -> IO ()
put_ BinHandle
bh IfaceTrustInfo
iftrust = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ IfaceTrustInfo -> Word8
trustInfoToNum IfaceTrustInfo
iftrust
    get :: BinHandle -> IO IfaceTrustInfo
get BinHandle
bh = BinHandle -> IO Word8
getByte BinHandle
bh IO Word8 -> (Word8 -> IO IfaceTrustInfo) -> IO IfaceTrustInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IfaceTrustInfo -> IO IfaceTrustInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (IfaceTrustInfo -> IO IfaceTrustInfo)
-> (Word8 -> IfaceTrustInfo) -> Word8 -> IO IfaceTrustInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> IfaceTrustInfo
numToTrustInfo)

{-
************************************************************************
*                                                                      *
\subsection{Parser result}
*                                                                      *
************************************************************************
-}

data HsParsedModule = HsParsedModule {
    HsParsedModule -> Located HsModule
hpm_module    :: Located HsModule,
    HsParsedModule -> [FieldName]
hpm_src_files :: [FilePath],
       -- ^ extra source files (e.g. from #includes).  The lexer collects
       -- these from '# <file> <line>' pragmas, which the C preprocessor
       -- leaves behind.  These files and their timestamps are stored in
       -- the .hi file, so that we can force recompilation if any of
       -- them change (#3589)
    HsParsedModule -> ApiAnns
hpm_annotations :: ApiAnns
    -- See note [Api annotations] in GHC.Parser.Annotation
  }

{-
************************************************************************
*                                                                      *
\subsection{Linkable stuff}
*                                                                      *
************************************************************************

This stuff is in here, rather than (say) in "GHC.Runtime.Linker", because the "GHC.Runtime.Linker"
stuff is the *dynamic* linker, and isn't present in a stage-1 compiler
-}

isObjectLinkable :: Linkable -> Bool
isObjectLinkable :: Linkable -> Bool
isObjectLinkable Linkable
l = Bool -> Bool
not ([Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unlinked]
unlinked) Bool -> Bool -> Bool
&& (Unlinked -> Bool) -> [Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Unlinked -> Bool
isObject [Unlinked]
unlinked
  where unlinked :: [Unlinked]
unlinked = Linkable -> [Unlinked]
linkableUnlinked Linkable
l
        -- A linkable with no Unlinked's is treated as a BCO.  We can
        -- generate a linkable with no Unlinked's as a result of
        -- compiling a module in HscNothing mode, and this choice
        -- happens to work well with checkStability in module GHC.

linkableObjs :: Linkable -> [FilePath]
linkableObjs :: Linkable -> [FieldName]
linkableObjs Linkable
l = [ FieldName
f | DotO FieldName
f <- Linkable -> [Unlinked]
linkableUnlinked Linkable
l ]

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

-- | Is this an actual file on disk we can link in somehow?
isObject :: Unlinked -> Bool
isObject :: Unlinked -> Bool
isObject (DotO FieldName
_)   = Bool
True
isObject (DotA FieldName
_)   = Bool
True
isObject (DotDLL FieldName
_) = Bool
True
isObject Unlinked
_          = Bool
False

-- | Is this a bytecode linkable with no file on disk?
isInterpretable :: Unlinked -> Bool
isInterpretable :: Unlinked -> Bool
isInterpretable = Bool -> Bool
not (Bool -> Bool) -> (Unlinked -> Bool) -> Unlinked -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unlinked -> Bool
isObject

-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object
nameOfObject :: Unlinked -> FilePath
nameOfObject :: Unlinked -> FieldName
nameOfObject (DotO FieldName
fn)   = FieldName
fn
nameOfObject (DotA FieldName
fn)   = FieldName
fn
nameOfObject (DotDLL FieldName
fn) = FieldName
fn
nameOfObject Unlinked
other       = FieldName -> SDoc -> FieldName
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"nameOfObject" (Unlinked -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unlinked
other)

-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
byteCodeOfObject :: Unlinked -> CompiledByteCode
byteCodeOfObject :: Unlinked -> CompiledByteCode
byteCodeOfObject (BCOs CompiledByteCode
bc [SptEntry]
_) = CompiledByteCode
bc
byteCodeOfObject Unlinked
other       = FieldName -> SDoc -> CompiledByteCode
forall a. HasCallStack => FieldName -> SDoc -> a
pprPanic FieldName
"byteCodeOfObject" (Unlinked -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unlinked
other)


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

-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.

-- See Note [Implementation of COMPLETE signatures]
data CompleteMatch = CompleteMatch {
                            CompleteMatch -> [Name]
completeMatchConLikes :: [Name]
                            -- ^ The ConLikes that form a covering family
                            -- (e.g. Nothing, Just)
                          , CompleteMatch -> Name
completeMatchTyCon :: Name
                            -- ^ The TyCon that they cover (e.g. Maybe)
                          }

instance Outputable CompleteMatch where
  ppr :: CompleteMatch -> SDoc
ppr (CompleteMatch [Name]
cl Name
ty) = FieldName -> SDoc
text FieldName
"CompleteMatch:" SDoc -> SDoc -> SDoc
<+> [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
cl
                                                    SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
ty

-- | A map keyed by the 'completeMatchTyCon' which has type Name.

-- See Note [Implementation of COMPLETE signatures]
type CompleteMatchMap = UniqFM Name [CompleteMatch]

mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap :: [CompleteMatch] -> PackageCompleteMatchMap
mkCompleteMatchMap = PackageCompleteMatchMap
-> [CompleteMatch] -> PackageCompleteMatchMap
extendCompleteMatchMap PackageCompleteMatchMap
forall key elt. UniqFM key elt
emptyUFM

extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]
                       -> CompleteMatchMap
extendCompleteMatchMap :: PackageCompleteMatchMap
-> [CompleteMatch] -> PackageCompleteMatchMap
extendCompleteMatchMap = (PackageCompleteMatchMap
 -> CompleteMatch -> PackageCompleteMatchMap)
-> PackageCompleteMatchMap
-> [CompleteMatch]
-> PackageCompleteMatchMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PackageCompleteMatchMap -> CompleteMatch -> PackageCompleteMatchMap
insertMatch
  where
    insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
    insertMatch :: PackageCompleteMatchMap -> CompleteMatch -> PackageCompleteMatchMap
insertMatch PackageCompleteMatchMap
ufm c :: CompleteMatch
c@(CompleteMatch [Name]
_ Name
t) = ([CompleteMatch] -> [CompleteMatch] -> [CompleteMatch])
-> PackageCompleteMatchMap
-> Name
-> [CompleteMatch]
-> PackageCompleteMatchMap
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
(++) PackageCompleteMatchMap
ufm Name
t [CompleteMatch
c]

{-
Note [Implementation of COMPLETE signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A COMPLETE signature represents a set of conlikes (i.e., constructors or
pattern synonyms) such that if they are all pattern-matched against in a
function, it gives rise to a total function. An example is:

  newtype Boolean = Boolean Int
  pattern F, T :: Boolean
  pattern F = Boolean 0
  pattern T = Boolean 1
  {-# COMPLETE F, T #-}

  -- This is a total function
  booleanToInt :: Boolean -> Int
  booleanToInt F = 0
  booleanToInt T = 1

COMPLETE sets are represented internally in GHC with the CompleteMatch data
type. For example, {-# COMPLETE F, T #-} would be represented as:

  CompleteMatch { complateMatchConLikes = [F, T]
                , completeMatchTyCon    = Boolean }

Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the
cases in which it's ambiguous, you can also explicitly specify it in the source
language by writing this:

  {-# COMPLETE F, T :: Boolean #-}

For efficiency purposes, GHC collects all of the CompleteMatches that it knows
about into a CompleteMatchMap, which is a map that is keyed by the
completeMatchTyCon. In other words, you could have a multiple COMPLETE sets
for the same TyCon:

  {-# COMPLETE F, T1 :: Boolean #-}
  {-# COMPLETE F, T2 :: Boolean #-}

And looking up the values in the CompleteMatchMap associated with Boolean
would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].
dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup.

Also see Note [Typechecking Complete Matches] in GHC.Tc.Gen.Bind for a more detailed
explanation for how GHC ensures that all the conlikes in a COMPLETE set are
consistent.
-}

-- | Foreign language of the phase if the phase deals with a foreign code
phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang
phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang
phaseForeignLanguage Phase
phase = case Phase
phase of
  Phase
Phase.Cc           -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangC
  Phase
Phase.Ccxx         -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangCxx
  Phase
Phase.Cobjc        -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangObjc
  Phase
Phase.Cobjcxx      -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangObjcxx
  Phase
Phase.HCc          -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangC
  Phase.As Bool
_         -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
LangAsm
  Phase
Phase.MergeForeign -> ForeignSrcLang -> Maybe ForeignSrcLang
forall a. a -> Maybe a
Just ForeignSrcLang
RawObject
  Phase
_                  -> Maybe ForeignSrcLang
forall a. Maybe a
Nothing

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

-- Take care, this instance only forces to the degree necessary to
-- avoid major space leaks.
instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
  rnf :: ModIface_ phase -> ()
rnf (ModIface Module
f1 Maybe Module
f2 HscSource
f3 Dependencies
f4 [Usage]
f5 [IfaceExport]
f6 Bool
f7 [(OccName, Fixity)]
f8 Warnings
f9 [IfaceAnnotation]
f10 [IfaceDeclExts phase]
f11 Maybe GlobalRdrEnv
f12
                [IfaceClsInst]
f13 [IfaceFamInst]
f14 [IfaceRule]
f15 Bool
f16 IfaceTrustInfo
f17 Bool
f18 [IfaceCompleteMatch]
f19 Maybe HsDocString
f20 DeclDocMap
f21 ArgDocMap
f22 IfaceBackendExts phase
f23 ExtensibleFields
f24) =
    Module -> ()
forall a. NFData a => a -> ()
rnf Module
f1 () -> () -> ()
`seq` Maybe Module -> ()
forall a. NFData a => a -> ()
rnf Maybe Module
f2 () -> () -> ()
`seq` HscSource
f3 HscSource -> () -> ()
`seq` Dependencies
f4 Dependencies -> () -> ()
`seq` [Usage]
f5 [Usage] -> () -> ()
`seq` [IfaceExport]
f6 [IfaceExport] -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
f7 () -> () -> ()
`seq` [(OccName, Fixity)]
f8 [(OccName, Fixity)] -> () -> ()
`seq`
    Warnings
f9 Warnings -> () -> ()
`seq` [IfaceAnnotation] -> ()
forall a. NFData a => a -> ()
rnf [IfaceAnnotation]
f10 () -> () -> ()
`seq` [IfaceDeclExts phase] -> ()
forall a. NFData a => a -> ()
rnf [IfaceDeclExts phase]
f11 () -> () -> ()
`seq` Maybe GlobalRdrEnv
f12 Maybe GlobalRdrEnv -> () -> ()
`seq` [IfaceClsInst] -> ()
forall a. NFData a => a -> ()
rnf [IfaceClsInst]
f13 () -> () -> ()
`seq` [IfaceFamInst] -> ()
forall a. NFData a => a -> ()
rnf [IfaceFamInst]
f14 () -> () -> ()
`seq` [IfaceRule] -> ()
forall a. NFData a => a -> ()
rnf [IfaceRule]
f15 () -> () -> ()
`seq`
    Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
f16 () -> () -> ()
`seq` IfaceTrustInfo
f17 IfaceTrustInfo -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
f18 () -> () -> ()
`seq` [IfaceCompleteMatch] -> ()
forall a. NFData a => a -> ()
rnf [IfaceCompleteMatch]
f19 () -> () -> ()
`seq` Maybe HsDocString
f20 Maybe HsDocString -> () -> ()
`seq` DeclDocMap
f21 DeclDocMap -> () -> ()
`seq` ArgDocMap
f22 ArgDocMap -> () -> ()
`seq` IfaceBackendExts phase -> ()
forall a. NFData a => a -> ()
rnf IfaceBackendExts phase
f23
    () -> () -> ()
`seq` ExtensibleFields -> ()
forall a. NFData a => a -> ()
rnf ExtensibleFields
f24

{-
************************************************************************
*                                                                      *
\subsection{Extensible Iface Fields}
*                                                                      *
************************************************************************
-}

type FieldName = String

newtype ExtensibleFields = ExtensibleFields { ExtensibleFields -> Map FieldName BinData
getExtensibleFields :: (Map FieldName BinData) }

instance Binary ExtensibleFields where
  put_ :: BinHandle -> ExtensibleFields -> IO ()
put_ BinHandle
bh (ExtensibleFields Map FieldName BinData
fs) = do
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Map FieldName BinData -> Int
forall k a. Map k a -> Int
Map.size Map FieldName BinData
fs :: Int)

    -- Put the names of each field, and reserve a space
    -- for a payload pointer after each name:
    [(Bin (Bin Any), BinData)]
header_entries <- [(FieldName, BinData)]
-> ((FieldName, BinData) -> IO (Bin (Bin Any), BinData))
-> IO [(Bin (Bin Any), BinData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map FieldName BinData -> [(FieldName, BinData)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FieldName BinData
fs) (((FieldName, BinData) -> IO (Bin (Bin Any), BinData))
 -> IO [(Bin (Bin Any), BinData)])
-> ((FieldName, BinData) -> IO (Bin (Bin Any), BinData))
-> IO [(Bin (Bin Any), BinData)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, BinData
dat) -> do
      BinHandle -> FieldName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FieldName
name
      Bin (Bin Any)
field_p_p <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
      BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
field_p_p
      (Bin (Bin Any), BinData) -> IO (Bin (Bin Any), BinData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bin (Bin Any)
field_p_p, BinData
dat)

    -- Now put the payloads and use the reserved space
    -- to point to the start of each payload:
    [(Bin (Bin Any), BinData)]
-> ((Bin (Bin Any), BinData) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Bin (Bin Any), BinData)]
header_entries (((Bin (Bin Any), BinData) -> IO ()) -> IO ())
-> ((Bin (Bin Any), BinData) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Bin (Bin Any)
field_p_p, BinData
dat) -> do
      Bin Any
field_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
      BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
field_p_p Bin Any
field_p
      BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
      BinHandle -> BinData -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh BinData
dat

  get :: BinHandle -> IO ExtensibleFields
get BinHandle
bh = do
    Int
n <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int

    -- Get the names and field pointers:
    [(FieldName, Bin Any)]
header_entries <- Int -> IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)])
-> IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)]
forall a b. (a -> b) -> a -> b
$ do
      (,) (FieldName -> Bin Any -> (FieldName, Bin Any))
-> IO FieldName -> IO (Bin Any -> (FieldName, Bin Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO FieldName
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (Bin Any -> (FieldName, Bin Any))
-> IO (Bin Any) -> IO (FieldName, Bin Any)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

    -- Seek to and get each field's payload:
    [(FieldName, BinData)]
fields <- [(FieldName, Bin Any)]
-> ((FieldName, Bin Any) -> IO (FieldName, BinData))
-> IO [(FieldName, BinData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FieldName, Bin Any)]
header_entries (((FieldName, Bin Any) -> IO (FieldName, BinData))
 -> IO [(FieldName, BinData)])
-> ((FieldName, Bin Any) -> IO (FieldName, BinData))
-> IO [(FieldName, BinData)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, Bin Any
field_p) -> do
      BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
      BinData
dat <- BinHandle -> IO BinData
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      (FieldName, BinData) -> IO (FieldName, BinData)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName
name, BinData
dat)

    ExtensibleFields -> IO ExtensibleFields
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtensibleFields -> IO ExtensibleFields)
-> ([(FieldName, BinData)] -> ExtensibleFields)
-> [(FieldName, BinData)]
-> IO ExtensibleFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FieldName BinData -> ExtensibleFields
ExtensibleFields (Map FieldName BinData -> ExtensibleFields)
-> ([(FieldName, BinData)] -> Map FieldName BinData)
-> [(FieldName, BinData)]
-> ExtensibleFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldName, BinData)] -> Map FieldName BinData
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FieldName, BinData)] -> IO ExtensibleFields)
-> [(FieldName, BinData)] -> IO ExtensibleFields
forall a b. (a -> b) -> a -> b
$ [(FieldName, BinData)]
fields

instance NFData ExtensibleFields where
  rnf :: ExtensibleFields -> ()
rnf (ExtensibleFields Map FieldName BinData
fs) = Map FieldName BinData -> ()
forall a. NFData a => a -> ()
rnf Map FieldName BinData
fs

emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields = Map FieldName BinData -> ExtensibleFields
ExtensibleFields Map FieldName BinData
forall k a. Map k a
Map.empty

--------------------------------------------------------------------------------
-- | Reading

readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)
readIfaceField :: forall a. Binary a => FieldName -> ModIface -> IO (Maybe a)
readIfaceField FieldName
name = FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
forall a.
FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
readIfaceFieldWith FieldName
name BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get

readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField :: forall a. Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField FieldName
name = FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get

readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
readIfaceFieldWith :: forall a.
FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
readIfaceFieldWith FieldName
name BinHandle -> IO a
read ModIface
iface = FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name BinHandle -> IO a
read (ModIface -> ExtensibleFields
forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface
iface)

readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith :: forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name BinHandle -> IO a
read ExtensibleFields
fields = Maybe (IO a) -> IO (Maybe a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (IO a) -> IO (Maybe a)) -> Maybe (IO a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ((BinHandle -> IO a
read (BinHandle -> IO a) -> IO BinHandle -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO BinHandle -> IO a)
-> (BinData -> IO BinHandle) -> BinData -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinData -> IO BinHandle
dataHandle) (BinData -> IO a) -> Maybe BinData -> Maybe (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  FieldName -> Map FieldName BinData -> Maybe BinData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
name (ExtensibleFields -> Map FieldName BinData
getExtensibleFields ExtensibleFields
fields)

--------------------------------------------------------------------------------
-- | Writing

writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface
writeIfaceField :: forall a. Binary a => FieldName -> a -> ModIface -> IO ModIface
writeIfaceField FieldName
name a
x = FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface
writeIfaceFieldWith FieldName
name (BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
`put_` a
x)

writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField :: forall a.
Binary a =>
FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField FieldName
name a
x = FieldName
-> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith FieldName
name (BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
`put_` a
x)

writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface
writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface
writeIfaceFieldWith FieldName
name BinHandle -> IO ()
write ModIface
iface = do
  ExtensibleFields
fields <- FieldName
-> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith FieldName
name BinHandle -> IO ()
write (ModIface -> ExtensibleFields
forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface
iface)
  ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface{ mi_ext_fields :: ExtensibleFields
mi_ext_fields = ExtensibleFields
fields }

writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith :: FieldName
-> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith FieldName
name BinHandle -> IO ()
write ExtensibleFields
fields = do
  BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
  BinHandle -> IO ()
write BinHandle
bh
  --
  BinData
bd <- BinHandle -> IO BinData
handleData BinHandle
bh
  ExtensibleFields -> IO ExtensibleFields
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtensibleFields -> IO ExtensibleFields)
-> ExtensibleFields -> IO ExtensibleFields
forall a b. (a -> b) -> a -> b
$ Map FieldName BinData -> ExtensibleFields
ExtensibleFields (FieldName
-> BinData -> Map FieldName BinData -> Map FieldName BinData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
name BinData
bd (Map FieldName BinData -> Map FieldName BinData)
-> Map FieldName BinData -> Map FieldName BinData
forall a b. (a -> b) -> a -> b
$ ExtensibleFields -> Map FieldName BinData
getExtensibleFields ExtensibleFields
fields)

deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField FieldName
name (ExtensibleFields Map FieldName BinData
fs) = Map FieldName BinData -> ExtensibleFields
ExtensibleFields (Map FieldName BinData -> ExtensibleFields)
-> Map FieldName BinData -> ExtensibleFields
forall a b. (a -> b) -> a -> b
$ FieldName -> Map FieldName BinData -> Map FieldName BinData
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
name Map FieldName BinData
fs

deleteIfaceField :: FieldName -> ModIface -> ModIface
deleteIfaceField :: FieldName -> ModIface -> ModIface
deleteIfaceField FieldName
name ModIface
iface = ModIface
iface { mi_ext_fields :: ExtensibleFields
mi_ext_fields = FieldName -> ExtensibleFields -> ExtensibleFields
deleteField FieldName
name (ModIface -> ExtensibleFields
forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface
iface) }