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