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