Generate Typeable info at definition sites
[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 Nothing
304
305 tc_iface_decl :: Maybe Class -- ^ For associated type/data family 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 _ _ (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 tc_name mb_parent
330 ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom
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 :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
337 tc_parent tc_name IfNoParent
338 = do { tc_rep_name <- newTyConRepName tc_name
339 ; return (VanillaAlgTyCon tc_rep_name) }
340 tc_parent _ (IfDataInstance ax_name _ arg_tys)
341 = do { ax <- tcIfaceCoAxiom ax_name
342 ; let fam_tc = coAxiomTyCon ax
343 ax_unbr = toUnbranchedAxiom ax
344 ; lhs_tys <- tcIfaceTcArgs arg_tys
345 ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
346
347 tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
348 ifRoles = roles,
349 ifSynRhs = rhs_ty,
350 ifSynKind = kind })
351 = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
352 { tc_name <- lookupIfaceTop occ_name
353 ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
354 ; rhs <- forkM (mk_doc tc_name) $
355 tcIfaceType rhs_ty
356 ; let tycon = buildSynonymTyCon tc_name tyvars roles rhs rhs_kind
357 ; return (ATyCon tycon) }
358 where
359 mk_doc n = ptext (sLit "Type synonym") <+> ppr n
360
361 tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
362 ifFamFlav = fam_flav,
363 ifFamKind = kind,
364 ifResVar = res, ifFamInj = inj })
365 = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
366 { tc_name <- lookupIfaceTop occ_name
367 ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
368 ; rhs <- forkM (mk_doc tc_name) $
369 tc_fam_flav tc_name fam_flav
370 ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
371 ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind
372 parent inj
373 ; return (ATyCon tycon) }
374 where
375 mk_doc n = ptext (sLit "Type synonym") <+> ppr n
376
377 tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
378 tc_fam_flav tc_name IfaceDataFamilyTyCon
379 = do { tc_rep_name <- newTyConRepName tc_name
380 ; return (DataFamilyTyCon tc_rep_name) }
381 tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
382 tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
383 = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
384 ; return (ClosedSynFamilyTyCon ax) }
385 tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
386 = return AbstractClosedSynFamilyTyCon
387 tc_fam_flav _ IfaceBuiltInSynFamTyCon
388 = pprPanic "tc_iface_decl"
389 (text "IfaceBuiltInSynFamTyCon in interface file")
390
391 tc_iface_decl _parent ignore_prags
392 (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
393 ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds,
394 ifATs = rdr_ats, ifSigs = rdr_sigs,
395 ifMinDef = mindef_occ, ifRec = tc_isrec })
396 -- ToDo: in hs-boot files we should really treat abstract classes specially,
397 -- as we do abstract tycons
398 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
399 { tc_name <- lookupIfaceTop tc_occ
400 ; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
401 ; ctxt <- mapM tc_sc rdr_ctxt
402 ; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
403 ; sigs <- mapM tc_sig rdr_sigs
404 ; fds <- mapM tc_fd rdr_fds
405 ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
406 ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
407 ; cls <- fixM $ \ cls -> do
408 { ats <- mapM (tc_at cls) rdr_ats
409 ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
410 ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
411 ; return (ATyCon (classTyCon cls)) }
412 where
413 tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
414 -- The *length* of the superclasses is used by buildClass, and hence must
415 -- not be inside the thunk. But the *content* maybe recursive and hence
416 -- must be lazy (via forkM). Example:
417 -- class C (T a) => D a where
418 -- data T a
419 -- Here the associated type T is knot-tied with the class, and
420 -- so we must not pull on T too eagerly. See Trac #5970
421
422 tc_sig (IfaceClassOp occ dm rdr_ty)
423 = do { op_name <- lookupIfaceTop occ
424 ; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
425 -- Must be done lazily for just the same reason as the
426 -- type of a data con; to avoid sucking in types that
427 -- it mentions unless it's necessary to do so
428 ; return (op_name, dm, op_ty) }
429
430 tc_at cls (IfaceAT tc_decl if_def)
431 = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
432 mb_def <- case if_def of
433 Nothing -> return Nothing
434 Just def -> forkM (mk_at_doc tc) $
435 extendIfaceTyVarEnv (tyConTyVars tc) $
436 do { tc_def <- tcIfaceType def
437 ; return (Just (tc_def, noSrcSpan)) }
438 -- Must be done lazily in case the RHS of the defaults mention
439 -- the type constructor being defined here
440 -- e.g. type AT a; type AT b = AT [b] Trac #8002
441 return (ATI tc mb_def)
442
443 mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
444 mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc
445 mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
446
447 tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
448 ; tvs2' <- mapM tcIfaceTyVar tvs2
449 ; return (tvs1', tvs2') }
450
451 tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
452 , ifAxBranches = branches, ifRole = role })
453 = do { tc_name <- lookupIfaceTop ax_occ
454 ; tc_tycon <- tcIfaceTyCon tc
455 ; tc_branches <- tc_ax_branches branches
456 ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
457 , co_ax_name = tc_name
458 , co_ax_tc = tc_tycon
459 , co_ax_role = role
460 , co_ax_branches = manyBranches tc_branches
461 , co_ax_implicit = False }
462 ; return (ACoAxiom axiom) }
463
464 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
465 , ifPatMatcher = if_matcher
466 , ifPatBuilder = if_builder
467 , ifPatIsInfix = is_infix
468 , ifPatUnivTvs = univ_tvs
469 , ifPatExTvs = ex_tvs
470 , ifPatProvCtxt = prov_ctxt
471 , ifPatReqCtxt = req_ctxt
472 , ifPatArgs = args
473 , ifPatTy = pat_ty
474 , ifFieldLabels = field_labels })
475 = do { name <- lookupIfaceTop occ_name
476 ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
477 ; matcher <- tc_pr if_matcher
478 ; builder <- fmapMaybeM tc_pr if_builder
479 ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
480 { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
481 { patsyn <- forkM (mk_doc name) $
482 do { prov_theta <- tcIfaceCtxt prov_ctxt
483 ; req_theta <- tcIfaceCtxt req_ctxt
484 ; pat_ty <- tcIfaceType pat_ty
485 ; arg_tys <- mapM tcIfaceType args
486 ; return $ buildPatSyn name is_infix matcher builder
487 (univ_tvs, req_theta) (ex_tvs, prov_theta)
488 arg_tys pat_ty field_labels }
489 ; return $ AConLike . PatSynCon $ patsyn }}}
490 where
491 mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
492 tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
493 tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
494 ; return (id, b) }
495
496 tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
497 tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
498
499 tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
500 tc_ax_branch prev_branches
501 (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
502 , ifaxbRoles = roles, ifaxbIncomps = incomps })
503 = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
504 -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
505 { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds]
506 ; tc_rhs <- tcIfaceType rhs
507 ; let br = CoAxBranch { cab_loc = noSrcSpan
508 , cab_tvs = tvs
509 , cab_lhs = tc_lhs
510 , cab_roles = roles
511 , cab_rhs = tc_rhs
512 , cab_incomps = map (prev_branches !!) incomps }
513 ; return (prev_branches ++ [br]) }
514
515 tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs
516 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
517 = case if_cons of
518 IfAbstractTyCon dis -> return (AbstractTyCon dis)
519 IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
520 ; data_cons <- mapM (tc_con_decl field_lbls) cons
521 ; return (mkDataTyConRhs data_cons) }
522 IfNewTyCon con _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
523 ; data_con <- tc_con_decl field_lbls con
524 ; mkNewTyConRhs tycon_name tycon data_con }
525 where
526 tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
527 ifConExTvs = ex_tvs,
528 ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
529 ifConArgTys = args, ifConFields = my_lbls,
530 ifConStricts = if_stricts,
531 ifConSrcStricts = if_src_stricts})
532 = -- Universally-quantified tyvars are shared with
533 -- parent TyCon, and are alrady in scope
534 bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
535 { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
536 ; dc_name <- lookupIfaceTop occ
537
538 -- Read the context and argument types, but lazily for two reasons
539 -- (a) to avoid looking tugging on a recursive use of
540 -- the type itself, which is knot-tied
541 -- (b) to avoid faulting in the component types unless
542 -- they are really needed
543 ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
544 do { eq_spec <- tcIfaceEqSpec spec
545 ; theta <- tcIfaceCtxt ctxt
546 ; arg_tys <- mapM tcIfaceType args
547 ; stricts <- mapM tc_strict if_stricts
548 -- The IfBang field can mention
549 -- the type itself; hence inside forkM
550 ; return (eq_spec, theta, arg_tys, stricts) }
551
552 -- Look up the field labels for this constructor; note that
553 -- they should be in the same order as my_lbls!
554 ; let lbl_names = map find_lbl my_lbls
555 find_lbl x = case find (\ fl -> nameOccName (flSelector fl) == x) field_lbls of
556 Just fl -> fl
557 Nothing -> error $ "find_lbl missing " ++ occNameString x
558
559 -- Remember, tycon is the representation tycon
560 ; let orig_res_ty = mkFamilyTyConApp tycon
561 (substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
562
563 ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name
564 ; return (Promoted n) }
565 else return NotPromoted
566
567 ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
568 dc_name is_infix prom_info
569 (map src_strict if_src_stricts)
570 (Just stricts)
571 -- Pass the HsImplBangs (i.e. final
572 -- decisions) to buildDataCon; it'll use
573 -- these to guide the construction of a
574 -- worker.
575 -- See Note [Bangs on imported data constructors] in MkId
576 lbl_names
577 tc_tyvars ex_tyvars
578 eq_spec theta
579 arg_tys orig_res_ty tycon
580 ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
581 ; return con }
582 mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
583
584 tc_strict :: IfaceBang -> IfL HsImplBang
585 tc_strict IfNoBang = return (HsLazy)
586 tc_strict IfStrict = return (HsStrict)
587 tc_strict IfUnpack = return (HsUnpack Nothing)
588 tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
589 ; return (HsUnpack (Just co)) }
590
591 src_strict :: IfaceSrcBang -> HsSrcBang
592 src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang
593
594 tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)]
595 tcIfaceEqSpec spec
596 = mapM do_item spec
597 where
598 do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
599 ; ty <- tcIfaceType if_ty
600 ; return (tv,ty) }
601
602 {-
603 Note [Synonym kind loop]
604 ~~~~~~~~~~~~~~~~~~~~~~~~
605 Notice that we eagerly grab the *kind* from the interface file, but
606 build a forkM thunk for the *rhs* (and family stuff). To see why,
607 consider this (Trac #2412)
608
609 M.hs: module M where { import X; data T = MkT S }
610 X.hs: module X where { import {-# SOURCE #-} M; type S = T }
611 M.hs-boot: module M where { data T }
612
613 When kind-checking M.hs we need S's kind. But we do not want to
614 find S's kind from (typeKind S-rhs), because we don't want to look at
615 S-rhs yet! Since S is imported from X.hi, S gets just one chance to
616 be defined, and we must not do that until we've finished with M.T.
617
618 Solution: record S's kind in the interface file; now we can safely
619 look at it.
620
621 ************************************************************************
622 * *
623 Instances
624 * *
625 ************************************************************************
626 -}
627
628 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
629 tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
630 , ifInstCls = cls, ifInstTys = mb_tcs
631 , ifInstOrph = orph })
632 = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
633 tcIfaceExtId dfun_occ
634 ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
635 ; return (mkImportedInstance cls mb_tcs' dfun oflag orph) }
636
637 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
638 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
639 , ifFamInstAxiom = axiom_name } )
640 = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
641 tcIfaceCoAxiom axiom_name
642 -- will panic if branched, but that's OK
643 ; let axiom'' = toUnbranchedAxiom axiom'
644 mb_tcs' = map (fmap ifaceTyConName) mb_tcs
645 ; return (mkImportedFamInst fam mb_tcs' axiom'') }
646
647 {-
648 ************************************************************************
649 * *
650 Rules
651 * *
652 ************************************************************************
653
654 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
655 are in the type environment. However, remember that typechecking a Rule may
656 (as a side effect) augment the type envt, and so we may need to iterate the process.
657 -}
658
659 tcIfaceRules :: Bool -- True <=> ignore rules
660 -> [IfaceRule]
661 -> IfL [CoreRule]
662 tcIfaceRules ignore_prags if_rules
663 | ignore_prags = return []
664 | otherwise = mapM tcIfaceRule if_rules
665
666 tcIfaceRule :: IfaceRule -> IfL CoreRule
667 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
668 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
669 ifRuleAuto = auto, ifRuleOrph = orph })
670 = do { ~(bndrs', args', rhs') <-
671 -- Typecheck the payload lazily, in the hope it'll never be looked at
672 forkM (ptext (sLit "Rule") <+> pprRuleName name) $
673 bindIfaceBndrs bndrs $ \ bndrs' ->
674 do { args' <- mapM tcIfaceExpr args
675 ; rhs' <- tcIfaceExpr rhs
676 ; return (bndrs', args', rhs') }
677 ; let mb_tcs = map ifTopFreeName args
678 ; this_mod <- getIfModule
679 ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
680 ru_bndrs = bndrs', ru_args = args',
681 ru_rhs = occurAnalyseExpr rhs',
682 ru_rough = mb_tcs,
683 ru_origin = this_mod,
684 ru_orphan = orph,
685 ru_auto = auto,
686 ru_local = False }) } -- An imported RULE is never for a local Id
687 -- or, even if it is (module loop, perhaps)
688 -- we'll just leave it in the non-local set
689 where
690 -- This function *must* mirror exactly what Rules.roughTopNames does
691 -- We could have stored the ru_rough field in the iface file
692 -- but that would be redundant, I think.
693 -- The only wrinkle is that we must not be deceived by
694 -- type synonyms at the top of a type arg. Since
695 -- we can't tell at this point, we are careful not
696 -- to write them out in coreRuleToIfaceRule
697 ifTopFreeName :: IfaceExpr -> Maybe Name
698 ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
699 ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
700 ifTopFreeName (IfaceApp f _) = ifTopFreeName f
701 ifTopFreeName (IfaceExt n) = Just n
702 ifTopFreeName _ = Nothing
703
704 {-
705 ************************************************************************
706 * *
707 Annotations
708 * *
709 ************************************************************************
710 -}
711
712 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
713 tcIfaceAnnotations = mapM tcIfaceAnnotation
714
715 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
716 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
717 target' <- tcIfaceAnnTarget target
718 return $ Annotation {
719 ann_target = target',
720 ann_value = serialized
721 }
722
723 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
724 tcIfaceAnnTarget (NamedTarget occ) = do
725 name <- lookupIfaceTop occ
726 return $ NamedTarget name
727 tcIfaceAnnTarget (ModuleTarget mod) = do
728 return $ ModuleTarget mod
729
730 {-
731 ************************************************************************
732 * *
733 Vectorisation information
734 * *
735 ************************************************************************
736 -}
737
738 -- We need access to the type environment as we need to look up information about type constructors
739 -- (i.e., their data constructors and whether they are class type constructors). If a vectorised
740 -- type constructor or class is defined in the same module as where it is vectorised, we cannot
741 -- look that information up from the type constructor that we obtained via a 'forkM'ed
742 -- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
743 -- and again and again...
744 --
745 tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
746 tcIfaceVectInfo mod typeEnv (IfaceVectInfo
747 { ifaceVectInfoVar = vars
748 , ifaceVectInfoTyCon = tycons
749 , ifaceVectInfoTyConReuse = tyconsReuse
750 , ifaceVectInfoParallelVars = parallelVars
751 , ifaceVectInfoParallelTyCons = parallelTyCons
752 })
753 = do { let parallelTyConsSet = mkNameSet parallelTyCons
754 ; vVars <- mapM vectVarMapping vars
755 ; let varsSet = mkVarSet (map fst vVars)
756 ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
757 ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
758 ; vParallelVars <- mapM vectVar parallelVars
759 ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
760 ; return $ VectInfo
761 { vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels
762 , vectInfoTyCon = mkNameEnv vTyCons
763 , vectInfoDataCon = mkNameEnv (concat vDataCons)
764 , vectInfoParallelVars = mkVarSet vParallelVars
765 , vectInfoParallelTyCons = parallelTyConsSet
766 }
767 }
768 where
769 vectVarMapping name
770 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
771 ; var <- forkM (ptext (sLit "vect var") <+> ppr name) $
772 tcIfaceExtId name
773 ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+>
774 ppr mod <> ptext (sLit "; nameModule =") <+>
775 ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
776 tcIfaceExtId vName
777 ; return (var, (var, vVar))
778 }
779 -- where
780 -- lookupLocalOrExternalId name
781 -- = do { let mb_id = lookupTypeEnv typeEnv name
782 -- ; case mb_id of
783 -- -- id is local
784 -- Just (AnId id) -> return id
785 -- -- name is not an Id => internal inconsistency
786 -- Just _ -> notAnIdErr
787 -- -- Id is external
788 -- Nothing -> tcIfaceExtId name
789 -- }
790 --
791 -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
792
793 vectVar name
794 = forkM (ptext (sLit "vect scalar var") <+> ppr name) $
795 tcIfaceExtId name
796
797 vectTyConVectMapping vars name
798 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
799 ; vectTyConMapping vars name vName
800 }
801
802 vectTyConReuseMapping vars name
803 = vectTyConMapping vars name name
804
805 vectTyConMapping vars name vName
806 = do { tycon <- lookupLocalOrExternalTyCon name
807 ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $
808 lookupLocalOrExternalTyCon vName
809
810 -- Map the data constructors of the original type constructor to those of the
811 -- vectorised type constructor /unless/ the type constructor was vectorised
812 -- abstractly; if it was vectorised abstractly, the workers of its data constructors
813 -- do not appear in the set of vectorised variables.
814 --
815 -- NB: This is lazy! We don't pull at the type constructors before we actually use
816 -- the data constructor mapping.
817 ; let isAbstract | isClassTyCon tycon = False
818 | datacon:_ <- tyConDataCons tycon
819 = not $ dataConWrapId datacon `elemVarSet` vars
820 | otherwise = True
821 vDataCons | isAbstract = []
822 | otherwise = [ (dataConName datacon, (datacon, vDatacon))
823 | (datacon, vDatacon) <- zip (tyConDataCons tycon)
824 (tyConDataCons vTycon)
825 ]
826
827 -- Map the (implicit) superclass and methods selectors as they don't occur in
828 -- the var map.
829 vScSels | Just cls <- tyConClass_maybe tycon
830 , Just vCls <- tyConClass_maybe vTycon
831 = [ (sel, (sel, vSel))
832 | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
833 ]
834 | otherwise
835 = []
836
837 ; return ( (name, (tycon, vTycon)) -- (T, T_v)
838 , vDataCons -- list of (Ci, Ci_v)
839 , vScSels -- list of (seli, seli_v)
840 )
841 }
842 where
843 -- we need a fully defined version of the type constructor to be able to extract
844 -- its data constructors etc.
845 lookupLocalOrExternalTyCon name
846 = do { let mb_tycon = lookupTypeEnv typeEnv name
847 ; case mb_tycon of
848 -- tycon is local
849 Just (ATyCon tycon) -> return tycon
850 -- name is not a tycon => internal inconsistency
851 Just _ -> notATyConErr
852 -- tycon is external
853 Nothing -> tcIfaceTyConByName name
854 }
855
856 notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
857
858 {-
859 ************************************************************************
860 * *
861 Types
862 * *
863 ************************************************************************
864 -}
865
866 tcIfaceType :: IfaceType -> IfL Type
867 tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
868 tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
869 tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
870 tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2
871 tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2
872 tcIfaceType (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
873 tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
874 ; tks' <- tcIfaceTcArgs tks
875 ; return (mkTyConApp tc' tks') }
876 tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
877
878 tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type
879 tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
880
881 tcIfaceKind :: IfaceKind -> IfL Type
882 tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
883 tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2
884 tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2
885 tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l)
886 tcIfaceKind k = tcIfaceType k
887
888 tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type
889 tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
890
891 tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type
892 tcIfaceTupleTy sort info args
893 = do { args' <- tcIfaceTcArgs args
894 ; let arity = length args'
895 ; base_tc <- tcTupleTyCon sort arity
896 ; case info of
897 NoIfaceTyConInfo
898 -> return (mkTyConApp base_tc args')
899
900 IfacePromotedTyCon
901 | Promoted tc <- promotableTyCon_maybe base_tc
902 -> return (mkTyConApp tc args')
903 | otherwise
904 -> panic "tcIfaceTupleTy" (ppr base_tc)
905
906 IfacePromotedDataCon
907 -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
908 kind_args = map typeKind args'
909 ; return (mkTyConApp tc (kind_args ++ args')) } }
910
911 tcTupleTyCon :: TupleSort -> Arity -> IfL TyCon
912 tcTupleTyCon sort arity
913 = case sort of
914 ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
915 ; return (tyThingTyCon thing) }
916 BoxedTuple -> return (tupleTyCon Boxed arity)
917 UnboxedTuple -> return (tupleTyCon Unboxed arity)
918
919 tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
920 tcIfaceTcArgs args
921 = case args of
922 ITC_Type t ts ->
923 do { t' <- tcIfaceType t
924 ; ts' <- tcIfaceTcArgs ts
925 ; return (t':ts') }
926 ITC_Kind k ks ->
927 do { k' <- tcIfaceKind k
928 ; ks' <- tcIfaceTcArgs ks
929 ; return (k':ks') }
930 ITC_Nil -> return []
931 -----------------------------------------
932 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
933 tcIfaceCtxt sts = mapM tcIfaceType sts
934
935 -----------------------------------------
936 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
937 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
938 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
939
940 {-
941 ************************************************************************
942 * *
943 Coercions
944 * *
945 ************************************************************************
946 -}
947
948 tcIfaceCo :: IfaceCoercion -> IfL Coercion
949 tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t
950 tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2
951 tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc
952 <*> mapM tcIfaceCo cs
953 tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1
954 <*> tcIfaceCo c2
955 tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' ->
956 mkForAllCo tv' <$> tcIfaceCo c
957 tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n
958 tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n
959 <*> pure i
960 <*> mapM tcIfaceCo cs
961 tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1
962 <*> tcIfaceType t2
963 tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c
964 tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1
965 <*> tcIfaceCo c2
966 tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1
967 <*> tcIfaceType t2
968 tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c
969 tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c
970 tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c
971 tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo
972 <$> tcIfaceCoAxiomRule ax
973 <*> mapM tcIfaceType tys
974 <*> mapM tcIfaceCo cos
975
976 tcIfaceCoVar :: FastString -> IfL CoVar
977 tcIfaceCoVar = tcIfaceLclId
978
979 tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule
980 tcIfaceCoAxiomRule n =
981 case Map.lookup n typeNatCoAxiomRules of
982 Just ax -> return ax
983 _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
984
985 {-
986 ************************************************************************
987 * *
988 Core
989 * *
990 ************************************************************************
991 -}
992
993 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
994 tcIfaceExpr (IfaceType ty)
995 = Type <$> tcIfaceType ty
996
997 tcIfaceExpr (IfaceCo co)
998 = Coercion <$> tcIfaceCo co
999
1000 tcIfaceExpr (IfaceCast expr co)
1001 = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
1002
1003 tcIfaceExpr (IfaceLcl name)
1004 = Var <$> tcIfaceLclId name
1005
1006 tcIfaceExpr (IfaceExt gbl)
1007 = Var <$> tcIfaceExtId gbl
1008
1009 tcIfaceExpr (IfaceLit lit)
1010 = do lit' <- tcIfaceLit lit
1011 return (Lit lit')
1012
1013 tcIfaceExpr (IfaceFCall cc ty) = do
1014 ty' <- tcIfaceType ty
1015 u <- newUnique
1016 dflags <- getDynFlags
1017 return (Var (mkFCallId dflags u cc ty'))
1018
1019 tcIfaceExpr (IfaceTuple sort args)
1020 = do { args' <- mapM tcIfaceExpr args
1021 ; tc <- tcTupleTyCon sort arity
1022 ; let con_args = map (Type . exprType) args' ++ args'
1023 -- Put the missing type arguments back in
1024 con_id = dataConWorkId (tyConSingleDataCon tc)
1025 ; return (mkApps (Var con_id) con_args) }
1026 where
1027 arity = length args
1028
1029 tcIfaceExpr (IfaceLam (bndr, os) body)
1030 = bindIfaceBndr bndr $ \bndr' ->
1031 Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
1032 where
1033 tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
1034 tcIfaceOneShot _ b = b
1035
1036 tcIfaceExpr (IfaceApp fun arg)
1037 = tcIfaceApps fun arg
1038
1039 tcIfaceExpr (IfaceECase scrut ty)
1040 = do { scrut' <- tcIfaceExpr scrut
1041 ; ty' <- tcIfaceType ty
1042 ; return (castBottomExpr scrut' ty') }
1043
1044 tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
1045 scrut' <- tcIfaceExpr scrut
1046 case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1047 let
1048 scrut_ty = exprType scrut'
1049 case_bndr' = mkLocalId case_bndr_name scrut_ty
1050 tc_app = splitTyConApp scrut_ty
1051 -- NB: Won't always succeed (polymorphic case)
1052 -- but won't be demanded in those cases
1053 -- NB: not tcSplitTyConApp; we are looking at Core here
1054 -- look through non-rec newtypes to find the tycon that
1055 -- corresponds to the datacon in this case alternative
1056
1057 extendIfaceIdEnv [case_bndr'] $ do
1058 alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1059 return (Case scrut' case_bndr' (coreAltsType alts') alts')
1060
1061 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
1062 = do { name <- newIfaceName (mkVarOccFS fs)
1063 ; ty' <- tcIfaceType ty
1064 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1065 name ty' info
1066 ; let id = mkLocalIdWithInfo name ty' id_info
1067 ; rhs' <- tcIfaceExpr rhs
1068 ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1069 ; return (Let (NonRec id rhs') body') }
1070
1071 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1072 = do { ids <- mapM tc_rec_bndr (map fst pairs)
1073 ; extendIfaceIdEnv ids $ do
1074 { pairs' <- zipWithM tc_pair pairs ids
1075 ; body' <- tcIfaceExpr body
1076 ; return (Let (Rec pairs') body') } }
1077 where
1078 tc_rec_bndr (IfLetBndr fs ty _)
1079 = do { name <- newIfaceName (mkVarOccFS fs)
1080 ; ty' <- tcIfaceType ty
1081 ; return (mkLocalId name ty') }
1082 tc_pair (IfLetBndr _ _ info, rhs) id
1083 = do { rhs' <- tcIfaceExpr rhs
1084 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1085 (idName id) (idType id) info
1086 ; return (setIdInfo id id_info, rhs') }
1087
1088 tcIfaceExpr (IfaceTick tickish expr) = do
1089 expr' <- tcIfaceExpr expr
1090 -- If debug flag is not set: Ignore source notes
1091 dbgFlag <- fmap (gopt Opt_Debug) getDynFlags
1092 case tickish of
1093 IfaceSource{} | not dbgFlag
1094 -> return expr'
1095 _otherwise -> do
1096 tickish' <- tcIfaceTickish tickish
1097 return (Tick tickish' expr')
1098
1099 -------------------------
1100 tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr
1101 -- See Note [Checking IfaceTypes vs IfaceKinds]
1102 tcIfaceApps fun arg
1103 = go_down fun [arg]
1104 where
1105 go_down (IfaceApp fun arg) args = go_down fun (arg:args)
1106 go_down fun args = do { fun' <- tcIfaceExpr fun
1107 ; go_up fun' (exprType fun') args }
1108
1109 go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr
1110 go_up fun _ [] = return fun
1111 go_up fun fun_ty (IfaceType t : args)
1112 | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
1113 = do { t' <- if isKindVar tv
1114 then tcIfaceKind t
1115 else tcIfaceType t
1116 ; let fun_ty' = substTyWith [tv] [t'] body_ty
1117 ; go_up (App fun (Type t')) fun_ty' args }
1118 go_up fun fun_ty (arg : args)
1119 | Just (_, fun_ty') <- splitFunTy_maybe fun_ty
1120 = do { arg' <- tcIfaceExpr arg
1121 ; go_up (App fun arg') fun_ty' args }
1122 go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args)
1123
1124 -------------------------
1125 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1126 tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
1127 tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
1128 tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
1129
1130 -------------------------
1131 tcIfaceLit :: Literal -> IfL Literal
1132 -- Integer literals deserialise to (LitInteger i <error thunk>)
1133 -- so tcIfaceLit just fills in the type.
1134 -- See Note [Integer literals] in Literal
1135 tcIfaceLit (LitInteger i _)
1136 = do t <- tcIfaceTyConByName integerTyConName
1137 return (mkLitInteger i (mkTyConTy t))
1138 tcIfaceLit lit = return lit
1139
1140 -------------------------
1141 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1142 -> (IfaceConAlt, [FastString], IfaceExpr)
1143 -> IfL (AltCon, [TyVar], CoreExpr)
1144 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1145 = ASSERT( null names ) do
1146 rhs' <- tcIfaceExpr rhs
1147 return (DEFAULT, [], rhs')
1148
1149 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1150 = ASSERT( null names ) do
1151 lit' <- tcIfaceLit lit
1152 rhs' <- tcIfaceExpr rhs
1153 return (LitAlt lit', [], rhs')
1154
1155 -- A case alternative is made quite a bit more complicated
1156 -- by the fact that we omit type annotations because we can
1157 -- work them out. True enough, but its not that easy!
1158 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1159 = do { con <- tcIfaceDataCon data_occ
1160 ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1161 (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1162 ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1163
1164 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1165 -> IfL (AltCon, [TyVar], CoreExpr)
1166 tcIfaceDataAlt con inst_tys arg_strs rhs
1167 = do { us <- newUniqueSupply
1168 ; let uniqs = uniqsFromSupply us
1169 ; let (ex_tvs, arg_ids)
1170 = dataConRepFSInstPat arg_strs uniqs con inst_tys
1171
1172 ; rhs' <- extendIfaceTyVarEnv ex_tvs $
1173 extendIfaceIdEnv arg_ids $
1174 tcIfaceExpr rhs
1175 ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1176
1177 {-
1178 ************************************************************************
1179 * *
1180 IdInfo
1181 * *
1182 ************************************************************************
1183 -}
1184
1185 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1186 tcIdDetails _ IfVanillaId = return VanillaId
1187 tcIdDetails ty IfDFunId
1188 = return (DFunId (isNewTyCon (classTyCon cls)))
1189 where
1190 (_, _, cls, _) = tcSplitDFunTy ty
1191
1192 tcIdDetails _ (IfRecSelId tc naughty)
1193 = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
1194 (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
1195 tc
1196 ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1197 where
1198 tyThingPatSyn (AConLike (PatSynCon ps)) = ps
1199 tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
1200
1201 tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1202 tcIdInfo ignore_prags name ty info
1203 | ignore_prags = return vanillaIdInfo
1204 | otherwise = case info of
1205 NoInfo -> return vanillaIdInfo
1206 HasInfo info -> foldlM tcPrag init_info info
1207 where
1208 -- Set the CgInfo to something sensible but uninformative before
1209 -- we start; default assumption is that it has CAFs
1210 init_info = vanillaIdInfo
1211
1212 tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1213 tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
1214 tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
1215 tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1216 tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
1217
1218 -- The next two are lazy, so they don't transitively suck stuff in
1219 tcPrag info (HsUnfold lb if_unf)
1220 = do { unf <- tcUnfolding name ty info if_unf
1221 ; let info1 | lb = info `setOccInfo` strongLoopBreaker
1222 | otherwise = info
1223 ; return (info1 `setUnfoldingInfoLazily` unf) }
1224
1225 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1226 tcUnfolding name _ info (IfCoreUnfold stable if_expr)
1227 = do { dflags <- getDynFlags
1228 ; mb_expr <- tcPragExpr name if_expr
1229 ; let unf_src | stable = InlineStable
1230 | otherwise = InlineRhs
1231 ; return $ case mb_expr of
1232 Nothing -> NoUnfolding
1233 Just expr -> mkUnfolding dflags unf_src
1234 True {- Top level -}
1235 (isBottomingSig strict_sig)
1236 expr
1237 }
1238 where
1239 -- Strictness should occur before unfolding!
1240 strict_sig = strictnessInfo info
1241 tcUnfolding name _ _ (IfCompulsory if_expr)
1242 = do { mb_expr <- tcPragExpr name if_expr
1243 ; return (case mb_expr of
1244 Nothing -> NoUnfolding
1245 Just expr -> mkCompulsoryUnfolding expr) }
1246
1247 tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1248 = do { mb_expr <- tcPragExpr name if_expr
1249 ; return (case mb_expr of
1250 Nothing -> NoUnfolding
1251 Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
1252 where
1253 guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1254
1255 tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
1256 = bindIfaceBndrs bs $ \ bs' ->
1257 do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
1258 ; return (case mb_ops1 of
1259 Nothing -> noUnfolding
1260 Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
1261 where
1262 doc = text "Class ops for dfun" <+> ppr name
1263 (_, _, cls, _) = tcSplitDFunTy dfun_ty
1264
1265 {-
1266 For unfoldings we try to do the job lazily, so that we never type check
1267 an unfolding that isn't going to be looked at.
1268 -}
1269
1270 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1271 tcPragExpr name expr
1272 = forkM_maybe doc $ do
1273 core_expr' <- tcIfaceExpr expr
1274
1275 -- Check for type consistency in the unfolding
1276 whenGOptM Opt_DoCoreLinting $ do
1277 in_scope <- get_in_scope
1278 dflags <- getDynFlags
1279 case lintUnfolding dflags noSrcLoc in_scope core_expr' of
1280 Nothing -> return ()
1281 Just fail_msg -> do { mod <- getIfModule
1282 ; pprPanic "Iface Lint failure"
1283 (vcat [ ptext (sLit "In interface for") <+> ppr mod
1284 , hang doc 2 fail_msg
1285 , ppr name <+> equals <+> ppr core_expr'
1286 , ptext (sLit "Iface expr =") <+> ppr expr ]) }
1287 return core_expr'
1288 where
1289 doc = text "Unfolding of" <+> ppr name
1290
1291 get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
1292 get_in_scope
1293 = do { (gbl_env, lcl_env) <- getEnvs
1294 ; rec_ids <- case if_rec_types gbl_env of
1295 Nothing -> return []
1296 Just (_, get_env) -> do
1297 { type_env <- setLclEnv () get_env
1298 ; return (typeEnvIds type_env) }
1299 ; return (varEnvElts (if_tv_env lcl_env) ++
1300 varEnvElts (if_id_env lcl_env) ++
1301 rec_ids) }
1302
1303 {-
1304 ************************************************************************
1305 * *
1306 Getting from Names to TyThings
1307 * *
1308 ************************************************************************
1309 -}
1310
1311 tcIfaceGlobal :: Name -> IfL TyThing
1312 tcIfaceGlobal name
1313 | Just thing <- wiredInNameTyThing_maybe name
1314 -- Wired-in things include TyCons, DataCons, and Ids
1315 -- Even though we are in an interface file, we want to make
1316 -- sure the instances and RULES of this thing (particularly TyCon) are loaded
1317 -- Imagine: f :: Double -> Double
1318 = do { ifCheckWiredInThing thing; return thing }
1319
1320 | otherwise
1321 = do { env <- getGblEnv
1322 ; case if_rec_types env of { -- Note [Tying the knot]
1323 Just (mod, get_type_env)
1324 | nameIsLocalOrFrom mod name
1325 -> do -- It's defined in the module being compiled
1326 { type_env <- setLclEnv () get_type_env -- yuk
1327 ; case lookupNameEnv type_env name of
1328 Just thing -> return thing
1329 Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
1330 (ppr name $$ ppr type_env) }
1331
1332 ; _ -> do
1333
1334 { hsc_env <- getTopEnv
1335 ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1336 ; case mb_thing of {
1337 Just thing -> return thing ;
1338 Nothing -> do
1339
1340 { mb_thing <- importDecl name -- It's imported; go get it
1341 ; case mb_thing of
1342 Failed err -> failIfM err
1343 Succeeded thing -> return thing
1344 }}}}}
1345
1346 -- Note [Tying the knot]
1347 -- ~~~~~~~~~~~~~~~~~~~~~
1348 -- The if_rec_types field is used in two situations:
1349 --
1350 -- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T
1351 -- Then we look up M.T in M's type environment, which is splatted into if_rec_types
1352 -- after we've built M's type envt.
1353 --
1354 -- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi
1355 -- is up to date. So we call typecheckIface on M.hi. This splats M.T into
1356 -- if_rec_types so that the (lazily typechecked) decls see all the other decls
1357 --
1358 -- In case (b) it's important to do the if_rec_types check *before* looking in the HPT
1359 -- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its
1360 -- emasculated form (e.g. lacking data constructors).
1361
1362 tcIfaceTyConByName :: IfExtName -> IfL TyCon
1363 tcIfaceTyConByName name
1364 = do { thing <- tcIfaceGlobal name
1365 ; return (tyThingTyCon thing) }
1366
1367 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1368 tcIfaceTyCon (IfaceTyCon name info)
1369 = do { thing <- tcIfaceGlobal name
1370 ; case info of
1371 NoIfaceTyConInfo -> return (tyThingTyCon thing)
1372 IfacePromotedDataCon -> return (promoteDataCon (tyThingDataCon thing))
1373 -- Same Name as its underlying DataCon
1374 IfacePromotedTyCon -> return (promote_tc (tyThingTyCon thing)) }
1375 -- Same Name as its underlying TyCon
1376 where
1377 promote_tc tc
1378 | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc
1379 | isSuperKind (tyConKind tc) = tc
1380 | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc)
1381
1382 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
1383 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
1384 ; return (tyThingCoAxiom thing) }
1385
1386 tcIfaceDataCon :: Name -> IfL DataCon
1387 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1388 ; case thing of
1389 AConLike (RealDataCon dc) -> return dc
1390 _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1391
1392 tcIfaceExtId :: Name -> IfL Id
1393 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1394 ; case thing of
1395 AnId id -> return id
1396 _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1397
1398 {-
1399 ************************************************************************
1400 * *
1401 Bindings
1402 * *
1403 ************************************************************************
1404 -}
1405
1406 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1407 bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
1408 = do { name <- newIfaceName (mkVarOccFS fs)
1409 ; ty' <- tcIfaceType ty
1410 ; let id = mkLocalId name ty'
1411 ; extendIfaceIdEnv [id] (thing_inside id) }
1412 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1413 = bindIfaceTyVar bndr thing_inside
1414
1415 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1416 bindIfaceBndrs [] thing_inside = thing_inside []
1417 bindIfaceBndrs (b:bs) thing_inside
1418 = bindIfaceBndr b $ \ b' ->
1419 bindIfaceBndrs bs $ \ bs' ->
1420 thing_inside (b':bs')
1421
1422 -----------------------
1423 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1424 bindIfaceTyVar (occ,kind) thing_inside
1425 = do { name <- newIfaceName (mkTyVarOccFS occ)
1426 ; tyvar <- mk_iface_tyvar name kind
1427 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1428
1429 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1430 bindIfaceTyVars bndrs thing_inside
1431 = do { names <- newIfaceNames (map mkTyVarOccFS occs)
1432 ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
1433 (kis_name, tys_name) = splitAt (length kis_kind) names
1434 -- We need to bring the kind variables in scope since type
1435 -- variables may mention them.
1436 ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
1437 ; extendIfaceTyVarEnv kvs $ do
1438 { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
1439 ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
1440 where
1441 (occs,kinds) = unzip bndrs
1442
1443 isSuperIfaceKind :: IfaceKind -> Bool
1444 isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName
1445 isSuperIfaceKind _ = False
1446
1447 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1448 mk_iface_tyvar name ifKind
1449 = do { kind <- tcIfaceKind ifKind
1450 ; return (Var.mkTyVar name kind) }
1451
1452 bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1453 -- Used for type variable in nested associated data/type declarations
1454 -- where some of the type variables are already in scope
1455 -- class C a where { data T a b }
1456 -- Here 'a' is in scope when we look at the 'data T'
1457 bindIfaceTyVars_AT [] thing_inside
1458 = thing_inside []
1459 bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
1460 = do { mb_tv <- lookupIfaceTyVar tv_occ
1461 ; let bind_b :: (TyVar -> IfL a) -> IfL a
1462 bind_b = case mb_tv of
1463 Just b' -> \k -> k b'
1464 Nothing -> bindIfaceTyVar b
1465 ; bind_b $ \b' ->
1466 bindIfaceTyVars_AT bs $ \bs' ->
1467 thing_inside (b':bs') }