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