Coercion Quantification
[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 -> Bndr (IfaceTvBndr 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 ifConExTCvs = 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 bindIfaceBndrs 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 (\(Bndr bd vis) ->
913 case bd of
914 IfaceIdBndr (name, _) ->
915 Bndr <$> tcIfaceLclId name <*> pure vis
916 IfaceTvBndr (name, _) ->
917 Bndr <$> tcIfaceTyVar name <*> pure vis)
918 user_bndrs
919
920 -- Read the context and argument types, but lazily for two reasons
921 -- (a) to avoid looking tugging on a recursive use of
922 -- the type itself, which is knot-tied
923 -- (b) to avoid faulting in the component types unless
924 -- they are really needed
925 ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
926 do { eq_spec <- tcIfaceEqSpec spec
927 ; theta <- tcIfaceCtxt ctxt
928 -- This fixes #13710. The enclosing lazy thunk gets
929 -- forced when typechecking record wildcard pattern
930 -- matching (it's not completely clear why this
931 -- tuple is needed), which causes trouble if one of
932 -- the argument types was recursively defined.
933 -- See also Note [Tying the knot]
934 ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
935 $ mapM tcIfaceType args
936 ; stricts <- mapM tc_strict if_stricts
937 -- The IfBang field can mention
938 -- the type itself; hence inside forkM
939 ; return (eq_spec, theta, arg_tys, stricts) }
940
941 -- Remember, tycon is the representation tycon
942 ; let orig_res_ty = mkFamilyTyConApp tycon
943 (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
944 (binderVars tc_tybinders))
945
946 ; prom_rep_name <- newTyConRepName dc_name
947
948 ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
949 dc_name is_infix prom_rep_name
950 (map src_strict if_src_stricts)
951 (Just stricts)
952 -- Pass the HsImplBangs (i.e. final
953 -- decisions) to buildDataCon; it'll use
954 -- these to guide the construction of a
955 -- worker.
956 -- See Note [Bangs on imported data constructors] in MkId
957 lbl_names
958 univ_tvs ex_tvs user_tv_bndrs
959 eq_spec theta
960 arg_tys orig_res_ty tycon tag_map
961 ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
962 ; return con }
963 mk_doc con_name = text "Constructor" <+> ppr con_name
964
965 tc_strict :: IfaceBang -> IfL HsImplBang
966 tc_strict IfNoBang = return (HsLazy)
967 tc_strict IfStrict = return (HsStrict)
968 tc_strict IfUnpack = return (HsUnpack Nothing)
969 tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
970 ; return (HsUnpack (Just co)) }
971
972 src_strict :: IfaceSrcBang -> HsSrcBang
973 src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
974
975 tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
976 tcIfaceEqSpec spec
977 = mapM do_item spec
978 where
979 do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
980 ; ty <- tcIfaceType if_ty
981 ; return (mkEqSpec tv ty) }
982
983 {-
984 Note [Synonym kind loop]
985 ~~~~~~~~~~~~~~~~~~~~~~~~
986 Notice that we eagerly grab the *kind* from the interface file, but
987 build a forkM thunk for the *rhs* (and family stuff). To see why,
988 consider this (Trac #2412)
989
990 M.hs: module M where { import X; data T = MkT S }
991 X.hs: module X where { import {-# SOURCE #-} M; type S = T }
992 M.hs-boot: module M where { data T }
993
994 When kind-checking M.hs we need S's kind. But we do not want to
995 find S's kind from (typeKind S-rhs), because we don't want to look at
996 S-rhs yet! Since S is imported from X.hi, S gets just one chance to
997 be defined, and we must not do that until we've finished with M.T.
998
999 Solution: record S's kind in the interface file; now we can safely
1000 look at it.
1001
1002 ************************************************************************
1003 * *
1004 Instances
1005 * *
1006 ************************************************************************
1007 -}
1008
1009 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
1010 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
1011 , ifInstCls = cls, ifInstTys = mb_tcs
1012 , ifInstOrph = orph })
1013 = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
1014 fmap tyThingId (tcIfaceImplicit dfun_name)
1015 ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1016 ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
1017
1018 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
1019 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1020 , ifFamInstAxiom = axiom_name } )
1021 = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
1022 tcIfaceCoAxiom axiom_name
1023 -- will panic if branched, but that's OK
1024 ; let axiom'' = toUnbranchedAxiom axiom'
1025 mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1026 ; return (mkImportedFamInst fam mb_tcs' axiom'') }
1027
1028 {-
1029 ************************************************************************
1030 * *
1031 Rules
1032 * *
1033 ************************************************************************
1034
1035 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
1036 are in the type environment. However, remember that typechecking a Rule may
1037 (as a side effect) augment the type envt, and so we may need to iterate the process.
1038 -}
1039
1040 tcIfaceRules :: Bool -- True <=> ignore rules
1041 -> [IfaceRule]
1042 -> IfL [CoreRule]
1043 tcIfaceRules ignore_prags if_rules
1044 | ignore_prags = return []
1045 | otherwise = mapM tcIfaceRule if_rules
1046
1047 tcIfaceRule :: IfaceRule -> IfL CoreRule
1048 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1049 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1050 ifRuleAuto = auto, ifRuleOrph = orph })
1051 = do { ~(bndrs', args', rhs') <-
1052 -- Typecheck the payload lazily, in the hope it'll never be looked at
1053 forkM (text "Rule" <+> pprRuleName name) $
1054 bindIfaceBndrs bndrs $ \ bndrs' ->
1055 do { args' <- mapM tcIfaceExpr args
1056 ; rhs' <- tcIfaceExpr rhs
1057 ; return (bndrs', args', rhs') }
1058 ; let mb_tcs = map ifTopFreeName args
1059 ; this_mod <- getIfModule
1060 ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
1061 ru_bndrs = bndrs', ru_args = args',
1062 ru_rhs = occurAnalyseExpr rhs',
1063 ru_rough = mb_tcs,
1064 ru_origin = this_mod,
1065 ru_orphan = orph,
1066 ru_auto = auto,
1067 ru_local = False }) } -- An imported RULE is never for a local Id
1068 -- or, even if it is (module loop, perhaps)
1069 -- we'll just leave it in the non-local set
1070 where
1071 -- This function *must* mirror exactly what Rules.roughTopNames does
1072 -- We could have stored the ru_rough field in the iface file
1073 -- but that would be redundant, I think.
1074 -- The only wrinkle is that we must not be deceived by
1075 -- type synonyms at the top of a type arg. Since
1076 -- we can't tell at this point, we are careful not
1077 -- to write them out in coreRuleToIfaceRule
1078 ifTopFreeName :: IfaceExpr -> Maybe Name
1079 ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
1080 ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
1081 ifTopFreeName (IfaceApp f _) = ifTopFreeName f
1082 ifTopFreeName (IfaceExt n) = Just n
1083 ifTopFreeName _ = Nothing
1084
1085 {-
1086 ************************************************************************
1087 * *
1088 Annotations
1089 * *
1090 ************************************************************************
1091 -}
1092
1093 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
1094 tcIfaceAnnotations = mapM tcIfaceAnnotation
1095
1096 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
1097 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
1098 target' <- tcIfaceAnnTarget target
1099 return $ Annotation {
1100 ann_target = target',
1101 ann_value = serialized
1102 }
1103
1104 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
1105 tcIfaceAnnTarget (NamedTarget occ) = do
1106 name <- lookupIfaceTop occ
1107 return $ NamedTarget name
1108 tcIfaceAnnTarget (ModuleTarget mod) = do
1109 return $ ModuleTarget mod
1110
1111 {-
1112 ************************************************************************
1113 * *
1114 Complete Match Pragmas
1115 * *
1116 ************************************************************************
1117 -}
1118
1119 tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
1120 tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
1121
1122 tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
1123 tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
1124
1125 {-
1126 ************************************************************************
1127 * *
1128 Types
1129 * *
1130 ************************************************************************
1131 -}
1132
1133 tcIfaceType :: IfaceType -> IfL Type
1134 tcIfaceType = go
1135 where
1136 go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
1137 go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
1138 go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
1139 go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1140 go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1141 go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
1142 go (IfaceAppTy t ts)
1143 = do { t' <- go t
1144 ; ts' <- traverse go (appArgsIfaceTypes ts)
1145 ; pure (foldl' AppTy t' ts') }
1146 go (IfaceTyConApp tc tks)
1147 = do { tc' <- tcIfaceTyCon tc
1148 ; tks' <- mapM go (appArgsIfaceTypes tks)
1149 ; return (mkTyConApp tc' tks') }
1150 go (IfaceForAllTy bndr t)
1151 = bindIfaceForAllBndr bndr $ \ tv' vis ->
1152 ForAllTy (Bndr tv' vis) <$> go t
1153 go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
1154 go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
1155
1156 tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
1157 tcIfaceTupleTy sort is_promoted args
1158 = do { args' <- tcIfaceAppArgs args
1159 ; let arity = length args'
1160 ; base_tc <- tcTupleTyCon True sort arity
1161 ; case is_promoted of
1162 IsNotPromoted
1163 -> return (mkTyConApp base_tc args')
1164
1165 IsPromoted
1166 -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
1167 kind_args = map typeKind args'
1168 ; return (mkTyConApp tc (kind_args ++ args')) } }
1169
1170 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1171 tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
1172 -> TupleSort
1173 -> Arity -- the number of args. *not* the tuple arity.
1174 -> IfL TyCon
1175 tcTupleTyCon in_type sort arity
1176 = case sort of
1177 ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
1178 ; return (tyThingTyCon thing) }
1179 BoxedTuple -> return (tupleTyCon Boxed arity)
1180 UnboxedTuple -> return (tupleTyCon Unboxed arity')
1181 where arity' | in_type = arity `div` 2
1182 | otherwise = arity
1183 -- in expressions, we only have term args
1184
1185 tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
1186 tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
1187
1188 -----------------------------------------
1189 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
1190 tcIfaceCtxt sts = mapM tcIfaceType sts
1191
1192 -----------------------------------------
1193 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
1194 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
1195 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
1196
1197 {-
1198 %************************************************************************
1199 %* *
1200 Coercions
1201 * *
1202 ************************************************************************
1203 -}
1204
1205 tcIfaceCo :: IfaceCoercion -> IfL Coercion
1206 tcIfaceCo = go
1207 where
1208 go_mco IfaceMRefl = pure MRefl
1209 go_mco (IfaceMCo co) = MCo <$> (go co)
1210
1211 go (IfaceReflCo t) = Refl <$> tcIfaceType t
1212 go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco
1213 go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
1214 go (IfaceTyConAppCo r tc cs)
1215 = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
1216 go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
1217 go (IfaceForAllCo tv k c) = do { k' <- go k
1218 ; bindIfaceBndr tv $ \ tv' ->
1219 ForAllCo tv' k' <$> go c }
1220 go (IfaceCoVarCo n) = CoVarCo <$> go_var n
1221 go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
1222 go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
1223 <*> tcIfaceType t1 <*> tcIfaceType t2
1224 go (IfaceSymCo c) = SymCo <$> go c
1225 go (IfaceTransCo c1 c2) = TransCo <$> go c1
1226 <*> go c2
1227 go (IfaceInstCo c1 t2) = InstCo <$> go c1
1228 <*> go t2
1229 go (IfaceNthCo d c) = do { c' <- go c
1230 ; return $ mkNthCo (nthCoRole d c') d c' }
1231 go (IfaceLRCo lr c) = LRCo lr <$> go c
1232 go (IfaceKindCo c) = KindCo <$> go c
1233 go (IfaceSubCo c) = SubCo <$> go c
1234 go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
1235 <*> mapM go cos
1236 go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
1237 go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
1238
1239 go_var :: FastString -> IfL CoVar
1240 go_var = tcIfaceLclId
1241
1242 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
1243 tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
1244 tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
1245 tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
1246 tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
1247
1248 {-
1249 ************************************************************************
1250 * *
1251 Core
1252 * *
1253 ************************************************************************
1254 -}
1255
1256 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
1257 tcIfaceExpr (IfaceType ty)
1258 = Type <$> tcIfaceType ty
1259
1260 tcIfaceExpr (IfaceCo co)
1261 = Coercion <$> tcIfaceCo co
1262
1263 tcIfaceExpr (IfaceCast expr co)
1264 = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
1265
1266 tcIfaceExpr (IfaceLcl name)
1267 = Var <$> tcIfaceLclId name
1268
1269 tcIfaceExpr (IfaceExt gbl)
1270 = Var <$> tcIfaceExtId gbl
1271
1272 tcIfaceExpr (IfaceLit lit)
1273 = do lit' <- tcIfaceLit lit
1274 return (Lit lit')
1275
1276 tcIfaceExpr (IfaceFCall cc ty) = do
1277 ty' <- tcIfaceType ty
1278 u <- newUnique
1279 dflags <- getDynFlags
1280 return (Var (mkFCallId dflags u cc ty'))
1281
1282 tcIfaceExpr (IfaceTuple sort args)
1283 = do { args' <- mapM tcIfaceExpr args
1284 ; tc <- tcTupleTyCon False sort arity
1285 ; let con_tys = map exprType args'
1286 some_con_args = map Type con_tys ++ args'
1287 con_args = case sort of
1288 UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
1289 _ -> some_con_args
1290 -- Put the missing type arguments back in
1291 con_id = dataConWorkId (tyConSingleDataCon tc)
1292 ; return (mkApps (Var con_id) con_args) }
1293 where
1294 arity = length args
1295
1296 tcIfaceExpr (IfaceLam (bndr, os) body)
1297 = bindIfaceBndr bndr $ \bndr' ->
1298 Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
1299 where
1300 tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
1301 tcIfaceOneShot _ b = b
1302
1303 tcIfaceExpr (IfaceApp fun arg)
1304 = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1305
1306 tcIfaceExpr (IfaceECase scrut ty)
1307 = do { scrut' <- tcIfaceExpr scrut
1308 ; ty' <- tcIfaceType ty
1309 ; return (castBottomExpr scrut' ty') }
1310
1311 tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
1312 scrut' <- tcIfaceExpr scrut
1313 case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1314 let
1315 scrut_ty = exprType scrut'
1316 case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
1317 tc_app = splitTyConApp scrut_ty
1318 -- NB: Won't always succeed (polymorphic case)
1319 -- but won't be demanded in those cases
1320 -- NB: not tcSplitTyConApp; we are looking at Core here
1321 -- look through non-rec newtypes to find the tycon that
1322 -- corresponds to the datacon in this case alternative
1323
1324 extendIfaceIdEnv [case_bndr'] $ do
1325 alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1326 return (Case scrut' case_bndr' (coreAltsType alts') alts')
1327
1328 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
1329 = do { name <- newIfaceName (mkVarOccFS fs)
1330 ; ty' <- tcIfaceType ty
1331 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1332 NotTopLevel name ty' info
1333 ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
1334 `asJoinId_maybe` tcJoinInfo ji
1335 ; rhs' <- tcIfaceExpr rhs
1336 ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1337 ; return (Let (NonRec id rhs') body') }
1338
1339 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1340 = do { ids <- mapM tc_rec_bndr (map fst pairs)
1341 ; extendIfaceIdEnv ids $ do
1342 { pairs' <- zipWithM tc_pair pairs ids
1343 ; body' <- tcIfaceExpr body
1344 ; return (Let (Rec pairs') body') } }
1345 where
1346 tc_rec_bndr (IfLetBndr fs ty _ ji)
1347 = do { name <- newIfaceName (mkVarOccFS fs)
1348 ; ty' <- tcIfaceType ty
1349 ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
1350 tc_pair (IfLetBndr _ _ info _, rhs) id
1351 = do { rhs' <- tcIfaceExpr rhs
1352 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1353 NotTopLevel (idName id) (idType id) info
1354 ; return (setIdInfo id id_info, rhs') }
1355
1356 tcIfaceExpr (IfaceTick tickish expr) = do
1357 expr' <- tcIfaceExpr expr
1358 -- If debug flag is not set: Ignore source notes
1359 dbgLvl <- fmap debugLevel getDynFlags
1360 case tickish of
1361 IfaceSource{} | dbgLvl > 0
1362 -> return expr'
1363 _otherwise -> do
1364 tickish' <- tcIfaceTickish tickish
1365 return (Tick tickish' expr')
1366
1367 -------------------------
1368 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1369 tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
1370 tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
1371 tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
1372
1373 -------------------------
1374 tcIfaceLit :: Literal -> IfL Literal
1375 -- Integer literals deserialise to (LitInteger i <error thunk>)
1376 -- so tcIfaceLit just fills in the type.
1377 -- See Note [Integer literals] in Literal
1378 tcIfaceLit (LitNumber LitNumInteger i _)
1379 = do t <- tcIfaceTyConByName integerTyConName
1380 return (mkLitInteger i (mkTyConTy t))
1381 -- Natural literals deserialise to (LitNatural i <error thunk>)
1382 -- so tcIfaceLit just fills in the type.
1383 -- See Note [Natural literals] in Literal
1384 tcIfaceLit (LitNumber LitNumNatural i _)
1385 = do t <- tcIfaceTyConByName naturalTyConName
1386 return (mkLitNatural i (mkTyConTy t))
1387 tcIfaceLit lit = return lit
1388
1389 -------------------------
1390 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1391 -> (IfaceConAlt, [FastString], IfaceExpr)
1392 -> IfL (AltCon, [TyVar], CoreExpr)
1393 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1394 = ASSERT( null names ) do
1395 rhs' <- tcIfaceExpr rhs
1396 return (DEFAULT, [], rhs')
1397
1398 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1399 = ASSERT( null names ) do
1400 lit' <- tcIfaceLit lit
1401 rhs' <- tcIfaceExpr rhs
1402 return (LitAlt lit', [], rhs')
1403
1404 -- A case alternative is made quite a bit more complicated
1405 -- by the fact that we omit type annotations because we can
1406 -- work them out. True enough, but its not that easy!
1407 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1408 = do { con <- tcIfaceDataCon data_occ
1409 ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1410 (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1411 ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1412
1413 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1414 -> IfL (AltCon, [TyVar], CoreExpr)
1415 tcIfaceDataAlt con inst_tys arg_strs rhs
1416 = do { us <- newUniqueSupply
1417 ; let uniqs = uniqsFromSupply us
1418 ; let (ex_tvs, arg_ids)
1419 = dataConRepFSInstPat arg_strs uniqs con inst_tys
1420
1421 ; rhs' <- extendIfaceEnvs ex_tvs $
1422 extendIfaceIdEnv arg_ids $
1423 tcIfaceExpr rhs
1424 ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1425
1426 {-
1427 ************************************************************************
1428 * *
1429 IdInfo
1430 * *
1431 ************************************************************************
1432 -}
1433
1434 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1435 tcIdDetails _ IfVanillaId = return VanillaId
1436 tcIdDetails ty IfDFunId
1437 = return (DFunId (isNewTyCon (classTyCon cls)))
1438 where
1439 (_, _, cls, _) = tcSplitDFunTy ty
1440
1441 tcIdDetails _ (IfRecSelId tc naughty)
1442 = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
1443 (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
1444 tc
1445 ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1446 where
1447 tyThingPatSyn (AConLike (PatSynCon ps)) = ps
1448 tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
1449
1450 tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1451 tcIdInfo ignore_prags toplvl name ty info = do
1452 lcl_env <- getLclEnv
1453 -- Set the CgInfo to something sensible but uninformative before
1454 -- we start; default assumption is that it has CAFs
1455 let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
1456 | otherwise = vanillaIdInfo
1457 if ignore_prags
1458 then return init_info
1459 else case info of
1460 NoInfo -> return init_info
1461 HasInfo info -> foldlM tcPrag init_info info
1462 where
1463 tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1464 tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
1465 tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
1466 tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1467 tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
1468 tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
1469
1470 -- The next two are lazy, so they don't transitively suck stuff in
1471 tcPrag info (HsUnfold lb if_unf)
1472 = do { unf <- tcUnfolding toplvl name ty info if_unf
1473 ; let info1 | lb = info `setOccInfo` strongLoopBreaker
1474 | otherwise = info
1475 ; return (info1 `setUnfoldingInfo` unf) }
1476
1477 tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
1478 tcJoinInfo (IfaceJoinPoint ar) = Just ar
1479 tcJoinInfo IfaceNotJoinPoint = Nothing
1480
1481 tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1482 tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
1483 = do { dflags <- getDynFlags
1484 ; mb_expr <- tcPragExpr toplvl name if_expr
1485 ; let unf_src | stable = InlineStable
1486 | otherwise = InlineRhs
1487 ; return $ case mb_expr of
1488 Nothing -> NoUnfolding
1489 Just expr -> mkUnfolding dflags unf_src
1490 True {- Top level -}
1491 (isBottomingSig strict_sig)
1492 expr
1493 }
1494 where
1495 -- Strictness should occur before unfolding!
1496 strict_sig = strictnessInfo info
1497 tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
1498 = do { mb_expr <- tcPragExpr toplvl name if_expr
1499 ; return (case mb_expr of
1500 Nothing -> NoUnfolding
1501 Just expr -> mkCompulsoryUnfolding expr) }
1502
1503 tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1504 = do { mb_expr <- tcPragExpr toplvl name if_expr
1505 ; return (case mb_expr of
1506 Nothing -> NoUnfolding
1507 Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
1508 where
1509 guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1510
1511 tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
1512 = bindIfaceBndrs bs $ \ bs' ->
1513 do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
1514 ; return (case mb_ops1 of
1515 Nothing -> noUnfolding
1516 Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
1517 where
1518 doc = text "Class ops for dfun" <+> ppr name
1519 (_, _, cls, _) = tcSplitDFunTy dfun_ty
1520
1521 {-
1522 For unfoldings we try to do the job lazily, so that we never type check
1523 an unfolding that isn't going to be looked at.
1524 -}
1525
1526 tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1527 tcPragExpr toplvl name expr
1528 = forkM_maybe doc $ do
1529 core_expr' <- tcIfaceExpr expr
1530
1531 -- Check for type consistency in the unfolding
1532 -- See Note [Linting Unfoldings from Interfaces]
1533 when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
1534 in_scope <- get_in_scope
1535 dflags <- getDynFlags
1536 case lintUnfolding dflags noSrcLoc in_scope core_expr' of
1537 Nothing -> return ()
1538 Just fail_msg -> do { mod <- getIfModule
1539 ; pprPanic "Iface Lint failure"
1540 (vcat [ text "In interface for" <+> ppr mod
1541 , hang doc 2 fail_msg
1542 , ppr name <+> equals <+> ppr core_expr'
1543 , text "Iface expr =" <+> ppr expr ]) }
1544 return core_expr'
1545 where
1546 doc = text "Unfolding of" <+> ppr name
1547
1548 get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
1549 get_in_scope
1550 = do { (gbl_env, lcl_env) <- getEnvs
1551 ; rec_ids <- case if_rec_types gbl_env of
1552 Nothing -> return []
1553 Just (_, get_env) -> do
1554 { type_env <- setLclEnv () get_env
1555 ; return (typeEnvIds type_env) }
1556 ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
1557 bindingsVars (if_id_env lcl_env) `unionVarSet`
1558 mkVarSet rec_ids) }
1559
1560 bindingsVars :: FastStringEnv Var -> VarSet
1561 bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
1562 -- It's OK to use nonDetEltsUFM here because we immediately forget
1563 -- the ordering by creating a set
1564
1565 {-
1566 ************************************************************************
1567 * *
1568 Getting from Names to TyThings
1569 * *
1570 ************************************************************************
1571 -}
1572
1573 tcIfaceGlobal :: Name -> IfL TyThing
1574 tcIfaceGlobal name
1575 | Just thing <- wiredInNameTyThing_maybe name
1576 -- Wired-in things include TyCons, DataCons, and Ids
1577 -- Even though we are in an interface file, we want to make
1578 -- sure the instances and RULES of this thing (particularly TyCon) are loaded
1579 -- Imagine: f :: Double -> Double
1580 = do { ifCheckWiredInThing thing; return thing }
1581
1582 | otherwise
1583 = do { env <- getGblEnv
1584 ; case if_rec_types env of { -- Note [Tying the knot]
1585 Just (mod, get_type_env)
1586 | nameIsLocalOrFrom mod name
1587 -> do -- It's defined in the module being compiled
1588 { type_env <- setLclEnv () get_type_env -- yuk
1589 ; case lookupNameEnv type_env name of
1590 Just thing -> return thing
1591 -- See Note [Knot-tying fallback on boot]
1592 Nothing -> via_external
1593 }
1594
1595 ; _ -> via_external }}
1596 where
1597 via_external = do
1598 { hsc_env <- getTopEnv
1599 ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1600 ; case mb_thing of {
1601 Just thing -> return thing ;
1602 Nothing -> do
1603
1604 { mb_thing <- importDecl name -- It's imported; go get it
1605 ; case mb_thing of
1606 Failed err -> failIfM err
1607 Succeeded thing -> return thing
1608 }}}
1609
1610 -- Note [Tying the knot]
1611 -- ~~~~~~~~~~~~~~~~~~~~~
1612 -- The if_rec_types field is used when we are compiling M.hs, which indirectly
1613 -- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
1614 -- environment, which is splatted into if_rec_types after we've built M's type
1615 -- envt.
1616 --
1617 -- This is a dark and complicated part of GHC type checking, with a lot
1618 -- of moving parts. Interested readers should also look at:
1619 --
1620 -- * Note [Knot-tying typecheckIface]
1621 -- * Note [DFun knot-tying]
1622 -- * Note [hsc_type_env_var hack]
1623 -- * Note [Knot-tying fallback on boot]
1624 --
1625 -- There is also a wiki page on the subject, see:
1626 --
1627 -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
1628
1629 -- Note [Knot-tying fallback on boot]
1630 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1631 -- Suppose that you are typechecking A.hs, which transitively imports,
1632 -- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
1633 -- has a reference to a type T from A, what TyThing should we wire
1634 -- it up with? Clearly, if we have already typechecked T and
1635 -- added it into the type environment, we should go ahead and use that
1636 -- type. But what if we haven't typechecked it yet?
1637 --
1638 -- For the longest time, GHC adopted the policy that this was
1639 -- *an error condition*; that you MUST NEVER poke on B.hs's reference
1640 -- to a T defined in A.hs until A.hs has gotten around to kind-checking
1641 -- T and adding it to the env. However, actually ensuring this is the
1642 -- case has proven to be a bug farm, because it's really difficult to
1643 -- actually ensure this never happens. The problem was especially poignant
1644 -- with type family consistency checks, which eagerly happen before any
1645 -- typechecking takes place.
1646 --
1647 -- Today, we take a different strategy: if we ever try to access
1648 -- an entity from A which doesn't exist, we just fall back on the
1649 -- definition of A from the hs-boot file. This is complicated in
1650 -- its own way: it means that you may end up with a mix of A.hs and
1651 -- A.hs-boot TyThings during the course of typechecking. We don't
1652 -- think (and have not observed) any cases where this would cause
1653 -- problems, but the hypothetical situation one might worry about
1654 -- is something along these lines in Core:
1655 --
1656 -- case x of
1657 -- A -> e1
1658 -- B -> e2
1659 --
1660 -- If, when typechecking this, we find x :: T, and the T we are hooked
1661 -- up with is the abstract one from the hs-boot file, rather than the
1662 -- one defined in this module with constructors A and B. But it's hard
1663 -- to see how this could happen, especially because the reference to
1664 -- the constructor (A and B) means that GHC will always typecheck
1665 -- this expression *after* typechecking T.
1666
1667 tcIfaceTyConByName :: IfExtName -> IfL TyCon
1668 tcIfaceTyConByName name
1669 = do { thing <- tcIfaceGlobal name
1670 ; return (tyThingTyCon thing) }
1671
1672 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1673 tcIfaceTyCon (IfaceTyCon name info)
1674 = do { thing <- tcIfaceGlobal name
1675 ; return $ case ifaceTyConIsPromoted info of
1676 IsNotPromoted -> tyThingTyCon thing
1677 IsPromoted -> promoteDataCon $ tyThingDataCon thing }
1678
1679 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
1680 tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
1681 ; return (tyThingCoAxiom thing) }
1682
1683
1684 tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
1685 -- Unlike CoAxioms, which arise form user 'type instance' declarations,
1686 -- there are a fixed set of CoAxiomRules,
1687 -- currently enumerated in typeNatCoAxiomRules
1688 tcIfaceCoAxiomRule n
1689 = case Map.lookup n typeNatCoAxiomRules of
1690 Just ax -> return ax
1691 _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
1692
1693 tcIfaceDataCon :: Name -> IfL DataCon
1694 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1695 ; case thing of
1696 AConLike (RealDataCon dc) -> return dc
1697 _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1698
1699 tcIfaceExtId :: Name -> IfL Id
1700 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1701 ; case thing of
1702 AnId id -> return id
1703 _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1704
1705 -- See Note [Resolving never-exported Names in TcIface]
1706 tcIfaceImplicit :: Name -> IfL TyThing
1707 tcIfaceImplicit n = do
1708 lcl_env <- getLclEnv
1709 case if_implicits_env lcl_env of
1710 Nothing -> tcIfaceGlobal n
1711 Just tenv ->
1712 case lookupTypeEnv tenv n of
1713 Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
1714 Just tything -> return tything
1715
1716 {-
1717 ************************************************************************
1718 * *
1719 Bindings
1720 * *
1721 ************************************************************************
1722 -}
1723
1724 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
1725 bindIfaceId (fs, ty) thing_inside
1726 = do { name <- newIfaceName (mkVarOccFS fs)
1727 ; ty' <- tcIfaceType ty
1728 ; let id = mkLocalIdOrCoVar name ty'
1729 ; extendIfaceIdEnv [id] (thing_inside id) }
1730
1731 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
1732 bindIfaceIds [] thing_inside = thing_inside []
1733 bindIfaceIds (b:bs) thing_inside
1734 = bindIfaceId b $ \b' ->
1735 bindIfaceIds bs $ \bs' ->
1736 thing_inside (b':bs')
1737
1738 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1739 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
1740 = bindIfaceId bndr thing_inside
1741 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1742 = bindIfaceTyVar bndr thing_inside
1743
1744 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1745 bindIfaceBndrs [] thing_inside = thing_inside []
1746 bindIfaceBndrs (b:bs) thing_inside
1747 = bindIfaceBndr b $ \ b' ->
1748 bindIfaceBndrs bs $ \ bs' ->
1749 thing_inside (b':bs')
1750
1751 -----------------------
1752 bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a
1753 bindIfaceForAllBndrs [] thing_inside = thing_inside []
1754 bindIfaceForAllBndrs (bndr:bndrs) thing_inside
1755 = bindIfaceForAllBndr bndr $ \tv vis ->
1756 bindIfaceForAllBndrs bndrs $ \bndrs' ->
1757 thing_inside (mkTyCoVarBinder vis tv : bndrs')
1758
1759 bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a
1760 bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
1761 = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
1762 bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
1763 = bindIfaceId tv $ \tv' -> thing_inside tv' vis
1764
1765 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1766 bindIfaceTyVar (occ,kind) thing_inside
1767 = do { name <- newIfaceName (mkTyVarOccFS occ)
1768 ; tyvar <- mk_iface_tyvar name kind
1769 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1770
1771 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1772 mk_iface_tyvar name ifKind
1773 = do { kind <- tcIfaceType ifKind
1774 ; return (Var.mkTyVar name kind) }
1775
1776 bindIfaceTyConBinders :: [IfaceTyConBinder]
1777 -> ([TyConBinder] -> IfL a) -> IfL a
1778 bindIfaceTyConBinders [] thing_inside = thing_inside []
1779 bindIfaceTyConBinders (b:bs) thing_inside
1780 = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' ->
1781 bindIfaceTyConBinders bs $ \ bs' ->
1782 thing_inside (b':bs')
1783
1784 bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
1785 -> ([TyConBinder] -> IfL a) -> IfL a
1786 -- Used for type variable in nested associated data/type declarations
1787 -- where some of the type variables are already in scope
1788 -- class C a where { data T a b }
1789 -- Here 'a' is in scope when we look at the 'data T'
1790 bindIfaceTyConBinders_AT [] thing_inside
1791 = thing_inside []
1792 bindIfaceTyConBinders_AT (b : bs) thing_inside
1793 = bindIfaceTyConBinderX bind_tv b $ \b' ->
1794 bindIfaceTyConBinders_AT bs $ \bs' ->
1795 thing_inside (b':bs')
1796 where
1797 bind_tv tv thing
1798 = do { mb_tv <- lookupIfaceVar tv
1799 ; case mb_tv of
1800 Just b' -> thing b'
1801 Nothing -> bindIfaceBndr tv thing }
1802
1803 bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
1804 -> IfaceTyConBinder
1805 -> (TyConBinder -> IfL a) -> IfL a
1806 bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
1807 = bind_tv tv $ \tv' ->
1808 thing_inside (Bndr tv' vis)