{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TypeFamilies             #-}

module GHC.Tc.Utils.Backpack (
    findExtraSigImports,
    implicitRequirements,
    implicitRequirementsShallow,
    checkUnit,
    tcRnCheckUnit,
    tcRnMergeSignatures,
    mergeSignatures,
    tcRnInstantiateSignature,
    instantiateSignature,
) where

import GHC.Prelude


import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Driver.DynFlags

import GHC.Types.Basic (TypeOrKind(..))
import GHC.Types.Fixity (defaultFixity)
import GHC.Types.Fixity.Env
import GHC.Types.TypeEnv
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.Var
import GHC.Types.Id( idType )
import GHC.Types.Unique.DSet
import GHC.Types.Name.Shape
import GHC.Types.PkgQual

import GHC.Unit
import GHC.Unit.Finder
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps

import GHC.Tc.Errors
import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Module
import GHC.Tc.Gen.Export
import GHC.Tc.Solver
import GHC.Tc.TyCl.Utils
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc( mkGivenLoc )
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType

import GHC.Hs

import GHC.Core.InstEnv
import GHC.Core.FamInstEnv

import GHC.IfaceToCore
import GHC.Iface.Load
import GHC.Iface.Rename
import GHC.Iface.Syntax

import GHC.Rename.Names
import GHC.Rename.Fixity ( lookupFixityRn )

import GHC.Utils.Error
import GHC.Utils.Misc ( HasDebugCallStack )
import GHC.Utils.Outputable
import GHC.Utils.Panic

import GHC.Data.FastString
import GHC.Data.Maybe

import Control.Monad
import Data.List (find)

import GHC.Iface.Errors.Types
import Data.Function ((&))

checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
sig_iface TyThing
sig_thing TyThing
real_thing = do
    let name :: Name
name = TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
real_thing
    -- TODO: Distinguish between signature merging and signature
    -- implementation cases.
    HsBootOrSig -> TyThing -> TyThing -> TcRn ()
checkBootDeclM HsBootOrSig
Hsig TyThing
sig_thing TyThing
real_thing
    real_fixity <- Name -> RnM Fixity
lookupFixityRn Name
name
    let sig_fixity = case ModIfaceBackend -> OccName -> Maybe Fixity
mi_fix_fn (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
sig_iface) (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) of
                        Maybe Fixity
Nothing -> Fixity
defaultFixity
                        Just Fixity
f -> Fixity
f
    when (real_fixity /= sig_fixity) $
      addErrAt (nameSrcSpan name)
        (TcRnHsigFixityMismatch real_thing real_fixity sig_fixity)

-- | Given a 'ModDetails' of an instantiated signature (note that the
-- 'ModDetails' must be knot-tied consistently with the actual implementation)
-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
-- verify that the actual implementation actually matches the original
-- interface.
--
-- Note that it is already assumed that the implementation *exports*
-- a sufficient set of entities, since otherwise the renaming and then
-- typechecking of the signature 'ModIface' would have failed.
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface TcGblEnv
tcg_env GlobalRdrEnv
gre_env ModIface
sig_iface
  ModDetails { md_insts :: ModDetails -> InstEnv
md_insts = InstEnv
sig_insts, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
sig_fam_insts,
               md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
sig_type_env, md_exports :: ModDetails -> [AvailInfo]
md_exports = [AvailInfo]
sig_exports   } = do
    String -> SDoc -> TcRn ()
traceTc String
"checkHsigIface" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
sig_type_env, InstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstEnv
sig_insts, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AvailInfo]
sig_exports ]
    (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
check_export ((AvailInfo -> Name) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map AvailInfo -> Name
availName [AvailInfo]
sig_exports)
    TcRn ()
failIfErrsM -- See Note [Fail before checking instances in checkHsigIface]
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
sig_fam_insts) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
        String -> TcRn ()
forall a. HasCallStack => String -> a
panic (String
"GHC.Tc.Utils.Backpack.checkHsigIface: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"Cannot handle family instances in hsig files yet...")
    -- Delete instances so we don't look them up when
    -- checking instance satisfiability
    -- TODO: this should not be necessary
    tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
                        tcg_fam_inst_env = emptyFamInstEnv,
                        tcg_insts = [],
                        tcg_fam_insts = [] } $ do
    mapM_ check_inst (instEnvElts sig_insts)
    failIfErrsM
  where
    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
    -- in package p that defines T; and we implement with himpl:H.  Then the
    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
    -- have to look up the right name.
    sig_type_occ_env :: OccEnv TyThing
sig_type_occ_env = [(OccName, TyThing)] -> OccEnv TyThing
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv
                     ([(OccName, TyThing)] -> OccEnv TyThing)
-> ([TyThing] -> [(OccName, TyThing)])
-> [TyThing]
-> OccEnv TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing -> (OccName, TyThing))
-> [TyThing] -> [(OccName, TyThing)]
forall a b. (a -> b) -> [a] -> [b]
map (\TyThing
t -> (Name -> OccName
nameOccName (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
t), TyThing
t))
                     ([TyThing] -> OccEnv TyThing) -> [TyThing] -> OccEnv TyThing
forall a b. (a -> b) -> a -> b
$ TypeEnv -> [TyThing]
forall a. NameEnv a -> [a]
nonDetNameEnvElts TypeEnv
sig_type_env
    dfun_names :: [Name]
dfun_names = (ClsInst -> Name) -> [ClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Name
forall a. NamedThing a => a -> Name
getName (InstEnv -> [ClsInst]
instEnvElts InstEnv
sig_insts)
    check_export :: Name -> TcRn ()
check_export Name
name
      -- Skip instances, we'll check them later
      -- TODO: Actually this should never happen, because DFuns are
      -- never exported...
      | Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dfun_names = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- See if we can find the type directly in the hsig ModDetails
      -- TODO: need to special case wired in names
      | Just TyThing
sig_thing <- OccEnv TyThing -> OccName -> Maybe TyThing
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv TyThing
sig_type_occ_env (Name -> OccName
nameOccName Name
name) = do
        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
        -- tcg_env (TODO: but maybe this isn't relevant anymore).
        r <- Name -> TcM (MaybeErr IfaceMessage TyThing)
tcLookupImported_maybe Name
name
        case r of
          Failed IfaceMessage
err           -> TcRnMessage -> TcRn ()
addErr (IfaceMessage -> TcRnMessage
TcRnInterfaceError IfaceMessage
err)
          Succeeded TyThing
real_thing -> ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
sig_iface TyThing
sig_thing TyThing
real_thing

      -- The hsig did NOT define this function; that means it must
      -- be a reexport.  In this case, make sure the 'Name' of the
      -- reexport matches the 'Name' exported here.
      | [GlobalRdrEltX GREInfo
gre] <- GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
gre_env (OccName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. OccName -> WhichGREs info -> LookupGRE info
LookupOccName (Name -> OccName
nameOccName Name
name) WhichGREs GREInfo
forall info. WhichGREs info
SameNameSpace) = do
        let name' :: Name
name' = GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrEltX GREInfo
gre
        Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name') (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
            -- See Note [Error reporting bad reexport]
            -- TODO: Actually this error swizzle doesn't work
            let p :: GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)) -> Bool
p (L SrcSpanAnnA
_ IE (GhcPass 'Renamed)
ie) = Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IE (GhcPass 'Renamed) -> [IdP (GhcPass 'Renamed)]
forall (p :: Pass). IE (GhcPass p) -> [IdP (GhcPass p)]
ieNames IE (GhcPass 'Renamed)
ie
                loc :: SrcSpan
loc = case TcGblEnv -> Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])]
tcg_rn_exports TcGblEnv
tcg_env of
                       Just [(LIE (GhcPass 'Renamed), [AvailInfo])]
es | Just GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))
e <- (GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)) -> Bool)
-> [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))]
-> Maybe (GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)) -> Bool
p (((GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])
 -> GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)))
-> [(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])]
-> [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])
-> GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))
forall a b. (a, b) -> a
fst [(LIE (GhcPass 'Renamed), [AvailInfo])]
[(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])]
es)
                         -- TODO: maybe we can be a little more
                         -- precise here and use the Located
                         -- info for the *specific* name we matched.
                         -> GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))
e
                       Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])]
_ -> Name -> SrcSpan
nameSrcSpan Name
name
            SrcSpan -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
loc
              (HsBootOrSig -> BootMismatch -> TcRnMessage
TcRnBootMismatch HsBootOrSig
Hsig (BootMismatch -> TcRnMessage) -> BootMismatch -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ Name -> Name -> BootMismatch
BadReexportedBootThing Name
name Name
name')
      -- This should actually never happen, but whatever...
      | Bool
otherwise =
        SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
name)
            (HsBootOrSig -> Name -> MissingBootThing -> TcRnMessage
missingBootThing HsBootOrSig
Hsig Name
name MissingBootThing
MissingBootExport)

-- Note [Fail before checking instances in checkHsigIface]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We need to be careful about failing before checking instances if there happens
-- to be an error in the exports.
-- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on
-- ill-kinded types that are constructed while checking instances.
-- This lead to #19244

-- Note [Error reporting bad reexport]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- NB: You want to be a bit careful about what location you report on reexports.
-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
-- correct source location.  However, if it was *reexported*, obviously the name
-- is not going to have the right location.  In this case, we need to grovel in
-- tcg_rn_exports to figure out where the reexport came from.



-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
-- assume that the implementing file actually implemented the instances (they
-- may be reexported from elsewhere).  Where should we look for the instances?
-- We do the same as we would otherwise: consult the EPS.  This isn't perfect
-- (we might conclude the module exports an instance when it doesn't, see
-- #9422), but we will never refuse to compile something.
check_inst :: ClsInst -> TcM ()
check_inst :: ClsInst -> TcRn ()
check_inst sig_inst :: ClsInst
sig_inst@(ClsInst { is_dfun :: ClsInst -> DFunId
is_dfun = DFunId
dfun_id }) = do
    -- TODO: This could be very well generalized to support instance
    -- declarations in boot files.
    tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    lcl_env <- getLclEnv

    -- NB: Have to tug on the interface, not necessarily
    -- tugged... but it didn't work?
    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))

    -- Based off of 'simplifyDeriv'
    (skol_info, tvs_skols, inst_theta, cls, inst_tys) <- tcSkolDFunType (idType dfun_id)
    (tclvl,cts) <- pushTcLevelM $ do
       given_ids <- mapM newEvVar inst_theta
       let given_loc = TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc
mkGivenLoc TcLevel
topTcLevel SkolemInfoAnon
skol_info (TcLclEnv -> CtLocEnv
mkCtLocEnv TcLclEnv
lcl_env)
           givens = [ CtGiven { ctev_pred :: Type
ctev_pred = DFunId -> Type
idType DFunId
given_id
                              -- Doesn't matter, make something up
                              , ctev_evar :: DFunId
ctev_evar = DFunId
given_id
                              , ctev_loc :: CtLoc
ctev_loc  = CtLoc
given_loc  }
                    | DFunId
given_id <- [DFunId]
given_ids ]
           origin    = Module -> ClsInst -> CtOrigin
InstProvidedOrigin (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env) ClsInst
sig_inst
       wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys)
       return (wanted : givens)
    unsolved <- simplifyWantedsTcM cts

    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
    reportAllUnsolved (mkImplicWC implic)

-- | For a module @modname@ of type 'HscSource', determine the list
-- of extra "imports" of other requirements which should be considered part of
-- the import of the requirement, because it transitively depends on those
-- requirements by imports of modules from other packages.  The situation
-- is something like this:
--
--      unit p where
--          signature X
--          signature Y
--              import X
--
--      unit q where
--          dependency p[X=\<A>,Y=\<B>]
--          signature A
--          signature B
--
-- Although q's B does not directly import A, we still have to make sure we
-- process A first, because the merging process will cause B to indirectly
-- import A.  This function finds the TRANSITIVE closure of all such imports
-- we need to make.
findExtraSigImports :: HscEnv
                    -> HscSource
                    -> ModuleName
                    -> IO [ModuleName]
findExtraSigImports :: HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
HsigFile ModuleName
modname = do
    let
      dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      ctx :: SDocContext
ctx        = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
      unit_state :: UnitState
unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
      reqs :: [InstantiatedModule]
reqs       = UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
unit_state ModuleName
modname
    holes <- [InstantiatedModule]
-> (InstantiatedModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [InstantiatedModule]
reqs ((InstantiatedModule -> IO (UniqDSet ModuleName))
 -> IO [UniqDSet ModuleName])
-> (InstantiatedModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall a b. (a -> b) -> a -> b
$ \(Module InstantiatedUnit
iuid ModuleName
mod_name) -> do
        HscEnv -> IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env
            (IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName))
-> (IOEnv
      (Env IfGblEnv ())
      (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
    -> IfG (UniqDSet ModuleName))
-> IOEnv
     (Env IfGblEnv ())
     (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IOEnv
     (Env IfGblEnv ())
     (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
-> IfG (UniqDSet ModuleName)
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
            (IOEnv
   (Env IfGblEnv ())
   (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
 -> IO (UniqDSet ModuleName))
-> IOEnv
     (Env IfGblEnv ())
     (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> IOEnv
     (Env IfGblEnv ())
     (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
forall gbl lcl.
SDoc
-> Module
-> TcRnIf
     gbl lcl (MaybeErr MissingInterfaceError (UniqDSet ModuleName))
moduleFreeHolesPrecise (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"findExtraSigImports")
                (Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid) ModuleName
mod_name)
    return (uniqDSetToList (unionManyUniqDSets holes))

findExtraSigImports HscEnv
_ HscSource
_ ModuleName
_ = [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Given a list of 'import M' statements in a module, figure out
-- any extra implicit requirement imports they may have.  For
-- example, if they 'import M' and M resolves to p[A=<B>,C=D], then
-- they actually also import the local requirement B.
implicitRequirements :: HscEnv
                     -> [(PkgQual, Located ModuleName)]
                     -> IO [ModuleName]
implicitRequirements :: HscEnv -> [(PkgQual, Located ModuleName)] -> IO [ModuleName]
implicitRequirements HscEnv
hsc_env [(PkgQual, Located ModuleName)]
normal_imports
  = ([[ModuleName]] -> [ModuleName])
-> IO [[ModuleName]] -> IO [ModuleName]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ModuleName]] -> [ModuleName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[ModuleName]] -> IO [ModuleName])
-> IO [[ModuleName]] -> IO [ModuleName]
forall a b. (a -> b) -> a -> b
$
    [(PkgQual, Located ModuleName)]
-> ((PkgQual, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PkgQual, Located ModuleName)]
normal_imports (((PkgQual, Located ModuleName) -> IO [ModuleName])
 -> IO [[ModuleName]])
-> ((PkgQual, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall a b. (a -> b) -> a -> b
$ \(PkgQual
mb_pkg, L SrcSpan
_ ModuleName
imp) -> do
        found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
mb_pkg
        case found of
            Found ModLocation
_ Module
mod | Maybe HomeUnit -> Module -> Bool
notHomeModuleMaybe Maybe HomeUnit
mhome_unit Module
mod ->
                [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (Module -> UniqDSet ModuleName
forall u. GenModule (GenUnit u) -> UniqDSet ModuleName
moduleFreeHoles Module
mod))
            FindResult
_ -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env

-- | Like @implicitRequirements'@, but returns either the module name, if it is
-- a free hole, or the instantiated unit the imported module is from, so that
-- that instantiated unit can be processed and via the batch mod graph (rather
-- than a transitive closure done here) all the free holes are still reachable.
implicitRequirementsShallow
  :: HscEnv
  -> [(PkgQual, Located ModuleName)]
  -> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow :: HscEnv
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow HscEnv
hsc_env [(PkgQual, Located ModuleName)]
normal_imports = ([ModuleName], [InstantiatedUnit])
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
go ([], []) [(PkgQual, Located ModuleName)]
normal_imports
 where
  mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env

  go :: ([ModuleName], [InstantiatedUnit])
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
go ([ModuleName], [InstantiatedUnit])
acc [] = ([ModuleName], [InstantiatedUnit])
-> IO ([ModuleName], [InstantiatedUnit])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName], [InstantiatedUnit])
acc
  go ([ModuleName]
accL, [InstantiatedUnit]
accR) ((PkgQual
mb_pkg, L SrcSpan
_ ModuleName
imp):[(PkgQual, Located ModuleName)]
imports) = do
    found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
mb_pkg
    let acc' = case FindResult
found of
          Found ModLocation
_ Module
mod | Maybe HomeUnit -> Module -> Bool
notHomeModuleMaybe Maybe HomeUnit
mhome_unit Module
mod ->
              case Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod of
                  Unit
HoleUnit -> (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
accL, [InstantiatedUnit]
accR)
                  RealUnit Definite UnitId
_ -> ([ModuleName]
accL, [InstantiatedUnit]
accR)
                  VirtUnit InstantiatedUnit
u -> ([ModuleName]
accL, InstantiatedUnit
uInstantiatedUnit -> [InstantiatedUnit] -> [InstantiatedUnit]
forall a. a -> [a] -> [a]
:[InstantiatedUnit]
accR)
          FindResult
_ -> ([ModuleName]
accL, [InstantiatedUnit]
accR)
    go acc' imports

-- | Given a 'Unit', make sure it is well typed.  This is because
-- unit IDs come from Cabal, which does not know if things are well-typed or
-- not; a component may have been filled with implementations for the holes
-- that don't actually fulfill the requirements.
checkUnit :: Unit -> TcM ()
checkUnit :: Unit -> TcRn ()
checkUnit Unit
HoleUnit         = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnit (RealUnit Definite UnitId
_)     = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- if it's already compiled, must be well-typed
checkUnit (VirtUnit InstantiatedUnit
indef) = do
   let insts :: GenInstantiations UnitId
insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
indef
   GenInstantiations UnitId
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ GenInstantiations UnitId
insts (((ModuleName, Module) -> TcRn ()) -> TcRn ())
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
mod) ->
       -- NB: direct hole instantiations are well-typed by construction
       -- (because we FORCE things to be merged in), so don't check them
       Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
           Unit -> TcRn ()
checkUnit (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod)
           _ <- Module
mod HasDebugCallStack =>
Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
`checkImplements` InstantiatedUnit -> ModuleName -> InstantiatedModule
forall u. u -> ModuleName -> GenModule u
Module InstantiatedUnit
indef ModuleName
mod_name
           return ()

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnCheckUnit ::
    HscEnv -> Unit ->
    IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env Unit
uid =
   Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe ()) -> ())
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages TcRnMessage, Maybe ())
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Check unit id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid)
              (() -> (Messages TcRnMessage, Maybe ()) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe ())
 -> IO (Messages TcRnMessage, Maybe ()))
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRn ()
-> IO (Messages TcRnMessage, Maybe ())
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env
          HscSource
HsigFile -- bogus
          Bool
False
          (HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env))
          (RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
loc_str) Int
0 Int
0)) -- bogus
    (TcRn () -> IO (Messages TcRnMessage, Maybe ()))
-> TcRn () -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ Unit -> TcRn ()
checkUnit Unit
uid
  where
   dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
   logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
   loc_str :: String
loc_str = String
"Command line argument: -unit-id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid)

-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...

-- | Top-level driver for signature merging (run after typechecking
-- an @hsig@ file).
tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
                    -> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures :: HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
orig_tcg_env ModIface
iface =
  Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
             (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signature merging" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
             (() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
 -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
  HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    HasDebugCallStack =>
HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures HsParsedModule
hpm TcGblEnv
orig_tcg_env ModIface
iface
 where
  logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  this_mod :: Module
this_mod = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface
  real_loc :: RealSrcSpan
real_loc = TcGblEnv -> RealSrcSpan
tcg_top_loc TcGblEnv
orig_tcg_env

thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface [AvailInfo]
avails ModIface
iface =
    ModIface
iface
        ModIface -> (ModIface -> ModIface) -> ModIface
forall a b. a -> (a -> b) -> b
& [AvailInfo] -> ModIface -> ModIface
forall (phase :: ModIfacePhase).
[AvailInfo] -> ModIface_ phase -> ModIface_ phase
set_mi_exports [AvailInfo]
avails
        -- mi_fixities = ...,
        -- mi_warns = ...,
        -- mi_anns = ...,
        -- TODO: The use of nameOccName here is a bit dodgy, because
        -- perhaps there might be two IfaceTopBndr that are the same
        -- OccName but different Name.  Requires better understanding
        -- of invariants here.
        ModIface -> (ModIface -> ModIface) -> ModIface
forall a b. a -> (a -> b) -> b
& [IfaceDeclExts 'ModIfaceFinal] -> ModIface -> ModIface
forall (phase :: ModIfacePhase).
[IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase
set_mi_decls ([(Fingerprint, IfaceDecl)]
exported_decls [(Fingerprint, IfaceDecl)]
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. [a] -> [a] -> [a]
++ [(Fingerprint, IfaceDecl)]
non_exported_decls [(Fingerprint, IfaceDecl)]
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. [a] -> [a] -> [a]
++ [(Fingerprint, IfaceDecl)]
dfun_decls)
        -- mi_insts = ...,
        -- mi_fam_insts = ...,
  where
    decl_pred :: OccSet -> IfaceDecl -> Bool
decl_pred OccSet
occs IfaceDecl
decl = Name -> OccName
nameOccName (IfaceDecl -> Name
ifName IfaceDecl
decl) OccName -> OccSet -> Bool
`elemOccSet` OccSet
occs
    filter_decls :: OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
occs = ((Fingerprint, IfaceDecl) -> Bool)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. (a -> Bool) -> [a] -> [a]
filter (OccSet -> IfaceDecl -> Bool
decl_pred OccSet
occs (IfaceDecl -> Bool)
-> ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> (Fingerprint, IfaceDecl)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd) (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)

    exported_occs :: OccSet
exported_occs = [OccName] -> OccSet
mkOccSet [ Name -> OccName
nameOccName Name
n
                             | AvailInfo
a <- [AvailInfo]
avails
                             , Name
n <- AvailInfo -> [Name]
availNames AvailInfo
a ]
    exported_decls :: [(Fingerprint, IfaceDecl)]
exported_decls = OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
exported_occs

    non_exported_occs :: OccSet
non_exported_occs = [OccName] -> OccSet
mkOccSet [ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n
                                 | (Fingerprint
_, IfaceDecl
d) <- [(Fingerprint, IfaceDecl)]
exported_decls
                                 , Name
n <- IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs IfaceDecl
d ]
    non_exported_decls :: [(Fingerprint, IfaceDecl)]
non_exported_decls = OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
non_exported_occs

    dfun_pred :: IfaceDecl -> Bool
dfun_pred IfaceId{ ifIdDetails :: IfaceDecl -> IfaceIdDetails
ifIdDetails = IfaceIdDetails
IfDFunId } = Bool
True
    dfun_pred IfaceDecl
_ = Bool
False
    dfun_decls :: [(Fingerprint, IfaceDecl)]
dfun_decls = ((Fingerprint, IfaceDecl) -> Bool)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IfaceDecl -> Bool
dfun_pred (IfaceDecl -> Bool)
-> ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> (Fingerprint, IfaceDecl)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd) (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)

-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept
-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
-- refers to it; we can't decide to keep it by looking at the exports
-- of a module after thinning.  Keep this synchronized with
-- 'rnIfaceDecl'.
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs d :: IfaceDecl
d@IfaceFamily{} =
    case IfaceDecl -> IfaceFamTyConFlav
ifFamFlav IfaceDecl
d of
        IfaceClosedSynFamilyTyCon (Just (Name
n, [IfaceAxBranch]
_))
            -> [Name
n]
        IfaceFamTyConFlav
_   -> []
ifaceDeclNeverExportedRefs IfaceDecl
_ = []


-- Note [Blank hsigs for all requirements]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- One invariant that a client of GHC must uphold is that there
-- must be an hsig file for every requirement (according to
-- @-this-unit-id@); this ensures that for every interface
-- file (hi), there is a source file (hsig), which helps grease
-- the wheels of recompilation avoidance which assumes that
-- source files always exist.

{-
inheritedSigPvpWarning :: WarningTxt
inheritedSigPvpWarning =
    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
  where
    msg = "Inherited requirements from non-signature libraries (libraries " ++
          "with modules) should not be used, as this mode of use is not " ++
          "compatible with PVP-style version bounds.  Instead, copy the " ++
          "declaration to the local hsig file or move the signature to a " ++
          "library of its own and add that library as a dependency."
-}

-- Note [Handling never-exported TyThings under Backpack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
--   never be mentioned in the export list of a module (mi_avails).
--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
--   TyThings DO have a standalone IfaceDecl declaration in their
--   interface file.
--
-- Originally, Backpack was designed under the assumption that anything
-- you could declare in a module could also be exported; thus, merging
-- the export lists of two signatures is just merging the declarations
-- of two signatures writ small.  Of course, in GHC Haskell, there are a
-- few important things which are not explicitly exported but still can
-- be used:  in particular, dictionary functions for instances, Typeable
-- TyCon bindings, and coercion axioms for type families also count.
--
-- When handling these non-exported things, there two primary things
-- we need to watch out for:
--
--  * Signature matching/merging is done by comparing each
--    of the exported entities of a signature and a module.  These exported
--    entities may refer to non-exported TyThings which must be tested for
--    consistency.  For example, an instance (ClsInst) will refer to a
--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the
--    embedded 'DFunId' in 'is_dfun'.
--
--    For this to work at all, we must ensure that pointers in 'is_dfun' refer
--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
--    Unfortunately, this is the OPPOSITE of how we treat most other references
--    to 'Name's, so this case needs to be handled specially.
--
--    The details are in the documentation for 'typecheckIfacesForMerging'.
--    and the Note [Resolving never-exported Names] in GHC.IfaceToCore.
--
--  * When we rename modules and signatures, we use the export lists to
--    decide how the declarations should be renamed.  However, this
--    means we don't get any guidance for how to rename non-exported
--    entities.  Fortunately, we only need to rename these entities
--    *consistently*, so that 'typecheckIfacesForMerging' can wire them
--    up as needed.
--
--    The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'.
--
-- The root cause for all of these complications is the fact that these
-- logically "implicit" entities are defined indirectly in an interface
-- file.  #13151 gives a proposal to make these *truly* implicit.

merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc
merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc
merge_msg ModuleName
mod_name [] =
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while checking the local signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for consistency"
merge_msg ModuleName
mod_name [InstantiatedModule]
reqs =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while merging the signatures from" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
   Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InstantiatedModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedModule
req | InstantiatedModule
req <- [InstantiatedModule]
reqs ] SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"...and the local signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name)

-- | Given a local 'ModIface', merge all inherited requirements
-- from 'requirementMerges' into this signature, producing
-- a final 'TcGblEnv' that matches the local signature and
-- all required signatures.
mergeSignatures :: HasDebugCallStack => HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
mergeSignatures :: HasDebugCallStack =>
HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures
  (HsParsedModule { hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = L SrcSpan
loc (HsModule { hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports = Maybe (XRec GhcPs [LIE GhcPs])
mb_exports }),
                    hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files })
  TcGblEnv
orig_tcg_env ModIface
lcl_iface0 = SrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    -- The lcl_iface0 is the ModIface for the local hsig
    -- file, which is guaranteed to exist, see
    -- Note [Blank hsigs for all requirements]
    hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv

    -- Copy over some things from the original TcGblEnv that
    -- we want to preserve
    updGblEnv (\TcGblEnv
env -> TcGblEnv
env {
        -- Renamed imports/declarations are often used
        -- by programs that use the GHC API, e.g., Haddock.
        -- These won't get filled by the merging process (since
        -- we don't actually rename the parsed module again) so
        -- we need to take them directly from the previous
        -- typechecking.
        --
        -- NB: the export declarations aren't in their final
        -- form yet.  We'll fill those in when we reprocess
        -- the export declarations.
        tcg_rn_imports = tcg_rn_imports orig_tcg_env,
        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
        -- Annotations
        tcg_ann_env    = tcg_ann_env    orig_tcg_env,
        -- Documentation header and located module name
        tcg_hdr_info    = tcg_hdr_info orig_tcg_env
        -- tcg_dus?
        -- tcg_th_used           = tcg_th_used orig_tcg_env,
        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env
       }) $ do
    tcg_env <- getGblEnv

    let outer_mod  = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
    let inner_mod  = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
    let mod_name   = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
    let unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    let dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    -- STEP 1: Figure out all of the external signature interfaces
    -- we are going to merge in.
    let reqs = UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
unit_state ModuleName
mod_name

    addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do

    -- STEP 2: Read in the RAW forms of all of these interfaces
    ireq_ifaces0 <- liftIO $ forM reqs $ \(Module InstantiatedUnit
iuid ModuleName
mod_name) -> do
        let m :: Module
m = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid) ModuleName
mod_name
            im :: InstalledModule
im = (InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation Module
m)
            ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
        ((ModIface, ModLocation) -> ModIface)
-> IO (ModIface, ModLocation) -> IO ModIface
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIface, ModLocation) -> ModIface
forall a b. (a, b) -> a
fst
         (IO (ModIface, ModLocation) -> IO ModIface)
-> (IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
    -> IO (ModIface, ModLocation))
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
-> IO (ModIface, ModLocation)
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
         (IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
 -> IO ModIface)
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
-> IO ModIface
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SDoc
-> InstalledModule
-> Module
-> IsBootInterface
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
findAndReadIface HscEnv
hsc_env (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mergeSignatures") InstalledModule
im Module
m IsBootInterface
NotBoot

    -- STEP 3: Get the unrenamed exports of all these interfaces,
    -- thin it according to the export list, and do shaping on them.
    let extend_ns NameShape
nsubst [AvailInfo]
as = IO (Either HsigShapeMismatchReason NameShape)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Either HsigShapeMismatchReason NameShape)
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HsigShapeMismatchReason NameShape)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Either HsigShapeMismatchReason NameShape))
-> IO (Either HsigShapeMismatchReason NameShape)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Either HsigShapeMismatchReason NameShape)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> NameShape
-> [AvailInfo]
-> IO (Either HsigShapeMismatchReason NameShape)
extendNameShape HscEnv
hsc_env NameShape
nsubst [AvailInfo]
as
        -- This function gets run on every inherited interface, and
        -- it's responsible for:
        --
        --  1. Merging the exports of the interface into @nsubst@,
        --  2. Adding these exports to the "OK to import" set (@oks@)
        --  if they came from a package with no exposed modules
        --  (this means we won't report a PVP error in this case), and
        --  3. Thinning the interface according to an explicit export
        --  list.
        --
        gen_subst (NameShape
nsubst,OccSet
oks,[(InstantiatedModule, ModIface)]
ifaces) (imod :: InstantiatedModule
imod@(Module InstantiatedUnit
iuid ModuleName
_), ModIface
ireq_iface) = do
            let insts :: GenInstantiations UnitId
insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
iuid
                isFromSignaturePackage :: Bool
isFromSignaturePackage =
                    let inst_uid :: UnitId
inst_uid = InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
iuid
                        pkg :: UnitInfo
pkg = HasDebugCallStack => UnitState -> UnitId -> UnitInfo
UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
unit_state UnitId
inst_uid
                    in [(ModuleName, Maybe Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnitInfo -> [(ModuleName, Maybe Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg)
            -- 3(a). Rename the exports according to how the dependency
            -- was instantiated.  The resulting export list will be accurate
            -- except for exports *from the signature itself* (which may
            -- be subsequently updated by exports from other signatures in
            -- the merge.
            as1 <- GenInstantiations UnitId -> ModIface -> TcM [AvailInfo]
tcRnModExports GenInstantiations UnitId
insts ModIface
ireq_iface
            -- 3(b). Thin the interface if it comes from a signature package.
            (thinned_iface, as2) <- case mb_exports of
                    Just (L EpAnn AnnList
loc [GenLocated SrcSpanAnnA (IE GhcPs)]
_)
                      -- Check if the package containing this signature is
                      -- a signature package (i.e., does not expose any
                      -- modules.)  If so, we can thin it.
                      | Bool
isFromSignaturePackage
                      -> EpAnn AnnList
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn AnnList
loc (IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
 -> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a b. (a -> b) -> a -> b
$ do
                        -- Suppress missing errors; they might be used to refer
                        -- to entities from other signatures we are merging in.
                        -- If an identifier truly doesn't exist in any of the
                        -- signatures that are merged in, we will discover this
                        -- when we run exports_from_avail on the final merged
                        -- export list.
                        (mb_r, msgs) <- TcRn
  (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
   [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
-> TcRn
     (Maybe
        (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
         [AvailInfo], ExportWarnNames (GhcPass 'Renamed)),
      Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (TcRn
   (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
    [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
 -> TcRn
      (Maybe
         (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
          [AvailInfo], ExportWarnNames (GhcPass 'Renamed)),
       Messages TcRnMessage))
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
-> TcRn
     (Maybe
        (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
         [AvailInfo], ExportWarnNames (GhcPass 'Renamed)),
      Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$ do
                            -- Suppose that we have written in a signature:
                            --  signature A ( module A ) where {- empty -}
                            -- If I am also inheriting a signature from a
                            -- signature package, does 'module A' scope over
                            -- all of its exports?
                            --
                            -- There are two possible interpretations:
                            --
                            --  1. For non self-reexports, a module reexport
                            --  is interpreted only in terms of the local
                            --  signature module, and not any of the inherited
                            --  ones.  The reason for this is because after
                            --  typechecking, module exports are completely
                            --  erased from the interface of a file, so we
                            --  have no way of "interpreting" a module reexport.
                            --  Thus, it's only useful for the local signature
                            --  module (where we have a useful GlobalRdrEnv.)
                            --
                            --  2. On the other hand, a common idiom when
                            --  you want to "export everything, plus a reexport"
                            --  in modules is to say module A ( module A, reex ).
                            --  This applies to signature modules too; and in
                            --  particular, you probably still want the entities
                            --  from the inherited signatures to be preserved
                            --  too.
                            --
                            -- We think it's worth making a special case for
                            -- self reexports to make use case (2) work.  To
                            -- do this, we take the exports of the inherited
                            -- signature @as1@, and bundle them into a
                            -- GlobalRdrEnv where we treat them as having come
                            -- from the import @import A@.  Thus, we will
                            -- pick them up if they are referenced explicitly
                            -- (@foo@) or even if we do a module reexport
                            -- (@module A@).
                            let ispec :: ImportSpec
ispec = ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec{
                                            -- NB: This needs to be mod name
                                            -- of the local signature, not
                                            -- the (original) module name of
                                            -- the inherited signature,
                                            -- because we need module
                                            -- LocalSig (from the local
                                            -- export list) to match it!
                                            is_mod :: Module
is_mod      = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
ireq_iface,
                                            is_as :: ModuleName
is_as       = ModuleName
mod_name,
                                            is_pkg_qual :: PkgQual
is_pkg_qual = PkgQual
NoPkgQual,
                                            is_qual :: Bool
is_qual     = Bool
False,
                                            is_isboot :: IsBootInterface
is_isboot   = IsBootInterface
NotBoot,
                                            is_dloc :: SrcSpan
is_dloc     = EpAnn AnnList -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn AnnList
loc
                                          } ImpItemSpec
ImpAll
                                rdr_env :: GlobalRdrEnv
rdr_env = [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
mkGlobalRdrEnv ([GlobalRdrEltX GREInfo] -> GlobalRdrEnv)
-> [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrEltX GREInfo]
gresFromAvails HscEnv
hsc_env (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
ispec) [AvailInfo]
as1
                            TcGblEnv
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
                                tcg_rdr_env = rdr_env
                            } (TcRn
   (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
    [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
 -> TcRn
      (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
       [AvailInfo], ExportWarnNames (GhcPass 'Renamed)))
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ Maybe (LocatedL [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> TcRn
     (Maybe [(LIE (GhcPass 'Renamed), DefaultEnv, [AvailInfo])],
      [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
exports_from_avail Maybe (XRec GhcPs [LIE GhcPs])
Maybe (LocatedL [LIE GhcPs])
mb_exports GlobalRdrEnv
rdr_env
                                    -- NB: tcg_imports is also empty!
                                    ImportAvails
emptyImportAvails
                                    (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env)
                        case mb_r of
                            Just (Maybe
  [(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), DefaultEnv,
    [AvailInfo])]
_, [AvailInfo]
as2, ExportWarnNames (GhcPass 'Renamed)
_) -> (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AvailInfo] -> ModIface -> ModIface
thinModIface [AvailInfo]
as2 ModIface
ireq_iface, [AvailInfo]
as2)
                            Maybe
  (Maybe
     [(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), DefaultEnv,
       [AvailInfo])],
   [AvailInfo], ExportWarnNames (GhcPass 'Renamed))
Nothing -> Messages TcRnMessage -> TcRn ()
addMessages Messages TcRnMessage
msgs TcRn ()
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall env a. IOEnv env a
failM
                    -- We can't thin signatures from non-signature packages
                    Maybe (XRec GhcPs [LIE GhcPs])
_ -> (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
ireq_iface, [AvailInfo]
as1)
            -- 3(c). Only identifiers from signature packages are "ok" to
            -- import (that is, they are safe from a PVP perspective.)
            -- (NB: This code is actually dead right now.)
            let oks' | Bool
isFromSignaturePackage
                     = OccSet -> [OccName] -> OccSet
extendOccSetList OccSet
oks ([AvailInfo] -> [OccName]
exportOccs [AvailInfo]
as2)
                     | Bool
otherwise
                     = OccSet
oks
            -- 3(d). Extend the name substitution (performing shaping)
            mb_r <- extend_ns nsubst as2
            case mb_r of
                Left HsigShapeMismatchReason
err -> TcRnMessage
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(InstantiatedModule, ModIface)])
forall a. TcRnMessage -> TcM a
failWithTc (HsigShapeMismatchReason -> TcRnMessage
TcRnHsigShapeMismatch HsigShapeMismatchReason
err)
                Right NameShape
nsubst' -> (NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(InstantiatedModule, ModIface)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NameShape
nsubst',OccSet
oks',(InstantiatedModule
imod, ModIface
thinned_iface)(InstantiatedModule, ModIface)
-> [(InstantiatedModule, ModIface)]
-> [(InstantiatedModule, ModIface)]
forall a. a -> [a] -> [a]
:[(InstantiatedModule, ModIface)]
ifaces)
        nsubst0 = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
inner_mod) (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
lcl_iface0)
        ok_to_use0 = [OccName] -> OccSet
mkOccSet ([AvailInfo] -> [OccName]
exportOccs (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
lcl_iface0))
    -- Process each interface, getting the thinned interfaces as well as
    -- the final, full set of exports @nsubst@ and the exports which are
    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
    (nsubst, ok_to_use, rev_thinned_ifaces)
        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
    let thinned_ifaces = [(InstantiatedModule, ModIface)]
-> [(InstantiatedModule, ModIface)]
forall a. [a] -> [a]
reverse [(InstantiatedModule, ModIface)]
rev_thinned_ifaces
        exports        = NameShape -> [AvailInfo]
nameShapeExports NameShape
nsubst
        rdr_env        = [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
mkGlobalRdrEnv (HscEnv
-> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrEltX GREInfo]
gresFromAvails HscEnv
hsc_env Maybe ImportSpec
forall a. Maybe a
Nothing [AvailInfo]
exports)
        _warn_occs     = (OccName -> Bool) -> [OccName] -> [OccName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (OccName -> Bool) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> OccSet -> Bool
`elemOccSet` OccSet
ok_to_use)) ([AvailInfo] -> [OccName]
exportOccs [AvailInfo]
exports)
        warns          = Warnings p
forall p. Warnings p
emptyWarn
        {-
        -- TODO: Warnings are transitive, but this is not what we want here:
        -- if a module reexports an entity from a signature, that should be OK.
        -- Not supported in current warning framework
        warns | null warn_occs = NoWarnings
              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
        -}
    setGblEnv tcg_env {
        -- The top-level GlobalRdrEnv is quite interesting.  It consists
        -- of two components:
        --  1. First, we reuse the GlobalRdrEnv of the local signature.
        --     This is very useful, because it means that if we have
        --     to print a message involving some entity that the local
        --     signature imported, we'll qualify it accordingly.
        --  2. Second, we need to add all of the declarations we are
        --     going to merge in (as they need to be in scope for the
        --     final test of the export list.)
        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
        -- Inherit imports from the local signature, so that module
        -- reexports are picked up correctly
        tcg_imports = tcg_imports orig_tcg_env,
        tcg_exports = exports,
        tcg_dus     = usesOnly (availsToNameSet exports),
        tcg_warns   = warns
        } $ do
    tcg_env <- getGblEnv

    -- Make sure we didn't refer to anything that doesn't actually exist
    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
    (mb_lies, _, _) <- exports_from_avail mb_exports rdr_env
                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)

    {- -- NB: This is commented out, because warns above is disabled.
    -- If you tried to explicitly export an identifier that has a warning
    -- attached to it, that's probably a mistake.  Warn about it.
    case mb_lies of
      Nothing -> return ()
      Just lies ->
        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
          setSrcSpan loc $
            unless (nameOccName n `elemOccSet` ok_to_use) $
                addWarn NoReason $ vcat [
                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
                    ]
    -}

    failIfErrsM

    -- Save the exports
    let drop_defaults (a
spans, b
_defaults, b
avails) = (a
spans, b
avails)
    setGblEnv tcg_env { tcg_rn_exports = map drop_defaults <$> mb_lies } $ do
    tcg_env <- getGblEnv

    let home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env

    -- STEP 4: Rename the interfaces
    ext_ifaces <- forM thinned_ifaces $ \((Module InstantiatedUnit
iuid ModuleName
_), ModIface
ireq_iface) ->
        GenInstantiations UnitId
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface (InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
iuid) (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
ireq_iface
    lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0
    let ifaces = ModIface
lcl_iface ModIface -> [ModIface] -> [ModIface]
forall a. a -> [a] -> [a]
: [ModIface]
ext_ifaces

    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
    let fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrEltX GREInfo
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
                            | (OccName
occ, Fixity
f) <- (ModIface -> [(OccName, Fixity)])
-> [ModIface] -> [(OccName, Fixity)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities [ModIface]
ifaces
                            , GlobalRdrEltX GREInfo
rdr_elt <- GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
rdr_env (OccName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. OccName -> WhichGREs info -> LookupGRE info
LookupOccName OccName
occ WhichGREs GREInfo
AllRelevantGREs) ]

    -- STEP 5: Typecheck the interfaces
    let type_env_var = TcGblEnv -> KnotVars (IORef TypeEnv)
tcg_type_env_var TcGblEnv
tcg_env

    -- typecheckIfacesForMerging does two things:
    --      1. It merges the all of the ifaces together, and typechecks the
    --      result to type_env.
    --      2. It typechecks each iface individually, but with their 'Name's
    --      resolving to the merged type_env from (1).
    -- See typecheckIfacesForMerging for more details.
    (type_env, detailss) <- initIfaceTcRn $
                            typecheckIfacesForMerging inner_mod ifaces type_env_var
    let infos = [ModIface] -> [ModDetails] -> [(ModIface, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModIface]
ifaces [ModDetails]
detailss

    -- Test for cycles
    checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) []

    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
    -- detailss, and given a Name that doesn't correspond to anything real.  See
    -- also Note [Signature merging DFuns]

    -- Add the merged type_env to TcGblEnv, so that it gets serialized
    -- out when we finally write out the interface.
    --
    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
    -- rather than use tcExtendGlobalEnv (the normal method to add newly
    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these
    -- TyThings to 'tcg_type_env_var', which is consulted when
    -- we read in interfaces to tie the knot.  But *these TyThings themselves
    -- come from interface*, so that would result in deadlock.  Don't
    -- update it!
    setGblEnv tcg_env {
        tcg_tcs = typeEnvTyCons type_env,
        tcg_patsyns = typeEnvPatSyns type_env,
        tcg_type_env = type_env,
        tcg_fix_env = fix_env
        } $ do
    tcg_env <- getGblEnv

    -- STEP 6: Check for compatibility/merge things
    tcg_env <- (\TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
x -> (TcGblEnv
 -> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcGblEnv
-> [(ModIface, ModDetails)]
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
x TcGblEnv
tcg_env [(ModIface, ModDetails)]
infos)
             $ \TcGblEnv
tcg_env (ModIface
iface, ModDetails
details) -> do

        let check_export :: Name -> TcRn ()
check_export Name
name
              | Just TyThing
sig_thing <- TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModDetails -> TypeEnv
md_types ModDetails
details) Name
name
              = case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
type_env (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
sig_thing) of
                  Just TyThing
thing -> ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
iface TyThing
sig_thing TyThing
thing
                  Maybe TyThing
Nothing -> String -> TcRn ()
forall a. HasCallStack => String -> a
panic String
"mergeSignatures: check_export"
              -- Oops! We're looking for this export but it's
              -- not actually in the type environment of the signature's
              -- ModDetails.
              --
              -- NB: This case happens because the we're iterating
              -- over the union of all exports, so some interfaces
              -- won't have everything.  Note that md_exports is nonsense
              -- (it's the same as exports); maybe we should fix this
              -- eventually.
              | Bool
otherwise
              = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
check_export ((AvailInfo -> Name) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map AvailInfo -> Name
availName [AvailInfo]
exports)

        -- Note [Signature merging instances]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        -- Merge instances into the global environment.  The algorithm here is
        -- dumb and simple: if an instance has exactly the same DFun type
        -- (tested by 'memberInstEnv') as an existing instance, we drop it;
        -- otherwise, we add it even, even if this would cause overlap.
        --
        -- Why don't we deduplicate instances with identical heads?  There's no
        -- good choice if they have premises:
        --
        --      instance K1 a => K (T a)
        --      instance K2 a => K (T a)
        --
        -- Why not eagerly error in this case?  The overlapping head does not
        -- necessarily mean that the instances are unimplementable: in fact,
        -- they may be implemented without overlap (if, for example, the
        -- implementing module has 'instance K (T a)'; both are implemented in
        -- this case.)  The implements test just checks that the wanteds are
        -- derivable assuming the givens.
        --
        -- Still, overlapping instances with hypotheses like above are going
        -- to be a bad deal, because instance resolution when we're typechecking
        -- against the merged signature is going to have a bad time when
        -- there are overlapping heads like this: we never backtrack, so it
        -- may be difficult to see that a wanted is derivable.  For now,
        -- we hope that we get lucky / the overlapping instances never
        -- get used, but it is not a very good situation to be in.
        --
        let merge_inst :: ([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv)
merge_inst ([ClsInst]
insts, InstEnv
inst_env) ClsInst
inst
                | InstEnv -> ClsInst -> Bool
memberInstEnv InstEnv
inst_env ClsInst
inst -- test DFun Type equality
                = ([ClsInst]
insts, InstEnv
inst_env)
                | Bool
otherwise
                -- NB: is_dfun_name inst is still nonsense here,
                -- see Note [Signature merging DFuns]
                = (ClsInst
instClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
:[ClsInst]
insts, InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
inst_env ClsInst
inst)
            ([ClsInst]
insts, InstEnv
inst_env) = (([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv))
-> ([ClsInst], InstEnv) -> [ClsInst] -> ([ClsInst], InstEnv)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv)
merge_inst
                                    (TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env, TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
tcg_env)
                                    (InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> InstEnv
md_insts ModDetails
details)
            -- Use mi_deps directly rather than calculateAvails.
            -- because a module is NOT
            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
            avails :: ImportAvails
avails = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env
            deps :: Dependencies
deps = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface
            avails_with_trans :: ImportAvails
avails_with_trans = ImportAvails -> Dependencies -> ImportAvails
addTransitiveDepInfo ImportAvails
avails Dependencies
deps

        TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
            tcg_inst_env = inst_env,
            tcg_insts    = insts,
            tcg_imports  = avails_with_trans,
            tcg_merged   =
                if outer_mod == mi_module iface
                    -- Don't add ourselves!
                    then tcg_merged tcg_env
                    else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env
            }

    -- Note [Signature merging DFuns]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- Once we know all of instances which will be defined by this merged
    -- signature, we go through each of the DFuns and rename them with a fresh,
    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
    --
    -- We can't do this fixup earlier, because we need a way to identify each
    -- source DFun (from each of the signatures we are merging in) so that
    -- when we have a ClsInst, we can pull up the correct DFun to check if
    -- the types match.
    --
    -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename
    dfun_insts <- forM (tcg_insts tcg_env) $ \ClsInst
inst -> do
        n <- Class -> TcThetaType -> SrcSpan -> TcM Name
newDFunName (ClsInst -> Class
is_cls ClsInst
inst) (ClsInst -> TcThetaType
is_tys ClsInst
inst) (Name -> SrcSpan
nameSrcSpan (ClsInst -> Name
is_dfun_name ClsInst
inst))
        let dfun = DFunId -> Name -> DFunId
setVarName (ClsInst -> DFunId
is_dfun ClsInst
inst) Name
n
        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })

    tcg_env <- return $
      tcg_env { tcg_insts    = map snd dfun_insts
              , tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) }

    addDependentFiles src_files

    return tcg_env

-- | Add on the necessary transitive information from the merged signature to
-- the 'ImportAvails' of the result of merging. This propagates the orphan instances
-- which were in the transitive closure of the signature through the merge.
addTransitiveDepInfo :: ImportAvails -- ^ From the signature resulting from the merge
                     -> Dependencies -- ^ From the original signature
                     -> ImportAvails
addTransitiveDepInfo :: ImportAvails -> Dependencies -> ImportAvails
addTransitiveDepInfo ImportAvails
avails Dependencies
deps =
  -- Avails for the merged in signature
  -- Add on transitive information from the signature but nothing else..
  -- because we do not "import" the signature.
  ImportAvails
avails { imp_orphs = imp_orphs avails ++ dep_orphs deps
         , imp_finsts = imp_finsts avails ++ dep_finsts deps
         , imp_sig_mods = imp_sig_mods avails ++ dep_sig_mods deps }

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnInstantiateSignature ::
    HscEnv -> Module -> RealSrcSpan ->
    IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature :: HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
this_mod RealSrcSpan
real_loc =
   Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signature instantiation"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
              (() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
 -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ TcRnIf TcGblEnv TcLclEnv TcGblEnv
instantiateSignature
  where
   logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

exportOccs :: [AvailInfo] -> [OccName]
exportOccs :: [AvailInfo] -> [OccName]
exportOccs = (AvailInfo -> [OccName]) -> [AvailInfo] -> [OccName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName ([Name] -> [OccName])
-> (AvailInfo -> [Name]) -> AvailInfo -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailInfo -> [Name]
availNames)

impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
impl_msg UnitState
unit_state Module
impl_mod (Module InstantiatedUnit
req_uid ModuleName
req_mod_name)
   = UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"While checking that" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
impl_mod) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"implements signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
req_mod_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
req_uid) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
dot

-- | Check if module implements a signature.  (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
checkImplements :: HasDebugCallStack => Module -> InstantiatedModule -> TcRn TcGblEnv
checkImplements :: HasDebugCallStack =>
Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
checkImplements Module
impl_mod req_mod :: InstantiatedModule
req_mod@(Module InstantiatedUnit
uid ModuleName
mod_name) = do
  hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
  let unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
      home_unit  = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      other_home_units = HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
  addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
    let insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
uid

    -- STEP 1: Load the implementing interface, and make a RdrEnv
    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',
    -- so that we treat all orphan instances it provides as visible
    -- when we verify that all instances are checked (see #12945), and so that
    -- when we eventually write out the interface we record appropriate
    -- dependency information.
    impl_iface <- initIfaceTcRn $
        loadSysInterface (text "checkImplements 1") impl_mod
    let impl_gr = [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
mkGlobalRdrEnv
                    (HscEnv
-> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrEltX GREInfo]
gresFromAvails HscEnv
hsc_env Maybe ImportSpec
forall a. Maybe a
Nothing (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
impl_iface))
        nsubst = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
impl_mod) (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
impl_iface)

    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
    -- all the instances it needs to
    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
                         (dep_orphs (mi_deps impl_iface))

    let avails = HomeUnit
-> Set UnitId
-> ModIface
-> Bool
-> IsBootInterface
-> ImportedBy
-> ImportAvails
calculateAvails HomeUnit
home_unit Set UnitId
other_home_units
                    ModIface
impl_iface Bool
False{- safe -} IsBootInterface
NotBoot ImportedBy
ImportedBySystem
        fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrEltX GREInfo
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
                            | (OccName
occ, Fixity
f) <- ModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities ModIface
impl_iface
                            , GlobalRdrEltX GREInfo
rdr_elt <- GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
impl_gr (OccName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. OccName -> WhichGREs info -> LookupGRE info
LookupOccName OccName
occ WhichGREs GREInfo
AllRelevantGREs) ]
    updGblEnv (\TcGblEnv
tcg_env -> TcGblEnv
tcg_env {
        -- Setting tcg_rdr_env to treat all exported entities from
        -- the implementing module as in scope improves error messages,
        -- as it reduces the amount of qualification we need.  Unfortunately,
        -- we still end up qualifying references to external modules
        -- (see bkpfail07 for an example); we'd need to record more
        -- information in ModIface to solve this.
        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
        -- This is here so that when we call 'lookupFixityRn' for something
        -- directly implemented by the module, we grab the right thing
        tcg_fix_env = fix_env
        }) $ do

    -- STEP 2: Load the *unrenamed, uninstantiated* interface for
    -- the ORIGINAL signature.  We are going to eventually rename it,
    -- but we must proceed slowly, because it is NOT known if the
    -- instantiation is correct.
    let sig_mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
uid) ModuleName
mod_name
        isig_mod = (InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation Module
sig_mod)
    hsc_env <- getTopEnv
    mb_isig_iface <- liftIO $ findAndReadIface hsc_env
                                               (text "checkImplements 2")
                                               isig_mod sig_mod NotBoot
    isig_iface <- case mb_isig_iface of
        Succeeded (ModIface
iface, ModLocation
_) -> ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
        Failed MissingInterfaceError
err ->
          TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$ IfaceMessage -> TcRnMessage
TcRnInterfaceError (IfaceMessage -> TcRnMessage) -> IfaceMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
          MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface MissingInterfaceError
err (InstalledModule -> InterfaceLookingFor
LookingForSig InstalledModule
isig_mod)

    -- STEP 3: Check that the implementing interface exports everything
    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
    forM_ (exportOccs (mi_exports isig_iface)) $ \OccName
occ ->
        case GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
impl_gr (OccName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. OccName -> WhichGREs info -> LookupGRE info
LookupOccName OccName
occ WhichGREs GREInfo
forall info. WhichGREs info
SameNameSpace) of
            [] -> TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ OccName -> UnitState -> Module -> TcRnMessage
TcRnHsigMissingModuleExport OccName
occ UnitState
unit_state Module
impl_mod
            [GlobalRdrEltX GREInfo]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    failIfErrsM

    -- STEP 4: Now that the export is complete, rename the interface...
    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface

    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
    -- lets us determine how top-level identifiers should be handled.)
    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface

    -- STEP 6: Check that it's sufficient
    tcg_env <- getGblEnv
    checkHsigIface tcg_env impl_gr sig_iface sig_details

    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
    -- so we write them out.
    return tcg_env {
        tcg_exports = mi_exports sig_iface
        }

-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
-- library to use the actual implementations of the relevant entities,
-- checking that the implementation matches the signature.
instantiateSignature :: TcRn TcGblEnv
instantiateSignature :: TcRnIf TcGblEnv TcLclEnv TcGblEnv
instantiateSignature = do
    hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
    tcg_env <- getGblEnv
    let outer_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
        inner_mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
        home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    -- TODO: setup the local RdrEnv so the error messages look a little better.
    -- But this information isn't stored anywhere. Should we RETYPECHECK
    -- the local one just to get the information?  Hmm...
    massert (isHomeModule home_unit outer_mod )
    massert (isHomeUnitInstantiating home_unit)
    let uid = HomeUnit -> UnitId
homeUnitInstanceOf HomeUnit
home_unit
    inner_mod `checkImplements`
        Module
            (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
            (moduleName outer_mod)