72c8652b92d4d5c7410b84707c4c64d5a5356558
[ghc.git] / compiler / typecheck / TcBackpack.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE NondecreasingIndentation #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 module TcBackpack (
7 findExtraSigImports',
8 findExtraSigImports,
9 implicitRequirements',
10 implicitRequirements,
11 checkUnitId,
12 tcRnCheckUnitId,
13 tcRnMergeSignatures,
14 mergeSignatures,
15 tcRnInstantiateSignature,
16 instantiateSignature,
17 ) where
18
19 import BasicTypes (defaultFixity)
20 import Packages
21 import TcRnExports
22 import DynFlags
23 import HsSyn
24 import RdrName
25 import TcRnMonad
26 import TcTyDecls
27 import InstEnv
28 import FamInstEnv
29 import Inst
30 import TcIface
31 import TcMType
32 import TcType
33 import TcSimplify
34 import LoadIface
35 import RnNames
36 import ErrUtils
37 import Id
38 import Module
39 import Name
40 import NameEnv
41 import NameSet
42 import Avail
43 import SrcLoc
44 import HscTypes
45 import Outputable
46 import Type
47 import FastString
48 import RnEnv
49 import Maybes
50 import TcEnv
51 import Var
52 import IfaceSyn
53 import PrelNames
54 import qualified Data.Map as Map
55
56 import Finder
57 import UniqDSet
58 import NameShape
59 import TcErrors
60 import TcUnify
61 import RnModIface
62 import Util
63
64 import Control.Monad
65 import Data.List (find, foldl')
66
67 import {-# SOURCE #-} TcRnDriver
68
69 #include "HsVersions.h"
70
71 fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
72 fixityMisMatch real_thing real_fixity sig_fixity =
73 vcat [ppr real_thing <+> text "has conflicting fixities in the module",
74 text "and its hsig file",
75 text "Main module:" <+> ppr_fix real_fixity,
76 text "Hsig file:" <+> ppr_fix sig_fixity]
77 where
78 ppr_fix f =
79 ppr f <+>
80 (if f == defaultFixity
81 then parens (text "default")
82 else empty)
83
84 checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
85 checkHsigDeclM sig_iface sig_thing real_thing = do
86 let name = getName real_thing
87 -- TODO: Distinguish between signature merging and signature
88 -- implementation cases.
89 checkBootDeclM False sig_thing real_thing
90 real_fixity <- lookupFixityRn name
91 let sig_fixity = case mi_fix_fn sig_iface (occName name) of
92 Nothing -> defaultFixity
93 Just f -> f
94 when (real_fixity /= sig_fixity) $
95 addErrAt (nameSrcSpan name)
96 (fixityMisMatch real_thing real_fixity sig_fixity)
97
98 -- | Given a 'ModDetails' of an instantiated signature (note that the
99 -- 'ModDetails' must be knot-tied consistently with the actual implementation)
100 -- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
101 -- verify that the actual implementation actually matches the original
102 -- interface.
103 --
104 -- Note that it is already assumed that the implementation *exports*
105 -- a sufficient set of entities, since otherwise the renaming and then
106 -- typechecking of the signature 'ModIface' would have failed.
107 checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
108 checkHsigIface tcg_env gr sig_iface
109 ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
110 md_types = sig_type_env, md_exports = sig_exports } = do
111 traceTc "checkHsigIface" $ vcat
112 [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
113 mapM_ check_export (map availName sig_exports)
114 unless (null sig_fam_insts) $
115 panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
116 "instances in hsig files yet...")
117 -- Delete instances so we don't look them up when
118 -- checking instance satisfiability
119 -- TODO: this should not be necessary
120 tcg_env <- getGblEnv
121 setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
122 tcg_fam_inst_env = emptyFamInstEnv,
123 tcg_insts = [],
124 tcg_fam_insts = [] } $ do
125 mapM_ check_inst sig_insts
126 failIfErrsM
127 where
128 -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig
129 -- in package p that defines T; and we implement with himpl:H. Then the
130 -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just
131 -- have to look up the right name.
132 sig_type_occ_env = mkOccEnv
133 . map (\t -> (nameOccName (getName t), t))
134 $ nameEnvElts sig_type_env
135 dfun_names = map getName sig_insts
136 check_export name
137 -- Skip instances, we'll check them later
138 -- TODO: Actually this should never happen, because DFuns are
139 -- never exported...
140 | name `elem` dfun_names = return ()
141 -- See if we can find the type directly in the hsig ModDetails
142 -- TODO: need to special case wired in names
143 | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
144 -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
145 -- tcg_env (TODO: but maybe this isn't relevant anymore).
146 r <- tcLookupImported_maybe name
147 case r of
148 Failed err -> addErr err
149 Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
150
151 -- The hsig did NOT define this function; that means it must
152 -- be a reexport. In this case, make sure the 'Name' of the
153 -- reexport matches the 'Name exported here.
154 | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
155 when (name /= name') $ do
156 -- See Note [Error reporting bad reexport]
157 -- TODO: Actually this error swizzle doesn't work
158 let p (L _ ie) = name `elem` ieNames ie
159 loc = case tcg_rn_exports tcg_env of
160 Just es | Just e <- find p es
161 -- TODO: maybe we can be a little more
162 -- precise here and use the Located
163 -- info for the *specific* name we matched.
164 -> getLoc e
165 _ -> nameSrcSpan name
166 dflags <- getDynFlags
167 addErrAt loc
168 (badReexportedBootThing dflags False name name')
169 -- This should actually never happen, but whatever...
170 | otherwise =
171 addErrAt (nameSrcSpan name)
172 (missingBootThing False name "exported by")
173
174 -- Note [Error reporting bad reexport]
175 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
176 -- NB: You want to be a bit careful about what location you report on reexports.
177 -- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
178 -- correct source location. However, if it was *reexported*, obviously the name
179 -- is not going to have the right location. In this case, we need to grovel in
180 -- tcg_rn_exports to figure out where the reexport came from.
181
182
183
184 -- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
185 -- assume that the implementing file actually implemented the instances (they
186 -- may be reexported from elsewhere). Where should we look for the instances?
187 -- We do the same as we would otherwise: consult the EPS. This isn't perfect
188 -- (we might conclude the module exports an instance when it doesn't, see
189 -- #9422), but we will never refuse to compile something.
190 check_inst :: ClsInst -> TcM ()
191 check_inst sig_inst = do
192 -- TODO: This could be very well generalized to support instance
193 -- declarations in boot files.
194 tcg_env <- getGblEnv
195 -- NB: Have to tug on the interface, not necessarily
196 -- tugged... but it didn't work?
197 mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
198 -- Based off of 'simplifyDeriv'
199 let ty = idType (instanceDFunId sig_inst)
200 skol_info = InstSkol
201 -- Based off of tcSplitDFunTy
202 (tvs, theta, pred) =
203 case tcSplitForAllTys ty of { (tvs, rho) ->
204 case splitFunTys rho of { (theta, pred) ->
205 (tvs, theta, pred) }}
206 origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
207 (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
208 (cts, tclvl) <- pushTcLevelM $ do
209 wanted <- newWanted origin
210 (Just TypeLevel)
211 (substTy skol_subst pred)
212 givens <- forM theta $ \given -> do
213 loc <- getCtLocM origin (Just TypeLevel)
214 let given_pred = substTy skol_subst given
215 new_ev <- newEvVar given_pred
216 return CtGiven { ctev_pred = given_pred
217 -- Doesn't matter, make something up
218 , ctev_evar = new_ev
219 , ctev_loc = loc
220 }
221 return $ wanted : givens
222 unsolved <- simplifyWantedsTcM cts
223
224 (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
225 reportAllUnsolved (mkImplicWC implic)
226
227 -- | Return this list of requirement interfaces that need to be merged
228 -- to form @mod_name@, or @[]@ if this is not a requirement.
229 requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
230 requirementMerges dflags mod_name =
231 fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
232
233 -- | For a module @modname@ of type 'HscSource', determine the list
234 -- of extra "imports" of other requirements which should be considered part of
235 -- the import of the requirement, because it transitively depends on those
236 -- requirements by imports of modules from other packages. The situation
237 -- is something like this:
238 --
239 -- unit p where
240 -- signature A
241 -- signature B
242 -- import A
243 --
244 -- unit q where
245 -- dependency p[A=<A>,B=<B>]
246 -- signature A
247 -- signature B
248 --
249 -- Although q's B does not directly import A, we still have to make sure we
250 -- process A first, because the merging process will cause B to indirectly
251 -- import A. This function finds the TRANSITIVE closure of all such imports
252 -- we need to make.
253 findExtraSigImports' :: HscEnv
254 -> HscSource
255 -> ModuleName
256 -> IO (UniqDSet ModuleName)
257 findExtraSigImports' hsc_env HsigFile modname =
258 fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
259 (initIfaceLoad hsc_env
260 . withException
261 $ moduleFreeHolesPrecise (text "findExtraSigImports")
262 (mkModule (IndefiniteUnitId iuid) mod_name)))
263 where
264 reqs = requirementMerges (hsc_dflags hsc_env) modname
265
266 findExtraSigImports' _ _ _ = return emptyUniqDSet
267
268 -- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
269 -- "TcRnDriver".
270 findExtraSigImports :: HscEnv -> HscSource -> ModuleName
271 -> IO [(Maybe FastString, Located ModuleName)]
272 findExtraSigImports hsc_env hsc_src modname = do
273 extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
274 return [ (Nothing, noLoc mod_name)
275 | mod_name <- uniqDSetToList extra_requirements ]
276
277 -- A version of 'implicitRequirements'' which is more friendly
278 -- for "GhcMake" and "TcRnDriver".
279 implicitRequirements :: HscEnv
280 -> [(Maybe FastString, Located ModuleName)]
281 -> IO [(Maybe FastString, Located ModuleName)]
282 implicitRequirements hsc_env normal_imports
283 = do mns <- implicitRequirements' hsc_env normal_imports
284 return [ (Nothing, noLoc mn) | mn <- mns ]
285
286 -- Given a list of 'import M' statements in a module, figure out
287 -- any extra implicit requirement imports they may have. For
288 -- example, if they 'import M' and M resolves to p[A=<B>], then
289 -- they actually also import the local requirement B.
290 implicitRequirements' :: HscEnv
291 -> [(Maybe FastString, Located ModuleName)]
292 -> IO [ModuleName]
293 implicitRequirements' hsc_env normal_imports
294 = fmap concat $
295 forM normal_imports $ \(mb_pkg, L _ imp) -> do
296 found <- findImportedModule hsc_env imp mb_pkg
297 case found of
298 Found _ mod | thisPackage dflags /= moduleUnitId mod ->
299 return (uniqDSetToList (moduleFreeHoles mod))
300 _ -> return []
301 where dflags = hsc_dflags hsc_env
302
303 -- | Given a 'UnitId', make sure it is well typed. This is because
304 -- unit IDs come from Cabal, which does not know if things are well-typed or
305 -- not; a component may have been filled with implementations for the holes
306 -- that don't actually fulfill the requirements.
307 --
308 -- INVARIANT: the UnitId is NOT a InstalledUnitId
309 checkUnitId :: UnitId -> TcM ()
310 checkUnitId uid = do
311 case splitUnitIdInsts uid of
312 (_, Just indef) ->
313 let insts = indefUnitIdInsts indef in
314 forM_ insts $ \(mod_name, mod) ->
315 -- NB: direct hole instantiations are well-typed by construction
316 -- (because we FORCE things to be merged in), so don't check them
317 when (not (isHoleModule mod)) $ do
318 checkUnitId (moduleUnitId mod)
319 _ <- mod `checkImplements` IndefModule indef mod_name
320 return ()
321 _ -> return () -- if it's hashed, must be well-typed
322
323 -- | Top-level driver for signature instantiation (run when compiling
324 -- an @hsig@ file.)
325 tcRnCheckUnitId ::
326 HscEnv -> UnitId ->
327 IO (Messages, Maybe ())
328 tcRnCheckUnitId hsc_env uid =
329 withTiming (pure dflags)
330 (text "Check unit id" <+> ppr uid)
331 (const ()) $
332 initTc hsc_env
333 HsigFile -- bogus
334 False
335 mAIN -- bogus
336 (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
337 $ checkUnitId uid
338 where
339 dflags = hsc_dflags hsc_env
340 loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
341
342 -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
343
344 -- | Top-level driver for signature merging (run after typechecking
345 -- an @hsig@ file).
346 tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
347 -> IO (Messages, Maybe TcGblEnv)
348 tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
349 withTiming (pure dflags)
350 (text "Signature merging" <+> brackets (ppr this_mod))
351 (const ()) $
352 initTc hsc_env HsigFile False this_mod real_loc $
353 mergeSignatures hpm orig_tcg_env iface
354 where
355 dflags = hsc_dflags hsc_env
356 this_mod = mi_module iface
357 real_loc = tcg_top_loc orig_tcg_env
358
359 thinModIface :: [AvailInfo] -> ModIface -> ModIface
360 thinModIface avails iface =
361 iface {
362 mi_exports = avails,
363 -- mi_fixities = ...,
364 -- mi_warns = ...,
365 -- mi_anns = ...,
366 -- TODO: The use of nameOccName here is a bit dodgy, because
367 -- perhaps there might be two IfaceTopBndr that are the same
368 -- OccName but different Name. Requires better understanding
369 -- of invariants here.
370 mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
371 -- mi_insts = ...,
372 -- mi_fam_insts = ...,
373 }
374 where
375 decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
376 filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
377
378 exported_occs = mkOccSet [ occName n
379 | a <- avails
380 , n <- availNames a ]
381 exported_decls = filter_decls exported_occs
382
383 non_exported_occs = mkOccSet [ occName n
384 | (_, d) <- exported_decls
385 , n <- ifaceDeclNeverExportedRefs d ]
386 non_exported_decls = filter_decls non_exported_occs
387
388 dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
389 dfun_pred _ = False
390 dfun_decls = filter (dfun_pred . snd) (mi_decls iface)
391
392 -- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
393 -- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept
394 -- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
395 -- refers to it; we can't decide to keep it by looking at the exports
396 -- of a module after thinning. Keep this synchronized with
397 -- 'rnIfaceDecl'.
398 ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
399 ifaceDeclNeverExportedRefs d@IfaceFamily{} =
400 case ifFamFlav d of
401 IfaceClosedSynFamilyTyCon (Just (n, _))
402 -> [n]
403 _ -> []
404 ifaceDeclNeverExportedRefs _ = []
405
406
407 -- Note [Blank hsigs for all requirements]
408 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409 -- One invariant that a client of GHC must uphold is that there
410 -- must be an hsig file for every requirement (according to
411 -- @-this-unit-id@); this ensures that for every interface
412 -- file (hi), there is a source file (hsig), which helps grease
413 -- the wheels of recompilation avoidance which assumes that
414 -- source files always exist.
415
416 {-
417 inheritedSigPvpWarning :: WarningTxt
418 inheritedSigPvpWarning =
419 WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
420 where
421 msg = "Inherited requirements from non-signature libraries (libraries " ++
422 "with modules) should not be used, as this mode of use is not " ++
423 "compatible with PVP-style version bounds. Instead, copy the " ++
424 "declaration to the local hsig file or move the signature to a " ++
425 "library of its own and add that library as a dependency."
426 -}
427
428 -- Note [Handling never-exported TyThings under Backpack]
429 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
430 -- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
431 -- never be mentioned in the export list of a module (mi_avails).
432 -- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
433 -- TyThings DO have a standalone IfaceDecl declaration in their
434 -- interface file.
435 --
436 -- Originally, Backpack was designed under the assumption that anything
437 -- you could declare in a module could also be exported; thus, merging
438 -- the export lists of two signatures is just merging the declarations
439 -- of two signatures writ small. Of course, in GHC Haskell, there are a
440 -- few important things which are not explicitly exported but still can
441 -- be used: in particular, dictionary functions for instances, Typeable
442 -- TyCon bindings, and coercion axioms for type families also count.
443 --
444 -- When handling these non-exported things, there two primary things
445 -- we need to watch out for:
446 --
447 -- * Signature matching/merging is done by comparing each
448 -- of the exported entities of a signature and a module. These exported
449 -- entities may refer to non-exported TyThings which must be tested for
450 -- consistency. For example, an instance (ClsInst) will refer to a
451 -- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the
452 -- embedded 'DFunId' in 'is_dfun'.
453 --
454 -- For this to work at all, we must ensure that pointers in 'is_dfun' refer
455 -- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
456 -- Unfortunately, this is the OPPOSITE of how we treat most other references
457 -- to 'Name's, so this case needs to be handled specially.
458 --
459 -- The details are in the documentation for 'typecheckIfacesForMerging'.
460 -- and the Note [Resolving never-exported Names in TcIface].
461 --
462 -- * When we rename modules and signatures, we use the export lists to
463 -- decide how the declarations should be renamed. However, this
464 -- means we don't get any guidance for how to rename non-exported
465 -- entities. Fortunately, we only need to rename these entities
466 -- *consistently*, so that 'typecheckIfacesForMerging' can wire them
467 -- up as needed.
468 --
469 -- The details are in Note [rnIfaceNeverExported] in 'RnModIface'.
470 --
471 -- The root cause for all of these complications is the fact that these
472 -- logically "implicit" entities are defined indirectly in an interface
473 -- file. #13151 gives a proposal to make these *truly* implicit.
474
475 merge_msg :: ModuleName -> [IndefModule] -> SDoc
476 merge_msg mod_name [] =
477 text "while checking the local signature" <+> ppr mod_name <+>
478 text "for consistency"
479 merge_msg mod_name reqs =
480 hang (text "while merging the signatures from" <> colon)
481 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
482 bullet <+> text "...and the local signature for" <+> ppr mod_name)
483
484 -- | Given a local 'ModIface', merge all inherited requirements
485 -- from 'requirementMerges' into this signature, producing
486 -- a final 'TcGblEnv' that matches the local signature and
487 -- all required signatures.
488 mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
489 mergeSignatures
490 (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
491 hpm_src_files = src_files })
492 orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
493 -- The lcl_iface0 is the ModIface for the local hsig
494 -- file, which is guaranteed to exist, see
495 -- Note [Blank hsigs for all requirements]
496 hsc_env <- getTopEnv
497 dflags <- getDynFlags
498
499 -- Copy over some things from the original TcGblEnv that
500 -- we want to preserve
501 updGblEnv (\env -> env {
502 -- Renamed imports/declarations are often used
503 -- by programs that use the GHC API, e.g., Haddock.
504 -- These won't get filled by the merging process (since
505 -- we don't actually rename the parsed module again) so
506 -- we need to take them directly from the previous
507 -- typechecking.
508 --
509 -- NB: the export declarations aren't in their final
510 -- form yet. We'll fill those in when we reprocess
511 -- the export declarations.
512 tcg_rn_imports = tcg_rn_imports orig_tcg_env,
513 tcg_rn_decls = tcg_rn_decls orig_tcg_env,
514 -- Annotations
515 tcg_ann_env = tcg_ann_env orig_tcg_env,
516 -- Documentation header
517 tcg_doc_hdr = tcg_doc_hdr orig_tcg_env
518 -- tcg_dus?
519 -- tcg_th_used = tcg_th_used orig_tcg_env,
520 -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env
521 -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env
522 }) $ do
523 tcg_env <- getGblEnv
524
525 let outer_mod = tcg_mod tcg_env
526 inner_mod = tcg_semantic_mod tcg_env
527 mod_name = moduleName (tcg_mod tcg_env)
528
529 -- STEP 1: Figure out all of the external signature interfaces
530 -- we are going to merge in.
531 let reqs = requirementMerges dflags mod_name
532
533 addErrCtxt (merge_msg mod_name reqs) $ do
534
535 -- STEP 2: Read in the RAW forms of all of these interfaces
536 ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
537 let m = mkModule (IndefiniteUnitId iuid) mod_name
538 im = fst (splitModuleInsts m)
539 in fmap fst
540 . withException
541 $ findAndReadIface (text "mergeSignatures") im m False
542
543 -- STEP 3: Get the unrenamed exports of all these interfaces,
544 -- thin it according to the export list, and do shaping on them.
545 let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
546 -- This function gets run on every inherited interface, and
547 -- it's responsible for:
548 --
549 -- 1. Merging the exports of the interface into @nsubst@,
550 -- 2. Adding these exports to the "OK to import" set (@oks@)
551 -- if they came from a package with no exposed modules
552 -- (this means we won't report a PVP error in this case), and
553 -- 3. Thinning the interface according to an explicit export
554 -- list.
555 --
556 gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
557 let insts = indefUnitIdInsts iuid
558 as1 <- tcRnModExports insts ireq_iface
559 let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
560 pkg = getInstalledPackageDetails dflags inst_uid
561 -- Setup the import spec correctly, so that when we apply
562 -- IEModuleContents we pick up EVERYTHING
563 ispec = ImpSpec
564 ImpDeclSpec{
565 is_mod = mod_name,
566 is_as = mod_name,
567 is_qual = False,
568 is_dloc = loc
569 } ImpAll
570 rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
571 (thinned_iface, as2) <- case mb_exports of
572 Just (L loc _)
573 | null (exposedModules pkg) -> setSrcSpan loc $ do
574 -- Suppress missing errors; we'll pick em up
575 -- when we test exports on the final thing
576 (msgs, mb_r) <- tryTc $
577 setGblEnv tcg_env {
578 tcg_rdr_env = rdr_env
579 } $ exports_from_avail mb_exports rdr_env
580 (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
581 case mb_r of
582 Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
583 Nothing -> addMessages msgs >> failM
584 _ -> return (ireq_iface, as1)
585 let oks' | null (exposedModules pkg)
586 = extendOccSetList oks (exportOccs as2)
587 | otherwise
588 = oks
589 mb_r <- extend_ns nsubst as2
590 case mb_r of
591 Left err -> failWithTc err
592 Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
593 nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
594 ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
595 -- Process each interface, getting the thinned interfaces as well as
596 -- the final, full set of exports @nsubst@ and the exports which are
597 -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
598 (nsubst, ok_to_use, rev_thinned_ifaces)
599 <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
600 let thinned_ifaces = reverse rev_thinned_ifaces
601 exports = nameShapeExports nsubst
602 rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports)
603 _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
604 warns = NoWarnings
605 {-
606 -- TODO: Warnings are transitive, but this is not what we want here:
607 -- if a module reexports an entity from a signature, that should be OK.
608 -- Not supported in current warning framework
609 warns | null warn_occs = NoWarnings
610 | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
611 -}
612 setGblEnv tcg_env {
613 -- The top-level GlobalRdrEnv is quite interesting. It consists
614 -- of two components:
615 -- 1. First, we reuse the GlobalRdrEnv of the local signature.
616 -- This is very useful, because it means that if we have
617 -- to print a message involving some entity that the local
618 -- signature imported, we'll qualify it accordingly.
619 -- 2. Second, we need to add all of the declarations we are
620 -- going to merge in (as they need to be in scope for the
621 -- final test of the export list.)
622 tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
623 -- Inherit imports from the local signature, so that module
624 -- rexports are picked up correctly
625 tcg_imports = tcg_imports orig_tcg_env,
626 tcg_exports = exports,
627 tcg_dus = usesOnly (availsToNameSetWithSelectors exports),
628 tcg_warns = warns
629 } $ do
630 tcg_env <- getGblEnv
631
632 -- Make sure we didn't refer to anything that doesn't actually exist
633 -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
634 (mb_lies, _) <- exports_from_avail mb_exports rdr_env
635 (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
636
637 {- -- NB: This is commented out, because warns above is disabled.
638 -- If you tried to explicitly export an identifier that has a warning
639 -- attached to it, that's probably a mistake. Warn about it.
640 case mb_lies of
641 Nothing -> return ()
642 Just lies ->
643 forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
644 setSrcSpan loc $
645 unless (nameOccName n `elemOccSet` ok_to_use) $
646 addWarn NoReason $ vcat [
647 text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
648 parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
649 ]
650 -}
651
652 failIfErrsM
653
654 -- Save the exports
655 setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
656 tcg_env <- getGblEnv
657
658 -- STEP 4: Rename the interfaces
659 ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
660 tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
661 lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
662 let ifaces = lcl_iface : ext_ifaces
663
664 -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
665 let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
666 | (occ, f) <- concatMap mi_fixities ifaces
667 , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
668
669 -- STEP 5: Typecheck the interfaces
670 let type_env_var = tcg_type_env_var tcg_env
671
672 -- typecheckIfacesForMerging does two things:
673 -- 1. It merges the all of the ifaces together, and typechecks the
674 -- result to type_env.
675 -- 2. It typechecks each iface individually, but with their 'Name's
676 -- resolving to the merged type_env from (1).
677 -- See typecheckIfacesForMerging for more details.
678 (type_env, detailss) <- initIfaceTcRn $
679 typecheckIfacesForMerging inner_mod ifaces type_env_var
680 let infos = zip ifaces detailss
681
682 -- Test for cycles
683 checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
684
685 -- NB on type_env: it contains NO dfuns. DFuns are recorded inside
686 -- detailss, and given a Name that doesn't correspond to anything real. See
687 -- also Note [Signature merging DFuns]
688
689 -- Add the merged type_env to TcGblEnv, so that it gets serialized
690 -- out when we finally write out the interface.
691 --
692 -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
693 -- rather than use tcExtendGlobalEnv (the normal method to add newly
694 -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these
695 -- TyThings to 'tcg_type_env_var', which is consulted when
696 -- we read in interfaces to tie the knot. But *these TyThings themselves
697 -- come from interface*, so that would result in deadlock. Don't
698 -- update it!
699 setGblEnv tcg_env {
700 tcg_tcs = typeEnvTyCons type_env,
701 tcg_patsyns = typeEnvPatSyns type_env,
702 tcg_type_env = type_env,
703 tcg_fix_env = fix_env
704 } $ do
705 tcg_env <- getGblEnv
706
707 -- STEP 6: Check for compatibility/merge things
708 tcg_env <- (\x -> foldM x tcg_env infos)
709 $ \tcg_env (iface, details) -> do
710
711 let check_export name
712 | Just sig_thing <- lookupTypeEnv (md_types details) name
713 = case lookupTypeEnv type_env (getName sig_thing) of
714 Just thing -> checkHsigDeclM iface sig_thing thing
715 Nothing -> panic "mergeSignatures: check_export"
716 -- Oops! We're looking for this export but it's
717 -- not actually in the type environment of the signature's
718 -- ModDetails.
719 --
720 -- NB: This case happens because the we're iterating
721 -- over the union of all exports, so some interfaces
722 -- won't have everything. Note that md_exports is nonsense
723 -- (it's the same as exports); maybe we should fix this
724 -- eventually.
725 | otherwise
726 = return ()
727 mapM_ check_export (map availName exports)
728
729 -- Note [Signature merging instances]
730 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
731 -- Merge instances into the global environment. The algorithm here is
732 -- dumb and simple: if an instance has exactly the same DFun type
733 -- (tested by 'memberInstEnv') as an existing instance, we drop it;
734 -- otherwise, we add it even, even if this would cause overlap.
735 --
736 -- Why don't we deduplicate instances with identical heads? There's no
737 -- good choice if they have premises:
738 --
739 -- instance K1 a => K (T a)
740 -- instance K2 a => K (T a)
741 --
742 -- Why not eagerly error in this case? The overlapping head does not
743 -- necessarily mean that the instances are unimplementable: in fact,
744 -- they may be implemented without overlap (if, for example, the
745 -- implementing module has 'instance K (T a)'; both are implemented in
746 -- this case.) The implements test just checks that the wanteds are
747 -- derivable assuming the givens.
748 --
749 -- Still, overlapping instances with hypotheses like above are going
750 -- to be a bad deal, because instance resolution when we're typechecking
751 -- against the merged signature is going to have a bad time when
752 -- there are overlapping heads like this: we never backtrack, so it
753 -- may be difficult to see that a wanted is derivable. For now,
754 -- we hope that we get lucky / the overlapping instances never
755 -- get used, but it is not a very good situation to be in.
756 --
757 let merge_inst (insts, inst_env) inst
758 | memberInstEnv inst_env inst -- test DFun Type equality
759 = (insts, inst_env)
760 | otherwise
761 -- NB: is_dfun_name inst is still nonsense here,
762 -- see Note [Signature merging DFuns]
763 = (inst:insts, extendInstEnv inst_env inst)
764 (insts, inst_env) = foldl' merge_inst
765 (tcg_insts tcg_env, tcg_inst_env tcg_env)
766 (md_insts details)
767 -- This is a HACK to prevent calculateAvails from including imp_mod
768 -- in the listing. We don't want it because a module is NOT
769 -- supposed to include itself in its dep_orphs/dep_finsts. See #13214
770 iface' = iface { mi_orphan = False, mi_finsts = False }
771 avails = plusImportAvails (tcg_imports tcg_env) $
772 calculateAvails dflags iface' False False ImportedBySystem
773 return tcg_env {
774 tcg_inst_env = inst_env,
775 tcg_insts = insts,
776 tcg_imports = avails,
777 tcg_merged =
778 if outer_mod == mi_module iface
779 -- Don't add ourselves!
780 then tcg_merged tcg_env
781 else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
782 }
783
784 -- Note [Signature merging DFuns]
785 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
786 -- Once we know all of instances which will be defined by this merged
787 -- signature, we go through each of the DFuns and rename them with a fresh,
788 -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
789 -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
790 --
791 -- We can't do this fixup earlier, because we need a way to identify each
792 -- source DFun (from each of the signatures we are merging in) so that
793 -- when we have a ClsInst, we can pull up the correct DFun to check if
794 -- the types match.
795 --
796 -- See also Note [rnIfaceNeverExported] in RnModIface
797 dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
798 n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
799 let dfun = setVarName (is_dfun inst) n
800 return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
801 tcg_env <- return tcg_env {
802 tcg_insts = map snd dfun_insts,
803 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
804 }
805
806 addDependentFiles src_files
807
808 return tcg_env
809
810 -- | Top-level driver for signature instantiation (run when compiling
811 -- an @hsig@ file.)
812 tcRnInstantiateSignature ::
813 HscEnv -> Module -> RealSrcSpan ->
814 IO (Messages, Maybe TcGblEnv)
815 tcRnInstantiateSignature hsc_env this_mod real_loc =
816 withTiming (pure dflags)
817 (text "Signature instantiation"<+>brackets (ppr this_mod))
818 (const ()) $
819 initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
820 where
821 dflags = hsc_dflags hsc_env
822
823 exportOccs :: [AvailInfo] -> [OccName]
824 exportOccs = concatMap (map occName . availNames)
825
826 impl_msg :: Module -> IndefModule -> SDoc
827 impl_msg impl_mod (IndefModule req_uid req_mod_name) =
828 text "while checking that" <+> ppr impl_mod <+>
829 text "implements signature" <+> ppr req_mod_name <+>
830 text "in" <+> ppr req_uid
831
832 -- | Check if module implements a signature. (The signature is
833 -- always un-hashed, which is why its components are specified
834 -- explicitly.)
835 checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
836 checkImplements impl_mod req_mod@(IndefModule uid mod_name) =
837 addErrCtxt (impl_msg impl_mod req_mod) $ do
838 let insts = indefUnitIdInsts uid
839
840 -- STEP 1: Load the implementing interface, and make a RdrEnv
841 -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports',
842 -- so that we treat all orphan instances it provides as visible
843 -- when we verify that all instances are checked (see #12945), and so that
844 -- when we eventually write out the interface we record appropriate
845 -- dependency information.
846 impl_iface <- initIfaceTcRn $
847 loadSysInterface (text "checkImplements 1") impl_mod
848 let impl_gr = mkGlobalRdrEnv
849 (gresFromAvails Nothing (mi_exports impl_iface))
850 nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
851
852 -- Load all the orphans, so the subsequent 'checkHsigIface' sees
853 -- all the instances it needs to
854 loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
855 (dep_orphs (mi_deps impl_iface))
856
857 dflags <- getDynFlags
858 let avails = calculateAvails dflags
859 impl_iface False{- safe -} False{- boot -} ImportedBySystem
860 fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
861 | (occ, f) <- mi_fixities impl_iface
862 , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
863 updGblEnv (\tcg_env -> tcg_env {
864 -- Setting tcg_rdr_env to treat all exported entities from
865 -- the implementing module as in scope improves error messages,
866 -- as it reduces the amount of qualification we need. Unfortunately,
867 -- we still end up qualifying references to external modules
868 -- (see bkpfail07 for an example); we'd need to record more
869 -- information in ModIface to solve this.
870 tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
871 tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
872 -- This is here so that when we call 'lookupFixityRn' for something
873 -- directly implemented by the module, we grab the right thing
874 tcg_fix_env = fix_env
875 }) $ do
876
877 -- STEP 2: Load the *unrenamed, uninstantiated* interface for
878 -- the ORIGINAL signature. We are going to eventually rename it,
879 -- but we must proceed slowly, because it is NOT known if the
880 -- instantiation is correct.
881 let sig_mod = mkModule (IndefiniteUnitId uid) mod_name
882 isig_mod = fst (splitModuleInsts sig_mod)
883 mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
884 isig_iface <- case mb_isig_iface of
885 Succeeded (iface, _) -> return iface
886 Failed err -> failWithTc $
887 hang (text "Could not find hi interface for signature" <+>
888 quotes (ppr isig_mod) <> colon) 4 err
889
890 -- STEP 3: Check that the implementing interface exports everything
891 -- we need. (Notice we IGNORE the Modules in the AvailInfos.)
892 forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
893 case lookupGlobalRdrEnv impl_gr occ of
894 [] -> addErr $ quotes (ppr occ)
895 <+> text "is exported by the hsig file, but not"
896 <+> text "exported by the implementing module"
897 <+> quotes (ppr impl_mod)
898 _ -> return ()
899 failIfErrsM
900
901 -- STEP 4: Now that the export is complete, rename the interface...
902 sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
903
904 -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst
905 -- lets us determine how top-level identifiers should be handled.)
906 sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
907
908 -- STEP 6: Check that it's sufficient
909 tcg_env <- getGblEnv
910 checkHsigIface tcg_env impl_gr sig_iface sig_details
911
912 -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
913 -- so we write them out.
914 return tcg_env {
915 tcg_exports = mi_exports sig_iface
916 }
917
918 -- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
919 -- library to use the actual implementations of the relevant entities,
920 -- checking that the implementation matches the signature.
921 instantiateSignature :: TcRn TcGblEnv
922 instantiateSignature = do
923 tcg_env <- getGblEnv
924 dflags <- getDynFlags
925 let outer_mod = tcg_mod tcg_env
926 inner_mod = tcg_semantic_mod tcg_env
927 -- TODO: setup the local RdrEnv so the error messages look a little better.
928 -- But this information isn't stored anywhere. Should we RETYPECHECK
929 -- the local one just to get the information? Hmm...
930 MASSERT( moduleUnitId outer_mod == thisPackage dflags )
931 inner_mod `checkImplements`
932 IndefModule
933 (newIndefUnitId (thisComponentId dflags)
934 (thisUnitIdInsts dflags))
935 (moduleName outer_mod)