Comments and tiny refactor
[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 {-# LANGUAGE NondecreasingIndentation #-}
11
12 module TcIface (
13 tcLookupImported_maybe,
14 importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
15 typecheckIfacesForMerging,
16 typecheckIfaceForInstantiate,
17 tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
18 tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs,
19 tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
20 tcIfaceGlobal
21 ) where
22
23 #include "HsVersions.h"
24
25 import GhcPrelude
26
27 import TcTypeNats(typeNatCoAxiomRules)
28 import IfaceSyn
29 import LoadIface
30 import IfaceEnv
31 import BuildTyCl
32 import TcRnMonad
33 import TcType
34 import Type
35 import Coercion
36 import CoAxiom
37 import TyCoRep -- needs to build types & coercions in a knot
38 import HscTypes
39 import Annotations
40 import InstEnv
41 import FamInstEnv
42 import CoreSyn
43 import CoreUtils
44 import CoreUnfold
45 import CoreLint
46 import MkCore
47 import Id
48 import MkId
49 import IdInfo
50 import Class
51 import TyCon
52 import ConLike
53 import DataCon
54 import PrelNames
55 import TysWiredIn
56 import Literal
57 import Var
58 import VarEnv
59 import VarSet
60 import Name
61 import NameEnv
62 import NameSet
63 import OccurAnal ( occurAnalyseExpr )
64 import Demand
65 import Module
66 import UniqFM
67 import UniqSupply
68 import Outputable
69 import Maybes
70 import SrcLoc
71 import DynFlags
72 import Util
73 import FastString
74 import BasicTypes hiding ( SuccessFlag(..) )
75 import ListSetOps
76 import GHC.Fingerprint
77 import qualified BooleanFormula as BF
78
79 import Data.List
80 import Control.Monad
81 import qualified Data.Map as Map
82
83 {-
84 This module takes
85
86 IfaceDecl -> TyThing
87 IfaceType -> Type
88 etc
89
90 An IfaceDecl is populated with RdrNames, and these are not renamed to
91 Names before typechecking, because there should be no scope errors etc.
92
93 -- For (b) consider: f = \$(...h....)
94 -- where h is imported, and calls f via an hi-boot file.
95 -- This is bad! But it is not seen as a staging error, because h
96 -- is indeed imported. We don't want the type-checker to black-hole
97 -- when simplifying and compiling the splice!
98 --
99 -- Simple solution: discard any unfolding that mentions a variable
100 -- bound in this module (and hence not yet processed).
101 -- The discarding happens when forkM finds a type error.
102
103
104 ************************************************************************
105 * *
106 Type-checking a complete interface
107 * *
108 ************************************************************************
109
110 Suppose we discover we don't need to recompile. Then we must type
111 check the old interface file. This is a bit different to the
112 incremental type checking we do as we suck in interface files. Instead
113 we do things similarly as when we are typechecking source decls: we
114 bring into scope the type envt for the interface all at once, using a
115 knot. Remember, the decls aren't necessarily in dependency order --
116 and even if they were, the type decls might be mutually recursive.
117
118 Note [Knot-tying typecheckIface]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
120 Suppose we are typechecking an interface A.hi, and we come across
121 a Name for another entity defined in A.hi. How do we get the
122 'TyCon', in this case? There are three cases:
123
124 1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in
125 preparation of checking if the hs file we're building
126 is compatible. In this case, we want all of the internal
127 TyCons to MATCH the ones that we just constructed during
128 typechecking: the knot is thus tied through if_rec_types.
129
130 2) retypecheckLoop in GhcMake: We are retypechecking a
131 mutually recursive cluster of hi files, in order to ensure
132 that all of the references refer to each other correctly.
133 In this case, the knot is tied through the HPT passed in,
134 which contains all of the interfaces we are in the process
135 of typechecking.
136
137 3) genModDetails in HscMain: We are typechecking an
138 old interface to generate the ModDetails. In this case,
139 we do the same thing as (2) and pass in an HPT with
140 the HomeModInfo being generated to tie knots.
141
142 The upshot is that the CLIENT of this function is responsible
143 for making sure that the knot is tied correctly. If you don't,
144 then you'll get a message saying that we couldn't load the
145 declaration you wanted.
146
147 BTW, in one-shot mode we never call typecheckIface; instead,
148 loadInterface handles type-checking interface. In that case,
149 knots are tied through the EPS. No problem!
150 -}
151
152 -- Clients of this function be careful, see Note [Knot-tying typecheckIface]
153 typecheckIface :: ModIface -- Get the decls from here
154 -> IfG ModDetails
155 typecheckIface iface
156 = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
157 { -- Get the right set of decls and rules. If we are compiling without -O
158 -- we discard pragmas before typechecking, so that we don't "see"
159 -- information that we shouldn't. From a versioning point of view
160 -- It's not actually *wrong* to do so, but in fact GHCi is unable
161 -- to handle unboxed tuples, so it must not see unfoldings.
162 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
163
164 -- Typecheck the decls. This is done lazily, so that the knot-tying
165 -- within this single module works out right. It's the callers
166 -- job to make sure the knot is tied.
167 ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
168 ; let type_env = mkNameEnv names_w_things
169
170 -- Now do those rules, instances and annotations
171 ; insts <- mapM tcIfaceInst (mi_insts iface)
172 ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
173 ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
174 ; anns <- tcIfaceAnnotations (mi_anns iface)
175
176 -- Vectorisation information
177 ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
178
179 -- Exports
180 ; exports <- ifaceExportNames (mi_exports iface)
181
182 -- Complete Sigs
183 ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
184
185 -- Finished
186 ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
187 -- Careful! If we tug on the TyThing thunks too early
188 -- we'll infinite loop with hs-boot. See #10083 for
189 -- an example where this would cause non-termination.
190 text "Type envt:" <+> ppr (map fst names_w_things)])
191 ; return $ ModDetails { md_types = type_env
192 , md_insts = insts
193 , md_fam_insts = fam_insts
194 , md_rules = rules
195 , md_anns = anns
196 , md_vect_info = vect_info
197 , md_exports = exports
198 , md_complete_sigs = complete_sigs
199 }
200 }
201
202 {-
203 ************************************************************************
204 * *
205 Typechecking for merging
206 * *
207 ************************************************************************
208 -}
209
210 -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
211 isAbstractIfaceDecl :: IfaceDecl -> Bool
212 isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
213 isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
214 isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
215 isAbstractIfaceDecl _ = False
216
217 ifMaybeRoles :: IfaceDecl -> Maybe [Role]
218 ifMaybeRoles IfaceData { ifRoles = rs } = Just rs
219 ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
220 ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs
221 ifMaybeRoles _ = Nothing
222
223 -- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If
224 -- both are non-abstract we pick one arbitrarily (and check for consistency
225 -- later.)
226 mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
227 mergeIfaceDecl d1 d2
228 | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
229 | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
230 | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
231 , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
232 = let ops = nameEnvElts $
233 plusNameEnv_C mergeIfaceClassOp
234 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
235 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
236 in d1 { ifBody = (ifBody d1) {
237 ifSigs = ops,
238 ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
239 }
240 } `withRolesFrom` d2
241 -- It doesn't matter; we'll check for consistency later when
242 -- we merge, see 'mergeSignatures'
243 | otherwise = d1 `withRolesFrom` d2
244
245 -- Note [Role merging]
246 -- ~~~~~~~~~~~~~~~~~~~
247 -- First, why might it be necessary to do a non-trivial role
248 -- merge? It may rescue a merge that might otherwise fail:
249 --
250 -- signature A where
251 -- type role T nominal representational
252 -- data T a b
253 --
254 -- signature A where
255 -- type role T representational nominal
256 -- data T a b
257 --
258 -- A module that defines T as representational in both arguments
259 -- would successfully fill both signatures, so it would be better
260 -- if we merged the roles of these types in some nontrivial
261 -- way.
262 --
263 -- However, we have to be very careful about how we go about
264 -- doing this, because role subtyping is *conditional* on
265 -- the supertype being NOT representationally injective, e.g.,
266 -- if we have instead:
267 --
268 -- signature A where
269 -- type role T nominal representational
270 -- data T a b = T a b
271 --
272 -- signature A where
273 -- type role T representational nominal
274 -- data T a b = T a b
275 --
276 -- Should we merge the definitions of T so that the roles are R/R (or N/N)?
277 -- Absolutely not: neither resulting type is a subtype of the original
278 -- types (see Note [Role subtyping]), because data is not representationally
279 -- injective.
280 --
281 -- Thus, merging only occurs when BOTH TyCons in question are
282 -- representationally injective. If they're not, no merge.
283
284 withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
285 d1 `withRolesFrom` d2
286 | Just roles1 <- ifMaybeRoles d1
287 , Just roles2 <- ifMaybeRoles d2
288 , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
289 = d1 { ifRoles = mergeRoles roles1 roles2 }
290 | otherwise = d1
291 where
292 mergeRoles roles1 roles2 = zipWith max roles1 roles2
293
294 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
295 isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
296 isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
297 isRepInjectiveIfaceDecl _ = False
298
299 mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
300 mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
301 mergeIfaceClassOp _ op2 = op2
302
303 -- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
304 mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
305 mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
306
307 -- | This is a very interesting function. Like typecheckIface, we want
308 -- to type check an interface file into a ModDetails. However, the use-case
309 -- for these ModDetails is different: we want to compare all of the
310 -- ModDetails to ensure they define compatible declarations, and then
311 -- merge them together. So in particular, we have to take a different
312 -- strategy for knot-tying: we first speculatively merge the declarations
313 -- to get the "base" truth for what we believe the types will be
314 -- (this is "type computation.") Then we read everything in relative
315 -- to this truth and check for compatibility.
316 --
317 -- During the merge process, we may need to nondeterministically
318 -- pick a particular declaration to use, if multiple signatures define
319 -- the declaration ('mergeIfaceDecl'). If, for all choices, there
320 -- are no type synonym cycles in the resulting merged graph, then
321 -- we can show that our choice cannot matter. Consider the
322 -- set of entities which the declarations depend on: by assumption
323 -- of acyclicity, we can assume that these have already been shown to be equal
324 -- to each other (otherwise merging will fail). Then it must
325 -- be the case that all candidate declarations here are type-equal
326 -- (the choice doesn't matter) or there is an inequality (in which
327 -- case merging will fail.)
328 --
329 -- Unfortunately, the choice can matter if there is a cycle. Consider the
330 -- following merge:
331 --
332 -- signature H where { type A = C; type B = A; data C }
333 -- signature H where { type A = (); data B; type C = B }
334 --
335 -- If we pick @type A = C@ as our representative, there will be
336 -- a cycle and merging will fail. But if we pick @type A = ()@ as
337 -- our representative, no cycle occurs, and we instead conclude
338 -- that all of the types are unit. So it seems that we either
339 -- (a) need a stronger acyclicity check which considers *all*
340 -- possible choices from a merge, or (b) we must find a selection
341 -- of declarations which is acyclic, and show that this is always
342 -- the "best" choice we could have made (ezyang conjectures this
343 -- is the case but does not have a proof). For now this is
344 -- not implemented.
345 --
346 -- It's worth noting that at the moment, a data constructor and a
347 -- type synonym are never compatible. Consider:
348 --
349 -- signature H where { type Int=C; type B = Int; data C = Int}
350 -- signature H where { export Prelude.Int; data B; type C = B; }
351 --
352 -- This will be rejected, because the reexported Int in the second
353 -- signature (a proper data type) is never considered equal to a
354 -- type synonym. Perhaps this should be relaxed, where a type synonym
355 -- in a signature is considered implemented by a data type declaration
356 -- which matches the reference of the type synonym.
357 typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
358 typecheckIfacesForMerging mod ifaces tc_env_var =
359 -- cannot be boot (False)
360 initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
361 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
362 -- Build the initial environment
363 -- NB: Don't include dfuns here, because we don't want to
364 -- serialize them out. See Note [rnIfaceNeverExported] in RnModIface
365 -- NB: But coercions are OK, because they will have the right OccName.
366 let mk_decl_env decls
367 = mkOccEnv [ (getOccName decl, decl)
368 | decl <- decls
369 , case decl of
370 IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
371 _ -> True ]
372 decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
373 :: [OccEnv IfaceDecl]
374 decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
375 :: OccEnv IfaceDecl
376 -- TODO: change loadDecls to accept w/o Fingerprint
377 names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
378 (occEnvElts decl_env))
379 let global_type_env = mkNameEnv names_w_things
380 writeMutVar tc_env_var global_type_env
381
382 -- OK, now typecheck each ModIface using this environment
383 details <- forM ifaces $ \iface -> do
384 -- See Note [Resolving never-exported Names in TcIface]
385 type_env <- fixM $ \type_env -> do
386 setImplicitEnvM type_env $ do
387 decls <- loadDecls ignore_prags (mi_decls iface)
388 return (mkNameEnv decls)
389 -- But note that we use this type_env to typecheck references to DFun
390 -- in 'IfaceInst'
391 setImplicitEnvM type_env $ do
392 insts <- mapM tcIfaceInst (mi_insts iface)
393 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
394 rules <- tcIfaceRules ignore_prags (mi_rules iface)
395 anns <- tcIfaceAnnotations (mi_anns iface)
396 vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
397 exports <- ifaceExportNames (mi_exports iface)
398 complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
399 return $ ModDetails { md_types = type_env
400 , md_insts = insts
401 , md_fam_insts = fam_insts
402 , md_rules = rules
403 , md_anns = anns
404 , md_vect_info = vect_info
405 , md_exports = exports
406 , md_complete_sigs = complete_sigs
407 }
408 return (global_type_env, details)
409
410 -- | Typecheck a signature 'ModIface' under the assumption that we have
411 -- instantiated it under some implementation (recorded in 'mi_semantic_module')
412 -- and want to check if the implementation fills the signature.
413 --
414 -- This needs to operate slightly differently than 'typecheckIface'
415 -- because (1) we have a 'NameShape', from the exports of the
416 -- implementing module, which we will use to give our top-level
417 -- declarations the correct 'Name's even when the implementor
418 -- provided them with a reexport, and (2) we have to deal with
419 -- DFun silliness (see Note [rnIfaceNeverExported])
420 typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
421 typecheckIfaceForInstantiate nsubst iface =
422 initIfaceLclWithSubst (mi_semantic_module iface)
423 (text "typecheckIfaceForInstantiate")
424 (mi_boot iface) nsubst $ do
425 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
426 -- See Note [Resolving never-exported Names in TcIface]
427 type_env <- fixM $ \type_env -> do
428 setImplicitEnvM type_env $ do
429 decls <- loadDecls ignore_prags (mi_decls iface)
430 return (mkNameEnv decls)
431 -- See Note [rnIfaceNeverExported]
432 setImplicitEnvM type_env $ do
433 insts <- mapM tcIfaceInst (mi_insts iface)
434 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
435 rules <- tcIfaceRules ignore_prags (mi_rules iface)
436 anns <- tcIfaceAnnotations (mi_anns iface)
437 vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
438 exports <- ifaceExportNames (mi_exports iface)
439 complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
440 return $ ModDetails { md_types = type_env
441 , md_insts = insts
442 , md_fam_insts = fam_insts
443 , md_rules = rules
444 , md_anns = anns
445 , md_vect_info = vect_info
446 , md_exports = exports
447 , md_complete_sigs = complete_sigs
448 }
449
450 -- Note [Resolving never-exported Names in TcIface]
451 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
452 -- For the high-level overview, see
453 -- Note [Handling never-exported TyThings under Backpack]
454 --
455 -- As described in 'typecheckIfacesForMerging', the splendid innovation
456 -- of signature merging is to rewrite all Names in each of the signatures
457 -- we are merging together to a pre-merged structure; this is the key
458 -- ingredient that lets us solve some problems when merging type
459 -- synonyms.
460 --
461 -- However, when a 'Name' refers to a NON-exported entity, as is the
462 -- case with the DFun of a ClsInst, or a CoAxiom of a type family,
463 -- this strategy causes problems: if we pick one and rewrite all
464 -- references to a shared 'Name', we will accidentally fail to check
465 -- if the DFun or CoAxioms are compatible, as they will never be
466 -- checked--only exported entities are checked for compatibility,
467 -- and a non-exported TyThing is checked WHEN we are checking the
468 -- ClsInst or type family for compatibility in checkBootDeclM.
469 -- By virtue of the fact that everything's been pointed to the merged
470 -- declaration, you'll never notice there's a difference even if there
471 -- is one.
472 --
473 -- Fortunately, there are only a few places in the interface declarations
474 -- where this can occur, so we replace those calls with 'tcIfaceImplicit',
475 -- which will consult a local TypeEnv that records any never-exported
476 -- TyThings which we should wire up with.
477 --
478 -- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a
479 -- type family can refer to a coercion axiom, all of which are done in one go
480 -- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck
481 -- coercions first before type families, but that seemed more fragile.
482 --
483
484 {-
485 ************************************************************************
486 * *
487 Type and class declarations
488 * *
489 ************************************************************************
490 -}
491
492 tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
493 -- Load the hi-boot iface for the module being compiled,
494 -- if it indeed exists in the transitive closure of imports
495 -- Return the ModDetails; Nothing if no hi-boot iface
496 tcHiBootIface hsc_src mod
497 | HsBootFile <- hsc_src -- Already compiling a hs-boot file
498 = return NoSelfBoot
499 | otherwise
500 = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
501
502 ; mode <- getGhcMode
503 ; if not (isOneShot mode)
504 -- In --make and interactive mode, if this module has an hs-boot file
505 -- we'll have compiled it already, and it'll be in the HPT
506 --
507 -- We check wheher the interface is a *boot* interface.
508 -- It can happen (when using GHC from Visual Studio) that we
509 -- compile a module in TypecheckOnly mode, with a stable,
510 -- fully-populated HPT. In that case the boot interface isn't there
511 -- (it's been replaced by the mother module) so we can't check it.
512 -- And that's fine, because if M's ModInfo is in the HPT, then
513 -- it's been compiled once, and we don't need to check the boot iface
514 then do { hpt <- getHpt
515 ; case lookupHpt hpt (moduleName mod) of
516 Just info | mi_boot (hm_iface info)
517 -> mkSelfBootInfo (hm_iface info) (hm_details info)
518 _ -> return NoSelfBoot }
519 else do
520
521 -- OK, so we're in one-shot mode.
522 -- Re #9245, we always check if there is an hi-boot interface
523 -- to check consistency against, rather than just when we notice
524 -- that an hi-boot is necessary due to a circular import.
525 { read_result <- findAndReadIface
526 need (fst (splitModuleInsts mod)) mod
527 True -- Hi-boot file
528
529 ; case read_result of {
530 Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
531 ; mkSelfBootInfo iface tc_iface } ;
532 Failed err ->
533
534 -- There was no hi-boot file. But if there is circularity in
535 -- the module graph, there really should have been one.
536 -- Since we've read all the direct imports by now,
537 -- eps_is_boot will record if any of our imports mention the
538 -- current module, which either means a module loop (not
539 -- a SOURCE import) or that our hi-boot file has mysteriously
540 -- disappeared.
541 do { eps <- getEps
542 ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
543 Nothing -> return NoSelfBoot -- The typical case
544
545 Just (_, False) -> failWithTc moduleLoop
546 -- Someone below us imported us!
547 -- This is a loop with no hi-boot in the way
548
549 Just (_mod, True) -> failWithTc (elaborate err)
550 -- The hi-boot file has mysteriously disappeared.
551 }}}}
552 where
553 need = text "Need the hi-boot interface for" <+> ppr mod
554 <+> text "to compare against the Real Thing"
555
556 moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
557 <+> text "depends on itself"
558
559 elaborate err = hang (text "Could not find hi-boot interface for" <+>
560 quotes (ppr mod) <> colon) 4 err
561
562
563 mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
564 mkSelfBootInfo iface mds
565 = do -- NB: This is computed DIRECTLY from the ModIface rather
566 -- than from the ModDetails, so that we can query 'sb_tcs'
567 -- WITHOUT forcing the contents of the interface.
568 let tcs = map ifName
569 . filter isIfaceTyCon
570 . map snd
571 $ mi_decls iface
572 return $ SelfBoot { sb_mds = mds
573 , sb_tcs = mkNameSet tcs }
574 where
575 -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on
576 -- this 'IfaceDecl', an ATyCon would be returned.
577 -- NB: This code assumes that a TyCon cannot be implicit.
578 isIfaceTyCon IfaceId{} = False
579 isIfaceTyCon IfaceData{} = True
580 isIfaceTyCon IfaceSynonym{} = True
581 isIfaceTyCon IfaceFamily{} = True
582 isIfaceTyCon IfaceClass{} = True
583 isIfaceTyCon IfaceAxiom{} = False
584 isIfaceTyCon IfacePatSyn{} = False
585
586 {-
587 ************************************************************************
588 * *
589 Type and class declarations
590 * *
591 ************************************************************************
592
593 When typechecking a data type decl, we *lazily* (via forkM) typecheck
594 the constructor argument types. This is in the hope that we may never
595 poke on those argument types, and hence may never need to load the
596 interface files for types mentioned in the arg types.
597
598 E.g.
599 data Foo.S = MkS Baz.T
600 Maybe we can get away without even loading the interface for Baz!
601
602 This is not just a performance thing. Suppose we have
603 data Foo.S = MkS Baz.T
604 data Baz.T = MkT Foo.S
605 (in different interface files, of course).
606 Now, first we load and typecheck Foo.S, and add it to the type envt.
607 If we do explore MkS's argument, we'll load and typecheck Baz.T.
608 If we explore MkT's argument we'll find Foo.S already in the envt.
609
610 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
611 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
612 which isn't done yet.
613
614 All very cunning. However, there is a rather subtle gotcha which bit
615 me when developing this stuff. When we typecheck the decl for S, we
616 extend the type envt with S, MkS, and all its implicit Ids. Suppose
617 (a bug, but it happened) that the list of implicit Ids depended in
618 turn on the constructor arg types. Then the following sequence of
619 events takes place:
620 * we build a thunk <t> for the constructor arg tys
621 * we build a thunk for the extended type environment (depends on <t>)
622 * we write the extended type envt into the global EPS mutvar
623
624 Now we look something up in the type envt
625 * that pulls on <t>
626 * which reads the global type envt out of the global EPS mutvar
627 * but that depends in turn on <t>
628
629 It's subtle, because, it'd work fine if we typechecked the constructor args
630 eagerly -- they don't need the extended type envt. They just get the extended
631 type envt by accident, because they look at it later.
632
633 What this means is that the implicitTyThings MUST NOT DEPEND on any of
634 the forkM stuff.
635 -}
636
637 tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
638 -> IfaceDecl
639 -> IfL TyThing
640 tcIfaceDecl = tc_iface_decl Nothing
641
642 tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations
643 -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings
644 -> IfaceDecl
645 -> IfL TyThing
646 tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
647 ifIdDetails = details, ifIdInfo = info})
648 = do { ty <- tcIfaceType iface_type
649 ; details <- tcIdDetails ty details
650 ; info <- tcIdInfo ignore_prags TopLevel name ty info
651 ; return (AnId (mkGlobalId details name ty info)) }
652
653 tc_iface_decl _ _ (IfaceData {ifName = tc_name,
654 ifCType = cType,
655 ifBinders = binders,
656 ifResKind = res_kind,
657 ifRoles = roles,
658 ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
659 ifCons = rdr_cons,
660 ifParent = mb_parent })
661 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
662 { res_kind' <- tcIfaceType res_kind
663
664 ; tycon <- fixM $ \ tycon -> do
665 { stupid_theta <- tcIfaceCtxt ctxt
666 ; parent' <- tc_parent tc_name mb_parent
667 ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
668 ; return (mkAlgTyCon tc_name binders' res_kind'
669 roles cType stupid_theta
670 cons parent' gadt_syn) }
671 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
672 ; return (ATyCon tycon) }
673 where
674 tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
675 tc_parent tc_name IfNoParent
676 = do { tc_rep_name <- newTyConRepName tc_name
677 ; return (VanillaAlgTyCon tc_rep_name) }
678 tc_parent _ (IfDataInstance ax_name _ arg_tys)
679 = do { ax <- tcIfaceCoAxiom ax_name
680 ; let fam_tc = coAxiomTyCon ax
681 ax_unbr = toUnbranchedAxiom ax
682 ; lhs_tys <- tcIfaceTcArgs arg_tys
683 ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
684
685 tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
686 ifRoles = roles,
687 ifSynRhs = rhs_ty,
688 ifBinders = binders,
689 ifResKind = res_kind })
690 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
691 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
692 ; rhs <- forkM (mk_doc tc_name) $
693 tcIfaceType rhs_ty
694 ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
695 ; return (ATyCon tycon) }
696 where
697 mk_doc n = text "Type synonym" <+> ppr n
698
699 tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
700 ifFamFlav = fam_flav,
701 ifBinders = binders,
702 ifResKind = res_kind,
703 ifResVar = res, ifFamInj = inj })
704 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
705 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
706 ; rhs <- forkM (mk_doc tc_name) $
707 tc_fam_flav tc_name fam_flav
708 ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
709 ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
710 ; return (ATyCon tycon) }
711 where
712 mk_doc n = text "Type synonym" <+> ppr n
713
714 tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
715 tc_fam_flav tc_name IfaceDataFamilyTyCon
716 = do { tc_rep_name <- newTyConRepName tc_name
717 ; return (DataFamilyTyCon tc_rep_name) }
718 tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
719 tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
720 = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
721 ; return (ClosedSynFamilyTyCon ax) }
722 tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
723 = return AbstractClosedSynFamilyTyCon
724 tc_fam_flav _ IfaceBuiltInSynFamTyCon
725 = pprPanic "tc_iface_decl"
726 (text "IfaceBuiltInSynFamTyCon in interface file")
727
728 tc_iface_decl _parent _ignore_prags
729 (IfaceClass {ifName = tc_name,
730 ifRoles = roles,
731 ifBinders = binders,
732 ifFDs = rdr_fds,
733 ifBody = IfAbstractClass})
734 = bindIfaceTyConBinders binders $ \ binders' -> do
735 { fds <- mapM tc_fd rdr_fds
736 ; cls <- buildClass tc_name binders' roles fds Nothing
737 ; return (ATyCon (classTyCon cls)) }
738
739 tc_iface_decl _parent ignore_prags
740 (IfaceClass {ifName = tc_name,
741 ifRoles = roles,
742 ifBinders = binders,
743 ifFDs = rdr_fds,
744 ifBody = IfConcreteClass {
745 ifClassCtxt = rdr_ctxt,
746 ifATs = rdr_ats, ifSigs = rdr_sigs,
747 ifMinDef = mindef_occ
748 }})
749 = bindIfaceTyConBinders binders $ \ binders' -> do
750 { traceIf (text "tc-iface-class1" <+> ppr tc_name)
751 ; ctxt <- mapM tc_sc rdr_ctxt
752 ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
753 ; sigs <- mapM tc_sig rdr_sigs
754 ; fds <- mapM tc_fd rdr_fds
755 ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
756 ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
757 ; cls <- fixM $ \ cls -> do
758 { ats <- mapM (tc_at cls) rdr_ats
759 ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
760 ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
761 ; return (ATyCon (classTyCon cls)) }
762 where
763 tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
764 -- The *length* of the superclasses is used by buildClass, and hence must
765 -- not be inside the thunk. But the *content* maybe recursive and hence
766 -- must be lazy (via forkM). Example:
767 -- class C (T a) => D a where
768 -- data T a
769 -- Here the associated type T is knot-tied with the class, and
770 -- so we must not pull on T too eagerly. See Trac #5970
771
772 tc_sig :: IfaceClassOp -> IfL TcMethInfo
773 tc_sig (IfaceClassOp op_name rdr_ty dm)
774 = do { let doc = mk_op_doc op_name rdr_ty
775 ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
776 -- Must be done lazily for just the same reason as the
777 -- type of a data con; to avoid sucking in types that
778 -- it mentions unless it's necessary to do so
779 ; dm' <- tc_dm doc dm
780 ; return (op_name, op_ty, dm') }
781
782 tc_dm :: SDoc
783 -> Maybe (DefMethSpec IfaceType)
784 -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
785 tc_dm _ Nothing = return Nothing
786 tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
787 tc_dm doc (Just (GenericDM ty))
788 = do { -- Must be done lazily to avoid sucking in types
789 ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
790 ; return (Just (GenericDM (noSrcSpan, ty'))) }
791
792 tc_at cls (IfaceAT tc_decl if_def)
793 = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
794 mb_def <- case if_def of
795 Nothing -> return Nothing
796 Just def -> forkM (mk_at_doc tc) $
797 extendIfaceTyVarEnv (tyConTyVars tc) $
798 do { tc_def <- tcIfaceType def
799 ; return (Just (tc_def, noSrcSpan)) }
800 -- Must be done lazily in case the RHS of the defaults mention
801 -- the type constructor being defined here
802 -- e.g. type AT a; type AT b = AT [b] Trac #8002
803 return (ATI tc mb_def)
804
805 mk_sc_doc pred = text "Superclass" <+> ppr pred
806 mk_at_doc tc = text "Associated type" <+> ppr tc
807 mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
808
809 tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
810 , ifAxBranches = branches, ifRole = role })
811 = do { tc_tycon <- tcIfaceTyCon tc
812 -- Must be done lazily, because axioms are forced when checking
813 -- for family instance consistency, and the RHS may mention
814 -- a hs-boot declared type constructor that is going to be
815 -- defined by this module.
816 -- e.g. type instance F Int = ToBeDefined
817 -- See Trac #13803
818 ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
819 $ tc_ax_branches branches
820 ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
821 , co_ax_name = tc_name
822 , co_ax_tc = tc_tycon
823 , co_ax_role = role
824 , co_ax_branches = manyBranches tc_branches
825 , co_ax_implicit = False }
826 ; return (ACoAxiom axiom) }
827
828 tc_iface_decl _ _ (IfacePatSyn{ ifName = name
829 , ifPatMatcher = if_matcher
830 , ifPatBuilder = if_builder
831 , ifPatIsInfix = is_infix
832 , ifPatUnivBndrs = univ_bndrs
833 , ifPatExBndrs = ex_bndrs
834 , ifPatProvCtxt = prov_ctxt
835 , ifPatReqCtxt = req_ctxt
836 , ifPatArgs = args
837 , ifPatTy = pat_ty
838 , ifFieldLabels = field_labels })
839 = do { traceIf (text "tc_iface_decl" <+> ppr name)
840 ; matcher <- tc_pr if_matcher
841 ; builder <- fmapMaybeM tc_pr if_builder
842 ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
843 { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
844 { patsyn <- forkM (mk_doc name) $
845 do { prov_theta <- tcIfaceCtxt prov_ctxt
846 ; req_theta <- tcIfaceCtxt req_ctxt
847 ; pat_ty <- tcIfaceType pat_ty
848 ; arg_tys <- mapM tcIfaceType args
849 ; return $ buildPatSyn name is_infix matcher builder
850 (univ_tvs, req_theta)
851 (ex_tvs, prov_theta)
852 arg_tys pat_ty field_labels }
853 ; return $ AConLike . PatSynCon $ patsyn }}}
854 where
855 mk_doc n = text "Pattern synonym" <+> ppr n
856 tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
857 tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
858 ; return (id, b) }
859
860 tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
861 tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
862 ; tvs2' <- mapM tcIfaceTyVar tvs2
863 ; return (tvs1', tvs2') }
864
865 tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
866 tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
867
868 tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
869 tc_ax_branch prev_branches
870 (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
871 , ifaxbLHS = lhs, ifaxbRHS = rhs
872 , ifaxbRoles = roles, ifaxbIncomps = incomps })
873 = bindIfaceTyConBinders_AT
874 (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
875 -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
876 bindIfaceIds cv_bndrs $ \ cvs -> do
877 { tc_lhs <- tcIfaceTcArgs lhs
878 ; tc_rhs <- tcIfaceType rhs
879 ; let br = CoAxBranch { cab_loc = noSrcSpan
880 , cab_tvs = binderVars tvs
881 , cab_cvs = cvs
882 , cab_lhs = tc_lhs
883 , cab_roles = roles
884 , cab_rhs = tc_rhs
885 , cab_incomps = map (prev_branches `getNth`) incomps }
886 ; return (prev_branches ++ [br]) }
887
888 tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
889 tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
890 = case if_cons of
891 IfAbstractTyCon -> return AbstractTyCon
892 IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
893 ; return (mkDataTyConRhs data_cons) }
894 IfNewTyCon con -> do { data_con <- tc_con_decl con
895 ; mkNewTyConRhs tycon_name tycon data_con }
896 where
897 univ_tvs :: [TyVar]
898 univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
899
900 tag_map :: NameEnv ConTag
901 tag_map = mkTyConTagMap tycon
902
903 tc_con_decl (IfCon { ifConInfix = is_infix,
904 ifConExTvs = ex_bndrs,
905 ifConUserTvBinders = user_bndrs,
906 ifConName = dc_name,
907 ifConCtxt = ctxt, ifConEqSpec = spec,
908 ifConArgTys = args, ifConFields = lbl_names,
909 ifConStricts = if_stricts,
910 ifConSrcStricts = if_src_stricts})
911 = -- Universally-quantified tyvars are shared with
912 -- parent TyCon, and are already in scope
913 bindIfaceTyVars ex_bndrs $ \ ex_tvs -> do
914 { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
915
916 -- By this point, we have bound every universal and existential
917 -- tyvar. Because of the dcUserTyVarBinders invariant
918 -- (see Note [DataCon user type variable binders]), *every* tyvar in
919 -- ifConUserTvBinders has a matching counterpart somewhere in the
920 -- bound universals/existentials. As a result, calling tcIfaceTyVar
921 -- below is always guaranteed to succeed.
922 ; user_tv_bndrs <- mapM (\(TvBndr (name, _) vis) ->
923 TvBndr <$> tcIfaceTyVar name <*> pure vis)
924 user_bndrs
925
926 -- Read the context and argument types, but lazily for two reasons
927 -- (a) to avoid looking tugging on a recursive use of
928 -- the type itself, which is knot-tied
929 -- (b) to avoid faulting in the component types unless
930 -- they are really needed
931 ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
932 do { eq_spec <- tcIfaceEqSpec spec
933 ; theta <- tcIfaceCtxt ctxt
934 -- This fixes #13710. The enclosing lazy thunk gets
935 -- forced when typechecking record wildcard pattern
936 -- matching (it's not completely clear why this
937 -- tuple is needed), which causes trouble if one of
938 -- the argument types was recursively defined.
939 -- See also Note [Tying the knot]
940 ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
941 $ mapM tcIfaceType args
942 ; stricts <- mapM tc_strict if_stricts
943 -- The IfBang field can mention
944 -- the type itself; hence inside forkM
945 ; return (eq_spec, theta, arg_tys, stricts) }
946
947 -- Remember, tycon is the representation tycon
948 ; let orig_res_ty = mkFamilyTyConApp tycon
949 (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
950 (binderVars tc_tybinders))
951
952 ; prom_rep_name <- newTyConRepName dc_name
953
954 ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
955 dc_name is_infix prom_rep_name
956 (map src_strict if_src_stricts)
957 (Just stricts)
958 -- Pass the HsImplBangs (i.e. final
959 -- decisions) to buildDataCon; it'll use
960 -- these to guide the construction of a
961 -- worker.
962 -- See Note [Bangs on imported data constructors] in MkId
963 lbl_names
964 univ_tvs ex_tvs user_tv_bndrs
965 eq_spec theta
966 arg_tys orig_res_ty tycon tag_map
967 ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
968 ; return con }
969 mk_doc con_name = text "Constructor" <+> ppr con_name
970
971 tc_strict :: IfaceBang -> IfL HsImplBang
972 tc_strict IfNoBang = return (HsLazy)
973 tc_strict IfStrict = return (HsStrict)
974 tc_strict IfUnpack = return (HsUnpack Nothing)
975 tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
976 ; return (HsUnpack (Just co)) }
977
978 src_strict :: IfaceSrcBang -> HsSrcBang
979 src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
980
981 tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
982 tcIfaceEqSpec spec
983 = mapM do_item spec
984 where
985 do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
986 ; ty <- tcIfaceType if_ty
987 ; return (mkEqSpec tv ty) }
988
989 {-
990 Note [Synonym kind loop]
991 ~~~~~~~~~~~~~~~~~~~~~~~~
992 Notice that we eagerly grab the *kind* from the interface file, but
993 build a forkM thunk for the *rhs* (and family stuff). To see why,
994 consider this (Trac #2412)
995
996 M.hs: module M where { import X; data T = MkT S }
997 X.hs: module X where { import {-# SOURCE #-} M; type S = T }
998 M.hs-boot: module M where { data T }
999
1000 When kind-checking M.hs we need S's kind. But we do not want to
1001 find S's kind from (typeKind S-rhs), because we don't want to look at
1002 S-rhs yet! Since S is imported from X.hi, S gets just one chance to
1003 be defined, and we must not do that until we've finished with M.T.
1004
1005 Solution: record S's kind in the interface file; now we can safely
1006 look at it.
1007
1008 ************************************************************************
1009 * *
1010 Instances
1011 * *
1012 ************************************************************************
1013 -}
1014
1015 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
1016 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
1017 , ifInstCls = cls, ifInstTys = mb_tcs
1018 , ifInstOrph = orph })
1019 = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
1020 fmap tyThingId (tcIfaceImplicit dfun_name)
1021 ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1022 ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
1023
1024 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
1025 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1026 , ifFamInstAxiom = axiom_name } )
1027 = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
1028 tcIfaceCoAxiom axiom_name
1029 -- will panic if branched, but that's OK
1030 ; let axiom'' = toUnbranchedAxiom axiom'
1031 mb_tcs' = map (fmap ifaceTyConName) mb_tcs
1032 ; return (mkImportedFamInst fam mb_tcs' axiom'') }
1033
1034 {-
1035 ************************************************************************
1036 * *
1037 Rules
1038 * *
1039 ************************************************************************
1040
1041 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
1042 are in the type environment. However, remember that typechecking a Rule may
1043 (as a side effect) augment the type envt, and so we may need to iterate the process.
1044 -}
1045
1046 tcIfaceRules :: Bool -- True <=> ignore rules
1047 -> [IfaceRule]
1048 -> IfL [CoreRule]
1049 tcIfaceRules ignore_prags if_rules
1050 | ignore_prags = return []
1051 | otherwise = mapM tcIfaceRule if_rules
1052
1053 tcIfaceRule :: IfaceRule -> IfL CoreRule
1054 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1055 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1056 ifRuleAuto = auto, ifRuleOrph = orph })
1057 = do { ~(bndrs', args', rhs') <-
1058 -- Typecheck the payload lazily, in the hope it'll never be looked at
1059 forkM (text "Rule" <+> pprRuleName name) $
1060 bindIfaceBndrs bndrs $ \ bndrs' ->
1061 do { args' <- mapM tcIfaceExpr args
1062 ; rhs' <- tcIfaceExpr rhs
1063 ; return (bndrs', args', rhs') }
1064 ; let mb_tcs = map ifTopFreeName args
1065 ; this_mod <- getIfModule
1066 ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
1067 ru_bndrs = bndrs', ru_args = args',
1068 ru_rhs = occurAnalyseExpr rhs',
1069 ru_rough = mb_tcs,
1070 ru_origin = this_mod,
1071 ru_orphan = orph,
1072 ru_auto = auto,
1073 ru_local = False }) } -- An imported RULE is never for a local Id
1074 -- or, even if it is (module loop, perhaps)
1075 -- we'll just leave it in the non-local set
1076 where
1077 -- This function *must* mirror exactly what Rules.roughTopNames does
1078 -- We could have stored the ru_rough field in the iface file
1079 -- but that would be redundant, I think.
1080 -- The only wrinkle is that we must not be deceived by
1081 -- type synonyms at the top of a type arg. Since
1082 -- we can't tell at this point, we are careful not
1083 -- to write them out in coreRuleToIfaceRule
1084 ifTopFreeName :: IfaceExpr -> Maybe Name
1085 ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
1086 ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
1087 ifTopFreeName (IfaceApp f _) = ifTopFreeName f
1088 ifTopFreeName (IfaceExt n) = Just n
1089 ifTopFreeName _ = Nothing
1090
1091 {-
1092 ************************************************************************
1093 * *
1094 Annotations
1095 * *
1096 ************************************************************************
1097 -}
1098
1099 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
1100 tcIfaceAnnotations = mapM tcIfaceAnnotation
1101
1102 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
1103 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
1104 target' <- tcIfaceAnnTarget target
1105 return $ Annotation {
1106 ann_target = target',
1107 ann_value = serialized
1108 }
1109
1110 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
1111 tcIfaceAnnTarget (NamedTarget occ) = do
1112 name <- lookupIfaceTop occ
1113 return $ NamedTarget name
1114 tcIfaceAnnTarget (ModuleTarget mod) = do
1115 return $ ModuleTarget mod
1116
1117 {-
1118 ************************************************************************
1119 * *
1120 Complete Match Pragmas
1121 * *
1122 ************************************************************************
1123 -}
1124
1125 tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
1126 tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
1127
1128 tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
1129 tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
1130
1131 {-
1132 ************************************************************************
1133 * *
1134 Vectorisation information
1135 * *
1136 ************************************************************************
1137 -}
1138
1139 -- We need access to the type environment as we need to look up information about type constructors
1140 -- (i.e., their data constructors and whether they are class type constructors). If a vectorised
1141 -- type constructor or class is defined in the same module as where it is vectorised, we cannot
1142 -- look that information up from the type constructor that we obtained via a 'forkM'ed
1143 -- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
1144 -- and again and again...
1145 --
1146 tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
1147 tcIfaceVectInfo mod typeEnv (IfaceVectInfo
1148 { ifaceVectInfoVar = vars
1149 , ifaceVectInfoTyCon = tycons
1150 , ifaceVectInfoTyConReuse = tyconsReuse
1151 , ifaceVectInfoParallelVars = parallelVars
1152 , ifaceVectInfoParallelTyCons = parallelTyCons
1153 })
1154 = do { let parallelTyConsSet = mkNameSet parallelTyCons
1155 ; vVars <- mapM vectVarMapping vars
1156 ; let varsSet = mkVarSet (map fst vVars)
1157 ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
1158 ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
1159 ; vParallelVars <- mapM vectVar parallelVars
1160 ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
1161 ; return $ VectInfo
1162 { vectInfoVar = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
1163 , vectInfoTyCon = mkNameEnv vTyCons
1164 , vectInfoDataCon = mkNameEnv (concat vDataCons)
1165 , vectInfoParallelVars = mkDVarSet vParallelVars
1166 , vectInfoParallelTyCons = parallelTyConsSet
1167 }
1168 }
1169 where
1170 vectVarMapping name
1171 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
1172 ; var <- forkM (text "vect var" <+> ppr name) $
1173 tcIfaceExtId name
1174 ; vVar <- forkM (text "vect vVar [mod =" <+>
1175 ppr mod <> text "; nameModule =" <+>
1176 ppr (nameModule name) <> text "]" <+> ppr vName) $
1177 tcIfaceExtId vName
1178 ; return (var, (var, vVar))
1179 }
1180 -- where
1181 -- lookupLocalOrExternalId name
1182 -- = do { let mb_id = lookupTypeEnv typeEnv name
1183 -- ; case mb_id of
1184 -- -- id is local
1185 -- Just (AnId id) -> return id
1186 -- -- name is not an Id => internal inconsistency
1187 -- Just _ -> notAnIdErr
1188 -- -- Id is external
1189 -- Nothing -> tcIfaceExtId name
1190 -- }
1191 --
1192 -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
1193
1194 vectVar name
1195 = forkM (text "vect scalar var" <+> ppr name) $
1196 tcIfaceExtId name
1197
1198 vectTyConVectMapping vars name
1199 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
1200 ; vectTyConMapping vars name vName
1201 }
1202
1203 vectTyConReuseMapping vars name
1204 = vectTyConMapping vars name name
1205
1206 vectTyConMapping vars name vName
1207 = do { tycon <- lookupLocalOrExternalTyCon name
1208 ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $
1209 lookupLocalOrExternalTyCon vName
1210
1211 -- Map the data constructors of the original type constructor to those of the
1212 -- vectorised type constructor /unless/ the type constructor was vectorised
1213 -- abstractly; if it was vectorised abstractly, the workers of its data constructors
1214 -- do not appear in the set of vectorised variables.
1215 --
1216 -- NB: This is lazy! We don't pull at the type constructors before we actually use
1217 -- the data constructor mapping.
1218 ; let isAbstract | isClassTyCon tycon = False
1219 | datacon:_ <- tyConDataCons tycon
1220 = not $ dataConWrapId datacon `elemVarSet` vars
1221 | otherwise = True
1222 vDataCons | isAbstract = []
1223 | otherwise = [ (dataConName datacon, (datacon, vDatacon))
1224 | (datacon, vDatacon) <- zip (tyConDataCons tycon)
1225 (tyConDataCons vTycon)
1226 ]
1227
1228 -- Map the (implicit) superclass and methods selectors as they don't occur in
1229 -- the var map.
1230 vScSels | Just cls <- tyConClass_maybe tycon
1231 , Just vCls <- tyConClass_maybe vTycon
1232 = [ (sel, (sel, vSel))
1233 | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
1234 ]
1235 | otherwise
1236 = []
1237
1238 ; return ( (name, (tycon, vTycon)) -- (T, T_v)
1239 , vDataCons -- list of (Ci, Ci_v)
1240 , vScSels -- list of (seli, seli_v)
1241 )
1242 }
1243 where
1244 -- we need a fully defined version of the type constructor to be able to extract
1245 -- its data constructors etc.
1246 lookupLocalOrExternalTyCon name
1247 = do { let mb_tycon = lookupTypeEnv typeEnv name
1248 ; case mb_tycon of
1249 -- tycon is local
1250 Just (ATyCon tycon) -> return tycon
1251 -- name is not a tycon => internal inconsistency
1252 Just _ -> notATyConErr
1253 -- tycon is external
1254 Nothing -> tcIfaceTyConByName name
1255 }
1256
1257 notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
1258
1259 {-
1260 ************************************************************************
1261 * *
1262 Types
1263 * *
1264 ************************************************************************
1265 -}
1266
1267 tcIfaceType :: IfaceType -> IfL Type
1268 tcIfaceType = go
1269 where
1270 go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
1271 go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
1272 go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
1273 go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
1274 go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1275 go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1276 go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
1277 go (IfaceTyConApp tc tks)
1278 = do { tc' <- tcIfaceTyCon tc
1279 ; tks' <- mapM go (tcArgsIfaceTypes tks)
1280 ; return (mkTyConApp tc' tks') }
1281 go (IfaceForAllTy bndr t)
1282 = bindIfaceForAllBndr bndr $ \ tv' vis ->
1283 ForAllTy (TvBndr tv' vis) <$> go t
1284 go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
1285 go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
1286
1287 tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
1288 tcIfaceTupleTy sort is_promoted args
1289 = do { args' <- tcIfaceTcArgs args
1290 ; let arity = length args'
1291 ; base_tc <- tcTupleTyCon True sort arity
1292 ; case is_promoted of
1293 IsNotPromoted
1294 -> return (mkTyConApp base_tc args')
1295
1296 IsPromoted
1297 -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
1298 kind_args = map typeKind args'
1299 ; return (mkTyConApp tc (kind_args ++ args')) } }
1300
1301 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1302 tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
1303 -> TupleSort
1304 -> Arity -- the number of args. *not* the tuple arity.
1305 -> IfL TyCon
1306 tcTupleTyCon in_type sort arity
1307 = case sort of
1308 ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
1309 ; return (tyThingTyCon thing) }
1310 BoxedTuple -> return (tupleTyCon Boxed arity)
1311 UnboxedTuple -> return (tupleTyCon Unboxed arity')
1312 where arity' | in_type = arity `div` 2
1313 | otherwise = arity
1314 -- in expressions, we only have term args
1315
1316 tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
1317 tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
1318
1319 -----------------------------------------
1320 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
1321 tcIfaceCtxt sts = mapM tcIfaceType sts
1322
1323 -----------------------------------------
1324 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
1325 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
1326 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
1327
1328 {-
1329 %************************************************************************
1330 %* *
1331 Coercions
1332 * *
1333 ************************************************************************
1334 -}
1335
1336 tcIfaceCo :: IfaceCoercion -> IfL Coercion
1337 tcIfaceCo = go
1338 where
1339 go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
1340 go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
1341 go (IfaceTyConAppCo r tc cs)
1342 = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
1343 go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
1344 go (IfaceForAllCo tv k c) = do { k' <- go k
1345 ; bindIfaceTyVar tv $ \ tv' ->
1346 ForAllCo tv' k' <$> go c }
1347 go (IfaceCoVarCo n) = CoVarCo <$> go_var n
1348 go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
1349 go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
1350 <*> tcIfaceType t1 <*> tcIfaceType t2
1351 go (IfaceSymCo c) = SymCo <$> go c
1352 go (IfaceTransCo c1 c2) = TransCo <$> go c1
1353 <*> go c2
1354 go (IfaceInstCo c1 t2) = InstCo <$> go c1
1355 <*> go t2
1356 go (IfaceNthCo d c) = NthCo d <$> go c
1357 go (IfaceLRCo lr c) = LRCo lr <$> go c
1358 go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
1359 <*> go c2
1360 go (IfaceKindCo c) = KindCo <$> go c
1361 go (IfaceSubCo c) = SubCo <$> go c
1362 go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
1363 <*> mapM go cos
1364 go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
1365 go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
1366
1367 go_var :: FastString -> IfL CoVar
1368 go_var = tcIfaceLclId
1369
1370 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
1371 tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
1372 tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
1373 tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
1374 tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
1375
1376 {-
1377 ************************************************************************
1378 * *
1379 Core
1380 * *
1381 ************************************************************************
1382 -}
1383
1384 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
1385 tcIfaceExpr (IfaceType ty)
1386 = Type <$> tcIfaceType ty
1387
1388 tcIfaceExpr (IfaceCo co)
1389 = Coercion <$> tcIfaceCo co
1390
1391 tcIfaceExpr (IfaceCast expr co)
1392 = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
1393
1394 tcIfaceExpr (IfaceLcl name)
1395 = Var <$> tcIfaceLclId name
1396
1397 tcIfaceExpr (IfaceExt gbl)
1398 = Var <$> tcIfaceExtId gbl
1399
1400 tcIfaceExpr (IfaceLit lit)
1401 = do lit' <- tcIfaceLit lit
1402 return (Lit lit')
1403
1404 tcIfaceExpr (IfaceFCall cc ty) = do
1405 ty' <- tcIfaceType ty
1406 u <- newUnique
1407 dflags <- getDynFlags
1408 return (Var (mkFCallId dflags u cc ty'))
1409
1410 tcIfaceExpr (IfaceTuple sort args)
1411 = do { args' <- mapM tcIfaceExpr args
1412 ; tc <- tcTupleTyCon False sort arity
1413 ; let con_tys = map exprType args'
1414 some_con_args = map Type con_tys ++ args'
1415 con_args = case sort of
1416 UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
1417 _ -> some_con_args
1418 -- Put the missing type arguments back in
1419 con_id = dataConWorkId (tyConSingleDataCon tc)
1420 ; return (mkApps (Var con_id) con_args) }
1421 where
1422 arity = length args
1423
1424 tcIfaceExpr (IfaceLam (bndr, os) body)
1425 = bindIfaceBndr bndr $ \bndr' ->
1426 Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
1427 where
1428 tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
1429 tcIfaceOneShot _ b = b
1430
1431 tcIfaceExpr (IfaceApp fun arg)
1432 = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1433
1434 tcIfaceExpr (IfaceECase scrut ty)
1435 = do { scrut' <- tcIfaceExpr scrut
1436 ; ty' <- tcIfaceType ty
1437 ; return (castBottomExpr scrut' ty') }
1438
1439 tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
1440 scrut' <- tcIfaceExpr scrut
1441 case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1442 let
1443 scrut_ty = exprType scrut'
1444 case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
1445 tc_app = splitTyConApp scrut_ty
1446 -- NB: Won't always succeed (polymorphic case)
1447 -- but won't be demanded in those cases
1448 -- NB: not tcSplitTyConApp; we are looking at Core here
1449 -- look through non-rec newtypes to find the tycon that
1450 -- corresponds to the datacon in this case alternative
1451
1452 extendIfaceIdEnv [case_bndr'] $ do
1453 alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1454 return (Case scrut' case_bndr' (coreAltsType alts') alts')
1455
1456 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
1457 = do { name <- newIfaceName (mkVarOccFS fs)
1458 ; ty' <- tcIfaceType ty
1459 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1460 NotTopLevel name ty' info
1461 ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
1462 `asJoinId_maybe` tcJoinInfo ji
1463 ; rhs' <- tcIfaceExpr rhs
1464 ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1465 ; return (Let (NonRec id rhs') body') }
1466
1467 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1468 = do { ids <- mapM tc_rec_bndr (map fst pairs)
1469 ; extendIfaceIdEnv ids $ do
1470 { pairs' <- zipWithM tc_pair pairs ids
1471 ; body' <- tcIfaceExpr body
1472 ; return (Let (Rec pairs') body') } }
1473 where
1474 tc_rec_bndr (IfLetBndr fs ty _ ji)
1475 = do { name <- newIfaceName (mkVarOccFS fs)
1476 ; ty' <- tcIfaceType ty
1477 ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
1478 tc_pair (IfLetBndr _ _ info _, rhs) id
1479 = do { rhs' <- tcIfaceExpr rhs
1480 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1481 NotTopLevel (idName id) (idType id) info
1482 ; return (setIdInfo id id_info, rhs') }
1483
1484 tcIfaceExpr (IfaceTick tickish expr) = do
1485 expr' <- tcIfaceExpr expr
1486 -- If debug flag is not set: Ignore source notes
1487 dbgLvl <- fmap debugLevel getDynFlags
1488 case tickish of
1489 IfaceSource{} | dbgLvl > 0
1490 -> return expr'
1491 _otherwise -> do
1492 tickish' <- tcIfaceTickish tickish
1493 return (Tick tickish' expr')
1494
1495 -------------------------
1496 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1497 tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
1498 tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
1499 tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
1500
1501 -------------------------
1502 tcIfaceLit :: Literal -> IfL Literal
1503 -- Integer literals deserialise to (LitInteger i <error thunk>)
1504 -- so tcIfaceLit just fills in the type.
1505 -- See Note [Integer literals] in Literal
1506 tcIfaceLit (LitInteger i _)
1507 = do t <- tcIfaceTyConByName integerTyConName
1508 return (mkLitInteger i (mkTyConTy t))
1509 tcIfaceLit lit = return lit
1510
1511 -------------------------
1512 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1513 -> (IfaceConAlt, [FastString], IfaceExpr)
1514 -> IfL (AltCon, [TyVar], CoreExpr)
1515 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1516 = ASSERT( null names ) do
1517 rhs' <- tcIfaceExpr rhs
1518 return (DEFAULT, [], rhs')
1519
1520 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1521 = ASSERT( null names ) do
1522 lit' <- tcIfaceLit lit
1523 rhs' <- tcIfaceExpr rhs
1524 return (LitAlt lit', [], rhs')
1525
1526 -- A case alternative is made quite a bit more complicated
1527 -- by the fact that we omit type annotations because we can
1528 -- work them out. True enough, but its not that easy!
1529 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1530 = do { con <- tcIfaceDataCon data_occ
1531 ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1532 (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1533 ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1534
1535 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1536 -> IfL (AltCon, [TyVar], CoreExpr)
1537 tcIfaceDataAlt con inst_tys arg_strs rhs
1538 = do { us <- newUniqueSupply
1539 ; let uniqs = uniqsFromSupply us
1540 ; let (ex_tvs, arg_ids)
1541 = dataConRepFSInstPat arg_strs uniqs con inst_tys
1542
1543 ; rhs' <- extendIfaceEnvs ex_tvs $
1544 extendIfaceIdEnv arg_ids $
1545 tcIfaceExpr rhs
1546 ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1547
1548 {-
1549 ************************************************************************
1550 * *
1551 IdInfo
1552 * *
1553 ************************************************************************
1554 -}
1555
1556 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1557 tcIdDetails _ IfVanillaId = return VanillaId
1558 tcIdDetails ty IfDFunId
1559 = return (DFunId (isNewTyCon (classTyCon cls)))
1560 where
1561 (_, _, cls, _) = tcSplitDFunTy ty
1562
1563 tcIdDetails _ (IfRecSelId tc naughty)
1564 = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
1565 (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
1566 tc
1567 ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1568 where
1569 tyThingPatSyn (AConLike (PatSynCon ps)) = ps
1570 tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
1571
1572 tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1573 tcIdInfo ignore_prags toplvl name ty info = do
1574 lcl_env <- getLclEnv
1575 -- Set the CgInfo to something sensible but uninformative before
1576 -- we start; default assumption is that it has CAFs
1577 let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
1578 | otherwise = vanillaIdInfo
1579 if ignore_prags
1580 then return init_info
1581 else case info of
1582 NoInfo -> return init_info
1583 HasInfo info -> foldlM tcPrag init_info info
1584 where
1585 tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1586 tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
1587 tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
1588 tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1589 tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
1590 tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
1591
1592 -- The next two are lazy, so they don't transitively suck stuff in
1593 tcPrag info (HsUnfold lb if_unf)
1594 = do { unf <- tcUnfolding toplvl name ty info if_unf
1595 ; let info1 | lb = info `setOccInfo` strongLoopBreaker
1596 | otherwise = info
1597 ; return (info1 `setUnfoldingInfo` unf) }
1598
1599 tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
1600 tcJoinInfo (IfaceJoinPoint ar) = Just ar
1601 tcJoinInfo IfaceNotJoinPoint = Nothing
1602
1603 tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1604 tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
1605 = do { dflags <- getDynFlags
1606 ; mb_expr <- tcPragExpr toplvl name if_expr
1607 ; let unf_src | stable = InlineStable
1608 | otherwise = InlineRhs
1609 ; return $ case mb_expr of
1610 Nothing -> NoUnfolding
1611 Just expr -> mkUnfolding dflags unf_src
1612 True {- Top level -}
1613 (isBottomingSig strict_sig)
1614 expr
1615 }
1616 where
1617 -- Strictness should occur before unfolding!
1618 strict_sig = strictnessInfo info
1619 tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
1620 = do { mb_expr <- tcPragExpr toplvl name if_expr
1621 ; return (case mb_expr of
1622 Nothing -> NoUnfolding
1623 Just expr -> mkCompulsoryUnfolding expr) }
1624
1625 tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1626 = do { mb_expr <- tcPragExpr toplvl name if_expr
1627 ; return (case mb_expr of
1628 Nothing -> NoUnfolding
1629 Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
1630 where
1631 guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1632
1633 tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
1634 = bindIfaceBndrs bs $ \ bs' ->
1635 do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
1636 ; return (case mb_ops1 of
1637 Nothing -> noUnfolding
1638 Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
1639 where
1640 doc = text "Class ops for dfun" <+> ppr name
1641 (_, _, cls, _) = tcSplitDFunTy dfun_ty
1642
1643 {-
1644 For unfoldings we try to do the job lazily, so that we never type check
1645 an unfolding that isn't going to be looked at.
1646 -}
1647
1648 tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1649 tcPragExpr toplvl name expr
1650 = forkM_maybe doc $ do
1651 core_expr' <- tcIfaceExpr expr
1652
1653 -- Check for type consistency in the unfolding
1654 -- See Note [Linting Unfoldings from Interfaces]
1655 when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
1656 in_scope <- get_in_scope
1657 dflags <- getDynFlags
1658 case lintUnfolding dflags noSrcLoc in_scope core_expr' of
1659 Nothing -> return ()
1660 Just fail_msg -> do { mod <- getIfModule
1661 ; pprPanic "Iface Lint failure"
1662 (vcat [ text "In interface for" <+> ppr mod
1663 , hang doc 2 fail_msg
1664 , ppr name <+> equals <+> ppr core_expr'
1665 , text "Iface expr =" <+> ppr expr ]) }
1666 return core_expr'
1667 where
1668 doc = text "Unfolding of" <+> ppr name
1669
1670 get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
1671 get_in_scope
1672 = do { (gbl_env, lcl_env) <- getEnvs
1673 ; rec_ids <- case if_rec_types gbl_env of
1674 Nothing -> return []
1675 Just (_, get_env) -> do
1676 { type_env <- setLclEnv () get_env
1677 ; return (typeEnvIds type_env) }
1678 ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
1679 bindingsVars (if_id_env lcl_env) `unionVarSet`
1680 mkVarSet rec_ids) }
1681
1682 bindingsVars :: FastStringEnv Var -> VarSet
1683 bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
1684 -- It's OK to use nonDetEltsUFM here because we immediately forget
1685 -- the ordering by creating a set
1686
1687 {-
1688 ************************************************************************
1689 * *
1690 Getting from Names to TyThings
1691 * *
1692 ************************************************************************
1693 -}
1694
1695 tcIfaceGlobal :: Name -> IfL TyThing
1696 tcIfaceGlobal name
1697 | Just thing <- wiredInNameTyThing_maybe name
1698 -- Wired-in things include TyCons, DataCons, and Ids
1699 -- Even though we are in an interface file, we want to make
1700 -- sure the instances and RULES of this thing (particularly TyCon) are loaded
1701 -- Imagine: f :: Double -> Double
1702 = do { ifCheckWiredInThing thing; return thing }
1703
1704 | otherwise
1705 = do { env <- getGblEnv
1706 ; case if_rec_types env of { -- Note [Tying the knot]
1707 Just (mod, get_type_env)
1708 | nameIsLocalOrFrom mod name
1709 -> do -- It's defined in the module being compiled
1710 { type_env <- setLclEnv () get_type_env -- yuk
1711 ; case lookupNameEnv type_env name of
1712 Just thing -> return thing
1713 -- See Note [Knot-tying fallback on boot]
1714 Nothing -> via_external
1715 }
1716
1717 ; _ -> via_external }}
1718 where
1719 via_external = do
1720 { hsc_env <- getTopEnv
1721 ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1722 ; case mb_thing of {
1723 Just thing -> return thing ;
1724 Nothing -> do
1725
1726 { mb_thing <- importDecl name -- It's imported; go get it
1727 ; case mb_thing of
1728 Failed err -> failIfM err
1729 Succeeded thing -> return thing
1730 }}}
1731
1732 -- Note [Tying the knot]
1733 -- ~~~~~~~~~~~~~~~~~~~~~
1734 -- The if_rec_types field is used when we are compiling M.hs, which indirectly
1735 -- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
1736 -- environment, which is splatted into if_rec_types after we've built M's type
1737 -- envt.
1738 --
1739 -- This is a dark and complicated part of GHC type checking, with a lot
1740 -- of moving parts. Interested readers should also look at:
1741 --
1742 -- * Note [Knot-tying typecheckIface]
1743 -- * Note [DFun knot-tying]
1744 -- * Note [hsc_type_env_var hack]
1745 -- * Note [Knot-tying fallback on boot]
1746 --
1747 -- There is also a wiki page on the subject, see:
1748 --
1749 -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
1750
1751 -- Note [Knot-tying fallback on boot]
1752 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1753 -- Suppose that you are typechecking A.hs, which transitively imports,
1754 -- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
1755 -- has a reference to a type T from A, what TyThing should we wire
1756 -- it up with? Clearly, if we have already typechecked T and
1757 -- added it into the type environment, we should go ahead and use that
1758 -- type. But what if we haven't typechecked it yet?
1759 --
1760 -- For the longest time, GHC adopted the policy that this was
1761 -- *an error condition*; that you MUST NEVER poke on B.hs's reference
1762 -- to a T defined in A.hs until A.hs has gotten around to kind-checking
1763 -- T and adding it to the env. However, actually ensuring this is the
1764 -- case has proven to be a bug farm, because it's really difficult to
1765 -- actually ensure this never happens. The problem was especially poignant
1766 -- with type family consistency checks, which eagerly happen before any
1767 -- typechecking takes place.
1768 --
1769 -- Today, we take a different strategy: if we ever try to access
1770 -- an entity from A which doesn't exist, we just fall back on the
1771 -- definition of A from the hs-boot file. This is complicated in
1772 -- its own way: it means that you may end up with a mix of A.hs and
1773 -- A.hs-boot TyThings during the course of typechecking. We don't
1774 -- think (and have not observed) any cases where this would cause
1775 -- problems, but the hypothetical situation one might worry about
1776 -- is something along these lines in Core:
1777 --
1778 -- case x of
1779 -- A -> e1
1780 -- B -> e2
1781 --
1782 -- If, when typechecking this, we find x :: T, and the T we are hooked
1783 -- up with is the abstract one from the hs-boot file, rather than the
1784 -- one defined in this module with constructors A and B. But it's hard
1785 -- to see how this could happen, especially because the reference to
1786 -- the constructor (A and B) means that GHC will always typecheck
1787 -- this expression *after* typechecking T.
1788
1789 tcIfaceTyConByName :: IfExtName -> IfL TyCon
1790 tcIfaceTyConByName name
1791 = do { thing <- tcIfaceGlobal name
1792 ; return (tyThingTyCon thing) }
1793
1794 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1795 tcIfaceTyCon (IfaceTyCon name info)
1796 = do { thing <- tcIfaceGlobal name
1797 ; return $ case ifaceTyConIsPromoted info of
1798 IsNotPromoted -> tyThingTyCon thing
1799 IsPromoted -> promoteDataCon $ tyThingDataCon thing }
1800
1801 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
1802 tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
1803 ; return (tyThingCoAxiom thing) }
1804
1805
1806 tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
1807 -- Unlike CoAxioms, which arise form user 'type instance' declarations,
1808 -- there are a fixed set of CoAxiomRules,
1809 -- currently enumerated in typeNatCoAxiomRules
1810 tcIfaceCoAxiomRule n
1811 = case Map.lookup n typeNatCoAxiomRules of
1812 Just ax -> return ax
1813 _ -> pprPanic "go_axiom_rule" (ppr n)
1814
1815 tcIfaceDataCon :: Name -> IfL DataCon
1816 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1817 ; case thing of
1818 AConLike (RealDataCon dc) -> return dc
1819 _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1820
1821 tcIfaceExtId :: Name -> IfL Id
1822 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1823 ; case thing of
1824 AnId id -> return id
1825 _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1826
1827 -- See Note [Resolving never-exported Names in TcIface]
1828 tcIfaceImplicit :: Name -> IfL TyThing
1829 tcIfaceImplicit n = do
1830 lcl_env <- getLclEnv
1831 case if_implicits_env lcl_env of
1832 Nothing -> tcIfaceGlobal n
1833 Just tenv ->
1834 case lookupTypeEnv tenv n of
1835 Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
1836 Just tything -> return tything
1837
1838 {-
1839 ************************************************************************
1840 * *
1841 Bindings
1842 * *
1843 ************************************************************************
1844 -}
1845
1846 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
1847 bindIfaceId (fs, ty) thing_inside
1848 = do { name <- newIfaceName (mkVarOccFS fs)
1849 ; ty' <- tcIfaceType ty
1850 ; let id = mkLocalIdOrCoVar name ty'
1851 ; extendIfaceIdEnv [id] (thing_inside id) }
1852
1853 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
1854 bindIfaceIds [] thing_inside = thing_inside []
1855 bindIfaceIds (b:bs) thing_inside
1856 = bindIfaceId b $ \b' ->
1857 bindIfaceIds bs $ \bs' ->
1858 thing_inside (b':bs')
1859
1860 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1861 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
1862 = bindIfaceId bndr thing_inside
1863 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1864 = bindIfaceTyVar bndr thing_inside
1865
1866 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1867 bindIfaceBndrs [] thing_inside = thing_inside []
1868 bindIfaceBndrs (b:bs) thing_inside
1869 = bindIfaceBndr b $ \ b' ->
1870 bindIfaceBndrs bs $ \ bs' ->
1871 thing_inside (b':bs')
1872
1873 -----------------------
1874 bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
1875 bindIfaceForAllBndrs [] thing_inside = thing_inside []
1876 bindIfaceForAllBndrs (bndr:bndrs) thing_inside
1877 = bindIfaceForAllBndr bndr $ \tv vis ->
1878 bindIfaceForAllBndrs bndrs $ \bndrs' ->
1879 thing_inside (mkTyVarBinder vis tv : bndrs')
1880
1881 bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
1882 bindIfaceForAllBndr (TvBndr tv vis) thing_inside
1883 = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
1884
1885 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1886 bindIfaceTyVars [] thing_inside = thing_inside []
1887 bindIfaceTyVars (tv:tvs) thing_inside
1888 = bindIfaceTyVar tv $ \tv' ->
1889 bindIfaceTyVars tvs $ \tvs' ->
1890 thing_inside (tv' : tvs')
1891
1892 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1893 bindIfaceTyVar (occ,kind) thing_inside
1894 = do { name <- newIfaceName (mkTyVarOccFS occ)
1895 ; tyvar <- mk_iface_tyvar name kind
1896 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1897
1898 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1899 mk_iface_tyvar name ifKind
1900 = do { kind <- tcIfaceType ifKind
1901 ; return (Var.mkTyVar name kind) }
1902
1903 bindIfaceTyConBinders :: [IfaceTyConBinder]
1904 -> ([TyConBinder] -> IfL a) -> IfL a
1905 bindIfaceTyConBinders [] thing_inside = thing_inside []
1906 bindIfaceTyConBinders (b:bs) thing_inside
1907 = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
1908 bindIfaceTyConBinders bs $ \ bs' ->
1909 thing_inside (b':bs')
1910
1911 bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
1912 -> ([TyConBinder] -> IfL a) -> IfL a
1913 -- Used for type variable in nested associated data/type declarations
1914 -- where some of the type variables are already in scope
1915 -- class C a where { data T a b }
1916 -- Here 'a' is in scope when we look at the 'data T'
1917 bindIfaceTyConBinders_AT [] thing_inside
1918 = thing_inside []
1919 bindIfaceTyConBinders_AT (b : bs) thing_inside
1920 = bindIfaceTyConBinderX bind_tv b $ \b' ->
1921 bindIfaceTyConBinders_AT bs $ \bs' ->
1922 thing_inside (b':bs')
1923 where
1924 bind_tv tv thing
1925 = do { mb_tv <- lookupIfaceTyVar tv
1926 ; case mb_tv of
1927 Just b' -> thing b'
1928 Nothing -> bindIfaceTyVar tv thing }
1929
1930 bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
1931 -> IfaceTyConBinder
1932 -> (TyConBinder -> IfL a) -> IfL a
1933 bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
1934 = bind_tv tv $ \tv' ->
1935 thing_inside (TvBndr tv' vis)