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