{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module TcBackpack (
    findExtraSigImports',
    findExtraSigImports,
    implicitRequirements',
    implicitRequirements,
    checkUnitId,
    tcRnCheckUnitId,
    tcRnMergeSignatures,
    mergeSignatures,
    tcRnInstantiateSignature,
    instantiateSignature,
) where

import GhcPrelude

import BasicTypes (defaultFixity)
import Packages
import TcRnExports
import DynFlags
import HsSyn
import RdrName
import TcRnMonad
import TcTyDecls
import InstEnv
import FamInstEnv
import Inst
import TcIface
import TcMType
import TcType
import TcSimplify
import LoadIface
import RnNames
import ErrUtils
import Id
import Module
import Name
import NameEnv
import NameSet
import Avail
import SrcLoc
import HscTypes
import Outputable
import Type
import FastString
import RnFixity ( lookupFixityRn )
import Maybes
import TcEnv
import Var
import IfaceSyn
import PrelNames
import qualified Data.Map as Map

import Finder
import UniqDSet
import NameShape
import TcErrors
import TcUnify
import RnModIface
import Util

import Control.Monad
import Data.List (find)

import {-# SOURCE #-} TcRnDriver

#include "HsVersions.h"

fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
fixityMisMatch real_thing :: TyThing
real_thing real_fixity :: Fixity
real_fixity sig_fixity :: Fixity
sig_fixity =
    [SDoc] -> SDoc
vcat [TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has conflicting fixities in the module",
          String -> SDoc
text "and its hsig file",
          String -> SDoc
text "Main module:" SDoc -> SDoc -> SDoc
<+> Fixity -> SDoc
ppr_fix Fixity
real_fixity,
          String -> SDoc
text "Hsig file:" SDoc -> SDoc -> SDoc
<+> Fixity -> SDoc
ppr_fix Fixity
sig_fixity]
  where
    ppr_fix :: Fixity -> SDoc
ppr_fix f :: Fixity
f =
        Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
f SDoc -> SDoc -> SDoc
<+>
        (if Fixity
f Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
defaultFixity
            then SDoc -> SDoc
parens (String -> SDoc
text "default")
            else SDoc
empty)

checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM sig_iface :: ModIface
sig_iface sig_thing :: TyThing
sig_thing real_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.
    Bool -> TyThing -> TyThing -> TcRn ()
checkBootDeclM Bool
False TyThing
sig_thing TyThing
real_thing
    Fixity
real_fixity <- Name -> RnM Fixity
lookupFixityRn Name
name
    let sig_fixity :: Fixity
sig_fixity = case ModIface -> OccName -> Maybe Fixity
mi_fix_fn ModIface
sig_iface (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) of
                        Nothing -> Fixity
defaultFixity
                        Just f :: Fixity
f -> Fixity
f
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fixity
real_fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixity
sig_fixity) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> SDoc -> TcRn ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
name)
        (TyThing -> Fixity -> Fixity -> SDoc
fixityMisMatch TyThing
real_thing Fixity
real_fixity 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 tcg_env :: TcGblEnv
tcg_env gr :: GlobalRdrEnv
gr sig_iface :: ModIface
sig_iface
  ModDetails { md_insts :: ModDetails -> [ClsInst]
md_insts = [ClsInst]
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 "checkHsigIface" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
        [ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
sig_type_env, [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
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)
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> 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. String -> a
panic ("TcRnDriver.checkHsigIface: Cannot handle family " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               "instances in hsig files yet...")
    -- Delete instances so we don't look them up when
    -- checking instance satisfiability
    -- TODO: this should not be necessary
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    TcGblEnv -> TcRn () -> TcRn ()
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env { tcg_inst_env :: InstEnv
tcg_inst_env = InstEnv
emptyInstEnv,
                        tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv
emptyFamInstEnv,
                        tcg_insts :: [ClsInst]
tcg_insts = [],
                        tcg_fam_insts :: [FamInst]
tcg_fam_insts = [] } (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
    (ClsInst -> TcRn ()) -> [ClsInst] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClsInst -> TcRn ()
check_inst [ClsInst]
sig_insts
    TcRn ()
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 (\t :: 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]
nameEnvElts 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 [ClsInst]
sig_insts
    check_export :: Name -> TcRn ()
check_export name :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dfun_names = () -> TcRn ()
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 sig_thing :: 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).
        MaybeErr SDoc TyThing
r <- Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name
        case MaybeErr SDoc TyThing
r of
          Failed err :: SDoc
err -> SDoc -> TcRn ()
addErr SDoc
err
          Succeeded real_thing :: 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.
      | [GRE { gre_name :: GlobalRdrElt -> Name
gre_name = Name
name' }] <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
gr (Name -> OccName
nameOccName Name
name) =
        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 SrcSpan (IE GhcRn) -> Bool
p (L _ ie :: IE GhcRn
ie) = Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IE GhcRn -> [IdP GhcRn]
forall pass. IE pass -> [IdP pass]
ieNames IE GhcRn
ie
                loc :: SrcSpan
loc = case TcGblEnv -> Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
tcg_rn_exports TcGblEnv
tcg_env of
                       Just es :: [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
es | Just e :: GenLocated SrcSpan (IE GhcRn)
e <- (GenLocated SrcSpan (IE GhcRn) -> Bool)
-> [GenLocated SrcSpan (IE GhcRn)]
-> Maybe (GenLocated SrcSpan (IE GhcRn))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find GenLocated SrcSpan (IE GhcRn) -> Bool
p (((GenLocated SrcSpan (IE GhcRn), [AvailInfo])
 -> GenLocated SrcSpan (IE GhcRn))
-> [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
-> [GenLocated SrcSpan (IE GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpan (IE GhcRn), [AvailInfo])
-> GenLocated SrcSpan (IE GhcRn)
forall a b. (a, b) -> a
fst [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
es)
                         -- TODO: maybe we can be a little more
                         -- precise here and use the Located
                         -- info for the *specific* name we matched.
                         -> GenLocated SrcSpan (IE GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc GenLocated SrcSpan (IE GhcRn)
e
                       _ -> Name -> SrcSpan
nameSrcSpan Name
name
            DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc
                (DynFlags -> Bool -> Name -> Name -> SDoc
badReexportedBootThing DynFlags
dflags Bool
False Name
name Name
name')
      -- This should actually never happen, but whatever...
      | Bool
otherwise =
        SrcSpan -> SDoc -> TcRn ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
name)
            (Bool -> Name -> String -> SDoc
missingBootThing Bool
False Name
name "exported by")

-- 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 = do
    -- TODO: This could be very well generalized to support instance
    -- declarations in boot files.
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    -- NB: Have to tug on the interface, not necessarily
    -- tugged... but it didn't work?
    (Name -> TcM (MaybeErr SDoc TyThing)) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe (NameSet -> [Name]
nameSetElemsStable (ClsInst -> NameSet
orphNamesOfClsInst ClsInst
sig_inst))
    -- Based off of 'simplifyDeriv'
    let ty :: Kind
ty = Id -> Kind
idType (ClsInst -> Id
instanceDFunId ClsInst
sig_inst)
        skol_info :: SkolemInfo
skol_info = SkolemInfo
InstSkol
        -- Based off of tcSplitDFunTy
        (tvs :: [Id]
tvs, theta :: [Kind]
theta, pred :: Kind
pred) =
           case Kind -> ([Id], Kind)
tcSplitForAllTys Kind
ty of { (tvs :: [Id]
tvs, rho :: Kind
rho)   ->
           case Kind -> ([Kind], Kind)
splitFunTys Kind
rho     of { (theta :: [Kind]
theta, pred :: Kind
pred) ->
           ([Id]
tvs, [Kind]
theta, Kind
pred) }}
        origin :: CtOrigin
origin = Module -> ClsInst -> CtOrigin
InstProvidedOrigin (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env) ClsInst
sig_inst
    (skol_subst :: TCvSubst
skol_subst, tvs_skols :: [Id]
tvs_skols) <- [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVars [Id]
tvs -- Skolemize
    (tclvl :: TcLevel
tclvl,cts :: [CtEvidence]
cts) <- TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence])
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence]))
-> TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence])
forall a b. (a -> b) -> a -> b
$ do
       CtEvidence
wanted <- CtOrigin -> Maybe TypeOrKind -> Kind -> TcM CtEvidence
newWanted CtOrigin
origin
                           (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
TypeLevel)
                           (HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
skol_subst Kind
pred)
       [CtEvidence]
givens <- [Kind] -> (Kind -> TcM CtEvidence) -> TcM [CtEvidence]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Kind]
theta ((Kind -> TcM CtEvidence) -> TcM [CtEvidence])
-> (Kind -> TcM CtEvidence) -> TcM [CtEvidence]
forall a b. (a -> b) -> a -> b
$ \given :: Kind
given -> do
           CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
TypeLevel)
           let given_pred :: Kind
given_pred = HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
skol_subst Kind
given
           Id
new_ev <- Kind -> TcRnIf TcGblEnv TcLclEnv Id
forall gbl lcl. Kind -> TcRnIf gbl lcl Id
newEvVar Kind
given_pred
           CtEvidence -> TcM CtEvidence
forall (m :: * -> *) a. Monad m => a -> m a
return CtGiven :: Kind -> Id -> CtLoc -> CtEvidence
CtGiven { ctev_pred :: Kind
ctev_pred = Kind
given_pred
                          -- Doesn't matter, make something up
                          , ctev_evar :: Id
ctev_evar = Id
new_ev
                          , ctev_loc :: CtLoc
ctev_loc = CtLoc
loc
                          }
       [CtEvidence] -> TcM [CtEvidence]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CtEvidence] -> TcM [CtEvidence])
-> [CtEvidence] -> TcM [CtEvidence]
forall a b. (a -> b) -> a -> b
$ CtEvidence
wanted CtEvidence -> [CtEvidence] -> [CtEvidence]
forall a. a -> [a] -> [a]
: [CtEvidence]
givens
    WantedConstraints
unsolved <- [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
cts

    (implic :: Bag Implication
implic, _) <- TcLevel
-> SkolemInfo
-> [Id]
-> [Id]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl SkolemInfo
skol_info [Id]
tvs_skols [] WantedConstraints
unsolved
    WantedConstraints -> TcRn ()
reportAllUnsolved (Bag Implication -> WantedConstraints
mkImplicWC Bag Implication
implic)

-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
requirementMerges dflags :: DynFlags
dflags mod_name :: ModuleName
mod_name =
    [IndefModule] -> Maybe [IndefModule] -> [IndefModule]
forall a. a -> Maybe a -> a
fromMaybe [] (ModuleName -> Map ModuleName [IndefModule] -> Maybe [IndefModule]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name (PackageState -> Map ModuleName [IndefModule]
requirementContext (DynFlags -> PackageState
pkgState DynFlags
dflags)))

-- | 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 A
--          signature B
--              import A
--
--      unit q where
--          dependency p[A=<A>,B=<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 (UniqDSet ModuleName)
findExtraSigImports' :: HscEnv -> HscSource -> ModuleName -> IO (UniqDSet ModuleName)
findExtraSigImports' hsc_env :: HscEnv
hsc_env HsigFile modname :: ModuleName
modname =
    ([UniqDSet ModuleName] -> UniqDSet ModuleName)
-> IO [UniqDSet ModuleName] -> IO (UniqDSet ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UniqDSet ModuleName] -> UniqDSet ModuleName
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets ([IndefModule]
-> (IndefModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [IndefModule]
reqs ((IndefModule -> IO (UniqDSet ModuleName))
 -> IO [UniqDSet ModuleName])
-> (IndefModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall a b. (a -> b) -> a -> b
$ \(IndefModule iuid :: IndefUnitId
iuid mod_name :: ModuleName
mod_name) ->
        (HscEnv -> IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env
            (IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName))
-> (TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
    -> IfG (UniqDSet ModuleName))
-> TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
-> IfG (UniqDSet ModuleName)
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
            (TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
 -> IO (UniqDSet ModuleName))
-> TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> TcRnIf IfGblEnv () (MaybeErr SDoc (UniqDSet ModuleName))
forall gbl lcl.
SDoc
-> Module -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName))
moduleFreeHolesPrecise (String -> SDoc
text "findExtraSigImports")
                (UnitId -> ModuleName -> Module
mkModule (IndefUnitId -> UnitId
IndefiniteUnitId IndefUnitId
iuid) ModuleName
mod_name)))
  where
    reqs :: [IndefModule]
reqs = DynFlags -> ModuleName -> [IndefModule]
requirementMerges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
modname

findExtraSigImports' _ _ _ = UniqDSet ModuleName -> IO (UniqDSet ModuleName)
forall (m :: * -> *) a. Monad m => a -> m a
return UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet

-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
-- "TcRnDriver".
findExtraSigImports :: HscEnv -> HscSource -> ModuleName
                    -> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports :: HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports hsc_env :: HscEnv
hsc_env hsc_src :: HscSource
hsc_src modname :: ModuleName
modname = do
    UniqDSet ModuleName
extra_requirements <- HscEnv -> HscSource -> ModuleName -> IO (UniqDSet ModuleName)
findExtraSigImports' HscEnv
hsc_env HscSource
hsc_src ModuleName
modname
    [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Maybe FastString
forall a. Maybe a
Nothing, SrcSpanLess (Located ModuleName) -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ModuleName
SrcSpanLess (Located ModuleName)
mod_name)
           | ModuleName
mod_name <- UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ModuleName
extra_requirements ]

-- A version of 'implicitRequirements'' which is more friendly
-- for "GhcMake" and "TcRnDriver".
implicitRequirements :: HscEnv
                     -> [(Maybe FastString, Located ModuleName)]
                     -> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements :: HscEnv
-> [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements hsc_env :: HscEnv
hsc_env normal_imports :: [(Maybe FastString, Located ModuleName)]
normal_imports
  = do [ModuleName]
mns <- HscEnv
-> [(Maybe FastString, Located ModuleName)] -> IO [ModuleName]
implicitRequirements' HscEnv
hsc_env [(Maybe FastString, Located ModuleName)]
normal_imports
       [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Maybe FastString
forall a. Maybe a
Nothing, SrcSpanLess (Located ModuleName) -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ModuleName
SrcSpanLess (Located ModuleName)
mn) | ModuleName
mn <- [ModuleName]
mns ]

-- 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>], then
-- they actually also import the local requirement B.
implicitRequirements' :: HscEnv
                     -> [(Maybe FastString, Located ModuleName)]
                     -> IO [ModuleName]
implicitRequirements' :: HscEnv
-> [(Maybe FastString, Located ModuleName)] -> IO [ModuleName]
implicitRequirements' hsc_env :: HscEnv
hsc_env normal_imports :: [(Maybe FastString, Located ModuleName)]
normal_imports
  = ([[ModuleName]] -> [ModuleName])
-> IO [[ModuleName]] -> IO [ModuleName]
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
$
    [(Maybe FastString, Located ModuleName)]
-> ((Maybe FastString, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Maybe FastString, Located ModuleName)]
normal_imports (((Maybe FastString, Located ModuleName) -> IO [ModuleName])
 -> IO [[ModuleName]])
-> ((Maybe FastString, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall a b. (a -> b) -> a -> b
$ \(mb_pkg :: Maybe FastString
mb_pkg, L _ imp :: ModuleName
imp) -> do
        FindResult
found <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp Maybe FastString
mb_pkg
        case FindResult
found of
            Found _ mod :: Module
mod | DynFlags -> UnitId
thisPackage DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> UnitId
moduleUnitId Module
mod ->
                [ModuleName] -> IO [ModuleName]
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (Module -> UniqDSet ModuleName
moduleFreeHoles Module
mod))
            _ -> [ModuleName] -> IO [ModuleName]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

-- | Given a 'UnitId', 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.
--
-- INVARIANT: the UnitId is NOT a InstalledUnitId
checkUnitId :: UnitId -> TcM ()
checkUnitId :: UnitId -> TcRn ()
checkUnitId uid :: UnitId
uid = do
    case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
      (_, Just indef :: IndefUnitId
indef) ->
        let insts :: [(ModuleName, Module)]
insts = IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef in
        [(ModuleName, Module)]
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ModuleName, Module)]
insts (((ModuleName, Module) -> TcRn ()) -> TcRn ())
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(mod_name :: ModuleName
mod_name, mod :: 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
isHoleModule Module
mod)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
                UnitId -> TcRn ()
checkUnitId (Module -> UnitId
moduleUnitId Module
mod)
                TcGblEnv
_ <- Module
mod Module -> IndefModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
`checkImplements` IndefUnitId -> ModuleName -> IndefModule
IndefModule IndefUnitId
indef ModuleName
mod_name
                () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- if it's hashed, must be well-typed

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnCheckUnitId ::
    HscEnv -> UnitId ->
    IO (Messages, Maybe ())
tcRnCheckUnitId :: HscEnv -> UnitId -> IO (Messages, Maybe ())
tcRnCheckUnitId hsc_env :: HscEnv
hsc_env uid :: UnitId
uid =
   IO DynFlags
-> SDoc
-> ((Messages, Maybe ()) -> ())
-> IO (Messages, Maybe ())
-> IO (Messages, Maybe ())
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
              (String -> SDoc
text "Check unit id" SDoc -> SDoc -> SDoc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid)
              (() -> (Messages, Maybe ()) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe ()) -> IO (Messages, Maybe ()))
-> IO (Messages, Maybe ()) -> IO (Messages, Maybe ())
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRn ()
-> IO (Messages, Maybe ())
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env
          HscSource
HsigFile -- bogus
          Bool
False
          Module
mAIN -- bogus
          (RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
loc_str) 0 0)) -- bogus
    (TcRn () -> IO (Messages, Maybe ()))
-> TcRn () -> IO (Messages, Maybe ())
forall a b. (a -> b) -> a -> b
$ UnitId -> TcRn ()
checkUnitId UnitId
uid
  where
   dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
   loc_str :: String
loc_str = "Command line argument: -unit-id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
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, Maybe TcGblEnv)
tcRnMergeSignatures :: HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages, Maybe TcGblEnv)
tcRnMergeSignatures hsc_env :: HscEnv
hsc_env hpm :: HsParsedModule
hpm orig_tcg_env :: TcGblEnv
orig_tcg_env iface :: ModIface
iface =
  IO DynFlags
-> SDoc
-> ((Messages, Maybe TcGblEnv) -> ())
-> IO (Messages, Maybe TcGblEnv)
-> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
             (String -> SDoc
text "Signature merging" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
             (() -> (Messages, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv))
-> IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
  HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> IO (Messages, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures HsParsedModule
hpm TcGblEnv
orig_tcg_env ModIface
iface
 where
  dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  this_mod :: Module
this_mod = ModIface -> 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 avails :: [AvailInfo]
avails iface :: ModIface
iface =
    ModIface
iface {
        mi_exports :: [AvailInfo]
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.
        mi_decls :: [(Fingerprint, IfaceDecl)]
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 occs :: OccSet
occs decl :: IfaceDecl
decl = Name -> OccName
nameOccName (IfaceDecl -> Name
ifName IfaceDecl
decl) OccName -> OccSet -> Bool
`elemOccSet` OccSet
occs
    filter_decls :: OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls occs :: 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 -> [(Fingerprint, IfaceDecl)]
mi_decls ModIface
iface)

    exported_occs :: OccSet
exported_occs = [OccName] -> OccSet
mkOccSet [ Name -> OccName
forall name. HasOccName name => name -> OccName
occName 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
                                 | (_, d :: 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 _ = 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 -> [(Fingerprint, IfaceDecl)]
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 (n :: Name
n, _))
            -> [Name
n]
        _   -> []
ifaceDeclNeverExportedRefs _ = []


-- 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 TcIface].
--
--  * 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 'RnModIface'.
--
-- 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 -> [IndefModule] -> SDoc
merge_msg :: ModuleName -> [IndefModule] -> SDoc
merge_msg mod_name :: ModuleName
mod_name [] =
    String -> SDoc
text "while checking the local signature" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name SDoc -> SDoc -> SDoc
<+>
    String -> SDoc
text "for consistency"
merge_msg mod_name :: ModuleName
mod_name reqs :: [IndefModule]
reqs =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "while merging the signatures from" SDoc -> SDoc -> SDoc
<> SDoc
colon)
   2 ([SDoc] -> SDoc
vcat [ SDoc
bullet SDoc -> SDoc -> SDoc
<+> IndefModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr IndefModule
req | IndefModule
req <- [IndefModule]
reqs ] SDoc -> SDoc -> SDoc
$$
      SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "...and the local signature for" SDoc -> SDoc -> SDoc
<+> 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 :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
mergeSignatures :: HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures
  (HsParsedModule { hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = L loc :: SrcSpan
loc (HsModule { hsmodExports :: forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports = Maybe (Located [LIE GhcPs])
mb_exports }),
                    hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files })
  orig_tcg_env :: TcGblEnv
orig_tcg_env lcl_iface0 :: 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]
    HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
    DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    -- Copy over some things from the original TcGblEnv that
    -- we want to preserve
    (TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\env :: 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 :: [LImportDecl GhcRn]
tcg_rn_imports = TcGblEnv -> [LImportDecl GhcRn]
tcg_rn_imports TcGblEnv
orig_tcg_env,
        tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls   = TcGblEnv -> Maybe (HsGroup GhcRn)
tcg_rn_decls   TcGblEnv
orig_tcg_env,
        -- Annotations
        tcg_ann_env :: AnnEnv
tcg_ann_env    = TcGblEnv -> AnnEnv
tcg_ann_env    TcGblEnv
orig_tcg_env,
        -- Documentation header
        tcg_doc_hdr :: Maybe LHsDocString
tcg_doc_hdr    = TcGblEnv -> Maybe LHsDocString
tcg_doc_hdr TcGblEnv
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
        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env
       }) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

    let outer_mod :: Module
outer_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
        inner_mod :: Module
inner_mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
        mod_name :: ModuleName
mod_name = Module -> ModuleName
moduleName (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env)

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

    SDoc
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ModuleName -> [IndefModule] -> SDoc
merge_msg ModuleName
mod_name [IndefModule]
reqs) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do

    -- STEP 2: Read in the RAW forms of all of these interfaces
    [ModIface]
ireq_ifaces0 <- [IndefModule]
-> (IndefModule -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [IndefModule]
reqs ((IndefModule -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
 -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface])
-> (IndefModule -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a b. (a -> b) -> a -> b
$ \(IndefModule iuid :: IndefUnitId
iuid mod_name :: ModuleName
mod_name) ->
        let m :: Module
m = UnitId -> ModuleName -> Module
mkModule (IndefUnitId -> UnitId
IndefiniteUnitId IndefUnitId
iuid) ModuleName
mod_name
            im :: InstalledModule
im = (InstalledModule, Maybe IndefModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe IndefModule)
splitModuleInsts Module
m)
        in ((ModIface, String) -> ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, String)
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIface, String) -> ModIface
forall a b. (a, b) -> a
fst
         (IOEnv (Env TcGblEnv TcLclEnv) (ModIface, String)
 -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> (TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
    -> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, String))
-> TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, String)
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
         (TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
 -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
forall gbl lcl.
SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, String))
findAndReadIface (String -> SDoc
text "mergeSignatures") InstalledModule
im Module
m Bool
False

    -- 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
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
extend_ns nsubst :: NameShape
nsubst as :: [AvailInfo]
as = IO (Either SDoc NameShape)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SDoc NameShape)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape))
-> IO (Either SDoc NameShape)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
forall a b. (a -> b) -> a -> b
$ HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc 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, OccSet, [(IndefModule, ModIface)])
-> (IndefModule, ModIface)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(IndefModule, ModIface)])
gen_subst (nsubst :: NameShape
nsubst,oks :: OccSet
oks,ifaces :: [(IndefModule, ModIface)]
ifaces) (imod :: IndefModule
imod@(IndefModule iuid :: IndefUnitId
iuid _), ireq_iface :: ModIface
ireq_iface) = do
            let insts :: [(ModuleName, Module)]
insts = IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
iuid
                isFromSignaturePackage :: Bool
isFromSignaturePackage =
                    let inst_uid :: InstalledUnitId
inst_uid = (InstalledUnitId, Maybe IndefUnitId) -> InstalledUnitId
forall a b. (a, b) -> a
fst (UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts (IndefUnitId -> UnitId
IndefiniteUnitId IndefUnitId
iuid))
                        pkg :: PackageConfig
pkg = DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails DynFlags
dflags InstalledUnitId
inst_uid
                    in [(ModuleName, Maybe Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
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.
            [AvailInfo]
as1 <- [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
tcRnModExports [(ModuleName, Module)]
insts ModIface
ireq_iface
            -- 3(b). Thin the interface if it comes from a signature package.
            (thinned_iface :: ModIface
thinned_iface, as2 :: [AvailInfo]
as2) <- case Maybe (Located [LIE GhcPs])
mb_exports of
                    Just (L loc :: SrcSpan
loc _)
                      -- 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
                      -> SrcSpan
-> TcRn (ModIface, [AvailInfo]) -> TcRn (ModIface, [AvailInfo])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (ModIface, [AvailInfo]) -> TcRn (ModIface, [AvailInfo]))
-> TcRn (ModIface, [AvailInfo]) -> TcRn (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.
                        (msgs :: Messages
msgs, mb_r :: Maybe
  (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
mb_r) <- TcRn
  (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
-> TcRn
     (Messages,
      Maybe
        (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])],
         [AvailInfo]))
forall a. TcRn a -> TcRn (Messages, Maybe a)
tryTc (TcRn
   (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
 -> TcRn
      (Messages,
       Maybe
         (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])],
          [AvailInfo])))
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
-> TcRn
     (Messages,
      Maybe
        (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])],
         [AvailInfo]))
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 :: ModuleName -> ModuleName -> Bool -> SrcSpan -> ImpDeclSpec
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 :: ModuleName
is_mod  = ModuleName
mod_name,
                                            is_as :: ModuleName
is_as   = ModuleName
mod_name,
                                            is_qual :: Bool
is_qual = Bool
False,
                                            is_dloc :: SrcSpan
is_dloc = SrcSpan
loc
                                          } ImpItemSpec
ImpAll
                                rdr_env :: GlobalRdrEnv
rdr_env = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
ispec) [AvailInfo]
as1)
                            TcGblEnv
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
                                tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env
                            } (TcRn
   (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
 -> TcRn
      (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])],
       [AvailInfo]))
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
forall a b. (a -> b) -> a -> b
$ Maybe (Located [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
exports_from_avail Maybe (Located [LIE GhcPs])
mb_exports GlobalRdrEnv
rdr_env
                                    -- NB: tcg_imports is also empty!
                                    ImportAvails
emptyImportAvails
                                    (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env)
                        case Maybe
  (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
mb_r of
                            Just (_, as2 :: [AvailInfo]
as2) -> (ModIface, [AvailInfo]) -> TcRn (ModIface, [AvailInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([AvailInfo] -> ModIface -> ModIface
thinModIface [AvailInfo]
as2 ModIface
ireq_iface, [AvailInfo]
as2)
                            Nothing -> Messages -> TcRn ()
addMessages Messages
msgs TcRn ()
-> TcRn (ModIface, [AvailInfo]) -> TcRn (ModIface, [AvailInfo])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn (ModIface, [AvailInfo])
forall env a. IOEnv env a
failM
                    -- We can't think signatures from non signature packages
                    _ -> (ModIface, [AvailInfo]) -> TcRn (ModIface, [AvailInfo])
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' :: OccSet
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)
            Either SDoc NameShape
mb_r <- NameShape
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
extend_ns NameShape
nsubst [AvailInfo]
as2
            case Either SDoc NameShape
mb_r of
                Left err :: SDoc
err -> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(IndefModule, ModIface)])
forall a. SDoc -> TcM a
failWithTc SDoc
err
                Right nsubst' :: NameShape
nsubst' -> (NameShape, OccSet, [(IndefModule, ModIface)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(IndefModule, ModIface)])
forall (m :: * -> *) a. Monad m => a -> m a
return (NameShape
nsubst',OccSet
oks',(IndefModule
imod, ModIface
thinned_iface)(IndefModule, ModIface)
-> [(IndefModule, ModIface)] -> [(IndefModule, ModIface)]
forall a. a -> [a] -> [a]
:[(IndefModule, ModIface)]
ifaces)
        nsubst0 :: NameShape
nsubst0 = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
moduleName Module
inner_mod) (ModIface -> [AvailInfo]
mi_exports ModIface
lcl_iface0)
        ok_to_use0 :: OccSet
ok_to_use0 = [OccName] -> OccSet
mkOccSet ([AvailInfo] -> [OccName]
exportOccs (ModIface -> [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 :: NameShape
nsubst, ok_to_use :: OccSet
ok_to_use, rev_thinned_ifaces :: [(IndefModule, ModIface)]
rev_thinned_ifaces)
        <- ((NameShape, OccSet, [(IndefModule, ModIface)])
 -> (IndefModule, ModIface)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (NameShape, OccSet, [(IndefModule, ModIface)]))
-> (NameShape, OccSet, [(IndefModule, ModIface)])
-> [(IndefModule, ModIface)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(IndefModule, ModIface)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NameShape, OccSet, [(IndefModule, ModIface)])
-> (IndefModule, ModIface)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (NameShape, OccSet, [(IndefModule, ModIface)])
gen_subst (NameShape
nsubst0, OccSet
ok_to_use0, []) ([IndefModule] -> [ModIface] -> [(IndefModule, ModIface)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IndefModule]
reqs [ModIface]
ireq_ifaces0)
    let thinned_ifaces :: [(IndefModule, ModIface)]
thinned_ifaces = [(IndefModule, ModIface)] -> [(IndefModule, ModIface)]
forall a. [a] -> [a]
reverse [(IndefModule, ModIface)]
rev_thinned_ifaces
        exports :: [AvailInfo]
exports        = NameShape -> [AvailInfo]
nameShapeExports NameShape
nsubst
        rdr_env :: GlobalRdrEnv
rdr_env        = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails Maybe ImportSpec
forall a. Maybe a
Nothing [AvailInfo]
exports)
        _warn_occs :: [OccName]
_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
warns          = Warnings
NoWarnings
        {-
        -- 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
        -}
    TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
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 :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
`plusGlobalRdrEnv` TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
orig_tcg_env,
        -- Inherit imports from the local signature, so that module
        -- rexports are picked up correctly
        tcg_imports :: ImportAvails
tcg_imports = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
orig_tcg_env,
        tcg_exports :: [AvailInfo]
tcg_exports = [AvailInfo]
exports,
        tcg_dus :: DefUses
tcg_dus     = NameSet -> DefUses
usesOnly ([AvailInfo] -> NameSet
availsToNameSetWithSelectors [AvailInfo]
exports),
        tcg_warns :: Warnings
tcg_warns   = Warnings
warns
        } (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

    -- Make sure we didn't refer to anything that doesn't actually exist
    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
    (mb_lies :: Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
mb_lies, _) <- Maybe (Located [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> TcRn
     (Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])], [AvailInfo])
exports_from_avail Maybe (Located [LIE GhcPs])
mb_exports GlobalRdrEnv
rdr_env
                        (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
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.")
                    ]
    -}

    TcRn ()
failIfErrsM

    -- Save the exports
    TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env { tcg_rn_exports :: Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
tcg_rn_exports = Maybe [(GenLocated SrcSpan (IE GhcRn), [AvailInfo])]
mb_lies } (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

    -- STEP 4: Rename the interfaces
    [ModIface]
ext_ifaces <- [(IndefModule, ModIface)]
-> ((IndefModule, ModIface)
    -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IndefModule, ModIface)]
thinned_ifaces (((IndefModule, ModIface)
  -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
 -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface])
-> ((IndefModule, ModIface)
    -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a b. (a -> b) -> a -> b
$ \((IndefModule iuid :: IndefUnitId
iuid _), ireq_iface :: ModIface
ireq_iface) ->
        [(ModuleName, Module)]
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface (IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
iuid) (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
ireq_iface
    ModIface
lcl_iface <- [(ModuleName, Module)]
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags) (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
lcl_iface0
    let ifaces :: [ModIface]
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 :: NameEnv FixItem
fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
gre_name GlobalRdrElt
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
                            | (occ :: OccName
occ, f :: Fixity
f) <- (ModIface -> [(OccName, Fixity)])
-> [ModIface] -> [(OccName, Fixity)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModIface -> [(OccName, Fixity)]
mi_fixities [ModIface]
ifaces
                            , GlobalRdrElt
rdr_elt <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
occ ]

    -- STEP 5: Typecheck the interfaces
    let type_env_var :: TcRef TypeEnv
type_env_var = TcGblEnv -> TcRef 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 :: TypeEnv
type_env, detailss :: [ModDetails]
detailss) <- IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails])
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails]))
-> IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails])
forall a b. (a -> b) -> a -> b
$
                            Module
-> [ModIface] -> TcRef TypeEnv -> IfG (TypeEnv, [ModDetails])
forall lcl.
Module
-> [ModIface] -> TcRef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging Module
inner_mod [ModIface]
ifaces TcRef TypeEnv
type_env_var
    let infos :: [(ModIface, ModDetails)]
infos = [ModIface] -> [ModDetails] -> [(ModIface, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModIface]
ifaces [ModDetails]
detailss

    -- Test for cycles
    UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcRn ()
checkSynCycles (DynFlags -> UnitId
thisPackage DynFlags
dflags) (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
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!
    TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
        tcg_tcs :: [TyCon]
tcg_tcs = TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env,
        tcg_patsyns :: [PatSyn]
tcg_patsyns = TypeEnv -> [PatSyn]
typeEnvPatSyns TypeEnv
type_env,
        tcg_type_env :: TypeEnv
tcg_type_env = TypeEnv
type_env,
        tcg_fix_env :: NameEnv FixItem
tcg_fix_env = NameEnv FixItem
fix_env
        } (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

    -- STEP 6: Check for compatibility/merge things
    TcGblEnv
tcg_env <- (\x :: 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
  -> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> (TcGblEnv
    -> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ \tcg_env :: TcGblEnv
tcg_env (iface :: ModIface
iface, details :: ModDetails
details) -> do

        let check_export :: Name -> TcRn ()
check_export name :: Name
name
              | Just sig_thing :: 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 thing :: TyThing
thing -> ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
iface TyThing
sig_thing TyThing
thing
                  Nothing -> String -> TcRn ()
forall a. String -> a
panic "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 (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 (insts :: [ClsInst]
insts, inst_env :: InstEnv
inst_env) inst :: 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)
            (insts :: [ClsInst]
insts, inst_env :: InstEnv
inst_env) = (([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv))
-> ([ClsInst], InstEnv) -> [ClsInst] -> ([ClsInst], InstEnv)
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)
                                    (ModDetails -> [ClsInst]
md_insts ModDetails
details)
            -- This is a HACK to prevent calculateAvails from including imp_mod
            -- in the listing.  We don't want it because a module is NOT
            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
            iface' :: ModIface
iface' = ModIface
iface { mi_orphan :: Bool
mi_orphan = Bool
False, mi_finsts :: Bool
mi_finsts = Bool
False }
            avails :: ImportAvails
avails = ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) (ImportAvails -> ImportAvails) -> ImportAvails -> ImportAvails
forall a b. (a -> b) -> a -> b
$
                        DynFlags -> ModIface -> Bool -> Bool -> ImportedBy -> ImportAvails
calculateAvails DynFlags
dflags ModIface
iface' Bool
False Bool
False ImportedBy
ImportedBySystem
        TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
            tcg_inst_env :: InstEnv
tcg_inst_env = InstEnv
inst_env,
            tcg_insts :: [ClsInst]
tcg_insts    = [ClsInst]
insts,
            tcg_imports :: ImportAvails
tcg_imports  = ImportAvails
avails,
            tcg_merged :: [(Module, Fingerprint)]
tcg_merged   =
                if Module
outer_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModIface -> Module
mi_module ModIface
iface
                    -- Don't add ourselves!
                    then TcGblEnv -> [(Module, Fingerprint)]
tcg_merged TcGblEnv
tcg_env
                    else (ModIface -> Module
mi_module ModIface
iface, ModIface -> Fingerprint
mi_mod_hash ModIface
iface) (Module, Fingerprint)
-> [(Module, Fingerprint)] -> [(Module, Fingerprint)]
forall a. a -> [a] -> [a]
: TcGblEnv -> [(Module, Fingerprint)]
tcg_merged TcGblEnv
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 RnModIface
    [(Id, ClsInst)]
dfun_insts <- [ClsInst]
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (Id, ClsInst))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Id, ClsInst)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env) ((ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (Id, ClsInst))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Id, ClsInst)])
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (Id, ClsInst))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Id, ClsInst)]
forall a b. (a -> b) -> a -> b
$ \inst :: ClsInst
inst -> do
        Name
n <- Class -> [Kind] -> SrcSpan -> TcM Name
newDFunName (ClsInst -> Class
is_cls ClsInst
inst) (ClsInst -> [Kind]
is_tys ClsInst
inst) (Name -> SrcSpan
nameSrcSpan (ClsInst -> Name
is_dfun_name ClsInst
inst))
        let dfun :: Id
dfun = Id -> Name -> Id
setVarName (ClsInst -> Id
is_dfun ClsInst
inst) Name
n
        (Id, ClsInst) -> IOEnv (Env TcGblEnv TcLclEnv) (Id, ClsInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
dfun, ClsInst
inst { is_dfun_name :: Name
is_dfun_name = Name
n, is_dfun :: Id
is_dfun = Id
dfun })
    TcGblEnv
tcg_env <- TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
            tcg_insts :: [ClsInst]
tcg_insts = ((Id, ClsInst) -> ClsInst) -> [(Id, ClsInst)] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map (Id, ClsInst) -> ClsInst
forall a b. (a, b) -> b
snd [(Id, ClsInst)]
dfun_insts,
            tcg_type_env :: TypeEnv
tcg_type_env = TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env) (((Id, ClsInst) -> Id) -> [(Id, ClsInst)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, ClsInst) -> Id
forall a b. (a, b) -> a
fst [(Id, ClsInst)]
dfun_insts)
        }

    [String] -> TcRn ()
addDependentFiles [String]
src_files

    TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnInstantiateSignature ::
    HscEnv -> Module -> RealSrcSpan ->
    IO (Messages, Maybe TcGblEnv)
tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages, Maybe TcGblEnv)
tcRnInstantiateSignature hsc_env :: HscEnv
hsc_env this_mod :: Module
this_mod real_loc :: RealSrcSpan
real_loc =
   IO DynFlags
-> SDoc
-> ((Messages, Maybe TcGblEnv) -> ())
-> IO (Messages, Maybe TcGblEnv)
-> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
              (String -> SDoc
text "Signature instantiation"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
              (() -> (Messages, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv))
-> IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> IO (Messages, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ TcRnIf TcGblEnv TcLclEnv TcGblEnv
instantiateSignature
  where
   dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags 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
forall name. HasOccName name => name -> OccName
occName ([Name] -> [OccName])
-> (AvailInfo -> [Name]) -> AvailInfo -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailInfo -> [Name]
availNames)

impl_msg :: Module -> IndefModule -> SDoc
impl_msg :: Module -> IndefModule -> SDoc
impl_msg impl_mod :: Module
impl_mod (IndefModule req_uid :: IndefUnitId
req_uid req_mod_name :: ModuleName
req_mod_name) =
  String -> SDoc
text "while checking that" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
impl_mod SDoc -> SDoc -> SDoc
<+>
  String -> SDoc
text "implements signature" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
req_mod_name SDoc -> SDoc -> SDoc
<+>
  String -> SDoc
text "in" SDoc -> SDoc -> SDoc
<+> IndefUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr IndefUnitId
req_uid

-- | Check if module implements a signature.  (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
checkImplements :: Module -> IndefModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
checkImplements impl_mod :: Module
impl_mod req_mod :: IndefModule
req_mod@(IndefModule uid :: IndefUnitId
uid mod_name :: ModuleName
mod_name) =
  SDoc
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Module -> IndefModule -> SDoc
impl_msg Module
impl_mod IndefModule
req_mod) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
    let insts :: [(ModuleName, Module)]
insts = IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
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.
    ModIface
impl_iface <- IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$
        SDoc -> Module -> IfG ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface (String -> SDoc
text "checkImplements 1") Module
impl_mod
    let impl_gr :: GlobalRdrEnv
impl_gr = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv
                    (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails Maybe ImportSpec
forall a. Maybe a
Nothing (ModIface -> [AvailInfo]
mi_exports ModIface
impl_iface))
        nsubst :: NameShape
nsubst = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
moduleName Module
impl_mod) (ModIface -> [AvailInfo]
mi_exports ModIface
impl_iface)

    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
    -- all the instances it needs to
    SDoc -> [Module] -> TcRn ()
loadModuleInterfaces (String -> SDoc
text "Loading orphan modules (from implementor of hsig)")
                         (Dependencies -> [Module]
dep_orphs (ModIface -> Dependencies
mi_deps ModIface
impl_iface))

    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let avails :: ImportAvails
avails = DynFlags -> ModIface -> Bool -> Bool -> ImportedBy -> ImportAvails
calculateAvails DynFlags
dflags
                    ModIface
impl_iface Bool
False{- safe -} Bool
False{- boot -} ImportedBy
ImportedBySystem
        fix_env :: NameEnv FixItem
fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
gre_name GlobalRdrElt
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
                            | (occ :: OccName
occ, f :: Fixity
f) <- ModIface -> [(OccName, Fixity)]
mi_fixities ModIface
impl_iface
                            , GlobalRdrElt
rdr_elt <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
impl_gr OccName
occ ]
    (TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\tcg_env :: 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 :: GlobalRdrEnv
tcg_rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcg_env GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
`plusGlobalRdrEnv` GlobalRdrEnv
impl_gr,
        tcg_imports :: ImportAvails
tcg_imports = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
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 :: NameEnv FixItem
tcg_fix_env = NameEnv FixItem
fix_env
        }) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ 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 :: Module
sig_mod = UnitId -> ModuleName -> Module
mkModule (IndefUnitId -> UnitId
IndefiniteUnitId IndefUnitId
uid) ModuleName
mod_name
        isig_mod :: InstalledModule
isig_mod = (InstalledModule, Maybe IndefModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe IndefModule)
splitModuleInsts Module
sig_mod)
    MaybeErr SDoc (ModIface, String)
mb_isig_iface <- SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf TcGblEnv TcLclEnv (MaybeErr SDoc (ModIface, String))
forall gbl lcl.
SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, String))
findAndReadIface (String -> SDoc
text "checkImplements 2") InstalledModule
isig_mod Module
sig_mod Bool
False
    ModIface
isig_iface <- case MaybeErr SDoc (ModIface, String)
mb_isig_iface of
        Succeeded (iface :: ModIface
iface, _) -> ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
        Failed err :: SDoc
err -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. SDoc -> TcM a
failWithTc (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$
            SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Could not find hi interface for signature" SDoc -> SDoc -> SDoc
<+>
                  SDoc -> SDoc
quotes (InstalledModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledModule
isig_mod) SDoc -> SDoc -> SDoc
<> SDoc
colon) 4 SDoc
err

    -- STEP 3: Check that the implementing interface exports everything
    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
    [OccName] -> (OccName -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([AvailInfo] -> [OccName]
exportOccs (ModIface -> [AvailInfo]
mi_exports ModIface
isig_iface)) ((OccName -> TcRn ()) -> TcRn ())
-> (OccName -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \occ :: OccName
occ ->
        case GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
impl_gr OccName
occ of
            [] -> SDoc -> TcRn ()
addErr (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is exported by the hsig file, but not"
                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "exported by the implementing module"
                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
impl_mod)
            _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TcRn ()
failIfErrsM

    -- STEP 4: Now that the export is complete, rename the interface...
    ModIface
sig_iface <- [(ModuleName, Module)]
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface [(ModuleName, Module)]
insts (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
isig_iface

    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
    -- lets us determine how top-level identifiers should be handled.)
    ModDetails
sig_details <- IfG ModDetails -> TcRn ModDetails
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG ModDetails -> TcRn ModDetails)
-> IfG ModDetails -> TcRn ModDetails
forall a b. (a -> b) -> a -> b
$ NameShape -> ModIface -> IfG ModDetails
forall lcl. NameShape -> ModIface -> IfM lcl ModDetails
typecheckIfaceForInstantiate NameShape
nsubst ModIface
sig_iface

    -- STEP 6: Check that it's sufficient
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface TcGblEnv
tcg_env GlobalRdrEnv
impl_gr ModIface
sig_iface ModDetails
sig_details

    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
    -- so we write them out.
    TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
        tcg_exports :: [AvailInfo]
tcg_exports = ModIface -> [AvailInfo]
mi_exports ModIface
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
    TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let outer_mod :: Module
outer_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
        inner_mod :: Module
inner_mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_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( moduleUnitId outer_mod == thisPackage dflags )
    Module
inner_mod Module -> IndefModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
`checkImplements`
        IndefUnitId -> ModuleName -> IndefModule
IndefModule
            (ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId (DynFlags -> ComponentId
thisComponentId DynFlags
dflags)
                            (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags))
            (Module -> ModuleName
moduleName Module
outer_mod)