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