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