Attach warnings to non-PVP compatible uses of signatures.
[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 (StringLiteral(..), SourceText(..))
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 Maybes
49 import TcEnv
50 import Var
51 import IfaceSyn
52 import PrelNames
53 import qualified Data.Map as Map
54
55 import Finder
56 import UniqDSet
57 import NameShape
58 import TcErrors
59 import TcUnify
60 import RnModIface
61 import Util
62
63 import Control.Monad
64 import Data.List (find, foldl')
65
66 import {-# SOURCE #-} TcRnDriver
67
68 #include "HsVersions.h"
69
70 -- | Given a 'ModDetails' of an instantiated signature (note that the
71 -- 'ModDetails' must be knot-tied consistently with the actual implementation)
72 -- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
73 -- verify that the actual implementation actually matches the original
74 -- interface.
75 --
76 -- Note that it is already assumed that the implementation *exports*
77 -- a sufficient set of entities, since otherwise the renaming and then
78 -- typechecking of the signature 'ModIface' would have failed.
79 checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModDetails -> TcRn ()
80 checkHsigIface tcg_env gr
81 ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
82 md_types = sig_type_env, md_exports = sig_exports } = do
83 traceTc "checkHsigIface" $ vcat
84 [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
85 mapM_ check_export (map availName sig_exports)
86 unless (null sig_fam_insts) $
87 panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
88 "instances in hsig files yet...")
89 -- Delete instances so we don't look them up when
90 -- checking instance satisfiability
91 -- TODO: this should not be necessary
92 tcg_env <- getGblEnv
93 setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
94 tcg_fam_inst_env = emptyFamInstEnv,
95 tcg_insts = [],
96 tcg_fam_insts = [] } $ do
97 mapM_ check_inst sig_insts
98 failIfErrsM
99 where
100 -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig
101 -- in package p that defines T; and we implement with himpl:H. Then the
102 -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just
103 -- have to look up the right name.
104 sig_type_occ_env = mkOccEnv
105 . map (\t -> (nameOccName (getName t), t))
106 $ nameEnvElts sig_type_env
107 dfun_names = map getName sig_insts
108 check_export name
109 -- Skip instances, we'll check them later
110 | name `elem` dfun_names = return ()
111 -- See if we can find the type directly in the hsig ModDetails
112 -- TODO: need to special case wired in names
113 | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
114 -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
115 -- tcg_env (TODO: but maybe this isn't relevant anymore).
116 r <- tcLookupImported_maybe name
117 case r of
118 Failed err -> addErr err
119 Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
120 -- The hsig did NOT define this function; that means it must
121 -- be a reexport. In this case, make sure the 'Name' of the
122 -- reexport matches the 'Name exported here.
123 | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
124 when (name /= name') $ do
125 -- See Note [Error reporting bad reexport]
126 -- TODO: Actually this error swizzle doesn't work
127 let p (L _ ie) = name `elem` ieNames ie
128 loc = case tcg_rn_exports tcg_env of
129 Just es | Just e <- find p es
130 -- TODO: maybe we can be a little more
131 -- precise here and use the Located
132 -- info for the *specific* name we matched.
133 -> getLoc e
134 _ -> nameSrcSpan name
135 addErrAt loc
136 (badReexportedBootThing False name name')
137 -- This should actually never happen, but whatever...
138 | otherwise =
139 addErrAt (nameSrcSpan name)
140 (missingBootThing False name "exported by")
141
142 -- Note [Error reporting bad reexport]
143 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 -- NB: You want to be a bit careful about what location you report on reexports.
145 -- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
146 -- correct source location. However, if it was *reexported*, obviously the name
147 -- is not going to have the right location. In this case, we need to grovel in
148 -- tcg_rn_exports to figure out where the reexport came from.
149
150
151
152 -- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
153 -- assume that the implementing file actually implemented the instances (they
154 -- may be reexported from elsewhere). Where should we look for the instances?
155 -- We do the same as we would otherwise: consult the EPS. This isn't perfect
156 -- (we might conclude the module exports an instance when it doesn't, see
157 -- #9422), but we will never refuse to compile something.
158 check_inst :: ClsInst -> TcM ()
159 check_inst sig_inst = do
160 -- TODO: This could be very well generalized to support instance
161 -- declarations in boot files.
162 tcg_env <- getGblEnv
163 -- NB: Have to tug on the interface, not necessarily
164 -- tugged... but it didn't work?
165 mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
166 -- Based off of 'simplifyDeriv'
167 let ty = idType (instanceDFunId sig_inst)
168 skol_info = InstSkol
169 -- Based off of tcSplitDFunTy
170 (tvs, theta, pred) =
171 case tcSplitForAllTys ty of { (tvs, rho) ->
172 case splitFunTys rho of { (theta, pred) ->
173 (tvs, theta, pred) }}
174 origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
175 (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
176 (cts, tclvl) <- pushTcLevelM $ do
177 wanted <- newWanted origin
178 (Just TypeLevel)
179 (substTy skol_subst pred)
180 givens <- forM theta $ \given -> do
181 loc <- getCtLocM origin (Just TypeLevel)
182 let given_pred = substTy skol_subst given
183 new_ev <- newEvVar given_pred
184 return CtGiven { ctev_pred = given_pred
185 -- Doesn't matter, make something up
186 , ctev_evar = new_ev
187 , ctev_loc = loc
188 }
189 return $ wanted : givens
190 unsolved <- simplifyWantedsTcM cts
191
192 (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
193 reportAllUnsolved (mkImplicWC implic)
194
195 -- | Return this list of requirement interfaces that need to be merged
196 -- to form @mod_name@, or @[]@ if this is not a requirement.
197 requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
198 requirementMerges dflags mod_name =
199 fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
200
201 -- | For a module @modname@ of type 'HscSource', determine the list
202 -- of extra "imports" of other requirements which should be considered part of
203 -- the import of the requirement, because it transitively depends on those
204 -- requirements by imports of modules from other packages. The situation
205 -- is something like this:
206 --
207 -- package p where
208 -- signature A
209 -- signature B
210 -- import A
211 --
212 -- package q where
213 -- include p
214 -- signature A
215 -- signature B
216 --
217 -- Although q's B does not directly import A, we still have to make sure we
218 -- process A first, because the merging process will cause B to indirectly
219 -- import A. This function finds the TRANSITIVE closure of all such imports
220 -- we need to make.
221 findExtraSigImports' :: HscEnv
222 -> HscSource
223 -> ModuleName
224 -> IO (UniqDSet ModuleName)
225 findExtraSigImports' hsc_env HsigFile modname =
226 fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
227 (initIfaceLoad hsc_env
228 . withException
229 $ moduleFreeHolesPrecise (text "findExtraSigImports")
230 (mkModule (IndefiniteUnitId iuid) mod_name)))
231 where
232 reqs = requirementMerges (hsc_dflags hsc_env) modname
233
234 findExtraSigImports' _ _ _ = return emptyUniqDSet
235
236 -- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
237 -- "TcRnDriver".
238 findExtraSigImports :: HscEnv -> HscSource -> ModuleName
239 -> IO [(Maybe FastString, Located ModuleName)]
240 findExtraSigImports hsc_env hsc_src modname = do
241 extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
242 return [ (Nothing, noLoc mod_name)
243 | mod_name <- uniqDSetToList extra_requirements ]
244
245 -- A version of 'implicitRequirements'' which is more friendly
246 -- for "GhcMake" and "TcRnDriver".
247 implicitRequirements :: HscEnv
248 -> [(Maybe FastString, Located ModuleName)]
249 -> IO [(Maybe FastString, Located ModuleName)]
250 implicitRequirements hsc_env normal_imports
251 = do mns <- implicitRequirements' hsc_env normal_imports
252 return [ (Nothing, noLoc mn) | mn <- mns ]
253
254 -- Given a list of 'import M' statements in a module, figure out
255 -- any extra implicit requirement imports they may have. For
256 -- example, if they 'import M' and M resolves to p[A=<B>], then
257 -- they actually also import the local requirement B.
258 implicitRequirements' :: HscEnv
259 -> [(Maybe FastString, Located ModuleName)]
260 -> IO [ModuleName]
261 implicitRequirements' hsc_env normal_imports
262 = fmap concat $
263 forM normal_imports $ \(mb_pkg, L _ imp) -> do
264 found <- findImportedModule hsc_env imp mb_pkg
265 case found of
266 Found _ mod | thisPackage dflags /= moduleUnitId mod ->
267 return (uniqDSetToList (moduleFreeHoles mod))
268 _ -> return []
269 where dflags = hsc_dflags hsc_env
270
271 -- | Given a 'UnitId', make sure it is well typed. This is because
272 -- unit IDs come from Cabal, which does not know if things are well-typed or
273 -- not; a component may have been filled with implementations for the holes
274 -- that don't actually fulfill the requirements.
275 --
276 -- INVARIANT: the UnitId is NOT a InstalledUnitId
277 checkUnitId :: UnitId -> TcM ()
278 checkUnitId uid = do
279 case splitUnitIdInsts uid of
280 (_, Just indef) ->
281 let insts = indefUnitIdInsts indef in
282 forM_ insts $ \(mod_name, mod) ->
283 -- NB: direct hole instantiations are well-typed by construction
284 -- (because we FORCE things to be merged in), so don't check them
285 when (not (isHoleModule mod)) $ do
286 checkUnitId (moduleUnitId mod)
287 _ <- addErrCtxt (text "while checking that" <+> ppr mod
288 <+> text "implements signature" <+> ppr mod_name <+> text "in"
289 <+> ppr uid) $
290 mod `checkImplements` IndefModule indef mod_name
291 return ()
292 _ -> return () -- if it's hashed, must be well-typed
293
294 -- | Top-level driver for signature instantiation (run when compiling
295 -- an @hsig@ file.)
296 tcRnCheckUnitId ::
297 HscEnv -> UnitId ->
298 IO (Messages, Maybe ())
299 tcRnCheckUnitId hsc_env uid =
300 withTiming (pure dflags)
301 (text "Check unit id" <+> ppr uid)
302 (const ()) $
303 initTc hsc_env
304 HsigFile -- bogus
305 False
306 mAIN -- bogus
307 (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
308 $ checkUnitId uid
309 where
310 dflags = hsc_dflags hsc_env
311 loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
312
313 -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
314
315 -- | Top-level driver for signature merging (run after typechecking
316 -- an @hsig@ file).
317 tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> HsParsedModule -> ModIface
318 -> IO (Messages, Maybe TcGblEnv)
319 tcRnMergeSignatures hsc_env real_loc hsmod iface =
320 withTiming (pure dflags)
321 (text "Signature merging" <+> brackets (ppr this_mod))
322 (const ()) $
323 initTc hsc_env HsigFile False this_mod real_loc $
324 mergeSignatures hsmod iface
325 where
326 dflags = hsc_dflags hsc_env
327 this_mod = mi_module iface
328
329 thinModIface :: [AvailInfo] -> ModIface -> ModIface
330 thinModIface avails iface =
331 iface {
332 mi_exports = avails,
333 -- mi_fixities = ...,
334 -- mi_warns = ...,
335 -- mi_anns = ...,
336 -- TODO: The use of nameOccName here is a bit dodgy, because
337 -- perhaps there might be two IfaceTopBndr that are the same
338 -- OccName but different Name. Requires better understanding
339 -- of invariants here.
340 mi_decls = filter (decl_pred . snd) (mi_decls iface)
341 -- mi_insts = ...,
342 -- mi_fam_insts = ...,
343 }
344 where
345 occs = mkOccSet [ occName n
346 | a <- avails
347 , n <- availNames a ]
348 -- NB: Never drop DFuns
349 decl_pred IfaceId{ ifIdDetails = IfDFunId } = True
350 decl_pred decl =
351 nameOccName (ifName decl) `elemOccSet` occs
352
353 -- Note [Blank hsigs for all requirements]
354 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 -- One invariant that a client of GHC must uphold is that there
356 -- must be an hsig file for every requirement (according to
357 -- @-this-unit-id@); this ensures that for every interface
358 -- file (hi), there is a source file (hsig), which helps grease
359 -- the wheels of recompilation avoidance which assumes that
360 -- source files always exist.
361
362 inheritedSigPvpWarning :: WarningTxt
363 inheritedSigPvpWarning =
364 WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
365 where
366 msg = "Inherited requirements from non-signature libraries (libraries " ++
367 "with modules) should not be used, as this mode of use is not " ++
368 "compatible with PVP-style version bounds. Instead, copy the " ++
369 "declaration to the local hsig file or move the signature to a " ++
370 "library of its own and add that library as a dependency."
371
372 -- | Given a local 'ModIface', merge all inherited requirements
373 -- from 'requirementMerges' into this signature, producing
374 -- a final 'TcGblEnv' that matches the local signature and
375 -- all required signatures.
376 mergeSignatures :: HsParsedModule -> ModIface -> TcRn TcGblEnv
377 mergeSignatures hsmod lcl_iface0 = do
378 -- The lcl_iface0 is the ModIface for the local hsig
379 -- file, which is guaranteed to exist, see
380 -- Note [Blank hsigs for all requirements]
381 hsc_env <- getTopEnv
382 dflags <- getDynFlags
383 tcg_env <- getGblEnv
384 let outer_mod = tcg_mod tcg_env
385 inner_mod = tcg_semantic_mod tcg_env
386 mb_exports = hsmodExports (unLoc (hpm_module hsmod))
387
388 -- STEP 1: Figure out all of the external signature interfaces
389 -- we are going to merge in.
390 let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env))
391
392 -- STEP 2: Read in the RAW forms of all of these interfaces
393 ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
394 fmap fst
395 . withException
396 . flip (findAndReadIface (text "mergeSignatures")) False
397 $ fst (splitModuleInsts (mkModule (IndefiniteUnitId iuid) mod_name))
398
399 -- STEP 3: Get the unrenamed exports of all these interfaces,
400 -- thin it according to the export list, and do shaping on them.
401 let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
402 -- This function gets run on every inherited interface, and
403 -- it's responsible for:
404 --
405 -- 1. Merging the exports of the interface into @nsubst@,
406 -- 2. Adding these exports to the "OK to import" set (@oks@)
407 -- if they came from a package with no exposed modules
408 -- (this means we won't report a PVP error in this case), and
409 -- 3. Thinning the interface according to an explicit export
410 -- list.
411 --
412 gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
413 let insts = indefUnitIdInsts iuid
414 as1 <- tcRnModExports insts ireq_iface
415 let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
416 pkg = getInstalledPackageDetails dflags inst_uid
417 rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing as1)
418 (thinned_iface, as2) <- case mb_exports of
419 Just (L loc _)
420 | null (exposedModules pkg) -> setSrcSpan loc $ do
421 -- Suppress missing errors; we'll pick em up
422 -- when we test exports on the final thing
423 (msgs, mb_r) <- tryTc $
424 setGblEnv tcg_env {
425 tcg_rdr_env = rdr_env
426 } $ exports_from_avail mb_exports rdr_env
427 (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
428 case mb_r of
429 Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
430 Nothing -> addMessages msgs >> failM
431 _ -> return (ireq_iface, as1)
432 let oks' | null (exposedModules pkg)
433 = extendOccSetList oks (exportOccs as2)
434 | otherwise
435 = oks
436 mb_r <- extend_ns nsubst as2
437 case mb_r of
438 Left err -> failWithTc err
439 Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
440 nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
441 ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
442 -- Process each interface, getting the thinned interfaces as well as
443 -- the final, full set of exports @nsubst@ and the exports which are
444 -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
445 (nsubst, ok_to_use, rev_thinned_ifaces)
446 <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
447 let thinned_ifaces = reverse rev_thinned_ifaces
448 exports = nameShapeExports nsubst
449 rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports)
450 warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
451 warns | null warn_occs = NoWarnings
452 | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
453 setGblEnv tcg_env {
454 tcg_rdr_env = rdr_env,
455 tcg_exports = exports,
456 tcg_dus = usesOnly (availsToNameSetWithSelectors exports),
457 tcg_warns = warns
458 } $ do
459 tcg_env <- getGblEnv
460
461 -- Make sure we didn't refer to anything that doesn't actually exist
462 _ <- exports_from_avail mb_exports rdr_env
463 (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
464
465 failIfErrsM
466
467 -- STEP 4: Rename the interfaces
468 ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
469 tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
470 lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
471 let ifaces = lcl_iface : ext_ifaces
472
473 -- STEP 5: Typecheck the interfaces
474 let type_env_var = tcg_type_env_var tcg_env
475
476 -- typecheckIfacesForMerging does two things:
477 -- 1. It merges the all of the ifaces together, and typechecks the
478 -- result to type_env.
479 -- 2. It typechecks each iface individually, but with their 'Name's
480 -- resolving to the merged type_env from (1).
481 -- See typecheckIfacesForMerging for more details.
482 (type_env, detailss) <- initIfaceTcRn $
483 typecheckIfacesForMerging inner_mod ifaces type_env_var
484 let infos = zip ifaces detailss
485
486 -- Test for cycles
487 checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
488
489 -- NB on type_env: it contains NO dfuns. DFuns are recorded inside
490 -- detailss, and given a Name that doesn't correspond to anything real. See
491 -- also Note [Signature merging DFuns]
492
493 -- Add the merged type_env to TcGblEnv, so that it gets serialized
494 -- out when we finally write out the interface.
495 --
496 -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
497 -- rather than use tcExtendGlobalEnv (the normal method to add newly
498 -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these
499 -- TyThings to 'tcg_type_env_var', which is consulted when
500 -- we read in interfaces to tie the knot. But *these TyThings themselves
501 -- come from interface*, so that would result in deadlock. Don't
502 -- update it!
503 setGblEnv tcg_env {
504 tcg_tcs = typeEnvTyCons type_env,
505 tcg_patsyns = typeEnvPatSyns type_env,
506 tcg_type_env = type_env
507 } $ do
508 tcg_env <- getGblEnv
509
510 -- STEP 6: Check for compatibility/merge things
511 tcg_env <- (\x -> foldM x tcg_env infos)
512 $ \tcg_env (iface, details) -> do
513
514 -- For every TyThing in the type environment, compare it for
515 -- compatibility with the merged environment, but skip
516 -- DFunIds and implicit TyThings.
517 let check_ty sig_thing
518 -- We'll check these with the parent
519 | isImplicitTyThing sig_thing
520 = return ()
521 -- These aren't in the type environment; checked
522 -- when merging instances
523 | AnId id <- sig_thing
524 , isDFunId id
525 = return ()
526 | Just thing <- lookupTypeEnv type_env (getName sig_thing)
527 = checkBootDeclM False sig_thing thing
528 | otherwise
529 = panic "mergeSignatures check_ty"
530 mapM_ check_ty (typeEnvElts (md_types details))
531
532 -- Note [Signature merging instances]
533 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534 -- Merge instances into the global environment. The algorithm here is
535 -- dumb and simple: if an instance has exactly the same DFun type
536 -- (tested by 'memberInstEnv') as an existing instance, we drop it;
537 -- otherwise, we add it even, even if this would cause overlap.
538 --
539 -- Why don't we deduplicate instances with identical heads? There's no
540 -- good choice if they have premises:
541 --
542 -- instance K1 a => K (T a)
543 -- instance K2 a => K (T a)
544 --
545 -- Why not eagerly error in this case? The overlapping head does not
546 -- necessarily mean that the instances are unimplementable: in fact,
547 -- they may be implemented without overlap (if, for example, the
548 -- implementing module has 'instance K (T a)'; both are implemented in
549 -- this case.) The implements test just checks that the wanteds are
550 -- derivable assuming the givens.
551 --
552 -- Still, overlapping instances with hypotheses like above are going
553 -- to be a bad deal, because instance resolution when we're typechecking
554 -- against the merged signature is going to have a bad time when
555 -- there are overlapping heads like this: we never backtrack, so it
556 -- may be difficult to see that a wanted is derivable. For now,
557 -- we hope that we get lucky / the overlapping instances never
558 -- get used, but it is not a very good situation to be in.
559 --
560 let merge_inst (insts, inst_env) inst
561 | memberInstEnv inst_env inst -- test DFun Type equality
562 = (insts, inst_env)
563 | otherwise
564 -- NB: is_dfun_name inst is still nonsense here,
565 -- see Note [Signature merging DFuns]
566 = (inst:insts, extendInstEnv inst_env inst)
567 (insts, inst_env) = foldl' merge_inst
568 (tcg_insts tcg_env, tcg_inst_env tcg_env)
569 (md_insts details)
570 avails = plusImportAvails (tcg_imports tcg_env)
571 (calculateAvails dflags iface False False)
572 return tcg_env {
573 tcg_inst_env = inst_env,
574 tcg_insts = insts,
575 tcg_imports = avails,
576 tcg_merged =
577 if outer_mod == mi_module iface
578 -- Don't add ourselves!
579 then tcg_merged tcg_env
580 else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
581 }
582
583 -- Note [Signature merging DFuns]
584 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
585 -- Once we know all of instances which will be defined by this merged
586 -- signature, we go through each of the DFuns and rename them with a fresh,
587 -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
588 -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
589 --
590 -- We can't do this fixup earlier, because we need a way to identify each
591 -- source DFun (from each of the signatures we are merging in) so that
592 -- when we have a ClsInst, we can pull up the correct DFun to check if
593 -- the types match.
594 --
595 -- See also Note [Bogus DFun renamings] in RnModIface
596 dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
597 n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
598 let dfun = setVarName (is_dfun inst) n
599 return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
600 tcg_env <- return tcg_env {
601 tcg_insts = map snd dfun_insts,
602 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
603 }
604
605 return tcg_env
606
607 -- | Top-level driver for signature instantiation (run when compiling
608 -- an @hsig@ file.)
609 tcRnInstantiateSignature ::
610 HscEnv -> Module -> RealSrcSpan ->
611 IO (Messages, Maybe TcGblEnv)
612 tcRnInstantiateSignature hsc_env this_mod real_loc =
613 withTiming (pure dflags)
614 (text "Signature instantiation"<+>brackets (ppr this_mod))
615 (const ()) $
616 initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
617 where
618 dflags = hsc_dflags hsc_env
619
620 exportOccs :: [AvailInfo] -> [OccName]
621 exportOccs = concatMap (map occName . availNames)
622
623 -- | Check if module implements a signature. (The signature is
624 -- always un-hashed, which is why its components are specified
625 -- explicitly.)
626 checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
627 checkImplements impl_mod (IndefModule uid mod_name) = do
628 let insts = indefUnitIdInsts uid
629
630 -- STEP 1: Load the implementing interface, and make a RdrEnv
631 -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports',
632 -- so that we treat all orphan instances it provides as visible
633 -- when we verify that all instances are checked (see #12945), and so that
634 -- when we eventually write out the interface we record appropriate
635 -- dependency information.
636 impl_iface <- initIfaceTcRn $
637 loadSysInterface (text "checkImplements 1") impl_mod
638 let impl_gr = mkGlobalRdrEnv
639 (gresFromAvails Nothing (mi_exports impl_iface))
640 nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
641
642 -- Load all the orphans, so the subsequent 'checkHsigIface' sees
643 -- all the instances it needs to
644 loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
645 (dep_orphs (mi_deps impl_iface))
646
647 dflags <- getDynFlags
648 let avails = calculateAvails dflags
649 impl_iface False{- safe -} False{- boot -}
650 updGblEnv (\tcg_env -> tcg_env {
651 -- Setting tcg_rdr_env to treat all exported entities from
652 -- the implementing module as in scope improves error messages,
653 -- as it reduces the amount of qualification we need. Unfortunately,
654 -- we still end up qualifying references to external modules
655 -- (see bkpfail07 for an example); we'd need to record more
656 -- information in ModIface to solve this.
657 tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
658 tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
659 }) $ do
660
661 -- STEP 2: Load the *unrenamed, uninstantiated* interface for
662 -- the ORIGINAL signature. We are going to eventually rename it,
663 -- but we must proceed slowly, because it is NOT known if the
664 -- instantiation is correct.
665 let isig_mod = fst (splitModuleInsts (mkModule (IndefiniteUnitId uid) mod_name))
666 mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False
667 isig_iface <- case mb_isig_iface of
668 Succeeded (iface, _) -> return iface
669 Failed err -> failWithTc $
670 hang (text "Could not find hi interface for signature" <+>
671 quotes (ppr isig_mod) <> colon) 4 err
672
673 -- STEP 3: Check that the implementing interface exports everything
674 -- we need. (Notice we IGNORE the Modules in the AvailInfos.)
675 forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
676 case lookupGlobalRdrEnv impl_gr occ of
677 [] -> addErr $ quotes (ppr occ)
678 <+> text "is exported by the hsig file, but not exported the module"
679 <+> quotes (ppr impl_mod)
680 _ -> return ()
681 failIfErrsM
682
683 -- STEP 4: Now that the export is complete, rename the interface...
684 sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
685
686 -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst
687 -- lets us determine how top-level identifiers should be handled.)
688 sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
689
690 -- STEP 6: Check that it's sufficient
691 tcg_env <- getGblEnv
692 checkHsigIface tcg_env impl_gr sig_details
693
694 -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
695 -- so we write them out.
696 return tcg_env {
697 tcg_exports = mi_exports sig_iface
698 }
699
700 -- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
701 -- library to use the actual implementations of the relevant entities,
702 -- checking that the implementation matches the signature.
703 instantiateSignature :: TcRn TcGblEnv
704 instantiateSignature = do
705 tcg_env <- getGblEnv
706 dflags <- getDynFlags
707 let outer_mod = tcg_mod tcg_env
708 inner_mod = tcg_semantic_mod tcg_env
709 -- TODO: setup the local RdrEnv so the error messages look a little better.
710 -- But this information isn't stored anywhere. Should we RETYPECHECK
711 -- the local one just to get the information? Hmm...
712 MASSERT( moduleUnitId outer_mod == thisPackage dflags )
713 inner_mod `checkImplements`
714 IndefModule
715 (newIndefUnitId (thisComponentId dflags)
716 (thisUnitIdInsts dflags))
717 (moduleName outer_mod)