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