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