Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / compiler / iface / TcIface.lhs
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 \begin{code}
9 module TcIface ( 
10         tcImportDecl, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, 
11         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
12         tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
13  ) where
14
15 #include "HsVersions.h"
16
17 import IfaceSyn
18 import LoadIface
19 import IfaceEnv
20 import BuildTyCl
21 import TcRnMonad
22 import TcType
23 import Type
24 import Coercion
25 import TypeRep
26 import HscTypes
27 import Annotations
28 import InstEnv
29 import FamInstEnv
30 import CoreSyn
31 import CoreUtils
32 import CoreUnfold
33 import CoreLint
34 import WorkWrap
35 import MkCore( castBottomExpr )
36 import Id
37 import MkId
38 import IdInfo
39 import Class
40 import TyCon
41 import DataCon
42 import PrelNames
43 import TysWiredIn
44 import TysPrim          ( superKindTyConName )
45 import BasicTypes       ( Arity, strongLoopBreaker )
46 import Literal
47 import qualified Var
48 import VarEnv
49 import VarSet
50 import Name
51 import NameEnv
52 import NameSet
53 import OccurAnal        ( occurAnalyseExpr )
54 import Demand           ( isBottomingSig )
55 import Module
56 import UniqFM
57 import UniqSupply
58 import Outputable       
59 import ErrUtils
60 import Maybes
61 import SrcLoc
62 import DynFlags
63 import Util
64 import FastString
65
66 import Control.Monad
67 \end{code}
68
69 This module takes
70
71         IfaceDecl -> TyThing
72         IfaceType -> Type
73         etc
74
75 An IfaceDecl is populated with RdrNames, and these are not renamed to
76 Names before typechecking, because there should be no scope errors etc.
77
78         -- For (b) consider: f = \$(...h....)
79         -- where h is imported, and calls f via an hi-boot file.  
80         -- This is bad!  But it is not seen as a staging error, because h
81         -- is indeed imported.  We don't want the type-checker to black-hole 
82         -- when simplifying and compiling the splice!
83         --
84         -- Simple solution: discard any unfolding that mentions a variable
85         -- bound in this module (and hence not yet processed).
86         -- The discarding happens when forkM finds a type error.
87
88 %************************************************************************
89 %*                                                                      *
90 %*      tcImportDecl is the key function for "faulting in"              *
91 %*      imported things
92 %*                                                                      *
93 %************************************************************************
94
95 The main idea is this.  We are chugging along type-checking source code, and
96 find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
97 it in the EPS type envt.  So it 
98         1 loads GHC.Base.hi
99         2 gets the decl for GHC.Base.map
100         3 typechecks it via tcIfaceDecl
101         4 and adds it to the type env in the EPS
102
103 Note that DURING STEP 4, we may find that map's type mentions a type 
104 constructor that also 
105
106 Notice that for imported things we read the current version from the EPS
107 mutable variable.  This is important in situations like
108         ...$(e1)...$(e2)...
109 where the code that e1 expands to might import some defns that 
110 also turn out to be needed by the code that e2 expands to.
111
112 \begin{code}
113 tcImportDecl :: Name -> TcM TyThing
114 -- Entry point for *source-code* uses of importDecl
115 tcImportDecl name 
116   | Just thing <- wiredInNameTyThing_maybe name
117   = do  { when (needWiredInHomeIface thing)
118                (initIfaceTcRn (loadWiredInHomeIface name))
119                 -- See Note [Loading instances for wired-in things]
120         ; return thing }
121   | otherwise
122   = do  { traceIf (text "tcImportDecl" <+> ppr name)
123         ; mb_thing <- initIfaceTcRn (importDecl name)
124         ; case mb_thing of
125             Succeeded thing -> return thing
126             Failed err      -> failWithTc err }
127
128 importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
129 -- Get the TyThing for this Name from an interface file
130 -- It's not a wired-in thing -- the caller caught that
131 importDecl name
132   = ASSERT( not (isWiredInName name) )
133     do  { traceIf nd_doc
134
135         -- Load the interface, which should populate the PTE
136         ; mb_iface <- ASSERT2( isExternalName name, ppr name ) 
137                       loadInterface nd_doc (nameModule name) ImportBySystem
138         ; case mb_iface of {
139                 Failed err_msg  -> return (Failed err_msg) ;
140                 Succeeded _ -> do
141
142         -- Now look it up again; this time we should find it
143         { eps <- getEps 
144         ; case lookupTypeEnv (eps_PTE eps) name of
145             Just thing -> return (Succeeded thing)
146             Nothing    -> return (Failed not_found_msg)
147     }}}
148   where
149     nd_doc = ptext (sLit "Need decl for") <+> ppr name
150     not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
151                                 pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
152                        2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
153                                 ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
154 \end{code}
155
156 %************************************************************************
157 %*                                                                      *
158            Checks for wired-in things
159 %*                                                                      *
160 %************************************************************************
161
162 Note [Loading instances for wired-in things]
163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
164 We need to make sure that we have at least *read* the interface files
165 for any module with an instance decl or RULE that we might want.  
166
167 * If the instance decl is an orphan, we have a whole separate mechanism
168   (loadOprhanModules)
169
170 * If the instance decl not an orphan, then the act of looking at the
171   TyCon or Class will force in the defining module for the
172   TyCon/Class, and hence the instance decl
173
174 * BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
175   but we must make sure we read its interface in case it has instances or
176   rules.  That is what LoadIface.loadWiredInHomeInterface does.  It's called
177   from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}
178
179 * HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There
180   are some wired-in Ids, but we don't want to load their interfaces. For
181   example, Control.Exception.Base.recSelError is wired in, but that module
182   is compiled late in the base library, and we don't want to force it to
183   load before it's been compiled!
184
185 All of this is done by the type checker. The renamer plays no role.
186 (It used to, but no longer.)
187
188
189 \begin{code}
190 checkWiredInTyCon :: TyCon -> TcM ()
191 -- Ensure that the home module of the TyCon (and hence its instances)
192 -- are loaded. See Note [Loading instances for wired-in things]
193 -- It might not be a wired-in tycon (see the calls in TcUnify),
194 -- in which case this is a no-op.
195 checkWiredInTyCon tc    
196   | not (isWiredInName tc_name) 
197   = return ()
198   | otherwise
199   = do  { mod <- getModule
200         ; ASSERT( isExternalName tc_name ) 
201           when (mod /= nameModule tc_name)
202                (initIfaceTcRn (loadWiredInHomeIface tc_name))
203                 -- Don't look for (non-existent) Float.hi when
204                 -- compiling Float.lhs, which mentions Float of course
205                 -- A bit yukky to call initIfaceTcRn here
206         }
207   where
208     tc_name = tyConName tc
209
210 ifCheckWiredInThing :: TyThing -> IfL ()
211 -- Even though we are in an interface file, we want to make
212 -- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
213 -- Ditto want to ensure that RULES are loaded too
214 -- See Note [Loading instances for wired-in things]
215 ifCheckWiredInThing thing
216   = do  { mod <- getIfModule
217                 -- Check whether we are typechecking the interface for this
218                 -- very module.  E.g when compiling the base library in --make mode
219                 -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
220                 -- the HPT, so without the test we'll demand-load it into the PIT!
221                 -- C.f. the same test in checkWiredInTyCon above
222         ; let name = getName thing
223         ; ASSERT2( isExternalName name, ppr name ) 
224           when (needWiredInHomeIface thing && mod /= nameModule name)
225                (loadWiredInHomeIface name) }
226
227 needWiredInHomeIface :: TyThing -> Bool
228 -- Only for TyCons; see Note [Loading instances for wired-in things]
229 needWiredInHomeIface (ATyCon {}) = True
230 needWiredInHomeIface _           = False
231 \end{code}
232
233 %************************************************************************
234 %*                                                                      *
235                 Type-checking a complete interface
236 %*                                                                      *
237 %************************************************************************
238
239 Suppose we discover we don't need to recompile.  Then we must type
240 check the old interface file.  This is a bit different to the
241 incremental type checking we do as we suck in interface files.  Instead
242 we do things similarly as when we are typechecking source decls: we
243 bring into scope the type envt for the interface all at once, using a
244 knot.  Remember, the decls aren't necessarily in dependency order --
245 and even if they were, the type decls might be mutually recursive.
246
247 \begin{code}
248 typecheckIface :: ModIface      -- Get the decls from here
249                -> TcRnIf gbl lcl ModDetails
250 typecheckIface iface
251   = initIfaceTc iface $ \ tc_env_var -> do
252         -- The tc_env_var is freshly allocated, private to 
253         -- type-checking this particular interface
254         {       -- Get the right set of decls and rules.  If we are compiling without -O
255                 -- we discard pragmas before typechecking, so that we don't "see"
256                 -- information that we shouldn't.  From a versioning point of view
257                 -- It's not actually *wrong* to do so, but in fact GHCi is unable 
258                 -- to handle unboxed tuples, so it must not see unfoldings.
259           ignore_prags <- goptM Opt_IgnoreInterfacePragmas
260
261                 -- Typecheck the decls.  This is done lazily, so that the knot-tying
262                 -- within this single module work out right.  In the If monad there is
263                 -- no global envt for the current interface; instead, the knot is tied
264                 -- through the if_rec_types field of IfGblEnv
265         ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
266         ; let type_env = mkNameEnv names_w_things
267         ; writeMutVar tc_env_var type_env
268
269                 -- Now do those rules, instances and annotations
270         ; insts     <- mapM tcIfaceInst (mi_insts iface)
271         ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
272         ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
273         ; anns      <- tcIfaceAnnotations (mi_anns iface)
274
275                 -- Vectorisation information
276         ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface)
277
278                 -- Exports
279         ; exports <- ifaceExportNames (mi_exports iface)
280
281                 -- Finished
282         ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
283                          text "Type envt:" <+> ppr type_env])
284         ; return $ ModDetails { md_types     = type_env
285                               , md_insts     = insts
286                               , md_fam_insts = fam_insts
287                               , md_rules     = rules
288                               , md_anns      = anns
289                               , md_vect_info = vect_info
290                               , md_exports   = exports
291                               }
292     }
293 \end{code}
294
295
296 %************************************************************************
297 %*                                                                      *
298                 Type and class declarations
299 %*                                                                      *
300 %************************************************************************
301
302 \begin{code}
303 tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
304 -- Load the hi-boot iface for the module being compiled,
305 -- if it indeed exists in the transitive closure of imports
306 -- Return the ModDetails, empty if no hi-boot iface
307 tcHiBootIface hsc_src mod
308   | isHsBoot hsc_src            -- Already compiling a hs-boot file
309   = return emptyModDetails
310   | otherwise
311   = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
312
313         ; mode <- getGhcMode
314         ; if not (isOneShot mode)
315                 -- In --make and interactive mode, if this module has an hs-boot file
316                 -- we'll have compiled it already, and it'll be in the HPT
317                 -- 
318                 -- We check wheher the interface is a *boot* interface.
319                 -- It can happen (when using GHC from Visual Studio) that we
320                 -- compile a module in TypecheckOnly mode, with a stable, 
321                 -- fully-populated HPT.  In that case the boot interface isn't there
322                 -- (it's been replaced by the mother module) so we can't check it.
323                 -- And that's fine, because if M's ModInfo is in the HPT, then 
324                 -- it's been compiled once, and we don't need to check the boot iface
325           then do { hpt <- getHpt
326                   ; case lookupUFM hpt (moduleName mod) of
327                       Just info | mi_boot (hm_iface info) 
328                                 -> return (hm_details info)
329                       _ -> return emptyModDetails }
330           else do
331
332         -- OK, so we're in one-shot mode.  
333         -- In that case, we're read all the direct imports by now, 
334         -- so eps_is_boot will record if any of our imports mention us by 
335         -- way of hi-boot file
336         { eps <- getEps
337         ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
338             Nothing -> return emptyModDetails ; -- The typical case
339
340             Just (_, False) -> failWithTc moduleLoop ;
341                 -- Someone below us imported us!
342                 -- This is a loop with no hi-boot in the way
343                 
344             Just (_mod, True) ->        -- There's a hi-boot interface below us
345                 
346     do  { read_result <- findAndReadIface 
347                                 need mod
348                                 True    -- Hi-boot file
349
350         ; case read_result of
351                 Failed err               -> failWithTc (elaborate err)
352                 Succeeded (iface, _path) -> typecheckIface iface
353     }}}}
354   where
355     need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
356                  <+> ptext (sLit "to compare against the Real Thing")
357
358     moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) 
359                      <+> ptext (sLit "depends on itself")
360
361     elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> 
362                           quotes (ppr mod) <> colon) 4 err
363 \end{code}
364
365
366 %************************************************************************
367 %*                                                                      *
368                 Type and class declarations
369 %*                                                                      *
370 %************************************************************************
371
372 When typechecking a data type decl, we *lazily* (via forkM) typecheck
373 the constructor argument types.  This is in the hope that we may never
374 poke on those argument types, and hence may never need to load the
375 interface files for types mentioned in the arg types.
376
377 E.g.    
378         data Foo.S = MkS Baz.T
379 Mabye we can get away without even loading the interface for Baz!
380
381 This is not just a performance thing.  Suppose we have
382         data Foo.S = MkS Baz.T
383         data Baz.T = MkT Foo.S
384 (in different interface files, of course).
385 Now, first we load and typecheck Foo.S, and add it to the type envt.  
386 If we do explore MkS's argument, we'll load and typecheck Baz.T.
387 If we explore MkT's argument we'll find Foo.S already in the envt.  
388
389 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
390 typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
391 which isn't done yet.
392
393 All very cunning. However, there is a rather subtle gotcha which bit
394 me when developing this stuff.  When we typecheck the decl for S, we
395 extend the type envt with S, MkS, and all its implicit Ids.  Suppose
396 (a bug, but it happened) that the list of implicit Ids depended in
397 turn on the constructor arg types.  Then the following sequence of
398 events takes place:
399         * we build a thunk <t> for the constructor arg tys
400         * we build a thunk for the extended type environment (depends on <t>)
401         * we write the extended type envt into the global EPS mutvar
402         
403 Now we look something up in the type envt
404         * that pulls on <t>
405         * which reads the global type envt out of the global EPS mutvar
406         * but that depends in turn on <t>
407
408 It's subtle, because, it'd work fine if we typechecked the constructor args 
409 eagerly -- they don't need the extended type envt.  They just get the extended
410 type envt by accident, because they look at it later.
411
412 What this means is that the implicitTyThings MUST NOT DEPEND on any of
413 the forkM stuff.
414
415
416 \begin{code}
417 tcIfaceDecl :: Bool     -- True <=> discard IdInfo on IfaceId bindings
418             -> IfaceDecl
419             -> IfL TyThing
420 tcIfaceDecl = tc_iface_decl NoParentTyCon
421
422 tc_iface_decl :: TyConParent    -- For nested declarations
423               -> Bool   -- True <=> discard IdInfo on IfaceId bindings
424               -> IfaceDecl
425               -> IfL TyThing
426 tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 
427                                        ifIdDetails = details, ifIdInfo = info})
428   = do  { name <- lookupIfaceTop occ_name
429         ; ty <- tcIfaceType iface_type
430         ; details <- tcIdDetails ty details
431         ; info <- tcIdInfo ignore_prags name ty info
432         ; return (AnId (mkGlobalId details name ty info)) }
433
434 tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
435                           ifCType = cType, 
436                           ifTyVars = tv_bndrs, 
437                           ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
438                           ifCons = rdr_cons, 
439                           ifRec = is_rec, 
440                           ifAxiom = mb_axiom_name })
441   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
442     { tc_name <- lookupIfaceTop occ_name
443     ; tycon <- fixM $ \ tycon -> do
444             { stupid_theta <- tcIfaceCtxt ctxt
445             ; parent' <- tc_parent tyvars mb_axiom_name
446             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
447             ; return (buildAlgTyCon tc_name tyvars cType stupid_theta 
448                                     cons is_rec gadt_syn parent') }
449     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
450     ; return (ATyCon tycon) }
451   where
452     tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
453     tc_parent _ Nothing = return parent
454     tc_parent tyvars (Just ax_name)
455       = ASSERT( isNoParent parent )
456         do { ax <- tcIfaceCoAxiom ax_name
457            ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax
458                  subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars)
459                             -- The subst matches the tyvar of the TyCon
460                             -- with those from the CoAxiom.  They aren't
461                             -- necessarily the same, since the two may be
462                             -- gotten from separate interface-file declarations
463            ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
464
465 tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
466                                   ifSynRhs = mb_rhs_ty,
467                                   ifSynKind = kind })
468    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
469      { tc_name  <- lookupIfaceTop occ_name
470      ; rhs_kind <- tcIfaceKind kind     -- Note [Synonym kind loop]
471      ; rhs      <- forkM (mk_doc tc_name) $ 
472                    tc_syn_rhs mb_rhs_ty
473      ; tycon    <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
474      ; return (ATyCon tycon) }
475    where
476      mk_doc n = ptext (sLit "Type syonym") <+> ppr n
477      tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b)
478      tc_syn_rhs (SynonymTyCon ty)    = do { rhs_ty <- tcIfaceType ty
479                                           ; return (SynonymTyCon rhs_ty) }
480
481 tc_iface_decl _parent ignore_prags
482             (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
483                          ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
484                          ifATs = rdr_ats, ifSigs = rdr_sigs, 
485                          ifRec = tc_isrec })
486 -- ToDo: in hs-boot files we should really treat abstract classes specially,
487 --       as we do abstract tycons
488   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
489     { tc_name <- lookupIfaceTop tc_occ
490     ; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
491     ; ctxt <- mapM tc_sc rdr_ctxt
492     ; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
493     ; sigs <- mapM tc_sig rdr_sigs
494     ; fds  <- mapM tc_fd rdr_fds
495     ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
496     ; cls  <- fixM $ \ cls -> do
497               { ats  <- mapM (tc_at cls) rdr_ats
498               ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
499               ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
500     ; return (ATyCon (classTyCon cls)) }
501   where
502    tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
503         -- The *length* of the superclasses is used by buildClass, and hence must
504         -- not be inside the thunk.  But the *content* maybe recursive and hence
505         -- must be lazy (via forkM).  Example:
506         --     class C (T a) => D a where
507         --       data T a
508         -- Here the associated type T is knot-tied with the class, and
509         -- so we must not pull on T too eagerly.  See Trac #5970
510    mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
511
512    tc_sig (IfaceClassOp occ dm rdr_ty)
513      = do { op_name <- lookupIfaceTop occ
514           ; op_ty   <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
515                 -- Must be done lazily for just the same reason as the 
516                 -- type of a data con; to avoid sucking in types that
517                 -- it mentions unless it's necessary to do so
518           ; return (op_name, dm, op_ty) }
519
520    tc_at cls (IfaceAT tc_decl defs_decls)
521      = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
522           defs <- mapM tc_iface_at_def defs_decls
523           return (tc, defs)
524
525    tc_iface_at_def (IfaceATD tvs pat_tys ty) =
526        bindIfaceTyVars_AT tvs $
527          \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
528                            (mapM tcIfaceType pat_tys) (tcIfaceType ty)
529
530    mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
531
532    tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
533                            ; tvs2' <- mapM tcIfaceTyVar tvs2
534                            ; return (tvs1', tvs2') }
535
536 tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
537   = do  { name <- lookupIfaceTop rdr_name
538         ; return (ATyCon (mkForeignTyCon name ext_name 
539                                          liftedTypeKind 0)) }
540
541 tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs,
542                                ifLHS = lhs, ifRHS = rhs })
543   = bindIfaceTyVars tv_bndrs $ \ tvs -> do
544     { tc_name <- lookupIfaceTop tc_occ
545     ; tc_lhs  <- tcIfaceType lhs
546     ; tc_rhs  <- tcIfaceType rhs
547     ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
548                           , co_ax_name     = tc_name
549                           , co_ax_implicit = False
550                           , co_ax_tvs      = tvs
551                           , co_ax_lhs      = tc_lhs
552                           , co_ax_rhs      = tc_rhs }
553     ; return (ACoAxiom axiom) }
554
555 tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
556 tcIfaceDataCons tycon_name tycon _ if_cons
557   = case if_cons of
558         IfAbstractTyCon dis -> return (AbstractTyCon dis)
559         IfDataFamTyCon  -> return DataFamilyTyCon
560         IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
561                                 ; return (mkDataTyConRhs data_cons) }
562         IfNewTyCon con   -> do  { data_con <- tc_con_decl con
563                                 ; mkNewTyConRhs tycon_name tycon data_con }
564   where
565     tc_con_decl (IfCon { ifConInfix = is_infix, 
566                          ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
567                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
568                          ifConArgTys = args, ifConFields = field_lbls,
569                          ifConStricts = stricts})
570      = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
571        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
572         { name  <- lookupIfaceTop occ
573
574         -- Read the context and argument types, but lazily for two reasons
575         -- (a) to avoid looking tugging on a recursive use of 
576         --     the type itself, which is knot-tied
577         -- (b) to avoid faulting in the component types unless 
578         --     they are really needed
579         ; ~(eq_spec, theta, arg_tys) <- forkM (mk_doc name) $
580              do { eq_spec <- tcIfaceEqSpec spec
581                 ; theta   <- tcIfaceCtxt ctxt
582                 ; arg_tys <- mapM tcIfaceType args
583                 ; return (eq_spec, theta, arg_tys) }
584         ; lbl_names <- mapM lookupIfaceTop field_lbls
585
586         -- Remember, tycon is the representation tycon
587         ; let orig_res_ty = mkFamilyTyConApp tycon 
588                                 (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
589
590         ; buildDataCon name is_infix
591                        stricts lbl_names
592                        univ_tyvars ex_tyvars 
593                        eq_spec theta 
594                        arg_tys orig_res_ty tycon
595         }
596     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
597
598 tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
599 tcIfaceEqSpec spec
600   = mapM do_item spec
601   where
602     do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
603                               ; ty <- tcIfaceType if_ty
604                               ; return (tv,ty) }
605 \end{code}
606
607 Note [Synonym kind loop]
608 ~~~~~~~~~~~~~~~~~~~~~~~~
609 Notice that we eagerly grab the *kind* from the interface file, but
610 build a forkM thunk for the *rhs* (and family stuff).  To see why, 
611 consider this (Trac #2412)
612
613 M.hs:       module M where { import X; data T = MkT S }
614 X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
615 M.hs-boot:  module M where { data T }
616
617 When kind-checking M.hs we need S's kind.  But we do not want to
618 find S's kind from (typeKind S-rhs), because we don't want to look at
619 S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
620 be defined, and we must not do that until we've finished with M.T.
621
622 Solution: record S's kind in the interface file; now we can safely
623 look at it.
624
625 %************************************************************************
626 %*                                                                      *
627                 Instances
628 %*                                                                      *
629 %************************************************************************
630
631 \begin{code}
632 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
633 tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
634                           , ifInstCls = cls, ifInstTys = mb_tcs })
635   = do { dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
636                      tcIfaceExtId dfun_occ
637        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
638        ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
639
640 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
641 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
642                              , ifFamInstAxiom = axiom_name } )
643     = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
644                      tcIfaceCoAxiom axiom_name
645          ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
646          ; return (mkImportedFamInst fam mb_tcs' axiom') }
647 \end{code}
648
649
650 %************************************************************************
651 %*                                                                      *
652                 Rules
653 %*                                                                      *
654 %************************************************************************
655
656 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
657 are in the type environment.  However, remember that typechecking a Rule may 
658 (as a side effect) augment the type envt, and so we may need to iterate the process.
659
660 \begin{code}
661 tcIfaceRules :: Bool            -- True <=> ignore rules
662              -> [IfaceRule]
663              -> IfL [CoreRule]
664 tcIfaceRules ignore_prags if_rules
665   | ignore_prags = return []
666   | otherwise    = mapM tcIfaceRule if_rules
667
668 tcIfaceRule :: IfaceRule -> IfL CoreRule
669 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
670                         ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
671                         ifRuleAuto = auto })
672   = do  { ~(bndrs', args', rhs') <- 
673                 -- Typecheck the payload lazily, in the hope it'll never be looked at
674                 forkM (ptext (sLit "Rule") <+> ftext name) $
675                 bindIfaceBndrs bndrs                      $ \ bndrs' ->
676                 do { args' <- mapM tcIfaceExpr args
677                    ; rhs'  <- tcIfaceExpr rhs
678                    ; return (bndrs', args', rhs') }
679         ; let mb_tcs = map ifTopFreeName args
680         ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, 
681                           ru_bndrs = bndrs', ru_args = args', 
682                           ru_rhs = occurAnalyseExpr rhs', 
683                           ru_rough = mb_tcs,
684                           ru_auto = auto,
685                           ru_local = False }) } -- An imported RULE is never for a local Id
686                                                 -- or, even if it is (module loop, perhaps)
687                                                 -- we'll just leave it in the non-local set
688   where
689         -- This function *must* mirror exactly what Rules.topFreeName does
690         -- We could have stored the ru_rough field in the iface file
691         -- but that would be redundant, I think.
692         -- The only wrinkle is that we must not be deceived by
693         -- type syononyms at the top of a type arg.  Since
694         -- we can't tell at this point, we are careful not
695         -- to write them out in coreRuleToIfaceRule
696     ifTopFreeName :: IfaceExpr -> Maybe Name
697     ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
698     ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
699     ifTopFreeName (IfaceExt n)                      = Just n
700     ifTopFreeName _                                 = Nothing
701 \end{code}
702
703
704 %************************************************************************
705 %*                                                                      *
706                 Annotations
707 %*                                                                      *
708 %************************************************************************
709
710 \begin{code}
711 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
712 tcIfaceAnnotations = mapM tcIfaceAnnotation
713
714 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
715 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
716     target' <- tcIfaceAnnTarget target
717     return $ Annotation {
718         ann_target = target',
719         ann_value = serialized
720     }
721
722 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
723 tcIfaceAnnTarget (NamedTarget occ) = do
724     name <- lookupIfaceTop occ
725     return $ NamedTarget name
726 tcIfaceAnnTarget (ModuleTarget mod) = do
727     return $ ModuleTarget mod
728
729 \end{code}
730
731
732 %************************************************************************
733 %*                                                                      *
734                 Vectorisation information
735 %*                                                                      *
736 %************************************************************************
737
738 \begin{code}
739 -- We need access to the type environment as we need to look up information about type constructors
740 -- (i.e., their data constructors and whether they are class type constructors).  If a vectorised
741 -- type constructor or class is defined in the same module as where it is vectorised, we cannot
742 -- look that information up from the type constructor that we obtained via a 'forkM'ed
743 -- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
744 -- and again and again...
745 --
746 tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
747 tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
748                              { ifaceVectInfoVar          = vars
749                              , ifaceVectInfoTyCon        = tycons
750                              , ifaceVectInfoTyConReuse   = tyconsReuse
751                              , ifaceVectInfoScalarVars   = scalarVars
752                              , ifaceVectInfoScalarTyCons = scalarTyCons
753                              })
754   = do { let scalarTyConsSet = mkNameSet scalarTyCons
755        ; vVars       <- mapM vectVarMapping                  vars
756        ; let varsSet = mkVarSet (map fst vVars)
757        ; tyConRes1   <- mapM (vectTyConVectMapping varsSet)  tycons
758        ; tyConRes2   <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
759        ; vScalarVars <- mapM vectVar                         scalarVars
760        ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
761        ; return $ VectInfo 
762                   { vectInfoVar          = mkVarEnv  vVars `extendVarEnvList` concat vScSels
763                   , vectInfoTyCon        = mkNameEnv vTyCons
764                   , vectInfoDataCon      = mkNameEnv (concat vDataCons)
765                   , vectInfoScalarVars   = mkVarSet  vScalarVars
766                   , vectInfoScalarTyCons = scalarTyConsSet
767                   }
768        }
769   where
770     vectVarMapping name 
771       = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
772            ; var   <- forkM (ptext (sLit "vect var")  <+> ppr name)  $
773                         tcIfaceExtId name
774            ; vVar  <- forkM (ptext (sLit "vect vVar [mod =") <+> 
775                              ppr mod <> ptext (sLit "; nameModule =") <+> 
776                              ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
777                        tcIfaceExtId vName
778            ; return (var, (var, vVar))
779            }
780       -- where
781       --   lookupLocalOrExternalId name
782       --     = do { let mb_id = lookupTypeEnv typeEnv name
783       --          ; case mb_id of
784       --                -- id is local
785       --              Just (AnId id) -> return id
786       --                -- name is not an Id => internal inconsistency
787       --              Just _         -> notAnIdErr
788       --                -- Id is external
789       --              Nothing        -> tcIfaceExtId name
790       --          }
791       -- 
792       --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
793
794     vectVar name 
795       = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
796           tcIfaceExtId name
797
798     vectTyConVectMapping vars name
799       = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
800            ; vectTyConMapping vars name vName
801            }
802
803     vectTyConReuseMapping vars name
804       = vectTyConMapping vars name name
805
806     vectTyConMapping vars name vName
807       = do { tycon  <- lookupLocalOrExternalTyCon name
808            ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ 
809                          lookupLocalOrExternalTyCon vName
810
811                -- Map the data constructors of the original type constructor to those of the
812                -- vectorised type constructor /unless/ the type constructor was vectorised
813                -- abstractly; if it was vectorised abstractly, the workers of its data constructors
814                -- do not appear in the set of vectorised variables.
815                --
816                -- NB: This is lazy!  We don't pull at the type constructors before we actually use
817                --     the data constructor mapping.
818            ; let isAbstract | isClassTyCon tycon = False
819                             | datacon:_ <- tyConDataCons tycon 
820                                                  = not $ dataConWrapId datacon `elemVarSet` vars
821                             | otherwise          = True
822                  vDataCons  | isAbstract = []
823                             | otherwise  = [ (dataConName datacon, (datacon, vDatacon))
824                                            | (datacon, vDatacon) <- zip (tyConDataCons tycon)
825                                                                         (tyConDataCons vTycon)
826                                            ]
827
828                    -- Map the (implicit) superclass and methods selectors as they don't occur in
829                    -- the var map.
830                  vScSels    | Just cls  <- tyConClass_maybe tycon
831                             , Just vCls <- tyConClass_maybe vTycon 
832                             = [ (sel, (sel, vSel))
833                               | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
834                               ]
835                             | otherwise
836                             = []
837
838            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
839                     , vDataCons                        -- list of (Ci, Ci_v)
840                     , vScSels                          -- list of (seli, seli_v)
841                     )
842            }
843       where
844           -- we need a fully defined version of the type constructor to be able to extract
845           -- its data constructors etc.
846         lookupLocalOrExternalTyCon name
847           = do { let mb_tycon = lookupTypeEnv typeEnv name
848                ; case mb_tycon of
849                      -- tycon is local
850                    Just (ATyCon tycon) -> return tycon
851                      -- name is not a tycon => internal inconsistency
852                    Just _              -> notATyConErr
853                      -- tycon is external
854                    Nothing             -> tcIfaceTyCon (IfaceTc name)
855                }
856
857         notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
858 \end{code}
859
860 %************************************************************************
861 %*                                                                      *
862                         Types
863 %*                                                                      *
864 %************************************************************************
865
866 \begin{code}
867 tcIfaceType :: IfaceType -> IfL Type
868 tcIfaceType (IfaceTyVar n)         = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
869 tcIfaceType (IfaceAppTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
870 tcIfaceType (IfaceLitTy l)         = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
871 tcIfaceType (IfaceFunTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
872 tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
873                                         ; tks' <- tcIfaceTcArgs (tyConKind tc') tks 
874                                         ; return (mkTyConApp tc' tks') }
875 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
876 tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
877
878 tcIfaceTypes :: [IfaceType] -> IfL [Type]
879 tcIfaceTypes tys = mapM tcIfaceType tys
880
881 tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type]
882 tcIfaceTcArgs _ [] 
883   = return []
884 tcIfaceTcArgs kind (tk:tks)
885   = case splitForAllTy_maybe kind of
886       Nothing         -> tcIfaceTypes (tk:tks)
887       Just (_, kind') -> do { k'   <- tcIfaceKind tk
888                             ; tks' <- tcIfaceTcArgs kind' tks
889                             ; return (k':tks') }
890   
891 -----------------------------------------
892 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
893 tcIfaceCtxt sts = mapM tcIfaceType sts
894
895 -----------------------------------------
896 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
897 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
898 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
899
900 -----------------------------------------
901 tcIfaceKind :: IfaceKind -> IfL Kind   -- See Note [Checking IfaceTypes vs IfaceKinds]
902 tcIfaceKind (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
903 tcIfaceKind (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
904 tcIfaceKind (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
905 tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') }
906 tcIfaceKind (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') }
907 tcIfaceKind t                     = pprPanic "tcIfaceKind" (ppr t)  -- IfaceCoApp, IfaceLitTy
908
909 tcIfaceKinds :: [IfaceKind] -> IfL [Kind]
910 tcIfaceKinds tys = mapM tcIfaceKind tys
911 \end{code}
912
913 Note [Checking IfaceTypes vs IfaceKinds]
914 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
915 We need to know whether we are checking a *type* or a *kind*.
916 Consider   module M where
917              Proxy :: forall k. k -> *
918              data T = T
919 and consider the two IfaceTypes
920       M.Proxy * M.T{tc}
921       M.Proxy 'M.T{tc} 'M.T(d}
922 The first is conventional, but in the latter we use the promoted
923 type constructor (as a kind) and data constructor (as a type).  However, 
924 the Name of the promoted type constructor is just M.T; it's the *same name*
925 as the ordinary type constructor.  
926
927 We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy.
928 Instead we use context to distinguish, as in the source language.  
929   - When checking a kind, we look up M.T{tc} and promote it
930   - When checking a type, we look up M.T{tc} and don't promote it
931                                  and M.T{d}  and promote it
932     See tcIfaceKindCon and tcIfaceKTyCon respectively
933
934 This context business is why we need tcIfaceTcArgs.
935
936
937 %************************************************************************
938 %*                                                                      *
939                         Coercions
940 %*                                                                      *
941 %************************************************************************
942
943 \begin{code}
944 tcIfaceCo :: IfaceType -> IfL Coercion
945 tcIfaceCo (IfaceTyVar n)        = mkCoVarCo <$> tcIfaceCoVar n
946 tcIfaceCo (IfaceAppTy t1 t2)    = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
947 tcIfaceCo (IfaceFunTy t1 t2)    = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
948 tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
949 tcIfaceCo t@(IfaceLitTy _)      = mkReflCo <$> tcIfaceType t
950 tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
951 tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
952                                   mkForAllCo tv' <$> tcIfaceCo t
953
954 tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
955 tcIfaceCoApp IfaceReflCo      [t]     = Refl         <$> tcIfaceType t
956 tcIfaceCoApp (IfaceCoAx n)    ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
957 tcIfaceCoApp IfaceUnsafeCo    [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
958 tcIfaceCoApp IfaceSymCo       [t]     = SymCo        <$> tcIfaceCo t
959 tcIfaceCoApp IfaceTransCo     [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
960 tcIfaceCoApp IfaceInstCo      [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
961 tcIfaceCoApp (IfaceNthCo d)   [t]     = NthCo d      <$> tcIfaceCo t
962 tcIfaceCoApp (IfaceLRCo lr)   [t]     = LRCo lr      <$> tcIfaceCo t
963 tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
964
965 tcIfaceCoVar :: FastString -> IfL CoVar
966 tcIfaceCoVar = tcIfaceLclId
967 \end{code}
968
969
970 %************************************************************************
971 %*                                                                      *
972                         Core
973 %*                                                                      *
974 %************************************************************************
975
976 \begin{code}
977 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
978 tcIfaceExpr (IfaceType ty)
979   = Type <$> tcIfaceType ty
980
981 tcIfaceExpr (IfaceCo co)
982   = Coercion <$> tcIfaceCo co
983
984 tcIfaceExpr (IfaceCast expr co)
985   = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
986
987 tcIfaceExpr (IfaceLcl name)
988   = Var <$> tcIfaceLclId name
989
990 tcIfaceExpr (IfaceExt gbl)
991   = Var <$> tcIfaceExtId gbl
992
993 tcIfaceExpr (IfaceLit lit)
994   = do lit' <- tcIfaceLit lit
995        return (Lit lit')
996  
997 tcIfaceExpr (IfaceFCall cc ty) = do
998     ty' <- tcIfaceType ty
999     u <- newUnique
1000     dflags <- getDynFlags
1001     return (Var (mkFCallId dflags u cc ty'))
1002
1003 tcIfaceExpr (IfaceTuple boxity args)  = do
1004     args' <- mapM tcIfaceExpr args
1005     -- Put the missing type arguments back in
1006     let con_args = map (Type . exprType) args' ++ args'
1007     return (mkApps (Var con_id) con_args)
1008   where
1009     arity = length args
1010     con_id = dataConWorkId (tupleCon boxity arity)
1011     
1012
1013 tcIfaceExpr (IfaceLam bndr body)
1014   = bindIfaceBndr bndr $ \bndr' ->
1015     Lam bndr' <$> tcIfaceExpr body
1016
1017 tcIfaceExpr (IfaceApp fun arg)
1018   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1019
1020 tcIfaceExpr (IfaceECase scrut ty) 
1021   = do { scrut' <- tcIfaceExpr scrut 
1022        ; ty' <- tcIfaceType ty
1023        ; return (castBottomExpr scrut' ty') }
1024
1025 tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
1026     scrut' <- tcIfaceExpr scrut
1027     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1028     let
1029         scrut_ty   = exprType scrut'
1030         case_bndr' = mkLocalId case_bndr_name scrut_ty
1031         tc_app     = splitTyConApp scrut_ty
1032                 -- NB: Won't always succeed (polymoprhic case)
1033                 --     but won't be demanded in those cases
1034                 -- NB: not tcSplitTyConApp; we are looking at Core here
1035                 --     look through non-rec newtypes to find the tycon that
1036                 --     corresponds to the datacon in this case alternative
1037
1038     extendIfaceIdEnv [case_bndr'] $ do
1039      alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1040      return (Case scrut' case_bndr' (coreAltsType alts') alts')
1041
1042 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
1043   = do  { name    <- newIfaceName (mkVarOccFS fs)
1044         ; ty'     <- tcIfaceType ty
1045         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1046                               name ty' info
1047         ; let id = mkLocalIdWithInfo name ty' id_info
1048         ; rhs' <- tcIfaceExpr rhs
1049         ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1050         ; return (Let (NonRec id rhs') body') }
1051
1052 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1053   = do { ids <- mapM tc_rec_bndr (map fst pairs)
1054        ; extendIfaceIdEnv ids $ do
1055        { pairs' <- zipWithM tc_pair pairs ids
1056        ; body' <- tcIfaceExpr body
1057        ; return (Let (Rec pairs') body') } }
1058  where
1059    tc_rec_bndr (IfLetBndr fs ty _) 
1060      = do { name <- newIfaceName (mkVarOccFS fs)  
1061           ; ty'  <- tcIfaceType ty
1062           ; return (mkLocalId name ty') }
1063    tc_pair (IfLetBndr _ _ info, rhs) id
1064      = do { rhs' <- tcIfaceExpr rhs
1065           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1066                                 (idName id) (idType id) info
1067           ; return (setIdInfo id id_info, rhs') }
1068
1069 tcIfaceExpr (IfaceTick tickish expr) = do
1070     expr' <- tcIfaceExpr expr
1071     tickish' <- tcIfaceTickish tickish
1072     return (Tick tickish' expr')
1073
1074 -------------------------
1075 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1076 tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
1077 tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
1078
1079 -------------------------
1080 tcIfaceLit :: Literal -> IfL Literal
1081 -- Integer literals deserialise to (LitInteger i <error thunk>) 
1082 -- so tcIfaceLit just fills in the type.
1083 -- See Note [Integer literals] in Literal
1084 tcIfaceLit (LitInteger i _)
1085   = do t <- tcIfaceTyCon (IfaceTc integerTyConName)
1086        return (mkLitInteger i (mkTyConTy t))
1087 tcIfaceLit lit = return lit
1088
1089 -------------------------
1090 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1091            -> (IfaceConAlt, [FastString], IfaceExpr)
1092            -> IfL (AltCon, [TyVar], CoreExpr)
1093 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1094   = ASSERT( null names ) do
1095     rhs' <- tcIfaceExpr rhs
1096     return (DEFAULT, [], rhs')
1097   
1098 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1099   = ASSERT( null names ) do
1100     lit' <- tcIfaceLit lit
1101     rhs' <- tcIfaceExpr rhs
1102     return (LitAlt lit', [], rhs')
1103
1104 -- A case alternative is made quite a bit more complicated
1105 -- by the fact that we omit type annotations because we can
1106 -- work them out.  True enough, but its not that easy!
1107 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1108   = do  { con <- tcIfaceDataCon data_occ
1109         ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1110                (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1111         ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1112
1113 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1114                -> IfL (AltCon, [TyVar], CoreExpr)
1115 tcIfaceDataAlt con inst_tys arg_strs rhs
1116   = do  { us <- newUniqueSupply
1117         ; let uniqs = uniqsFromSupply us
1118         ; let (ex_tvs, arg_ids)
1119                       = dataConRepFSInstPat arg_strs uniqs con inst_tys
1120
1121         ; rhs' <- extendIfaceTyVarEnv ex_tvs    $
1122                   extendIfaceIdEnv arg_ids      $
1123                   tcIfaceExpr rhs
1124         ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1125 \end{code}
1126
1127
1128 \begin{code}
1129 tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram  -- Used for external core
1130 tcExtCoreBindings []     = return []
1131 tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
1132
1133 do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
1134 do_one (IfaceNonRec bndr rhs) thing_inside
1135   = do  { rhs' <- tcIfaceExpr rhs
1136         ; bndr' <- newExtCoreBndr bndr
1137         ; extendIfaceIdEnv [bndr'] $ do 
1138         { core_binds <- thing_inside
1139         ; return (NonRec bndr' rhs' : core_binds) }}
1140
1141 do_one (IfaceRec pairs) thing_inside
1142   = do  { bndrs' <- mapM newExtCoreBndr bndrs
1143         ; extendIfaceIdEnv bndrs' $ do
1144         { rhss' <- mapM tcIfaceExpr rhss
1145         ; core_binds <- thing_inside
1146         ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
1147   where
1148     (bndrs,rhss) = unzip pairs
1149 \end{code}
1150
1151
1152 %************************************************************************
1153 %*                                                                      *
1154                 IdInfo
1155 %*                                                                      *
1156 %************************************************************************
1157
1158 \begin{code}
1159 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1160 tcIdDetails _  IfVanillaId = return VanillaId
1161 tcIdDetails ty (IfDFunId ns)
1162   = return (DFunId ns (isNewTyCon (classTyCon cls)))
1163   where
1164     (_, _, cls, _) = tcSplitDFunTy ty
1165
1166 tcIdDetails _ (IfRecSelId tc naughty)
1167   = do { tc' <- tcIfaceTyCon tc
1168        ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1169
1170 tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1171 tcIdInfo ignore_prags name ty info 
1172   | ignore_prags = return vanillaIdInfo
1173   | otherwise    = case info of
1174                         NoInfo       -> return vanillaIdInfo
1175                         HasInfo info -> foldlM tcPrag init_info info
1176   where
1177     -- Set the CgInfo to something sensible but uninformative before
1178     -- we start; default assumption is that it has CAFs
1179     init_info = vanillaIdInfo
1180
1181     tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1182     tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
1183     tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
1184     tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
1185     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
1186
1187         -- The next two are lazy, so they don't transitively suck stuff in
1188     tcPrag info (HsUnfold lb if_unf) 
1189       = do { unf <- tcUnfolding name ty info if_unf
1190            ; let info1 | lb        = info `setOccInfo` strongLoopBreaker
1191                        | otherwise = info
1192            ; return (info1 `setUnfoldingInfoLazily` unf) }
1193 \end{code}
1194
1195 \begin{code}
1196 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1197 tcUnfolding name _ info (IfCoreUnfold stable if_expr)
1198   = do  { dflags <- getDynFlags
1199         ; mb_expr <- tcPragExpr name if_expr
1200         ; let unf_src = if stable then InlineStable else InlineRhs
1201         ; return (case mb_expr of
1202                     Nothing   -> NoUnfolding
1203                     Just expr -> mkUnfolding dflags unf_src
1204                                              True {- Top level -} 
1205                                              is_bottoming expr) }
1206   where
1207      -- Strictness should occur before unfolding!
1208     is_bottoming = case strictnessInfo info of
1209                      Just sig -> isBottomingSig sig
1210                      Nothing  -> False
1211
1212 tcUnfolding name _ _ (IfCompulsory if_expr)
1213   = do  { mb_expr <- tcPragExpr name if_expr
1214         ; return (case mb_expr of
1215                     Nothing   -> NoUnfolding
1216                     Just expr -> mkCompulsoryUnfolding expr) }
1217
1218 tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1219   = do  { mb_expr <- tcPragExpr name if_expr
1220         ; return (case mb_expr of
1221                     Nothing   -> NoUnfolding
1222                     Just expr -> mkCoreUnfolding InlineStable True expr arity 
1223                                                  (UnfWhen unsat_ok boring_ok))
1224     }
1225
1226 tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
1227   = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
1228        ; return (case mb_ops1 of
1229                     Nothing   -> noUnfolding
1230                     Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
1231   where
1232     doc = text "Class ops for dfun" <+> ppr name
1233     tc_arg (DFunPolyArg  e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
1234     tc_arg (DFunLamArg i)   = return (DFunLamArg i)
1235
1236 tcUnfolding name ty info (IfExtWrapper arity wkr)
1237   = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
1238 tcUnfolding name ty info (IfLclWrapper arity wkr)
1239   = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr)
1240
1241 -------------
1242 tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
1243 tcIfaceWrapper name ty info arity get_worker
1244   = do  { mb_wkr_id <- forkM_maybe doc get_worker
1245         ; us <- newUniqueSupply
1246         ; dflags <- getDynFlags
1247         ; return (case mb_wkr_id of
1248                      Nothing     -> noUnfolding
1249                      Just wkr_id -> make_inline_rule dflags wkr_id us) }
1250   where
1251     doc = text "Worker for" <+> ppr name
1252
1253     make_inline_rule dflags wkr_id us 
1254         = mkWwInlineRule wkr_id
1255                          (initUs_ us (mkWrapper dflags ty strict_sig) wkr_id) 
1256                          arity
1257
1258         -- Again we rely here on strictness info always appearing 
1259         -- before unfolding
1260     strict_sig = case strictnessInfo info of
1261                    Just sig -> sig
1262                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr name)
1263 \end{code}
1264
1265 For unfoldings we try to do the job lazily, so that we never type check
1266 an unfolding that isn't going to be looked at.
1267
1268 \begin{code}
1269 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1270 tcPragExpr name expr
1271   = forkM_maybe doc $ do
1272     core_expr' <- tcIfaceExpr expr
1273
1274                 -- Check for type consistency in the unfolding
1275     whenGOptM Opt_DoCoreLinting $ do
1276         in_scope <- get_in_scope
1277         case lintUnfolding noSrcLoc in_scope core_expr' of
1278           Nothing       -> return ()
1279           Just fail_msg -> do { mod <- getIfModule 
1280                               ; pprPanic "Iface Lint failure" 
1281                                   (vcat [ ptext (sLit "In interface for") <+> ppr mod
1282                                         , hang doc 2 fail_msg
1283                                         , ppr name <+> equals <+> ppr core_expr'
1284                                         , ptext (sLit "Iface expr =") <+> ppr expr ]) }
1285     return core_expr'
1286   where
1287     doc = text "Unfolding of" <+> ppr name
1288
1289     get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
1290     get_in_scope        
1291         = do { (gbl_env, lcl_env) <- getEnvs
1292              ; rec_ids <- case if_rec_types gbl_env of
1293                             Nothing -> return []
1294                             Just (_, get_env) -> do
1295                                { type_env <- setLclEnv () get_env
1296                                ; return (typeEnvIds type_env) }
1297              ; return (varEnvElts (if_tv_env lcl_env) ++
1298                        varEnvElts (if_id_env lcl_env) ++
1299                        rec_ids) }
1300 \end{code}
1301
1302
1303
1304 %************************************************************************
1305 %*                                                                      *
1306                 Getting from Names to TyThings
1307 %*                                                                      *
1308 %************************************************************************
1309
1310 \begin{code}
1311 tcIfaceGlobal :: Name -> IfL TyThing
1312 tcIfaceGlobal name
1313   | Just thing <- wiredInNameTyThing_maybe name
1314         -- Wired-in things include TyCons, DataCons, and Ids
1315         -- Even though we are in an interface file, we want to make
1316         -- sure the instances and RULES of this thing (particularly TyCon) are loaded 
1317         -- Imagine: f :: Double -> Double
1318   = do { ifCheckWiredInThing thing; return thing }
1319   | otherwise
1320   = do  { env <- getGblEnv
1321         ; case if_rec_types env of {    -- Note [Tying the knot]
1322             Just (mod, get_type_env) 
1323                 | nameIsLocalOrFrom mod name
1324                 -> do           -- It's defined in the module being compiled
1325                 { type_env <- setLclEnv () get_type_env         -- yuk
1326                 ; case lookupNameEnv type_env name of
1327                         Just thing -> return thing
1328                         Nothing   -> pprPanic "tcIfaceGlobal (local): not found:"  
1329                                                 (ppr name $$ ppr type_env) }
1330
1331           ; _ -> do
1332
1333         { hsc_env <- getTopEnv
1334         ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1335         ; case mb_thing of {
1336             Just thing -> return thing ;
1337             Nothing    -> do
1338
1339         { mb_thing <- importDecl name   -- It's imported; go get it
1340         ; case mb_thing of
1341             Failed err      -> failIfM err
1342             Succeeded thing -> return thing
1343     }}}}}
1344
1345 -- Note [Tying the knot]
1346 -- ~~~~~~~~~~~~~~~~~~~~~
1347 -- The if_rec_types field is used in two situations:
1348 --
1349 -- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T
1350 --    Then we look up M.T in M's type environment, which is splatted into if_rec_types
1351 --    after we've built M's type envt.
1352 --
1353 -- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi
1354 --    is up to date.  So we call typecheckIface on M.hi.  This splats M.T into 
1355 --    if_rec_types so that the (lazily typechecked) decls see all the other decls
1356 --
1357 -- In case (b) it's important to do the if_rec_types check *before* looking in the HPT
1358 -- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its
1359 -- emasculated form (e.g. lacking data constructors).
1360
1361 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1362 tcIfaceTyCon (IfaceTc name) 
1363   = do { thing <- tcIfaceGlobal name
1364        ; case thing of    -- A "type constructor" can be a promoted data constructor
1365                           --           c.f. Trac #5881
1366            ATyCon   tc -> return tc
1367            ADataCon dc -> return (promoteDataCon dc)
1368            _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
1369
1370 tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
1371 tcIfaceKindCon (IfaceTc name) 
1372   = do { thing <- tcIfaceGlobal name
1373        ; case thing of    -- A "type constructor" here is a promoted type constructor
1374                           --           c.f. Trac #5881
1375            ATyCon tc 
1376              | isSuperKind (tyConKind tc) -> return tc   -- Mainly just '*' or 'AnyK'
1377              | otherwise                  -> return (promoteTyCon tc)
1378
1379            _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
1380
1381 tcIfaceCoAxiom :: Name -> IfL CoAxiom
1382 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
1383                          ; return (tyThingCoAxiom thing) }
1384
1385 tcIfaceDataCon :: Name -> IfL DataCon
1386 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1387                          ; case thing of
1388                                 ADataCon dc -> return dc
1389                                 _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1390
1391 tcIfaceExtId :: Name -> IfL Id
1392 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1393                        ; case thing of
1394                           AnId id -> return id
1395                           _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1396 \end{code}
1397
1398 %************************************************************************
1399 %*                                                                      *
1400                 Bindings
1401 %*                                                                      *
1402 %************************************************************************
1403
1404 \begin{code}
1405 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1406 bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
1407   = do  { name <- newIfaceName (mkVarOccFS fs)
1408         ; ty' <- tcIfaceType ty
1409         ; let id = mkLocalId name ty'
1410         ; extendIfaceIdEnv [id] (thing_inside id) }
1411 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1412   = bindIfaceTyVar bndr thing_inside
1413     
1414 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1415 bindIfaceBndrs []     thing_inside = thing_inside []
1416 bindIfaceBndrs (b:bs) thing_inside
1417   = bindIfaceBndr b     $ \ b' ->
1418     bindIfaceBndrs bs   $ \ bs' ->
1419     thing_inside (b':bs')
1420
1421 -----------------------
1422 newExtCoreBndr :: IfaceLetBndr -> IfL Id
1423 newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now
1424   = do  { mod <- getIfModule
1425         ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
1426         ; ty' <- tcIfaceType ty
1427         ; return (mkLocalId name ty') }
1428
1429 -----------------------
1430 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1431 bindIfaceTyVar (occ,kind) thing_inside
1432   = do  { name <- newIfaceName (mkTyVarOccFS occ)
1433         ; tyvar <- mk_iface_tyvar name kind
1434         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1435
1436 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1437 bindIfaceTyVars bndrs thing_inside
1438   = do { names <- newIfaceNames (map mkTyVarOccFS occs)
1439         ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
1440               (kis_name, tys_name) = splitAt (length kis_kind) names
1441           -- We need to bring the kind variables in scope since type
1442           -- variables may mention them.
1443         ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
1444         ; extendIfaceTyVarEnv kvs $ do
1445         { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
1446         ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
1447   where
1448     (occs,kinds) = unzip bndrs
1449
1450 isSuperIfaceKind :: IfaceKind -> Bool
1451 isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
1452 isSuperIfaceKind _ = False
1453
1454 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1455 mk_iface_tyvar name ifKind
1456    = do { kind <- tcIfaceKind ifKind
1457         ; return (Var.mkTyVar name kind) }
1458
1459 bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
1460 -- Used for type variable in nested associated data/type declarations
1461 -- where some of the type variables are already in scope
1462 --    class C a where { data T a b }
1463 -- Here 'a' is in scope when we look at the 'data T'
1464 bindIfaceTyVars_AT [] thing_inside
1465   = thing_inside []
1466 bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
1467   = do { mb_tv <- lookupIfaceTyVar tv_occ
1468        ; let bind_b :: (TyVar -> IfL a) -> IfL a
1469              bind_b = case mb_tv of
1470                         Just b' -> \k -> k b'
1471                         Nothing -> bindIfaceTyVar b
1472        ; bind_b $ \b' ->
1473          bindIfaceTyVars_AT bs $ \bs' ->
1474          thing_inside (b':bs') }
1475 \end{code}
1476