0dc3fb538171c0602a68b0aba5067d9d490b75bc
[ghc.git] / compiler / iface / TcIface.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Type checking of type signatures in interface files
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE NondecreasingIndentation #-}
11
12 module TcIface (
13 tcLookupImported_maybe,
14 importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
15 typecheckIfacesForMerging,
16 typecheckIfaceForInstantiate,
17 tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
18 tcIfaceAnnotations, tcIfaceCompleteSigs,
19 tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
20 tcIfaceGlobal
21 ) where
22
23 #include "HsVersions.h"
24
25 import GhcPrelude
26
27 import TcTypeNats(typeNatCoAxiomRules)
28 import IfaceSyn
29 import LoadIface
30 import IfaceEnv
31 import BuildTyCl
32 import TcRnMonad
33 import TcType
34 import Type
35 import Coercion
36 import CoAxiom
37 import TyCoRep -- needs to build types & coercions in a knot
38 import HscTypes
39 import Annotations
40 import InstEnv
41 import FamInstEnv
42 import CoreSyn
43 import CoreUtils
44 import CoreUnfold
45 import CoreLint
46 import MkCore
47 import Id
48 import MkId
49 import IdInfo
50 import Class
51 import TyCon
52 import ConLike
53 import DataCon
54 import PrelNames
55 import TysWiredIn
56 import Literal
57 import Var
58 import VarSet
59 import Name
60 import NameEnv
61 import NameSet
62 import OccurAnal ( occurAnalyseExpr )
63 import Demand
64 import Module
65 import UniqFM
66 import UniqSupply
67 import Outputable
68 import Maybes
69 import SrcLoc
70 import DynFlags
71 import Util
72 import FastString
73 import BasicTypes hiding ( SuccessFlag(..) )
74 import ListSetOps
75 import GHC.Fingerprint
76 import qualified BooleanFormula as BF
77
78 import Control.Monad
79 import qualified Data.Map as Map
80
81 {-
82 This module takes
83
84 IfaceDecl -> TyThing
85 IfaceType -> Type
86 etc
87
88 An IfaceDecl is populated with RdrNames, and these are not renamed to
89 Names before typechecking, because there should be no scope errors etc.
90
91 -- For (b) consider: f = \$(...h....)
92 -- where h is imported, and calls f via an hi-boot file.
93 -- This is bad! But it is not seen as a staging error, because h
94 -- is indeed imported. We don't want the type-checker to black-hole
95 -- when simplifying and compiling the splice!
96 --
97 -- Simple solution: discard any unfolding that mentions a variable
98 -- bound in this module (and hence not yet processed).
99 -- The discarding happens when forkM finds a type error.
100
101
102 ************************************************************************
103 * *
104 Type-checking a complete interface
105 * *
106 ************************************************************************
107
108 Suppose we discover we don't need to recompile. Then we must type
109 check the old interface file. This is a bit different to the
110 incremental type checking we do as we suck in interface files. Instead
111 we do things similarly as when we are typechecking source decls: we
112 bring into scope the type envt for the interface all at once, using a
113 knot. Remember, the decls aren't necessarily in dependency order --
114 and even if they were, the type decls might be mutually recursive.
115
116 Note [Knot-tying typecheckIface]
117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 Suppose we are typechecking an interface A.hi, and we come across
119 a Name for another entity defined in A.hi. How do we get the
120 'TyCon', in this case? There are three cases:
121
122 1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in
123 preparation of checking if the hs file we're building
124 is compatible. In this case, we want all of the internal
125 TyCons to MATCH the ones that we just constructed during
126 typechecking: the knot is thus tied through if_rec_types.
127
128 2) retypecheckLoop in GhcMake: We are retypechecking a
129 mutually recursive cluster of hi files, in order to ensure
130 that all of the references refer to each other correctly.
131 In this case, the knot is tied through the HPT passed in,
132 which contains all of the interfaces we are in the process
133 of typechecking.
134
135 3) genModDetails in HscMain: We are typechecking an
136 old interface to generate the ModDetails. In this case,
137 we do the same thing as (2) and pass in an HPT with
138 the HomeModInfo being generated to tie knots.
139
140 The upshot is that the CLIENT of this function is responsible
141 for making sure that the knot is tied correctly. If you don't,
142 then you'll get a message saying that we couldn't load the
143 declaration you wanted.
144
145 BTW, in one-shot mode we never call typecheckIface; instead,
146 loadInterface handles type-checking interface. In that case,
147 knots are tied through the EPS. No problem!
148 -}
149
150 -- Clients of this function be careful, see Note [Knot-tying typecheckIface]
151 typecheckIface :: ModIface -- Get the decls from here
152 -> IfG ModDetails
153 typecheckIface iface
154 = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
155 { -- Get the right set of decls and rules. If we are compiling without -O
156 -- we discard pragmas before typechecking, so that we don't "see"
157 -- information that we shouldn't. From a versioning point of view
158 -- It's not actually *wrong* to do so, but in fact GHCi is unable
159 -- to handle unboxed tuples, so it must not see unfoldings.
160 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
161
162 -- Typecheck the decls. This is done lazily, so that the knot-tying
163 -- within this single module works out right. It's the callers
164 -- job to make sure the knot is tied.
165 ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
166 ; let type_env = mkNameEnv names_w_things
167
168 -- Now do those rules, instances and annotations
169 ; insts <- mapM tcIfaceInst (mi_insts iface)
170 ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
171 ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
172 ; anns <- tcIfaceAnnotations (mi_anns iface)
173
174 -- Exports
175 ; exports <- ifaceExportNames (mi_exports iface)
176
177 -- Complete Sigs
178 ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
179
180 -- Finished
181 ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
182 -- Careful! If we tug on the TyThing thunks too early
183 -- we'll infinite loop with hs-boot. See #10083 for
184 -- an example where this would cause non-termination.
185 text "Type envt:" <+> ppr (map fst names_w_things)])
186 ; return $ ModDetails { md_types = type_env
187 , md_insts = insts
188 , md_fam_insts = fam_insts
189 , md_rules = rules
190 , md_anns = anns
191 , md_exports = exports
192 , md_complete_sigs = complete_sigs
193 }
194 }
195
196 {-
197 ************************************************************************
198 * *
199 Typechecking for merging
200 * *
201 ************************************************************************
202 -}
203
204 -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
205 isAbstractIfaceDecl :: IfaceDecl -> Bool
206 isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
207 isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
208 isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
209 isAbstractIfaceDecl _ = False
210
211 ifMaybeRoles :: IfaceDecl -> Maybe [Role]
212 ifMaybeRoles IfaceData { ifRoles = rs } = Just rs
213 ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
214 ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs
215 ifMaybeRoles _ = Nothing
216
217 -- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If
218 -- both are non-abstract we pick one arbitrarily (and check for consistency
219 -- later.)
220 mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
221 mergeIfaceDecl d1 d2
222 | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
223 | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
224 | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
225 , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
226 = let ops = nameEnvElts $
227 plusNameEnv_C mergeIfaceClassOp
228 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
229 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
230 in d1 { ifBody = (ifBody d1) {
231 ifSigs = ops,
232 ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
233 }
234 } `withRolesFrom` d2
235 -- It doesn't matter; we'll check for consistency later when
236 -- we merge, see 'mergeSignatures'
237 | otherwise = d1 `withRolesFrom` d2
238
239 -- Note [Role merging]
240 -- ~~~~~~~~~~~~~~~~~~~
241 -- First, why might it be necessary to do a non-trivial role
242 -- merge? It may rescue a merge that might otherwise fail:
243 --
244 -- signature A where
245 -- type role T nominal representational
246 -- data T a b
247 --
248 -- signature A where
249 -- type role T representational nominal
250 -- data T a b
251 --
252 -- A module that defines T as representational in both arguments
253 -- would successfully fill both signatures, so it would be better
254 -- if we merged the roles of these types in some nontrivial
255 -- way.
256 --
257 -- However, we have to be very careful about how we go about
258 -- doing this, because role subtyping is *conditional* on
259 -- the supertype being NOT representationally injective, e.g.,
260 -- if we have instead:
261 --
262 -- signature A where
263 -- type role T nominal representational
264 -- data T a b = T a b
265 --
266 -- signature A where
267 -- type role T representational nominal
268 -- data T a b = T a b
269 --
270 -- Should we merge the definitions of T so that the roles are R/R (or N/N)?
271 -- Absolutely not: neither resulting type is a subtype of the original
272 -- types (see Note [Role subtyping]), because data is not representationally
273 -- injective.
274 --
275 -- Thus, merging only occurs when BOTH TyCons in question are
276 -- representationally injective. If they're not, no merge.
277
278 withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
279 d1 `withRolesFrom` d2
280 | Just roles1 <- ifMaybeRoles d1
281 , Just roles2 <- ifMaybeRoles d2
282 , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
283 = d1 { ifRoles = mergeRoles roles1 roles2 }
284 | otherwise = d1
285 where
286 mergeRoles roles1 roles2 = zipWith max roles1 roles2
287
288 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
289 isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
290 isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
291 isRepInjectiveIfaceDecl _ = False
292
293 mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
294 mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
295 mergeIfaceClassOp _ op2 = op2
296
297 -- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
298 mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
299 mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
300
301 -- | This is a very interesting function. Like typecheckIface, we want
302 -- to type check an interface file into a ModDetails. However, the use-case
303 -- for these ModDetails is different: we want to compare all of the
304 -- ModDetails to ensure they define compatible declarations, and then
305 -- merge them together. So in particular, we have to take a different
306 -- strategy for knot-tying: we first speculatively merge the declarations
307 -- to get the "base" truth for what we believe the types will be
308 -- (this is "type computation.") Then we read everything in relative
309 -- to this truth and check for compatibility.
310 --
311 -- During the merge process, we may need to nondeterministically
312 -- pick a particular declaration to use, if multiple signatures define
313 -- the declaration ('mergeIfaceDecl'). If, for all choices, there
314 -- are no type synonym cycles in the resulting merged graph, then
315 -- we can show that our choice cannot matter. Consider the
316 -- set of entities which the declarations depend on: by assumption
317 -- of acyclicity, we can assume that these have already been shown to be equal
318 -- to each other (otherwise merging will fail). Then it must
319 -- be the case that all candidate declarations here are type-equal
320 -- (the choice doesn't matter) or there is an inequality (in which
321 -- case merging will fail.)
322 --
323 -- Unfortunately, the choice can matter if there is a cycle. Consider the
324 -- following merge:
325 --
326 -- signature H where { type A = C; type B = A; data C }
327 -- signature H where { type A = (); data B; type C = B }
328 --
329 -- If we pick @type A = C@ as our representative, there will be
330 -- a cycle and merging will fail. But if we pick @type A = ()@ as
331 -- our representative, no cycle occurs, and we instead conclude
332 -- that all of the types are unit. So it seems that we either
333 -- (a) need a stronger acyclicity check which considers *all*
334 -- possible choices from a merge, or (b) we must find a selection
335 -- of declarations which is acyclic, and show that this is always
336 -- the "best" choice we could have made (ezyang conjectures this
337 -- is the case but does not have a proof). For now this is
338 -- not implemented.
339 --
340 -- It's worth noting that at the moment, a data constructor and a
341 -- type synonym are never compatible. Consider:
342 --
343 -- signature H where { type Int=C; type B = Int; data C = Int}
344 -- signature H where { export Prelude.Int; data B; type C = B; }
345 --
346 -- This will be rejected, because the reexported Int in the second
347 -- signature (a proper data type) is never considered equal to a
348 -- type synonym. Perhaps this should be relaxed, where a type synonym
349 -- in a signature is considered implemented by a data type declaration
350 -- which matches the reference of the type synonym.
351 typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
352 typecheckIfacesForMerging mod ifaces tc_env_var =
353 -- cannot be boot (False)
354 initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
355 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
356 -- Build the initial environment
357 -- NB: Don't include dfuns here, because we don't want to
358 -- serialize them out. See Note [rnIfaceNeverExported] in RnModIface
359 -- NB: But coercions are OK, because they will have the right OccName.
360 let mk_decl_env decls
361 = mkOccEnv [ (getOccName decl, decl)
362 | decl <- decls
363 , case decl of
364 IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
365 _ -> True ]
366 decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
367 :: [OccEnv IfaceDecl]
368 decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
369 :: OccEnv IfaceDecl
370 -- TODO: change loadDecls to accept w/o Fingerprint
371 names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
372 (occEnvElts decl_env))
373 let global_type_env = mkNameEnv names_w_things
374 writeMutVar tc_env_var global_type_env
375
376 -- OK, now typecheck each ModIface using this environment
377 details <- forM ifaces $ \iface -> do
378 -- See Note [Resolving never-exported Names in TcIface]
379 type_env <- fixM $ \type_env -> do
380 setImplicitEnvM type_env $ do
381 decls <- loadDecls ignore_prags (mi_decls iface)
382 return (mkNameEnv decls)
383 -- But note that we use this type_env to typecheck references to DFun
384 -- in 'IfaceInst'
385 setImplicitEnvM type_env $ do
386 insts <- mapM tcIfaceInst (mi_insts iface)
387 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
388 rules <- tcIfaceRules ignore_prags (mi_rules iface)
389 anns <- tcIfaceAnnotations (mi_anns iface)
390 exports <- ifaceExportNames (mi_exports iface)
391 complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
392 return $ ModDetails { md_types = type_env
393 , md_insts = insts
394 , md_fam_insts = fam_insts
395 , md_rules = rules
396 , md_anns = anns
397 , md_exports = exports
398 , md_complete_sigs = complete_sigs
399 }
400 return (global_type_env, details)
401
402 -- | Typecheck a signature 'ModIface' under the assumption that we have
403 -- instantiated it under some implementation (recorded in 'mi_semantic_module')
404 -- and want to check if the implementation fills the signature.
405 --
406 -- This needs to operate slightly differently than 'typecheckIface'
407 -- because (1) we have a 'NameShape', from the exports of the
408 -- implementing module, which we will use to give our top-level
409 -- declarations the correct 'Name's even when the implementor
410 -- provided them with a reexport, and (2) we have to deal with
411 -- DFun silliness (see Note [rnIfaceNeverExported])
412 typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
413 typecheckIfaceForInstantiate nsubst iface =
414 initIfaceLclWithSubst (mi_semantic_module iface)
415 (text "typecheckIfaceForInstantiate")
416 (mi_boot iface) nsubst $ do
417 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
418 -- See Note [Resolving never-exported Names in TcIface]
419 type_env <- fixM $ \type_env -> do
420 setImplicitEnvM type_env $ do
421 decls <- loadDecls ignore_prags (mi_decls iface)
422 return (mkNameEnv decls)
423 -- See Note [rnIfaceNeverExported]
424 setImplicitEnvM type_env $ do
425 insts <- mapM tcIfaceInst (mi_insts iface)
426 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
427 rules <- tcIfaceRules ignore_prags (mi_rules iface)
428 anns <- tcIfaceAnnotations (mi_anns iface)
429 exports <- ifaceExportNames (mi_exports iface)
430 complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
431 return $ ModDetails { md_types = type_env
432 , md_insts = insts
433 , md_fam_insts = fam_insts
434 , md_rules = rules
435 , md_anns = anns
436 , md_exports = exports
437 , md_complete_sigs = complete_sigs
438 }
439
440 -- Note [Resolving never-exported Names in TcIface]
441 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 -- For the high-level overview, see
443 -- Note [Handling never-exported TyThings under Backpack]
444 --
445 -- As described in 'typecheckIfacesForMerging', the splendid innovation
446 -- of signature merging is to rewrite all Names in each of the signatures
447 -- we are merging together to a pre-merged structure; this is the key
448 -- ingredient that lets us solve some problems when merging type
449 -- synonyms.
450 --
451 -- However, when a 'Name' refers to a NON-exported entity, as is the
452 -- case with the DFun of a ClsInst, or a CoAxiom of a type family,
453 -- this strategy causes problems: if we pick one and rewrite all
454 -- references to a shared 'Name', we will accidentally fail to check
455 -- if the DFun or CoAxioms are compatible, as they will never be
456 -- checked--only exported entities are checked for compatibility,
457 -- and a non-exported TyThing is checked WHEN we are checking the
458 -- ClsInst or type family for compatibility in checkBootDeclM.
459 -- By virtue of the fact that everything's been pointed to the merged
460 -- declaration, you'll never notice there's a difference even if there
461 -- is one.
462 --
463 -- Fortunately, there are only a few places in the interface declarations
464 -- where this can occur, so we replace those calls with 'tcIfaceImplicit',
465 -- which will consult a local TypeEnv that records any never-exported
466 -- TyThings which we should wire up with.
467 --
468 -- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a
469 -- type family can refer to a coercion axiom, all of which are done in one go
470 -- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck
471 -- coercions first before type families, but that seemed more fragile.
472 --
473
474 {-
475 ************************************************************************
476 * *
477 Type and class declarations
478 * *
479 ************************************************************************
480 -}
481
482 tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
483 -- Load the hi-boot iface for the module being compiled,
484 -- if it indeed exists in the transitive closure of imports
485 -- Return the ModDetails; Nothing if no hi-boot iface
486 tcHiBootIface hsc_src mod
487 | HsBootFile <- hsc_src -- Already compiling a hs-boot file
488 = return NoSelfBoot
489 | otherwise
490 = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
491
492 ; mode <- getGhcMode
493 ; if not (isOneShot mode)
494 -- In --make and interactive mode, if this module has an hs-boot file
495 -- we'll have compiled it already, and it'll be in the HPT
496 --
497 -- We check wheher the interface is a *boot* interface.
498 -- It can happen (when using GHC from Visual Studio) that we
499 -- compile a module in TypecheckOnly mode, with a stable,
500 -- fully-populated HPT. In that case the boot interface isn't there
501 -- (it's been replaced by the mother module) so we can't check it.
502 -- And that's fine, because if M's ModInfo is in the HPT, then
503 -- it's been compiled once, and we don't need to check the boot iface
504 then do { hpt <- getHpt
505 ; case lookupHpt hpt (moduleName mod) of
506 Just info | mi_boot (hm_iface info)
507 -> mkSelfBootInfo (hm_iface info) (hm_details info)
508 _ -> return NoSelfBoot }
509 else do
510
511 -- OK, so we're in one-shot mode.
512 -- Re #9245, we always check if there is an hi-boot interface
513 -- to check consistency against, rather than just when we notice
514 -- that an hi-boot is necessary due to a circular import.
515 { read_result <- findAndReadIface
516 need (fst (splitModuleInsts mod)) mod
517 True -- Hi-boot file
518
519 ; case read_result of {
520 Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
521 ; mkSelfBootInfo iface tc_iface } ;
522 Failed err ->
523
524 -- There was no hi-boot file. But if there is circularity in
525 -- the module graph, there really should have been one.
526 -- Since we've read all the direct imports by now,
527 -- eps_is_boot will record if any of our imports mention the
528 -- current module, which either means a module loop (not
529 -- a SOURCE import) or that our hi-boot file has mysteriously
530 -- disappeared.
531 do { eps <- getEps
532 ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
533 Nothing -> return NoSelfBoot -- The typical case
534
535 Just (_, False) -> failWithTc moduleLoop
536 -- Someone below us imported us!
537 -- This is a loop with no hi-boot in the way
538
539 Just (_mod, True) -> failWithTc (elaborate err)
540 -- The hi-boot file has mysteriously disappeared.
541 }}}}
542 where
543 need = text "Need the hi-boot interface for" <+> ppr mod
544 <+> text "to compare against the Real Thing"
545
546 moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
547 <+> text "depends on itself"
548
549 elaborate err = hang (text "Could not find hi-boot interface for" <+>
550 quotes (ppr mod) <> colon) 4 err
551
552
553 mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
554 mkSelfBootInfo iface mds
555 = do -- NB: This is computed DIRECTLY from the ModIface rather
556 -- than from the ModDetails, so that we can query 'sb_tcs'
557 -- WITHOUT forcing the contents of the interface.
558 let tcs = map ifName
559 . filter isIfaceTyCon
560 . map snd
561 $ mi_decls iface
562 return $ SelfBoot { sb_mds = mds
563 , sb_tcs = mkNameSet tcs }
564 where
565 -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on
566 -- this 'IfaceDecl', an ATyCon would be returned.
567 -- NB: This code assumes that a TyCon cannot be implicit.
568 isIfaceTyCon IfaceId{} = False
569 isIfaceTyCon IfaceData{} = True
570 isIfaceTyCon IfaceSynonym{} = True
571 isIfaceTyCon IfaceFamily{} = True
572 isIfaceTyCon IfaceClass{} = True
573 isIfaceTyCon IfaceAxiom{} = False
574 isIfaceTyCon IfacePatSyn{} = False
575
576 {-
577 ************************************************************************
578 * *
579 Type and class declarations
580 * *
581 ************************************************************************
582
583 When typechecking a data type decl, we *lazily* (via forkM) typecheck
584 the constructor argument types. This is in the hope that we may never
585 poke on those argument types, and hence may never need to load the
586 interface files for types mentioned in the arg types.
587
588 E.g.
589 data Foo.S = MkS Baz.T
590 Maybe we can get away without even loading the interface for Baz!
591
592 This is not just a performance thing. Suppose we have
593 data Foo.S = MkS Baz.T
594 data Baz.T = MkT Foo.S
595 (in different interface files, of course).
596 Now, first we load and typecheck Foo.S, and add it to the type envt.
597 If we do explore MkS's argument, we'll load and typecheck Baz.T.
598 If we explore MkT's argument we'll find Foo.S already in the envt.
599
600 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
601 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
602 which isn't done yet.
603
604 All very cunning. However, there is a rather subtle gotcha which bit
605 me when developing this stuff. When we typecheck the decl for S, we
606 extend the type envt with S, MkS, and all its implicit Ids. Suppose
607 (a bug, but it happened) that the list of implicit Ids depended in
608 turn on the constructor arg types. Then the following sequence of
609 events takes place:
610 * we build a thunk <t> for the constructor arg tys
611 * we build a thunk for the extended type environment (depends on <t>)
612 * we write the extended type envt into the global EPS mutvar
613
614 Now we look something up in the type envt
615 * that pulls on <t>
616 * which reads the global type envt out of the global EPS mutvar
617 * but that depends in turn on <t>
618
619 It's subtle, because, it'd work fine if we typechecked the constructor args
620 eagerly -- they don't need the extended type envt. They just get the extended
621 type envt by accident, because they look at it later.
622
623 What this means is that the implicitTyThings MUST NOT DEPEND on any of
624 the forkM stuff.
625 -}
626
627 tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
628 -> IfaceDecl
629 -> IfL TyThing
630 tcIfaceDecl = tc_iface_decl Nothing
631
632 tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations
633 -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings
634 -> IfaceDecl
635 -> IfL TyThing
636 tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
637 ifIdDetails = details, ifIdInfo = info})
638 = do { ty <- tcIfaceType iface_type
639 ; details <- tcIdDetails ty details
640 ; info <- tcIdInfo ignore_prags TopLevel name ty info
641 ; return (AnId (mkGlobalId details name ty info)) }
642
643 tc_iface_decl _ _ (IfaceData {ifName = tc_name,
644 ifCType = cType,
645 ifBinders = binders,
646 ifResKind = res_kind,
647 ifRoles = roles,
648 ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
649 ifCons = rdr_cons,
650 ifParent = mb_parent })
651 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
652 { res_kind' <- tcIfaceType res_kind
653
654 ; tycon <- fixM $ \ tycon -> do
655 { stupid_theta <- tcIfaceCtxt ctxt
656 ; parent' <- tc_parent tc_name mb_parent
657 ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
658 ; return (mkAlgTyCon tc_name binders' res_kind'
659 roles cType stupid_theta
660 cons parent' gadt_syn) }
661 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
662 ; return (ATyCon tycon) }
663 where
664 tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
665 tc_parent tc_name IfNoParent
666 = do { tc_rep_name <- newTyConRepName tc_name
667 ; return (VanillaAlgTyCon tc_rep_name) }
668 tc_parent _ (IfDataInstance ax_name _ arg_tys)
669 = do { ax <- tcIfaceCoAxiom ax_name
670 ; let fam_tc = coAxiomTyCon ax
671 ax_unbr = toUnbranchedAxiom ax
672 ; lhs_tys <- tcIfaceAppArgs arg_tys
673 ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
674
675 tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
676 ifRoles = roles,
677 ifSynRhs = rhs_ty,
678 ifBinders = binders,
679 ifResKind = res_kind })
680 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
681 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
682 ; rhs <- forkM (mk_doc tc_name) $
683 tcIfaceType rhs_ty
684 ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
685 ; return (ATyCon tycon) }
686 where
687 mk_doc n = text "Type synonym" <+> ppr n
688
689 tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
690 ifFamFlav = fam_flav,
691 ifBinders = binders,
692 ifResKind = res_kind,
693 ifResVar = res, ifFamInj = inj })
694 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
695 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
696 ; rhs <- forkM (mk_doc tc_name) $
697 tc_fam_flav tc_name fam_flav
698 ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
699 ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
700 ; return (ATyCon tycon) }
701 where
702 mk_doc n = text "Type synonym" <+> ppr n
703
704 tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
705 tc_fam_flav tc_name IfaceDataFamilyTyCon
706 = do { tc_rep_name <- newTyConRepName tc_name
707 ; return (DataFamilyTyCon tc_rep_name) }
708 tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
709 tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
710 = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
711 ; return (ClosedSynFamilyTyCon ax) }
712 tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
713 = return AbstractClosedSynFamilyTyCon
714 tc_fam_flav _ IfaceBuiltInSynFamTyCon
715 = pprPanic "tc_iface_decl"
716 (text "IfaceBuiltInSynFamTyCon in interface file")
717
718 tc_iface_decl _parent _ignore_prags
719 (IfaceClass {ifName = tc_name,
720 ifRoles = roles,
721 ifBinders = binders,
722 ifFDs = rdr_fds,
723 ifBody = IfAbstractClass})
724 = bindIfaceTyConBinders binders $ \ binders' -> do
725 { fds <- mapM tc_fd rdr_fds
726 ; cls <- buildClass tc_name binders' roles fds Nothing
727 ; return (ATyCon (classTyCon cls)) }
728
729 tc_iface_decl _parent ignore_prags
730 (IfaceClass {ifName = tc_name,
731 ifRoles = roles,
732 ifBinders = binders,
733 ifFDs = rdr_fds,
734 ifBody = IfConcreteClass {
735 ifClassCtxt = rdr_ctxt,
736 ifATs = rdr_ats, ifSigs = rdr_sigs,
737 ifMinDef = mindef_occ
738 }})
739 = bindIfaceTyConBinders binders $ \ binders' -> do
740 { traceIf (text "tc-iface-class1" <+> ppr tc_name)
741 ; ctxt <- mapM tc_sc rdr_ctxt
742 ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
743 ; sigs <- mapM tc_sig rdr_sigs
744 ; fds <- mapM tc_fd rdr_fds
745 ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
746 ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
747 ; cls <- fixM $ \ cls -> do
748 { ats <- mapM (tc_at cls) rdr_ats
749 ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
750 ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
751 ; return (ATyCon (classTyCon cls)) }
752 where
753 tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
754 -- The *length* of the superclasses is used by buildClass, and hence must
755 -- not be inside the thunk. But the *content* maybe recursive and hence
756 -- must be lazy (via forkM). Example:
757 -- class C (T a) => D a where
758 -- data T a
759 -- Here the associated type T is knot-tied with the class, and
760 -- so we must not pull on T too eagerly. See Trac #5970
761
762 tc_sig :: IfaceClassOp -> IfL TcMethInfo
763 tc_sig (IfaceClassOp op_name rdr_ty dm)
764 = do { let doc = mk_op_doc op_name rdr_ty
765 ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
766 -- Must be done lazily for just the same reason as the
767 -- type of a data con; to avoid sucking in types that
768 -- it mentions unless it's necessary to do so
769 ; dm' <- tc_dm doc dm
770 ; return (op_name, op_ty, dm') }
771
772 tc_dm :: SDoc
773 -> Maybe (DefMethSpec IfaceType)
774 -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
775 tc_dm _ Nothing = return Nothing
776 tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
777 tc_dm doc (Just (GenericDM ty))
778 = do { -- Must be done lazily to avoid sucking in types
779 ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
780 ; return (Just (GenericDM (noSrcSpan, ty'))) }
781
782 tc_at cls (IfaceAT tc_decl if_def)
783 = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
784 mb_def <- case if_def of
785 Nothing -> return Nothing
786 Just def -> forkM (mk_at_doc tc) $
787 extendIfaceTyVarEnv (tyConTyVars tc) $
788 do { tc_def <- tcIfaceType def
789 ; return (Just (tc_def, noSrcSpan)) }
790 -- Must be done lazily in case the RHS of the defaults mention
791 -- the type constructor being defined here
792 -- e.g. type AT a; type AT b = AT [b] Trac #8002
793 return (ATI tc mb_def)
794
795 mk_sc_doc pred = text "Superclass" <+> ppr pred
796 mk_at_doc tc = text "Associated type" <+> ppr tc
797 mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
798
799 tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
800 , ifAxBranches = branches, ifRole = role })
801 = do { tc_tycon <- tcIfaceTyCon tc
802 -- Must be done lazily, because axioms are forced when checking
803 -- for family instance consistency, and the RHS may mention
804 -- a hs-boot declared type constructor that is going to be
805 -- defined by this module.
806 -- e.g. type instance F Int = ToBeDefined
807 -- See Trac #13803
808 ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
809 $ tc_ax_branches branches
810 ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
811 , co_ax_name = tc_name
812 , co_ax_tc = tc_tycon
813 , co_ax_role = role
814 , co_ax_branches = manyBranches tc_branches
815 , co_ax_implicit = False }
816 ; return (ACoAxiom axiom) }
817
818 tc_iface_decl _ _ (IfacePatSyn{ ifName = name
819 , ifPatMatcher = if_matcher
820 , ifPatBuilder = if_builder
821 , ifPatIsInfix = is_infix
822 , ifPatUnivBndrs = univ_bndrs
823 , ifPatExBndrs = ex_bndrs
824 , ifPatProvCtxt = prov_ctxt
825 , ifPatReqCtxt = req_ctxt
826 , ifPatArgs = args
827 , ifPatTy = pat_ty
828 , ifFieldLabels = field_labels })
829 = do { traceIf (text "tc_iface_decl" <+> ppr name)
830 ; matcher <- tc_pr if_matcher
831 ; builder <- fmapMaybeM tc_pr if_builder
832 ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
833 { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
834 { patsyn <- forkM (mk_doc name) $
835 do { prov_theta <- tcIfaceCtxt prov_ctxt
836 ; req_theta <- tcIfaceCtxt req_ctxt
837 ; pat_ty <- tcIfaceType pat_ty
838 ; arg_tys <- mapM tcIfaceType args
839 ; return $ buildPatSyn name is_infix matcher builder
840 (univ_tvs, req_theta)
841 (ex_tvs, prov_theta)
842 arg_tys pat_ty field_labels }
843 ; return $ AConLike . PatSynCon $ patsyn }}}
844 where
845 mk_doc n = text "Pattern synonym" <+> ppr n
846 tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
847 tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
848 ; return (id, b) }
849
850 tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
851 tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
852 ; tvs2' <- mapM tcIfaceTyVar tvs2
853 ; return (tvs1', tvs2') }
854
855 tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
856 tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
857
858 tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
859 tc_ax_branch prev_branches
860 (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
861 , ifaxbLHS = lhs, ifaxbRHS = rhs
862 , ifaxbRoles = roles, ifaxbIncomps = incomps })
863 = bindIfaceTyConBinders_AT
864 (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
865 -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
866 bindIfaceIds cv_bndrs $ \ cvs -> do
867 { tc_lhs <- tcIfaceAppArgs lhs
868 ; tc_rhs <- tcIfaceType rhs
869 ; let br = CoAxBranch { cab_loc = noSrcSpan
870 , cab_tvs = binderVars tvs
871 , cab_cvs = cvs
872 , cab_lhs = tc_lhs
873 , cab_roles = roles
874 , cab_rhs = tc_rhs
875 , cab_incomps = map (prev_branches `getNth`) incomps }
876 ; return (prev_branches ++ [br]) }
877
878 tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
879 tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
880 = case if_cons of
881 IfAbstractTyCon -> return AbstractTyCon
882 IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
883 ; return (mkDataTyConRhs data_cons) }
884 IfNewTyCon con -> do { data_con <- tc_con_decl con
885 ; mkNewTyConRhs tycon_name tycon data_con }
886 where
887 univ_tvs :: [TyVar]
888 univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
889
890 tag_map :: NameEnv ConTag
891 tag_map = mkTyConTagMap tycon
892
893 tc_con_decl (IfCon { ifConInfix = is_infix,
894 ifConExTvs = ex_bndrs,
895 ifConUserTvBinders = user_bndrs,
896 ifConName = dc_name,
897 ifConCtxt = ctxt, ifConEqSpec = spec,
898 ifConArgTys = args, ifConFields = lbl_names,
899 ifConStricts = if_stricts,
900 ifConSrcStricts = if_src_stricts})
901 = -- Universally-quantified tyvars are shared with
902 -- parent TyCon, and are already in scope
903 bindIfaceTyVars ex_bndrs $ \ ex_tvs -> do
904 { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
905
906 -- By this point, we have bound every universal and existential
907 -- tyvar. Because of the dcUserTyVarBinders invariant
908 -- (see Note [DataCon user type variable binders]), *every* tyvar in
909 -- ifConUserTvBinders has a matching counterpart somewhere in the
910 -- bound universals/existentials. As a result, calling tcIfaceTyVar
911 -- below is always guaranteed to succeed.
912 ; user_tv_bndrs <- mapM (\(TvBndr (name, _) vis) ->
913 TvBndr <$> tcIfaceTyVar name <*> pure vis)
914 user_bndrs
915
916 -- Read the context and argument types, but lazily for two reasons
917 -- (a) to avoid looking tugging on a recursive use of
918 -- the type itself, which is knot-tied
919 -- (b) to avoid faulting in the component types unless
920 -- they are really needed
921 ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
922 do { eq_spec <- tcIfaceEqSpec spec
923 ; theta <- tcIfaceCtxt ctxt
924 -- This fixes #13710. The enclosing lazy thunk gets
925 -- forced when typechecking record wildcard pattern
926 -- matching (it's not completely clear why this
927 -- tuple is needed), which causes trouble if one of
928 -- the argument types was recursively defined.
929 -- See also Note [Tying the knot]
930 ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
931 $ mapM tcIfaceType args
932 ; stricts <- mapM tc_strict if_stricts
933 -- The IfBang field can mention
934 -- the type itself; hence inside forkM
935 ; return (eq_spec, theta, arg_tys, stricts) }
936
937 -- Remember, tycon is the representation tycon
938 ; let orig_res_ty = mkFamilyTyConApp tycon
939 (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
940 (binderVars tc_tybinders))
941
942 ; prom_rep_name <- newTyConRepName dc_name
943
944 ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
945 dc_name is_infix prom_rep_name
946 (map src_strict if_src_stricts)
947 (Just stricts)
948 -- Pass the HsImplBangs (i.e. final
949 -- decisions) to buildDataCon; it'll use
950 -- these to guide the construction of a
951 -- worker.
952 -- See Note [Bangs on imported data constructors] in MkId
953 lbl_names
954 univ_tvs ex_tvs user_tv_bndrs
955 eq_spec theta
956 arg_tys orig_res_ty tycon tag_map
957 ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
958 ; return con }
959 mk_doc con_name = text "Constructor" <+> ppr con_name
960
961 tc_strict :: IfaceBang -> IfL HsImplBang
962 tc_strict IfNoBang = return (HsLazy)
963 tc_strict IfStrict = return (HsStrict)
964 tc_strict IfUnpack = return (HsUnpack Nothing)
965 tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
966 ; return (HsUnpack (Just co)) }
967
968 src_strict :: IfaceSrcBang -> HsSrcBang
969 src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
970
971 tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
972 tcIfaceEqSpec spec
973 = mapM do_item spec
974 where
975 do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
976 ; ty <- tcIfaceType if_ty
977 ; return (mkEqSpec tv ty) }
978
979 {-
980 Note [Synonym kind loop]
981 ~~~~~~~~~~~~~~~~~~~~~~~~
982 Notice that we eagerly grab the *kind* from the interface file, but
983 build a forkM thunk for the *rhs* (and family stuff). To see why,
984 consider this (Trac #2412)
985
986 M.hs: module M where { import X; data T = MkT S }
987 X.hs: module X where { import {-# SOURCE #-} M; type S = T }
988 M.hs-boot: module M where { data T }
989
990 When kind-checking M.hs we need S's kind. But we do not want to
991 find S's kind from (typeKind S-rhs), because we don't want to look at
992 S-rhs yet! Since S is imported from X.hi, S gets just one chance to
993 be defined, and we must not do that until we've finished with M.T.
994
995 Solution: record S's kind in the interface file; now we can safely
996 look at it.
997
998 ************************************************************************
999 * *
1000 Instances
1001 * *
1002 ************************************************************************
1003 -}
1004
1005 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
1006 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
1007 , ifInstCls = cls, ifInstTys = mb_tcs
1008 , ifInstOrph = orph })
1009 = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
1010 fmap tyThingId (tcIfaceImplicit dfun_name)
1011 ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1012 ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
1013
1014 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
1015 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1016 , ifFamInstAxiom = axiom_name } )
1017 = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
1018 tcIfaceCoAxiom axiom_name
1019 -- will panic if branched, but that's OK
1020 ; let axiom'' = toUnbranchedAxiom axiom'
1021 mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1022 ; return (mkImportedFamInst fam mb_tcs' axiom'') }
1023
1024 {-
1025 ************************************************************************
1026 * *
1027 Rules
1028 * *
1029 ************************************************************************
1030
1031 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
1032 are in the type environment. However, remember that typechecking a Rule may
1033 (as a side effect) augment the type envt, and so we may need to iterate the process.
1034 -}
1035
1036 tcIfaceRules :: Bool -- True <=> ignore rules
1037 -> [IfaceRule]
1038 -> IfL [CoreRule]
1039 tcIfaceRules ignore_prags if_rules
1040 | ignore_prags = return []
1041 | otherwise = mapM tcIfaceRule if_rules
1042
1043 tcIfaceRule :: IfaceRule -> IfL CoreRule
1044 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1045 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1046 ifRuleAuto = auto, ifRuleOrph = orph })
1047 = do { ~(bndrs', args', rhs') <-
1048 -- Typecheck the payload lazily, in the hope it'll never be looked at
1049 forkM (text "Rule" <+> pprRuleName name) $
1050 bindIfaceBndrs bndrs $ \ bndrs' ->
1051 do { args' <- mapM tcIfaceExpr args
1052 ; rhs' <- tcIfaceExpr rhs
1053 ; return (bndrs', args', rhs') }
1054 ; let mb_tcs = map ifTopFreeName args
1055 ; this_mod <- getIfModule
1056 ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
1057 ru_bndrs = bndrs', ru_args = args',
1058 ru_rhs = occurAnalyseExpr rhs',
1059 ru_rough = mb_tcs,
1060 ru_origin = this_mod,
1061 ru_orphan = orph,
1062 ru_auto = auto,
1063 ru_local = False }) } -- An imported RULE is never for a local Id
1064 -- or, even if it is (module loop, perhaps)
1065 -- we'll just leave it in the non-local set
1066 where
1067 -- This function *must* mirror exactly what Rules.roughTopNames does
1068 -- We could have stored the ru_rough field in the iface file
1069 -- but that would be redundant, I think.
1070 -- The only wrinkle is that we must not be deceived by
1071 -- type synonyms at the top of a type arg. Since
1072 -- we can't tell at this point, we are careful not
1073 -- to write them out in coreRuleToIfaceRule
1074 ifTopFreeName :: IfaceExpr -> Maybe Name
1075 ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
1076 ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
1077 ifTopFreeName (IfaceApp f _) = ifTopFreeName f
1078 ifTopFreeName (IfaceExt n) = Just n
1079 ifTopFreeName _ = Nothing
1080
1081 {-
1082 ************************************************************************
1083 * *
1084 Annotations
1085 * *
1086 ************************************************************************
1087 -}
1088
1089 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
1090 tcIfaceAnnotations = mapM tcIfaceAnnotation
1091
1092 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
1093 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
1094 target' <- tcIfaceAnnTarget target
1095 return $ Annotation {
1096 ann_target = target',
1097 ann_value = serialized
1098 }
1099
1100 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
1101 tcIfaceAnnTarget (NamedTarget occ) = do
1102 name <- lookupIfaceTop occ
1103 return $ NamedTarget name
1104 tcIfaceAnnTarget (ModuleTarget mod) = do
1105 return $ ModuleTarget mod
1106
1107 {-
1108 ************************************************************************
1109 * *
1110 Complete Match Pragmas
1111 * *
1112 ************************************************************************
1113 -}
1114
1115 tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
1116 tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
1117
1118 tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
1119 tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
1120
1121 {-
1122 ************************************************************************
1123 * *
1124 Types
1125 * *
1126 ************************************************************************
1127 -}
1128
1129 tcIfaceType :: IfaceType -> IfL Type
1130 tcIfaceType = go
1131 where
1132 go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
1133 go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
1134 go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
1135 go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1136 go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1137 go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
1138 go (IfaceAppTy t ts)
1139 = do { t' <- go t
1140 ; ts' <- traverse go (appArgsIfaceTypes ts)
1141 ; pure (foldl' AppTy t' ts') }
1142 go (IfaceTyConApp tc tks)
1143 = do { tc' <- tcIfaceTyCon tc
1144 ; tks' <- mapM go (appArgsIfaceTypes tks)
1145 ; return (mkTyConApp tc' tks') }
1146 go (IfaceForAllTy bndr t)
1147 = bindIfaceForAllBndr bndr $ \ tv' vis ->
1148 ForAllTy (TvBndr tv' vis) <$> go t
1149 go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
1150 go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
1151
1152 tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
1153 tcIfaceTupleTy sort is_promoted args
1154 = do { args' <- tcIfaceAppArgs args
1155 ; let arity = length args'
1156 ; base_tc <- tcTupleTyCon True sort arity
1157 ; case is_promoted of
1158 IsNotPromoted
1159 -> return (mkTyConApp base_tc args')
1160
1161 IsPromoted
1162 -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
1163 kind_args = map typeKind args'
1164 ; return (mkTyConApp tc (kind_args ++ args')) } }
1165
1166 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1167 tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
1168 -> TupleSort
1169 -> Arity -- the number of args. *not* the tuple arity.
1170 -> IfL TyCon
1171 tcTupleTyCon in_type sort arity
1172 = case sort of
1173 ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
1174 ; return (tyThingTyCon thing) }
1175 BoxedTuple -> return (tupleTyCon Boxed arity)
1176 UnboxedTuple -> return (tupleTyCon Unboxed arity')
1177 where arity' | in_type = arity `div` 2
1178 | otherwise = arity
1179 -- in expressions, we only have term args
1180
1181 tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
1182 tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
1183
1184 -----------------------------------------
1185 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
1186 tcIfaceCtxt sts = mapM tcIfaceType sts
1187
1188 -----------------------------------------
1189 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
1190 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
1191 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
1192
1193 {-
1194 %************************************************************************
1195 %* *
1196 Coercions
1197 * *
1198 ************************************************************************
1199 -}
1200
1201 tcIfaceCo :: IfaceCoercion -> IfL Coercion
1202 tcIfaceCo = go
1203 where
1204 go_mco IfaceMRefl = pure MRefl
1205 go_mco (IfaceMCo co) = MCo <$> (go co)
1206
1207 go (IfaceReflCo t) = Refl <$> tcIfaceType t
1208 go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco
1209 go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
1210 go (IfaceTyConAppCo r tc cs)
1211 = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
1212 go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
1213 go (IfaceForAllCo tv k c) = do { k' <- go k
1214 ; bindIfaceTyVar tv $ \ tv' ->
1215 ForAllCo tv' k' <$> go c }
1216 go (IfaceCoVarCo n) = CoVarCo <$> go_var n
1217 go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
1218 go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
1219 <*> tcIfaceType t1 <*> tcIfaceType t2
1220 go (IfaceSymCo c) = SymCo <$> go c
1221 go (IfaceTransCo c1 c2) = TransCo <$> go c1
1222 <*> go c2
1223 go (IfaceInstCo c1 t2) = InstCo <$> go c1
1224 <*> go t2
1225 go (IfaceNthCo d c) = do { c' <- go c
1226 ; return $ mkNthCo (nthCoRole d c') d c' }
1227 go (IfaceLRCo lr c) = LRCo lr <$> go c
1228 go (IfaceKindCo c) = KindCo <$> go c
1229 go (IfaceSubCo c) = SubCo <$> go c
1230 go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
1231 <*> mapM go cos
1232 go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
1233 go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
1234
1235 go_var :: FastString -> IfL CoVar
1236 go_var = tcIfaceLclId
1237
1238 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
1239 tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
1240 tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
1241 tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
1242 tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
1243
1244 {-
1245 ************************************************************************
1246 * *
1247 Core
1248 * *
1249 ************************************************************************
1250 -}
1251
1252 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
1253 tcIfaceExpr (IfaceType ty)
1254 = Type <$> tcIfaceType ty
1255
1256 tcIfaceExpr (IfaceCo co)
1257 = Coercion <$> tcIfaceCo co
1258
1259 tcIfaceExpr (IfaceCast expr co)
1260 = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
1261
1262 tcIfaceExpr (IfaceLcl name)
1263 = Var <$> tcIfaceLclId name
1264
1265 tcIfaceExpr (IfaceExt gbl)
1266 = Var <$> tcIfaceExtId gbl
1267
1268 tcIfaceExpr (IfaceLit lit)
1269 = do lit' <- tcIfaceLit lit
1270 return (Lit lit')
1271
1272 tcIfaceExpr (IfaceFCall cc ty) = do
1273 ty' <- tcIfaceType ty
1274 u <- newUnique
1275 dflags <- getDynFlags
1276 return (Var (mkFCallId dflags u cc ty'))
1277
1278 tcIfaceExpr (IfaceTuple sort args)
1279 = do { args' <- mapM tcIfaceExpr args
1280 ; tc <- tcTupleTyCon False sort arity
1281 ; let con_tys = map exprType args'
1282 some_con_args = map Type con_tys ++ args'
1283 con_args = case sort of
1284 UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
1285 _ -> some_con_args
1286 -- Put the missing type arguments back in
1287 con_id = dataConWorkId (tyConSingleDataCon tc)
1288 ; return (mkApps (Var con_id) con_args) }
1289 where
1290 arity = length args
1291
1292 tcIfaceExpr (IfaceLam (bndr, os) body)
1293 = bindIfaceBndr bndr $ \bndr' ->
1294 Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
1295 where
1296 tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
1297 tcIfaceOneShot _ b = b
1298
1299 tcIfaceExpr (IfaceApp fun arg)
1300 = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1301
1302 tcIfaceExpr (IfaceECase scrut ty)
1303 = do { scrut' <- tcIfaceExpr scrut
1304 ; ty' <- tcIfaceType ty
1305 ; return (castBottomExpr scrut' ty') }
1306
1307 tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
1308 scrut' <- tcIfaceExpr scrut
1309 case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1310 let
1311 scrut_ty = exprType scrut'
1312 case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
1313 tc_app = splitTyConApp scrut_ty
1314 -- NB: Won't always succeed (polymorphic case)
1315 -- but won't be demanded in those cases
1316 -- NB: not tcSplitTyConApp; we are looking at Core here
1317 -- look through non-rec newtypes to find the tycon that
1318 -- corresponds to the datacon in this case alternative
1319
1320 extendIfaceIdEnv [case_bndr'] $ do
1321 alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1322 return (Case scrut' case_bndr' (coreAltsType alts') alts')
1323
1324 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
1325 = do { name <- newIfaceName (mkVarOccFS fs)
1326 ; ty' <- tcIfaceType ty
1327 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1328 NotTopLevel name ty' info
1329 ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
1330 `asJoinId_maybe` tcJoinInfo ji
1331 ; rhs' <- tcIfaceExpr rhs
1332 ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1333 ; return (Let (NonRec id rhs') body') }
1334
1335 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1336 = do { ids <- mapM tc_rec_bndr (map fst pairs)
1337 ; extendIfaceIdEnv ids $ do
1338 { pairs' <- zipWithM tc_pair pairs ids
1339 ; body' <- tcIfaceExpr body
1340 ; return (Let (Rec pairs') body') } }
1341 where
1342 tc_rec_bndr (IfLetBndr fs ty _ ji)
1343 = do { name <- newIfaceName (mkVarOccFS fs)
1344 ; ty' <- tcIfaceType ty
1345 ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
1346 tc_pair (IfLetBndr _ _ info _, rhs) id
1347 = do { rhs' <- tcIfaceExpr rhs
1348 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1349 NotTopLevel (idName id) (idType id) info
1350 ; return (setIdInfo id id_info, rhs') }
1351
1352 tcIfaceExpr (IfaceTick tickish expr) = do
1353 expr' <- tcIfaceExpr expr
1354 -- If debug flag is not set: Ignore source notes
1355 dbgLvl <- fmap debugLevel getDynFlags
1356 case tickish of
1357 IfaceSource{} | dbgLvl > 0
1358 -> return expr'
1359 _otherwise -> do
1360 tickish' <- tcIfaceTickish tickish
1361 return (Tick tickish' expr')
1362
1363 -------------------------
1364 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1365 tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
1366 tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
1367 tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
1368
1369 -------------------------
1370 tcIfaceLit :: Literal -> IfL Literal
1371 -- Integer literals deserialise to (LitInteger i <error thunk>)
1372 -- so tcIfaceLit just fills in the type.
1373 -- See Note [Integer literals] in Literal
1374 tcIfaceLit (LitNumber LitNumInteger i _)
1375 = do t <- tcIfaceTyConByName integerTyConName
1376 return (mkLitInteger i (mkTyConTy t))
1377 -- Natural literals deserialise to (LitNatural i <error thunk>)
1378 -- so tcIfaceLit just fills in the type.
1379 -- See Note [Natural literals] in Literal
1380 tcIfaceLit (LitNumber LitNumNatural i _)
1381 = do t <- tcIfaceTyConByName naturalTyConName
1382 return (mkLitNatural i (mkTyConTy t))
1383 tcIfaceLit lit = return lit
1384
1385 -------------------------
1386 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1387 -> (IfaceConAlt, [FastString], IfaceExpr)
1388 -> IfL (AltCon, [TyVar], CoreExpr)
1389 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1390 = ASSERT( null names ) do
1391 rhs' <- tcIfaceExpr rhs
1392 return (DEFAULT, [], rhs')
1393
1394 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1395 = ASSERT( null names ) do
1396 lit' <- tcIfaceLit lit
1397 rhs' <- tcIfaceExpr rhs
1398 return (LitAlt lit', [], rhs')
1399
1400 -- A case alternative is made quite a bit more complicated
1401 -- by the fact that we omit type annotations because we can
1402 -- work them out. True enough, but its not that easy!
1403 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1404 = do { con <- tcIfaceDataCon data_occ
1405 ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1406 (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1407 ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1408
1409 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1410 -> IfL (AltCon, [TyVar], CoreExpr)
1411 tcIfaceDataAlt con inst_tys arg_strs rhs
1412 = do { us <- newUniqueSupply
1413 ; let uniqs = uniqsFromSupply us
1414 ; let (ex_tvs, arg_ids)
1415 = dataConRepFSInstPat arg_strs uniqs con inst_tys
1416
1417 ; rhs' <- extendIfaceEnvs ex_tvs $
1418 extendIfaceIdEnv arg_ids $
1419 tcIfaceExpr rhs
1420 ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1421
1422 {-
1423 ************************************************************************
1424 * *
1425 IdInfo
1426 * *
1427 ************************************************************************
1428 -}
1429
1430 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1431 tcIdDetails _ IfVanillaId = return VanillaId
1432 tcIdDetails ty IfDFunId
1433 = return (DFunId (isNewTyCon (classTyCon cls)))
1434 where
1435 (_, _, cls, _) = tcSplitDFunTy ty
1436
1437 tcIdDetails _ (IfRecSelId tc naughty)
1438 = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
1439 (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
1440 tc
1441 ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1442 where
1443 tyThingPatSyn (AConLike (PatSynCon ps)) = ps
1444 tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
1445
1446 tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1447 tcIdInfo ignore_prags toplvl name ty info = do
1448 lcl_env <- getLclEnv
1449 -- Set the CgInfo to something sensible but uninformative before
1450 -- we start; default assumption is that it has CAFs
1451 let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
1452 | otherwise = vanillaIdInfo
1453 if ignore_prags
1454 then return init_info
1455 else case info of
1456 NoInfo -> return init_info
1457 HasInfo info -> foldlM tcPrag init_info info
1458 where
1459 tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1460 tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
1461 tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
1462 tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1463 tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
1464 tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
1465
1466 -- The next two are lazy, so they don't transitively suck stuff in
1467 tcPrag info (HsUnfold lb if_unf)
1468 = do { unf <- tcUnfolding toplvl name ty info if_unf
1469 ; let info1 | lb = info `setOccInfo` strongLoopBreaker
1470 | otherwise = info
1471 ; return (info1 `setUnfoldingInfo` unf) }
1472
1473 tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
1474 tcJoinInfo (IfaceJoinPoint ar) = Just ar
1475 tcJoinInfo IfaceNotJoinPoint = Nothing
1476
1477 tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1478 tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
1479 = do { dflags <- getDynFlags
1480 ; mb_expr <- tcPragExpr toplvl name if_expr
1481 ; let unf_src | stable = InlineStable
1482 | otherwise = InlineRhs
1483 ; return $ case mb_expr of
1484 Nothing -> NoUnfolding
1485 Just expr -> mkUnfolding dflags unf_src
1486 True {- Top level -}
1487 (isBottomingSig strict_sig)
1488 expr
1489 }
1490 where
1491 -- Strictness should occur before unfolding!
1492 strict_sig = strictnessInfo info
1493 tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
1494 = do { mb_expr <- tcPragExpr toplvl name if_expr
1495 ; return (case mb_expr of
1496 Nothing -> NoUnfolding
1497 Just expr -> mkCompulsoryUnfolding expr) }
1498
1499 tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1500 = do { mb_expr <- tcPragExpr toplvl name if_expr
1501 ; return (case mb_expr of
1502 Nothing -> NoUnfolding
1503 Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
1504 where
1505 guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1506
1507 tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
1508 = bindIfaceBndrs bs $ \ bs' ->
1509 do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
1510 ; return (case mb_ops1 of
1511 Nothing -> noUnfolding
1512 Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
1513 where
1514 doc = text "Class ops for dfun" <+> ppr name
1515 (_, _, cls, _) = tcSplitDFunTy dfun_ty
1516
1517 {-
1518 For unfoldings we try to do the job lazily, so that we never type check
1519 an unfolding that isn't going to be looked at.
1520 -}
1521
1522 tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1523 tcPragExpr toplvl name expr
1524 = forkM_maybe doc $ do
1525 core_expr' <- tcIfaceExpr expr
1526
1527 -- Check for type consistency in the unfolding
1528 -- See Note [Linting Unfoldings from Interfaces]
1529 when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
1530 in_scope <- get_in_scope
1531 dflags <- getDynFlags
1532 case lintUnfolding dflags noSrcLoc in_scope core_expr' of
1533 Nothing -> return ()
1534 Just fail_msg -> do { mod <- getIfModule
1535 ; pprPanic "Iface Lint failure"
1536 (vcat [ text "In interface for" <+> ppr mod
1537 , hang doc 2 fail_msg
1538 , ppr name <+> equals <+> ppr core_expr'
1539 , text "Iface expr =" <+> ppr expr ]) }
1540 return core_expr'
1541 where
1542 doc = text "Unfolding of" <+> ppr name
1543
1544 get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
1545 get_in_scope
1546 = do { (gbl_env, lcl_env) <- getEnvs
1547 ; rec_ids <- case if_rec_types gbl_env of
1548 Nothing -> return []
1549 Just (_, get_env) -> do
1550 { type_env <- setLclEnv () get_env
1551 ; return (typeEnvIds type_env) }
1552 ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
1553 bindingsVars (if_id_env lcl_env) `unionVarSet`
1554 mkVarSet rec_ids) }
1555
1556 bindingsVars :: FastStringEnv Var -> VarSet
1557 bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
1558 -- It's OK to use nonDetEltsUFM here because we immediately forget
1559 -- the ordering by creating a set
1560
1561 {-
1562 ************************************************************************
1563 * *
1564 Getting from Names to TyThings
1565 * *
1566 ************************************************************************
1567 -}
1568
1569 tcIfaceGlobal :: Name -> IfL TyThing
1570 tcIfaceGlobal name
1571 | Just thing <- wiredInNameTyThing_maybe name
1572 -- Wired-in things include TyCons, DataCons, and Ids
1573 -- Even though we are in an interface file, we want to make
1574 -- sure the instances and RULES of this thing (particularly TyCon) are loaded
1575 -- Imagine: f :: Double -> Double
1576 = do { ifCheckWiredInThing thing; return thing }
1577
1578 | otherwise
1579 = do { env <- getGblEnv
1580 ; case if_rec_types env of { -- Note [Tying the knot]
1581 Just (mod, get_type_env)
1582 | nameIsLocalOrFrom mod name
1583 -> do -- It's defined in the module being compiled
1584 { type_env <- setLclEnv () get_type_env -- yuk
1585 ; case lookupNameEnv type_env name of
1586 Just thing -> return thing
1587 -- See Note [Knot-tying fallback on boot]
1588 Nothing -> via_external
1589 }
1590
1591 ; _ -> via_external }}
1592 where
1593 via_external = do
1594 { hsc_env <- getTopEnv
1595 ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1596 ; case mb_thing of {
1597 Just thing -> return thing ;
1598 Nothing -> do
1599
1600 { mb_thing <- importDecl name -- It's imported; go get it
1601 ; case mb_thing of
1602 Failed err -> failIfM err
1603 Succeeded thing -> return thing
1604 }}}
1605
1606 -- Note [Tying the knot]
1607 -- ~~~~~~~~~~~~~~~~~~~~~
1608 -- The if_rec_types field is used when we are compiling M.hs, which indirectly
1609 -- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
1610 -- environment, which is splatted into if_rec_types after we've built M's type
1611 -- envt.
1612 --
1613 -- This is a dark and complicated part of GHC type checking, with a lot
1614 -- of moving parts. Interested readers should also look at:
1615 --
1616 -- * Note [Knot-tying typecheckIface]
1617 -- * Note [DFun knot-tying]
1618 -- * Note [hsc_type_env_var hack]
1619 -- * Note [Knot-tying fallback on boot]
1620 --
1621 -- There is also a wiki page on the subject, see:
1622 --
1623 -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
1624
1625 -- Note [Knot-tying fallback on boot]
1626 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1627 -- Suppose that you are typechecking A.hs, which transitively imports,
1628 -- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
1629 -- has a reference to a type T from A, what TyThing should we wire
1630 -- it up with? Clearly, if we have already typechecked T and
1631 -- added it into the type environment, we should go ahead and use that
1632 -- type. But what if we haven't typechecked it yet?
1633 --
1634 -- For the longest time, GHC adopted the policy that this was
1635 -- *an error condition*; that you MUST NEVER poke on B.hs's reference
1636 -- to a T defined in A.hs until A.hs has gotten around to kind-checking
1637 -- T and adding it to the env. However, actually ensuring this is the
1638 -- case has proven to be a bug farm, because it's really difficult to
1639 -- actually ensure this never happens. The problem was especially poignant
1640 -- with type family consistency checks, which eagerly happen before any
1641 -- typechecking takes place.
1642 --
1643 -- Today, we take a different strategy: if we ever try to access
1644 -- an entity from A which doesn't exist, we just fall back on the
1645 -- definition of A from the hs-boot file. This is complicated in
1646 -- its own way: it means that you may end up with a mix of A.hs and
1647 -- A.hs-boot TyThings during the course of typechecking. We don't
1648 -- think (and have not observed) any cases where this would cause
1649 -- problems, but the hypothetical situation one might worry about
1650 -- is something along these lines in Core:
1651 --
1652 -- case x of
1653 -- A -> e1
1654 -- B -> e2
1655 --
1656 -- If, when typechecking this, we find x :: T, and the T we are hooked
1657 -- up with is the abstract one from the hs-boot file, rather than the
1658 -- one defined in this module with constructors A and B. But it's hard
1659 -- to see how this could happen, especially because the reference to
1660 -- the constructor (A and B) means that GHC will always typecheck
1661 -- this expression *after* typechecking T.
1662
1663 tcIfaceTyConByName :: IfExtName -> IfL TyCon
1664 tcIfaceTyConByName name
1665 = do { thing <- tcIfaceGlobal name
1666 ; return (tyThingTyCon thing) }
1667
1668 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1669 tcIfaceTyCon (IfaceTyCon name info)
1670 = do { thing <- tcIfaceGlobal name
1671 ; return $ case ifaceTyConIsPromoted info of
1672 IsNotPromoted -> tyThingTyCon thing
1673 IsPromoted -> promoteDataCon $ tyThingDataCon thing }
1674
1675 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
1676 tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
1677 ; return (tyThingCoAxiom thing) }
1678
1679
1680 tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
1681 -- Unlike CoAxioms, which arise form user 'type instance' declarations,
1682 -- there are a fixed set of CoAxiomRules,
1683 -- currently enumerated in typeNatCoAxiomRules
1684 tcIfaceCoAxiomRule n
1685 = case Map.lookup n typeNatCoAxiomRules of
1686 Just ax -> return ax
1687 _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
1688
1689 tcIfaceDataCon :: Name -> IfL DataCon
1690 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1691 ; case thing of
1692 AConLike (RealDataCon dc) -> return dc
1693 _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1694
1695 tcIfaceExtId :: Name -> IfL Id
1696 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1697 ; case thing of
1698 AnId id -> return id
1699 _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1700
1701 -- See Note [Resolving never-exported Names in TcIface]
1702 tcIfaceImplicit :: Name -> IfL TyThing
1703 tcIfaceImplicit n = do
1704 lcl_env <- getLclEnv
1705 case if_implicits_env lcl_env of
1706 Nothing -> tcIfaceGlobal n
1707 Just tenv ->
1708 case lookupTypeEnv tenv n of
1709 Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
1710 Just tything -> return tything
1711
1712 {-
1713 ************************************************************************
1714 * *
1715 Bindings
1716 * *
1717 ************************************************************************
1718 -}
1719
1720 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
1721 bindIfaceId (fs, ty) thing_inside
1722 = do { name <- newIfaceName (mkVarOccFS fs)
1723 ; ty' <- tcIfaceType ty
1724 ; let id = mkLocalIdOrCoVar name ty'
1725 ; extendIfaceIdEnv [id] (thing_inside id) }
1726
1727 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
1728 bindIfaceIds [] thing_inside = thing_inside []
1729 bindIfaceIds (b:bs) thing_inside
1730 = bindIfaceId b $ \b' ->
1731 bindIfaceIds bs $ \bs' ->
1732 thing_inside (b':bs')
1733
1734 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1735 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
1736 = bindIfaceId bndr thing_inside
1737 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1738 = bindIfaceTyVar bndr thing_inside
1739
1740 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1741 bindIfaceBndrs [] thing_inside = thing_inside []
1742 bindIfaceBndrs (b:bs) thing_inside
1743 = bindIfaceBndr b $ \ b' ->
1744 bindIfaceBndrs bs $ \ bs' ->
1745 thing_inside (b':bs')
1746
1747 -----------------------
1748 bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
1749 bindIfaceForAllBndrs [] thing_inside = thing_inside []
1750 bindIfaceForAllBndrs (bndr:bndrs) thing_inside
1751 = bindIfaceForAllBndr bndr $ \tv vis ->
1752 bindIfaceForAllBndrs bndrs $ \bndrs' ->
1753 thing_inside (mkTyVarBinder vis tv : bndrs')
1754
1755 bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
1756 bindIfaceForAllBndr (TvBndr tv vis) thing_inside
1757 = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
1758
1759 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1760 bindIfaceTyVars [] thing_inside = thing_inside []
1761 bindIfaceTyVars (tv:tvs) thing_inside
1762 = bindIfaceTyVar tv $ \tv' ->
1763 bindIfaceTyVars tvs $ \tvs' ->
1764 thing_inside (tv' : tvs')
1765
1766 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1767 bindIfaceTyVar (occ,kind) thing_inside
1768 = do { name <- newIfaceName (mkTyVarOccFS occ)
1769 ; tyvar <- mk_iface_tyvar name kind
1770 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1771
1772 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1773 mk_iface_tyvar name ifKind
1774 = do { kind <- tcIfaceType ifKind
1775 ; return (Var.mkTyVar name kind) }
1776
1777 bindIfaceTyConBinders :: [IfaceTyConBinder]
1778 -> ([TyConBinder] -> IfL a) -> IfL a
1779 bindIfaceTyConBinders [] thing_inside = thing_inside []
1780 bindIfaceTyConBinders (b:bs) thing_inside
1781 = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
1782 bindIfaceTyConBinders bs $ \ bs' ->
1783 thing_inside (b':bs')
1784
1785 bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
1786 -> ([TyConBinder] -> IfL a) -> IfL a
1787 -- Used for type variable in nested associated data/type declarations
1788 -- where some of the type variables are already in scope
1789 -- class C a where { data T a b }
1790 -- Here 'a' is in scope when we look at the 'data T'
1791 bindIfaceTyConBinders_AT [] thing_inside
1792 = thing_inside []
1793 bindIfaceTyConBinders_AT (b : bs) thing_inside
1794 = bindIfaceTyConBinderX bind_tv b $ \b' ->
1795 bindIfaceTyConBinders_AT bs $ \bs' ->
1796 thing_inside (b':bs')
1797 where
1798 bind_tv tv thing
1799 = do { mb_tv <- lookupIfaceTyVar tv
1800 ; case mb_tv of
1801 Just b' -> thing b'
1802 Nothing -> bindIfaceTyVar tv thing }
1803
1804 bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
1805 -> IfaceTyConBinder
1806 -> (TyConBinder -> IfL a) -> IfL a
1807 bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
1808 = bind_tv tv $ \tv' ->
1809 thing_inside (TvBndr tv' vis)