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