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