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