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