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