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