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