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