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