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