TcBackpack.hs 34.4 KB
Newer Older
Edward Z. Yang's avatar
Edward Z. Yang committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TcBackpack (
    findExtraSigImports',
    findExtraSigImports,
    implicitRequirements',
    implicitRequirements,
    checkUnitId,
    tcRnCheckUnitId,
    tcRnMergeSignatures,
    mergeSignatures,
    tcRnInstantiateSignature,
    instantiateSignature,
) where

19
import BasicTypes (StringLiteral(..), SourceText(..), defaultFixity)
Edward Z. Yang's avatar
Edward Z. Yang committed
20
import Packages
21
import TcRnExports
Edward Z. Yang's avatar
Edward Z. Yang committed
22
23
24
25
import DynFlags
import HsSyn
import RdrName
import TcRnMonad
26
import TcTyDecls
Edward Z. Yang's avatar
Edward Z. Yang committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
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
48
import RnEnv
Edward Z. Yang's avatar
Edward Z. Yang committed
49
50
51
import Maybes
import TcEnv
import Var
52
import IfaceSyn
Edward Z. Yang's avatar
Edward Z. Yang committed
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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, foldl')

import {-# SOURCE #-} TcRnDriver

#include "HsVersions.h"

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
fixityMisMatch real_thing real_fixity sig_fixity =
    vcat [ppr real_thing <+> text "has conflicting fixities in the module",
          text "and its hsig file",
          text "Main module:" <+> ppr_fix real_fixity,
          text "Hsig file:" <+> ppr_fix sig_fixity]
  where
    ppr_fix f =
        ppr f <+>
        (if f == defaultFixity
            then parens (text "default")
            else empty)

checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM sig_iface sig_thing real_thing = do
    let name = getName real_thing
    -- TODO: Distinguish between signature merging and signature
    -- implementation cases.
    checkBootDeclM False sig_thing real_thing
    real_fixity <- lookupFixityRn name
    let sig_fixity = case mi_fix_fn sig_iface (occName name) of
                        Nothing -> defaultFixity
                        Just f -> f
    when (real_fixity /= sig_fixity) $
      addErrAt (nameSrcSpan name)
        (fixityMisMatch real_thing real_fixity sig_fixity)

Edward Z. Yang's avatar
Edward Z. Yang committed
98
99
100
101
102
103
104
105
106
-- | 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.
107
108
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface tcg_env gr sig_iface
Edward Z. Yang's avatar
Edward Z. Yang committed
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
               md_types = sig_type_env, md_exports = sig_exports   } = do
    traceTc "checkHsigIface" $ vcat
        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
    mapM_ check_export (map availName sig_exports)
    unless (null sig_fam_insts) $
        panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
               "instances in hsig files yet...")
    -- Delete instances so we don't look them up when
    -- checking instance satisfiability
    -- TODO: this should not be necessary
    tcg_env <- getGblEnv
    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
                        tcg_fam_inst_env = emptyFamInstEnv,
                        tcg_insts = [],
                        tcg_fam_insts = [] } $ do
    mapM_ check_inst sig_insts
    failIfErrsM
  where
    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
    -- in package p that defines T; and we implement with himpl:H.  Then the
    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
    -- have to look up the right name.
    sig_type_occ_env = mkOccEnv
                     . map (\t -> (nameOccName (getName t), t))
                     $ nameEnvElts sig_type_env
    dfun_names = map getName sig_insts
    check_export name
      -- Skip instances, we'll check them later
138
139
      -- TODO: Actually this should never happen, because DFuns are
      -- never exported...
Edward Z. Yang's avatar
Edward Z. Yang committed
140
141
142
143
144
145
146
147
148
      | name `elem` dfun_names = return ()
      -- See if we can find the type directly in the hsig ModDetails
      -- TODO: need to special case wired in names
      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
        -- tcg_env (TODO: but maybe this isn't relevant anymore).
        r <- tcLookupImported_maybe name
        case r of
          Failed err -> addErr err
149
150
          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing

Edward Z. Yang's avatar
Edward Z. Yang committed
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
      -- 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 = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
        when (name /= name') $ do
            -- See Note [Error reporting bad reexport]
            -- TODO: Actually this error swizzle doesn't work
            let p (L _ ie) = name `elem` ieNames ie
                loc = case tcg_rn_exports tcg_env of
                       Just es | Just e <- find p es
                         -- TODO: maybe we can be a little more
                         -- precise here and use the Located
                         -- info for the *specific* name we matched.
                         -> getLoc e
                       _ -> nameSrcSpan name
            addErrAt loc
                (badReexportedBootThing False name name')
      -- This should actually never happen, but whatever...
      | otherwise =
        addErrAt (nameSrcSpan name)
            (missingBootThing False 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 sig_inst = do
    -- TODO: This could be very well generalized to support instance
    -- declarations in boot files.
    tcg_env <- getGblEnv
    -- NB: Have to tug on the interface, not necessarily
    -- tugged... but it didn't work?
    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
    -- Based off of 'simplifyDeriv'
    let ty = idType (instanceDFunId sig_inst)
        skol_info = InstSkol
        -- Based off of tcSplitDFunTy
        (tvs, theta, pred) =
           case tcSplitForAllTys ty of { (tvs, rho)   ->
           case splitFunTys rho     of { (theta, pred) ->
           (tvs, theta, pred) }}
        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
    (cts, tclvl) <- pushTcLevelM $ do
       wanted <- newWanted origin
                           (Just TypeLevel)
                           (substTy skol_subst pred)
       givens <- forM theta $ \given -> do
           loc <- getCtLocM origin (Just TypeLevel)
           let given_pred = substTy skol_subst given
           new_ev <- newEvVar given_pred
           return CtGiven { ctev_pred = given_pred
                          -- Doesn't matter, make something up
                          , ctev_evar = new_ev
                          , ctev_loc = loc
                          }
       return $ wanted : givens
    unsolved <- simplifyWantedsTcM cts

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

-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
228
requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
Edward Z. Yang's avatar
Edward Z. Yang committed
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
requirementMerges dflags mod_name =
    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState 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:
--
--      package p where
--          signature A
--          signature B
--              import A
--
--      package q where
--          include p
--          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' hsc_env HsigFile modname =
257
    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
Edward Z. Yang's avatar
Edward Z. Yang committed
258
259
260
        (initIfaceLoad hsc_env
            . withException
            $ moduleFreeHolesPrecise (text "findExtraSigImports")
261
                (mkModule (IndefiniteUnitId iuid) mod_name)))
Edward Z. Yang's avatar
Edward Z. Yang committed
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
  where
    reqs = requirementMerges (hsc_dflags hsc_env) modname

findExtraSigImports' _ _ _ = return emptyUniqDSet

-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
-- "TcRnDriver".
findExtraSigImports :: HscEnv -> HscSource -> ModuleName
                    -> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports hsc_env hsc_src modname = do
    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
    return [ (Nothing, noLoc mod_name)
           | mod_name <- uniqDSetToList 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 hsc_env normal_imports
  = do mns <- implicitRequirements' hsc_env normal_imports
       return [ (Nothing, noLoc mn) | mn <- 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' hsc_env normal_imports
  = fmap concat $
    forM normal_imports $ \(mb_pkg, L _ imp) -> do
        found <- findImportedModule hsc_env imp mb_pkg
        case found of
            Found _ mod | thisPackage dflags /= moduleUnitId mod ->
                return (uniqDSetToList (moduleFreeHoles mod))
            _ -> return []
  where dflags = hsc_dflags 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.
--
307
-- INVARIANT: the UnitId is NOT a InstalledUnitId
Edward Z. Yang's avatar
Edward Z. Yang committed
308
309
310
checkUnitId :: UnitId -> TcM ()
checkUnitId uid = do
    case splitUnitIdInsts uid of
311
312
      (_, Just indef) ->
        let insts = indefUnitIdInsts indef in
Edward Z. Yang's avatar
Edward Z. Yang committed
313
314
315
316
317
318
319
320
        forM_ insts $ \(mod_name, mod) ->
            -- NB: direct hole instantiations are well-typed by construction
            -- (because we FORCE things to be merged in), so don't check them
            when (not (isHoleModule mod)) $ do
                checkUnitId (moduleUnitId mod)
                _ <- addErrCtxt (text "while checking that" <+> ppr mod
                        <+> text "implements signature" <+> ppr mod_name <+> text "in"
                        <+> ppr uid) $
321
                    mod `checkImplements` IndefModule indef mod_name
Edward Z. Yang's avatar
Edward Z. Yang committed
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
                return ()
      _ -> 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 hsc_env uid =
   withTiming (pure dflags)
              (text "Check unit id" <+> ppr uid)
              (const ()) $
   initTc hsc_env
          HsigFile -- bogus
          False
          mAIN -- bogus
          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
    $ checkUnitId uid
  where
   dflags = hsc_dflags hsc_env
   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr 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).
348
tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> HsParsedModule -> ModIface
Edward Z. Yang's avatar
Edward Z. Yang committed
349
                    -> IO (Messages, Maybe TcGblEnv)
350
tcRnMergeSignatures hsc_env real_loc hsmod iface =
Edward Z. Yang's avatar
Edward Z. Yang committed
351
352
353
354
  withTiming (pure dflags)
             (text "Signature merging" <+> brackets (ppr this_mod))
             (const ()) $
  initTc hsc_env HsigFile False this_mod real_loc $
355
    mergeSignatures hsmod iface
Edward Z. Yang's avatar
Edward Z. Yang committed
356
357
358
359
 where
  dflags   = hsc_dflags hsc_env
  this_mod = mi_module iface

360
361
362
363
364
365
366
367
368
369
370
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface avails iface =
    iface {
        mi_exports = 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.
371
        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
372
373
374
375
        -- mi_insts = ...,
        -- mi_fam_insts = ...,
    }
  where
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)

    exported_occs = mkOccSet [ occName n
                             | a <- avails
                             , n <- availNames a ]
    exported_decls = filter_decls exported_occs

    non_exported_occs = mkOccSet [ occName n
                                 | (_, d) <- exported_decls
                                 , n <- ifaceDeclNonExportedRefs d ]
    non_exported_decls = filter_decls non_exported_occs

    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
    dfun_pred _ = False
    dfun_decls = filter (dfun_pred . snd) (mi_decls 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'.
ifaceDeclNonExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNonExportedRefs d@IfaceFamily{} =
    case ifFamFlav d of
        IfaceClosedSynFamilyTyCon (Just (n, _))
            -> [n]
        _   -> []
ifaceDeclNonExportedRefs _ = []

407

Edward Z. Yang's avatar
Edward Z. Yang committed
408
409
410
411
412
413
414
415
416
-- 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.

417
418
419
420
421
422
423
424
425
426
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."

Edward Z. Yang's avatar
Edward Z. Yang committed
427
428
429
430
-- | 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.
431
432
mergeSignatures :: HsParsedModule -> ModIface -> TcRn TcGblEnv
mergeSignatures hsmod lcl_iface0 = do
Edward Z. Yang's avatar
Edward Z. Yang committed
433
434
435
436
437
438
439
440
    -- The lcl_iface0 is the ModIface for the local hsig
    -- file, which is guaranteed to exist, see
    -- Note [Blank hsigs for all requirements]
    hsc_env <- getTopEnv
    dflags  <- getDynFlags
    tcg_env <- getGblEnv
    let outer_mod = tcg_mod tcg_env
        inner_mod = tcg_semantic_mod tcg_env
441
        mb_exports = hsmodExports (unLoc (hpm_module hsmod))
Edward Z. Yang's avatar
Edward Z. Yang committed
442
443
444
445
446
447

    -- STEP 1: Figure out all of the external signature interfaces
    -- we are going to merge in.
    let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env))

    -- STEP 2: Read in the RAW forms of all of these interfaces
448
    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
Edward Z. Yang's avatar
Edward Z. Yang committed
449
450
451
           fmap fst
         . withException
         . flip (findAndReadIface (text "mergeSignatures")) False
452
         $ fst (splitModuleInsts (mkModule (IndefiniteUnitId iuid) mod_name))
Edward Z. Yang's avatar
Edward Z. Yang committed
453

454
455
    -- STEP 3: Get the unrenamed exports of all these interfaces,
    -- thin it according to the export list, and do shaping on them.
Edward Z. Yang's avatar
Edward Z. Yang committed
456
    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
457
458
459
460
461
462
463
464
465
466
467
        -- 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 (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
Edward Z. Yang's avatar
Edward Z. Yang committed
468
            let insts = indefUnitIdInsts iuid
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
            as1 <- tcRnModExports insts ireq_iface
            let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
                pkg = getInstalledPackageDetails dflags inst_uid
                rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing as1)
            (thinned_iface, as2) <- case mb_exports of
                    Just (L loc _)
                      | null (exposedModules pkg) -> setSrcSpan loc $ do
                        -- Suppress missing errors; we'll pick em up
                        -- when we test exports on the final thing
                        (msgs, mb_r) <- tryTc $
                            setGblEnv tcg_env {
                                tcg_rdr_env = rdr_env
                            } $ exports_from_avail mb_exports rdr_env
                                    (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
                        case mb_r of
                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
                            Nothing -> addMessages msgs >> failM
                    _ -> return (ireq_iface, as1)
487
488
489
490
            let oks' | null (exposedModules pkg)
                     = extendOccSetList oks (exportOccs as2)
                     | otherwise
                     = oks
491
            mb_r <- extend_ns nsubst as2
Edward Z. Yang's avatar
Edward Z. Yang committed
492
493
            case mb_r of
                Left err -> failWithTc err
494
                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
Edward Z. Yang's avatar
Edward Z. Yang committed
495
        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
496
497
498
499
500
501
        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
    -- Process each interface, getting the thinned interfaces as well as
    -- the final, full set of exports @nsubst@ and the exports which are
    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
    (nsubst, ok_to_use, rev_thinned_ifaces)
        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
502
503
504
    let thinned_ifaces = reverse rev_thinned_ifaces
        exports        = nameShapeExports nsubst
        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)
505
506
507
        warn_occs      = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
        warns | null warn_occs = NoWarnings
              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
508
509
    setGblEnv tcg_env {
        tcg_rdr_env = rdr_env,
Edward Z. Yang's avatar
Edward Z. Yang committed
510
        tcg_exports = exports,
511
512
        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),
        tcg_warns   = warns
513
514
515
516
        } $ do
    tcg_env <- getGblEnv

    -- Make sure we didn't refer to anything that doesn't actually exist
517
    (mb_lies, _) <- exports_from_avail mb_exports rdr_env
518
519
                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)

520
521
522
523
524
525
526
527
528
529
530
531
532
    -- 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.")
                    ]

533
    failIfErrsM
Edward Z. Yang's avatar
Edward Z. Yang committed
534
535

    -- STEP 4: Rename the interfaces
536
537
538
    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
Edward Z. Yang's avatar
Edward Z. Yang committed
539
540
    let ifaces = lcl_iface : ext_ifaces

541
542
543
544
545
    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
                            | (occ, f) <- concatMap mi_fixities ifaces
                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]

Edward Z. Yang's avatar
Edward Z. Yang committed
546
547
    -- STEP 5: Typecheck the interfaces
    let type_env_var = tcg_type_env_var tcg_env
548
549
550
551
552
553
554

    -- 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.
Edward Z. Yang's avatar
Edward Z. Yang committed
555
556
557
    (type_env, detailss) <- initIfaceTcRn $
                            typecheckIfacesForMerging inner_mod ifaces type_env_var
    let infos = zip ifaces detailss
558

559
560
561
    -- Test for cycles
    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []

562
563
564
565
566
567
568
569
570
571
572
573
574
575
    -- 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!
Edward Z. Yang's avatar
Edward Z. Yang committed
576
577
578
    setGblEnv tcg_env {
        tcg_tcs = typeEnvTyCons type_env,
        tcg_patsyns = typeEnvPatSyns type_env,
579
580
        tcg_type_env = type_env,
        tcg_fix_env = fix_env
Edward Z. Yang's avatar
Edward Z. Yang committed
581
582
583
584
585
586
        } $ do
    tcg_env <- getGblEnv

    -- STEP 6: Check for compatibility/merge things
    tcg_env <- (\x -> foldM x tcg_env infos)
             $ \tcg_env (iface, details) -> do
587

588
589
590
591
592
593
594
595
596
597
598
599
600
601
        let check_export name
              | Just sig_thing <- lookupTypeEnv (md_types details) name
              = case lookupTypeEnv type_env (getName sig_thing) of
                  Just thing -> checkHsigDeclM iface sig_thing thing
                  Nothing -> 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.
Edward Z. Yang's avatar
Edward Z. Yang committed
602
              | otherwise
603
604
              = return ()
        mapM_ check_export (map availName exports)
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633

        -- 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.
        --
Edward Z. Yang's avatar
Edward Z. Yang committed
634
        let merge_inst (insts, inst_env) inst
635
                | memberInstEnv inst_env inst -- test DFun Type equality
Edward Z. Yang's avatar
Edward Z. Yang committed
636
637
                = (insts, inst_env)
                | otherwise
638
639
                -- NB: is_dfun_name inst is still nonsense here,
                -- see Note [Signature merging DFuns]
Edward Z. Yang's avatar
Edward Z. Yang committed
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
                = (inst:insts, extendInstEnv inst_env inst)
            (insts, inst_env) = foldl' merge_inst
                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)
                                    (md_insts details)
            avails = plusImportAvails (tcg_imports tcg_env)
                                      (calculateAvails dflags iface False False)
        return tcg_env {
            tcg_inst_env = inst_env,
            tcg_insts    = insts,
            tcg_imports  = avails,
            tcg_merged   =
                if outer_mod == mi_module iface
                    -- Don't add ourselves!
                    then tcg_merged tcg_env
                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
            }

657
658
659
660
661
662
663
664
665
666
667
668
669
    -- 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 [Bogus DFun renamings] in RnModIface
Edward Z. Yang's avatar
Edward Z. Yang committed
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
        let dfun = setVarName (is_dfun inst) n
        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
    tcg_env <- return tcg_env {
            tcg_insts = map snd dfun_insts,
            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
        }

    return tcg_env

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnInstantiateSignature ::
    HscEnv -> Module -> RealSrcSpan ->
    IO (Messages, Maybe TcGblEnv)
tcRnInstantiateSignature hsc_env this_mod real_loc =
   withTiming (pure dflags)
              (text "Signature instantiation"<+>brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
  where
   dflags = hsc_dflags hsc_env

694
695
696
exportOccs :: [AvailInfo] -> [OccName]
exportOccs = concatMap (map occName . availNames)

Edward Z. Yang's avatar
Edward Z. Yang committed
697
698
699
-- | Check if module implements a signature.  (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
700
701
checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
checkImplements impl_mod (IndefModule uid mod_name) = do
702
    let insts = indefUnitIdInsts uid
Edward Z. Yang's avatar
Edward Z. Yang committed
703
704

    -- STEP 1: Load the implementing interface, and make a RdrEnv
705
706
707
708
709
    -- 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.
Edward Z. Yang's avatar
Edward Z. Yang committed
710
711
712
713
714
715
    impl_iface <- initIfaceTcRn $
        loadSysInterface (text "checkImplements 1") impl_mod
    let impl_gr = mkGlobalRdrEnv
                    (gresFromAvails Nothing (mi_exports impl_iface))
        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)

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

721
722
723
    dflags <- getDynFlags
    let avails = calculateAvails dflags
                    impl_iface False{- safe -} False{- boot -}
724
725
726
        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
                            | (occ, f) <- mi_fixities impl_iface
                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
727
    updGblEnv (\tcg_env -> tcg_env {
728
729
730
731
732
733
734
        -- Setting tcg_rdr_env to treat all exported entities from
        -- the implementing module as in scope improves error messages,
        -- as it reduces the amount of qualification we need.  Unfortunately,
        -- we still end up qualifying references to external modules
        -- (see bkpfail07 for an example); we'd need to record more
        -- information in ModIface to solve this.
        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
735
736
737
738
        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
        -- This is here so that when we call 'lookupFixityRn' for something
        -- directly implemented by the module, we grab the right thing
        tcg_fix_env = fix_env
739
740
        }) $ do

Edward Z. Yang's avatar
Edward Z. Yang committed
741
742
743
744
    -- 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.
745
    let isig_mod = fst (splitModuleInsts (mkModule (IndefiniteUnitId uid) mod_name))
Edward Z. Yang's avatar
Edward Z. Yang committed
746
747
748
749
750
751
752
753
754
    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False
    isig_iface <- case mb_isig_iface of
        Succeeded (iface, _) -> return iface
        Failed err -> failWithTc $
            hang (text "Could not find hi interface for signature" <+>
                  quotes (ppr isig_mod) <> colon) 4 err

    -- STEP 3: Check that the implementing interface exports everything
    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
755
    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
Edward Z. Yang's avatar
Edward Z. Yang committed
756
757
758
759
760
761
762
763
        case lookupGlobalRdrEnv impl_gr occ of
            [] -> addErr $ quotes (ppr occ)
                    <+> text "is exported by the hsig file, but not exported the module"
                    <+> quotes (ppr impl_mod)
            _ -> return ()
    failIfErrsM

    -- STEP 4: Now that the export is complete, rename the interface...
764
    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
Edward Z. Yang's avatar
Edward Z. Yang committed
765
766
767
768
769
770
771

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

    -- STEP 6: Check that it's sufficient
    tcg_env <- getGblEnv
772
    checkHsigIface tcg_env impl_gr sig_iface sig_details
Edward Z. Yang's avatar
Edward Z. Yang committed
773

774
775
    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
    -- so we write them out.
Edward Z. Yang's avatar
Edward Z. Yang committed
776
    return tcg_env {
777
        tcg_exports = mi_exports sig_iface
Edward Z. Yang's avatar
Edward Z. Yang committed
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
        }

-- | 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 = do
    tcg_env <- getGblEnv
    dflags <- getDynFlags
    let outer_mod = tcg_mod tcg_env
        inner_mod = tcg_semantic_mod 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 )
    inner_mod `checkImplements`
794
795
796
797
        IndefModule
            (newIndefUnitId (thisComponentId dflags)
                            (thisUnitIdInsts dflags))
            (moduleName outer_mod)