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