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