TcIface.lhs 42.4 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Type checking of type signatures in interface files
7
8
9

\begin{code}
module TcIface ( 
10
	tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
11
12
	tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
	tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
13
 ) where
14

15
16
17
#include "HsVersions.h"

import IfaceSyn
Simon Marlow's avatar
Simon Marlow committed
18
19
20
import LoadIface
import IfaceEnv
import BuildTyCl
21
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
22
23
24
25
26
import Type
import TypeRep
import HscTypes
import InstEnv
import FamInstEnv
27
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
28
import CoreUtils
29
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
30
31
32
33
34
35
36
37
38
39
40
import CoreLint
import WorkWrap
import Id
import MkId
import IdInfo
import Class
import TyCon
import DataCon
import TysWiredIn
import Var              ( TyVar )
import qualified Var
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
41
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
42
import Name
43
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
44
45
import OccName
import Module
46
import LazyUniqFM
Simon Marlow's avatar
Simon Marlow committed
47
import UniqSupply
48
import Outputable	
Simon Marlow's avatar
Simon Marlow committed
49
50
51
52
import ErrUtils
import Maybes
import SrcLoc
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
53
import Util
54
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
55
import BasicTypes (Arity)
Simon Marlow's avatar
Simon Marlow committed
56

57
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
58
59
import Data.List
import Data.Maybe
60
61
62
63
64
65
66
67
68
69
70
\end{code}

This module takes

	IfaceDecl -> TyThing
	IfaceType -> Type
	etc

An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.

71
	-- For (b) consider: f = \$(...h....)
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
	-- where h is imported, and calls f via an hi-boot file.  
	-- This is bad!  But it is not seen as a staging error, because h
	-- is indeed imported.  We don't want the type-checker to black-hole 
	-- when simplifying and compiling the splice!
	--
	-- Simple solution: discard any unfolding that mentions a variable
	-- bound in this module (and hence not yet processed).
	-- The discarding happens when forkM finds a type error.

%************************************************************************
%*									*
%*	tcImportDecl is the key function for "faulting in" 		*
%*	imported things
%*									*
%************************************************************************

The main idea is this.  We are chugging along type-checking source code, and
find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
it in the EPS type envt.  So it 
	1 loads GHC.Base.hi
	2 gets the decl for GHC.Base.map
	3 typechecks it via tcIfaceDecl
	4 and adds it to the type env in the EPS

Note that DURING STEP 4, we may find that map's type mentions a type 
constructor that also 

Notice that for imported things we read the current version from the EPS
mutable variable.  This is important in situations like
	...$(e1)...$(e2)...
where the code that e1 expands to might import some defns that 
also turn out to be needed by the code that e2 expands to.

\begin{code}
106
tcImportDecl :: Name -> TcM TyThing
107
-- Entry point for *source-code* uses of importDecl
108
tcImportDecl name 
109
  | Just thing <- wiredInNameTyThing_maybe name
110
  = do	{ initIfaceTcRn (loadWiredInHomeIface name) 
111
		-- See Note [Loading instances] in LoadIface
112
	; return thing }
113
  | otherwise
114
  = do 	{ traceIf (text "tcImportDecl" <+> ppr name)
115
116
117
118
119
	; mb_thing <- initIfaceTcRn (importDecl name)
	; case mb_thing of
	    Succeeded thing -> return thing
	    Failed err      -> failWithTc err }

120
checkWiredInTyCon :: TyCon -> TcM ()
121
-- Ensure that the home module of the TyCon (and hence its instances)
122
123
-- are loaded. See See Note [Loading instances] in LoadIface
-- It might not be a wired-in tycon (see the calls in TcUnify),
124
-- in which case this is a no-op.
125
checkWiredInTyCon tc	
126
127
128
129
  | not (isWiredInName tc_name) 
  = return ()
  | otherwise
  = do	{ mod <- getModule
130
131
	; unless (mod == nameModule tc_name)
		 (initIfaceTcRn (loadWiredInHomeIface tc_name))
132
133
		-- Don't look for (non-existent) Float.hi when
		-- compiling Float.lhs, which mentions Float of course
134
	  	-- A bit yukky to call initIfaceTcRn here
135
136
	}
  where
137
    tc_name = tyConName tc
138

139
importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
140
-- Get the TyThing for this Name from an interface file
141
142
143
144
-- It's not a wired-in thing -- the caller caught that
importDecl name
  = ASSERT( not (isWiredInName name) )
    do	{ traceIf nd_doc
145
146

	-- Load the interface, which should populate the PTE
147
148
149
	; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
	; case mb_iface of {
		Failed err_msg  -> return (Failed err_msg) ;
Ian Lynagh's avatar
Ian Lynagh committed
150
		Succeeded _ -> do
151
152

	-- Now look it up again; this time we should find it
153
	{ eps <- getEps	
154
	; case lookupTypeEnv (eps_PTE eps) name of
155
156
157
	    Just thing -> return (Succeeded thing)
	    Nothing    -> return (Failed not_found_msg)
    }}}
158
  where
Ian Lynagh's avatar
Ian Lynagh committed
159
160
    nd_doc = ptext (sLit "Need decl for") <+> ppr name
    not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
161
				pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
Ian Lynagh's avatar
Ian Lynagh committed
162
163
	  	       2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
		                ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
164
165
166
167
\end{code}

%************************************************************************
%*									*
168
		Type-checking a complete interface
169
170
171
%*									*
%************************************************************************

172
173
174
175
176
177
178
179
Suppose we discover we don't need to recompile.  Then we must type
check the old interface file.  This is a bit different to the
incremental type checking we do as we suck in interface files.  Instead
we do things similarly as when we are typechecking source decls: we
bring into scope the type envt for the interface all at once, using a
knot.  Remember, the decls aren't necessarily in dependency order --
and even if they were, the type decls might be mutually recursive.

180
\begin{code}
181
182
183
184
185
186
typecheckIface :: ModIface 	-- Get the decls from here
	       -> TcRnIf gbl lcl ModDetails
typecheckIface iface
  = initIfaceTc iface $ \ tc_env_var -> do
	-- The tc_env_var is freshly allocated, private to 
	-- type-checking this particular interface
187
188
189
190
191
192
	{ 	-- Get the right set of decls and rules.  If we are compiling without -O
		-- we discard pragmas before typechecking, so that we don't "see"
		-- information that we shouldn't.  From a versioning point of view
		-- It's not actually *wrong* to do so, but in fact GHCi is unable 
		-- to handle unboxed tuples, so it must not see unfoldings.
	  ignore_prags <- doptM Opt_IgnoreInterfacePragmas
193

194
195
196
197
198
199
		-- Typecheck the decls.  This is done lazily, so that the knot-tying
		-- within this single module work out right.  In the If monad there is
		-- no global envt for the current interface; instead, the knot is tied
		-- through the if_rec_types field of IfGblEnv
	; names_w_things <- loadDecls ignore_prags (mi_decls iface)
	; let type_env = mkNameEnv names_w_things
200
201
202
	; writeMutVar tc_env_var type_env

		-- Now do those rules and instances
203
204
205
	; insts     <- mapM tcIfaceInst    (mi_insts     iface)
	; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
	; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
206

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
207
                -- Vectorisation information
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
208
209
        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env 
                                       (mi_vect_info iface)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
210

211
		-- Exports
212
	; exports <- ifaceExportNames (mi_exports iface)
213

214
		-- Finished
215
216
	; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
			 text "Type envt:" <+> ppr type_env])
217
	; return $ ModDetails { md_types     = type_env
218
219
			      , md_insts     = insts
			      , md_fam_insts = fam_insts
220
			      , md_rules     = rules
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
221
                              , md_vect_info = vect_info
mnislaih's avatar
mnislaih committed
222
			      , md_exports   = exports
223
			      }
224
    }
225
226
227
\end{code}


228
229
230
231
232
233
234
%************************************************************************
%*									*
		Type and class declarations
%*									*
%************************************************************************

\begin{code}
235
tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
236
237
238
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
239
240
241
242
tcHiBootIface hsc_src mod
  | isHsBoot hsc_src		-- Already compiling a hs-boot file
  = return emptyModDetails
  | otherwise
243
244
  = do 	{ traceIf (text "loadHiBootInterface" <+> ppr mod)

245
	; mode <- getGhcMode
246
247
248
	; if not (isOneShot mode)
		-- In --make and interactive mode, if this module has an hs-boot file
		-- we'll have compiled it already, and it'll be in the HPT
249
250
251
252
253
254
255
256
		-- 
		-- We check wheher the interface is a *boot* interface.
		-- It can happen (when using GHC from Visual Studio) that we
		-- compile a module in TypecheckOnly mode, with a stable, 
		-- fully-populated HPT.  In that case the boot interface isn't there
		-- (it's been replaced by the mother module) so we can't check it.
		-- And that's fine, because if M's ModInfo is in the HPT, then 
		-- it's been compiled once, and we don't need to check the boot iface
257
	  then do { hpt <- getHpt
Simon Marlow's avatar
Simon Marlow committed
258
		  ; case lookupUFM hpt (moduleName mod) of
259
260
		      Just info | mi_boot (hm_iface info) 
				-> return (hm_details info)
Ian Lynagh's avatar
Ian Lynagh committed
261
		      _ -> return emptyModDetails }
262
263
264
265
266
267
268
	  else do

	-- OK, so we're in one-shot mode.  
	-- In that case, we're read all the direct imports by now, 
	-- so eps_is_boot will record if any of our imports mention us by 
	-- way of hi-boot file
	{ eps <- getEps
Simon Marlow's avatar
Simon Marlow committed
269
	; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
270
271
272
273
274
275
	    Nothing -> return emptyModDetails ;	-- The typical case

	    Just (_, False) -> failWithTc moduleLoop ;
 		-- Someone below us imported us!
		-- This is a loop with no hi-boot in the way
		
Simon Marlow's avatar
Simon Marlow committed
276
	    Just (_mod, True) -> 	-- There's a hi-boot interface below us
277
278
279
280
281
282
283
284
		
    do	{ read_result <- findAndReadIface 
				need mod
				True	-- Hi-boot file

	; case read_result of
		Failed err               -> failWithTc (elaborate err)
		Succeeded (iface, _path) -> typecheckIface iface
285
    }}}}
286
  where
Ian Lynagh's avatar
Ian Lynagh committed
287
288
    need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
		 <+> ptext (sLit "to compare against the Real Thing")
289

Ian Lynagh's avatar
Ian Lynagh committed
290
291
    moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) 
		     <+> ptext (sLit "depends on itself")
292

Ian Lynagh's avatar
Ian Lynagh committed
293
    elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> 
294
295
296
297
		          quotes (ppr mod) <> colon) 4 err
\end{code}


298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
%************************************************************************
%*									*
		Type and class declarations
%*									*
%************************************************************************

When typechecking a data type decl, we *lazily* (via forkM) typecheck
the constructor argument types.  This is in the hope that we may never
poke on those argument types, and hence may never need to load the
interface files for types mentioned in the arg types.

E.g.	
	data Foo.S = MkS Baz.T
Mabye we can get away without even loading the interface for Baz!

This is not just a performance thing.  Suppose we have
	data Foo.S = MkS Baz.T
	data Baz.T = MkT Foo.S
(in different interface files, of course).
Now, first we load and typecheck Foo.S, and add it to the type envt.  
If we do explore MkS's argument, we'll load and typecheck Baz.T.
If we explore MkT's argument we'll find Foo.S already in the envt.  

If we typechecked constructor args eagerly, when loading Foo.S we'd try to
typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
which isn't done yet.

All very cunning. However, there is a rather subtle gotcha which bit
me when developing this stuff.  When we typecheck the decl for S, we
extend the type envt with S, MkS, and all its implicit Ids.  Suppose
(a bug, but it happened) that the list of implicit Ids depended in
turn on the constructor arg types.  Then the following sequence of
events takes place:
	* we build a thunk <t> for the constructor arg tys
	* we build a thunk for the extended type environment (depends on <t>)
	* we write the extended type envt into the global EPS mutvar
	
Now we look something up in the type envt
	* that pulls on <t>
	* which reads the global type envt out of the global EPS mutvar
	* but that depends in turn on <t>

It's subtle, because, it'd work fine if we typechecked the constructor args 
eagerly -- they don't need the extended type envt.  They just get the extended
type envt by accident, because they look at it later.

What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.


\begin{code}
349
350
351
tcIfaceDecl :: Bool	-- True <=> discard IdInfo on IfaceId bindings
	    -> IfaceDecl
	    -> IfL TyThing
352

353
tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
354
355
  = do	{ name <- lookupIfaceTop occ_name
	; ty <- tcIfaceType iface_type
356
	; info <- tcIdInfo ignore_prags name ty info
357
	; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
358

Ian Lynagh's avatar
Ian Lynagh committed
359
tcIfaceDecl _
360
	    (IfaceData {ifName = occ_name, 
361
			ifTyVars = tv_bndrs, 
362
			ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
363
			ifCons = rdr_cons, 
364
			ifRec = is_rec, 
365
			ifGeneric = want_generic,
366
			ifFamInst = mb_family })
367
368
369
  = do	{ tc_name <- lookupIfaceTop occ_name
	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do

370
	{ tycon <- fixM ( \ tycon -> do
371
	    { stupid_theta <- tcIfaceCtxt ctxt
372
373
	    ; famInst <- 
	        case mb_family of
374
		  Nothing         -> return Nothing
375
		  Just (fam, tys) -> 
376
377
		    do { famTyCon <- tcIfaceTyCon fam
		       ; insttys <- mapM tcIfaceType tys
378
		       ; return $ Just (famTyCon, insttys)
379
		       }
380
	    ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
381
	    ; buildAlgTyCon tc_name tyvars stupid_theta
382
			    cons is_rec want_generic gadt_syn famInst
383
384
385
	    })
        ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
	; return (ATyCon tycon)
386
    }}
387

Ian Lynagh's avatar
Ian Lynagh committed
388
tcIfaceDecl _
389
	    (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
390
391
		       ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
		       ifFamInst = mb_family})
392
393
   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
394
     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
395
     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
396
			   else SynonymTyCon rhs_tyki
397
398
399
400
401
402
403
404
     ; famInst <- case mb_family of
		    Nothing         -> return Nothing
		    Just (fam, tys) -> 
		      do { famTyCon <- tcIfaceTyCon fam
		         ; insttys <- mapM tcIfaceType tys
		         ; return $ Just (famTyCon, insttys)
		         }
     ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
405
     ; return $ ATyCon tycon
406
407
     }

408
409
tcIfaceDecl ignore_prags
	    (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
410
411
			 ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
			 ifATs = rdr_ats, ifSigs = rdr_sigs, 
412
			 ifRec = tc_isrec })
413
414
-- ToDo: in hs-boot files we should really treat abstract classes specially,
--	 as we do abstract tycons
415
416
417
  = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
    { cls_name <- lookupIfaceTop occ_name
    ; ctxt <- tcIfaceCtxt rdr_ctxt
418
419
420
    ; sigs <- mapM tc_sig rdr_sigs
    ; fds  <- mapM tc_fd rdr_fds
    ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
421
    ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
422
    ; cls  <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
423
424
425
426
427
428
    ; return (AClass cls) }
  where
   tc_sig (IfaceClassOp occ dm rdr_ty)
     = do { op_name <- lookupIfaceTop occ
	  ; op_ty   <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
		-- Must be done lazily for just the same reason as the 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
429
430
		-- type of a data con; to avoid sucking in types that
		-- it mentions unless it's necessray to do so
431
432
	  ; return (op_name, dm, op_ty) }

Ian Lynagh's avatar
Ian Lynagh committed
433
   mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
434

435
436
   tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
			   ; tvs2' <- mapM tcIfaceTyVar tvs2
437
438
			   ; return (tvs1', tvs2') }

439
440
441
442
443
444
445
446
447
448
449
450
451
   -- For each AT argument compute the position of the corresponding class
   -- parameter in the class head.  This will later serve as a permutation
   -- vector when checking the validity of instance declarations.
   setTyThingPoss (ATyCon tycon) atTyVars = 
     let classTyVars = map fst tv_bndrs
	 poss        =   catMaybes 
		       . map ((`elemIndex` classTyVars) . fst) 
		       $ atTyVars
		    -- There will be no Nothing, as we already passed renaming
     in 
     ATyCon (setTyConArgPoss tycon poss)
   setTyThingPoss _		  _ = panic "TcIface.setTyThingPoss"

Ian Lynagh's avatar
Ian Lynagh committed
452
tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
453
454
  = do	{ name <- lookupIfaceTop rdr_name
	; return (ATyCon (mkForeignTyCon name ext_name 
455
					 liftedTypeKind 0)) }
456

Ian Lynagh's avatar
Ian Lynagh committed
457
458
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
459
  = case if_cons of
460
	IfAbstractTyCon	 -> return mkAbstractTyConRhs
461
	IfOpenDataTyCon	 -> return mkOpenDataTyConRhs
462
	IfDataTyCon cons -> do 	{ data_cons <- mapM tc_con_decl cons
463
464
				; return (mkDataTyConRhs data_cons) }
	IfNewTyCon con	 -> do 	{ data_con <- tc_con_decl con
465
				; mkNewTyConRhs tycon_name tycon data_con }
466
  where
467
468
469
470
    tc_con_decl (IfCon { ifConInfix = is_infix, 
			 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
			 ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
			 ifConArgTys = args, ifConFields = field_lbls,
471
			 ifConStricts = stricts})
472
473
     = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
       bindIfaceTyVars ex_tvs	 $ \ ex_tyvars -> do
474
	{ name  <- lookupIfaceTop occ
475
        ; eq_spec <- tcIfaceEqSpec spec
476
477
478
479
480
481
482
483
484
	; theta <- tcIfaceCtxt ctxt	-- Laziness seems not worth the bother here
	 	-- At one stage I thought that this context checking *had*
		-- to be lazy, because of possible mutual recursion between the
		-- type and the classe: 
		-- E.g. 
		--	class Real a where { toRat :: a -> Ratio Integer }
		--	data (Real a) => Ratio a = ...
		-- But now I think that the laziness in checking class ops breaks 
		-- the loop, so no laziness needed
485
486
487

	-- Read the argument types, but lazily to avoid faulting in
	-- the component types unless they are really needed
488
489
 	; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
	; lbl_names <- mapM lookupIfaceTop field_lbls
490

491
492
493
494
495
	; buildDataCon name is_infix {- Not infix -}
		       stricts lbl_names
		       univ_tyvars ex_tyvars 
                       eq_spec theta 
		       arg_tys tycon
496
	}
Ian Lynagh's avatar
Ian Lynagh committed
497
    mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
498

Ian Lynagh's avatar
Ian Lynagh committed
499
tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
500
501
502
tcIfaceEqSpec spec
  = mapM do_item spec
  where
503
    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
504
505
                              ; ty <- tcIfaceType if_ty
                              ; return (tv,ty) }
506
\end{code}
507
508
509
510
511
512
513
514
515


%************************************************************************
%*									*
		Instances
%*									*
%************************************************************************

\begin{code}
516
517
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
Ian Lynagh's avatar
Ian Lynagh committed
518
			 ifInstCls = cls, ifInstTys = mb_tcs })
Ian Lynagh's avatar
Ian Lynagh committed
519
  = do	{ dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
520
521
		     tcIfaceExtId dfun_occ
        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
522
	; return (mkImportedInstance cls mb_tcs' dfun oflag) }
523
524
525
526

tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
			       ifFamInstFam = fam, ifFamInstTys = mb_tcs })
Ian Lynagh's avatar
Ian Lynagh committed
527
--	{ tycon'  <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
Thomas Schilling's avatar
Thomas Schilling committed
528
-- the above line doesn't work, but this below does => CPP in Haskell = evil!
529
530
531
532
    = do tycon'  <- forkM (text ("Inst tycon") <+> ppr tycon) $
                    tcIfaceTyCon tycon
         let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
         return (mkImportedFamInst fam mb_tcs' tycon')
533
534
\end{code}

535

536
537
538
539
540
541
542
543
544
545
546
%************************************************************************
%*									*
		Rules
%*									*
%************************************************************************

We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
are in the type environment.  However, remember that typechecking a Rule may 
(as a side effect) augment the type envt, and so we may need to iterate the process.

\begin{code}
547
548
549
550
551
552
553
tcIfaceRules :: Bool 		-- True <=> ignore rules
	     -> [IfaceRule]
	     -> IfL [CoreRule]
tcIfaceRules ignore_prags if_rules
  | ignore_prags = return []
  | otherwise    = mapM tcIfaceRule if_rules

554
555
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
Ian Lynagh's avatar
Ian Lynagh committed
556
			ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
557
  = do	{ ~(bndrs', args', rhs') <- 
558
		-- Typecheck the payload lazily, in the hope it'll never be looked at
Ian Lynagh's avatar
Ian Lynagh committed
559
		forkM (ptext (sLit "Rule") <+> ftext name) $
560
		bindIfaceBndrs bndrs 			  $ \ bndrs' ->
561
		do { args' <- mapM tcIfaceExpr args
562
563
		   ; rhs'  <- tcIfaceExpr rhs
		   ; return (bndrs', args', rhs') }
564
	; let mb_tcs = map ifTopFreeName args
565
	; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, 
566
			  ru_bndrs = bndrs', ru_args = args', 
567
			  ru_rhs = rhs', 
568
			  ru_rough = mb_tcs,
569
570
571
			  ru_local = False }) }	-- An imported RULE is never for a local Id
						-- or, even if it is (module loop, perhaps)
						-- we'll just leave it in the non-local set
572
  where
573
574
575
576
577
578
579
	-- This function *must* mirror exactly what Rules.topFreeName does
	-- We could have stored the ru_rough field in the iface file
	-- but that would be redundant, I think.
	-- The only wrinkle is that we must not be deceived by
	-- type syononyms at the top of a type arg.  Since
	-- we can't tell at this point, we are careful not
	-- to write them out in coreRuleToIfaceRule
580
581
    ifTopFreeName :: IfaceExpr -> Maybe Name
    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
Ian Lynagh's avatar
Ian Lynagh committed
582
    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
583
    ifTopFreeName (IfaceExt n)                      = Just n
Ian Lynagh's avatar
Ian Lynagh committed
584
    ifTopFreeName _                                 = Nothing
585
586
587
\end{code}


chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
588
589
590
591
592
593
594
595
%************************************************************************
%*									*
		Vectorisation information
%*									*
%************************************************************************

\begin{code}
tcIfaceVectInfo :: Module -> TypeEnv  -> IfaceVectInfo -> IfL VectInfo
596
tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
597
598
599
                             { ifaceVectInfoVar        = vars
                             , ifaceVectInfoTyCon      = tycons
                             , ifaceVectInfoTyConReuse = tyconsReuse
600
                             })
601
602
  = do { vVars     <- mapM vectVarMapping vars
       ; tyConRes1 <- mapM vectTyConMapping      tycons
603
       ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
604
       ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
605
       ; return $ VectInfo 
606
607
608
                  { vectInfoVar     = mkVarEnv  vVars
                  , vectInfoTyCon   = mkNameEnv vTyCons
                  , vectInfoDataCon = mkNameEnv (concat vDataCons)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
609
                  , vectInfoPADFun  = mkNameEnv vPAs
610
                  , vectInfoIso     = mkNameEnv vIsos
611
                  }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
612
613
       }
  where
614
615
616
617
    vectVarMapping name 
      = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name))
           ; let { var  = lookupVar name
                 ; vVar = lookupVar vName
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
618
                 }
619
           ; return (var, (var, vVar))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
620
           }
621
622
    vectTyConMapping name 
      = do { vName   <- lookupOrig mod (mkVectTyConOcc (nameOccName name))
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
623
           ; paName  <- lookupOrig mod (mkPADFunOcc    (nameOccName name))
624
           ; isoName <- lookupOrig mod (mkVectIsoOcc   (nameOccName name))
625
           ; let { tycon    = lookupTyCon name
626
                 ; vTycon   = lookupTyCon vName
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
627
                 ; paTycon  = lookupVar paName
628
629
                 ; isoTycon = lookupVar isoName
                 }
630
631
632
           ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
           ; return ((name, (tycon, vTycon)),    -- (T, T_v)
                     vDataCons,                  -- list of (Ci, Ci_v)
633
                     (vName, (vTycon, paTycon)), -- (T_v, paT)
634
635
                     (name, (tycon, isoTycon)))  -- (T, isoT)
           }
636
    vectTyConReuseMapping name 
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
637
638
      = do { paName  <- lookupOrig mod (mkPADFunOcc    (nameOccName name))
           ; isoName <- lookupOrig mod (mkVectIsoOcc   (nameOccName name))
639
           ; let { tycon      = lookupTyCon name
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
640
                 ; paTycon    = lookupVar paName
641
                 ; isoTycon   = lookupVar isoName
642
                 ; vDataCons  = [ (dataConName dc, (dc, dc)) 
643
644
645
                                | dc <- tyConDataCons tycon]
                 }
           ; return ((name, (tycon, tycon)),     -- (T, T)
646
                     vDataCons,                  -- list of (Ci, Ci)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
647
                     (name, (tycon, paTycon)),   -- (T, paT)
648
649
                     (name, (tycon, isoTycon)))  -- (T, isoT)
           }
650
    vectDataConMapping datacon
651
      = do { let name = dataConName datacon
652
653
654
           ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name))
           ; let vDataCon = lookupDataCon vName
           ; return (name, (datacon, vDataCon))
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
           }
    --
    lookupVar name = case lookupTypeEnv typeEnv name of
                       Just (AnId var) -> var
                       Just _         -> 
                         panic "TcIface.tcIfaceVectInfo: not an id"
                       Nothing        ->
                         panic "TcIface.tcIfaceVectInfo: unknown name"
    lookupTyCon name = case lookupTypeEnv typeEnv name of
                         Just (ATyCon tc) -> tc
                         Just _         -> 
                           panic "TcIface.tcIfaceVectInfo: not a tycon"
                         Nothing        ->
                           panic "TcIface.tcIfaceVectInfo: unknown name"
    lookupDataCon name = case lookupTypeEnv typeEnv name of
                           Just (ADataCon dc) -> dc
                           Just _         -> 
                             panic "TcIface.tcIfaceVectInfo: not a datacon"
                           Nothing        ->
                             panic "TcIface.tcIfaceVectInfo: unknown name"
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
675
676
\end{code}

677
678
679
680
681
682
683
684
685
686
687
%************************************************************************
%*									*
			Types
%*									*
%************************************************************************

\begin{code}
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
688
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
689
690
691
tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }

Ian Lynagh's avatar
Ian Lynagh committed
692
tcIfaceTypes :: [IfaceType] -> IfL [Type]
693
694
695
696
697
698
tcIfaceTypes tys = mapM tcIfaceType tys

-----------------------------------------
tcIfacePredType :: IfacePredType -> IfL PredType
tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
699
tcIfacePredType (IfaceEqPred t1 t2)  = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
700
701
702

-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
703
tcIfaceCtxt sts = mapM tcIfacePredType sts
704
705
706
707
708
709
710
711
712
713
714
715
\end{code}


%************************************************************************
%*									*
			Core
%*									*
%************************************************************************

\begin{code}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
716
  = Type <$> tcIfaceType ty
717
718

tcIfaceExpr (IfaceLcl name)
719
  = Var <$> tcIfaceLclId name
720

721
tcIfaceExpr (IfaceTick modName tickNo)
722
  = Var <$> tcIfaceTick modName tickNo
723

724
tcIfaceExpr (IfaceExt gbl)
725
  = Var <$> tcIfaceExtId gbl
726
727

tcIfaceExpr (IfaceLit lit)
728
729
730
731
732
733
734
735
736
737
738
739
  = return (Lit lit)

tcIfaceExpr (IfaceFCall cc ty) = do
    ty' <- tcIfaceType ty
    u <- newUnique
    return (Var (mkFCallId u cc ty'))

tcIfaceExpr (IfaceTuple boxity args)  = do
    args' <- mapM tcIfaceExpr args
    -- Put the missing type arguments back in
    let con_args = map (Type . exprType) args' ++ args'
    return (mkApps (Var con_id) con_args)
740
741
742
743
744
745
  where
    arity = length args
    con_id = dataConWorkId (tupleCon boxity arity)
    

tcIfaceExpr (IfaceLam bndr body)
746
747
  = bindIfaceBndr bndr $ \bndr' ->
    Lam bndr' <$> tcIfaceExpr body
748
749

tcIfaceExpr (IfaceApp fun arg)
750
  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
751

752
753
754
tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
    scrut' <- tcIfaceExpr scrut
    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
755
756
757
758
759
760
761
762
763
764
    let
	scrut_ty   = exprType scrut'
	case_bndr' = mkLocalId case_bndr_name scrut_ty
	tc_app     = splitTyConApp scrut_ty
		-- NB: Won't always succeed (polymoprhic case)
		--     but won't be demanded in those cases
		-- NB: not tcSplitTyConApp; we are looking at Core here
		--     look through non-rec newtypes to find the tycon that
		--     corresponds to the datacon in this case alternative

765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
    extendIfaceIdEnv [case_bndr'] $ do
     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
     ty' <- tcIfaceType ty
     return (Case scrut' case_bndr' ty' alts')

tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do
    rhs' <- tcIfaceExpr rhs
    id   <- tcIfaceLetBndr bndr
    body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
    return (Let (NonRec id rhs') body')

tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do
    ids <- mapM tcIfaceLetBndr bndrs
    extendIfaceIdEnv ids $ do
     rhss' <- mapM tcIfaceExpr rhss
     body' <- tcIfaceExpr body
     return (Let (Rec (ids `zip` rhss')) body')
782
783
784
  where
    (bndrs, rhss) = unzip pairs

785
tcIfaceExpr (IfaceCast expr co) = do
786
787
788
    expr' <- tcIfaceExpr expr
    co' <- tcIfaceType co
    return (Cast expr' co')
789

790
791
tcIfaceExpr (IfaceNote note expr) = do
    expr' <- tcIfaceExpr expr
792
    case note of
793
794
795
        IfaceInlineMe     -> return (Note InlineMe   expr')
        IfaceSCC cc       -> return (Note (SCC cc)   expr')
        IfaceCoreNote n   -> return (Note (CoreNote n) expr')
796
797

-------------------------
Ian Lynagh's avatar
Ian Lynagh committed
798
799
800
tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
           -> (IfaceConAlt, [FastString], IfaceExpr)
           -> IfL (AltCon, [TyVar], CoreExpr)
801
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
802
803
804
  = ASSERT( null names ) do
    rhs' <- tcIfaceExpr rhs
    return (DEFAULT, [], rhs')
805
  
806
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
807
808
809
  = ASSERT( null names ) do
    rhs' <- tcIfaceExpr rhs
    return (LitAlt lit, [], rhs')
810
811
812
813

-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out.  True enough, but its not that easy!
814
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
815
  = do	{ con <- tcIfaceDataCon data_occ
Ian Lynagh's avatar
Ian Lynagh committed
816
	; when (debugIsOn && not (con `elem` tyConDataCons tycon))
817
	       (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
818
	; tcIfaceDataAlt con inst_tys arg_strs rhs }
819
		  
Ian Lynagh's avatar
Ian Lynagh committed
820
tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
821
822
823
824
  = ASSERT( isTupleTyCon tycon )
    do	{ let [data_con] = tyConDataCons tycon
	; tcIfaceDataAlt data_con inst_tys arg_occs rhs }

Ian Lynagh's avatar
Ian Lynagh committed
825
826
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
               -> IfL (AltCon, [TyVar], CoreExpr)
827
tcIfaceDataAlt con inst_tys arg_strs rhs
828
829
  = do	{ us <- newUniqueSupply
	; let uniqs = uniqsFromSupply us
830
831
832
	; let (ex_tvs, co_tvs, arg_ids)
	              = dataConRepFSInstPat arg_strs uniqs con inst_tys
              all_tvs = ex_tvs ++ co_tvs
833
834

	; rhs' <- extendIfaceTyVarEnv all_tvs	$
835
836
		  extendIfaceIdEnv arg_ids	$
		  tcIfaceExpr rhs
837
	; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
838
839
840
841
\end{code}


\begin{code}
842
843
844
tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind]	-- Used for external core
tcExtCoreBindings []     = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
845

846
847
do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
do_one (IfaceNonRec bndr rhs) thing_inside
848
  = do	{ rhs' <- tcIfaceExpr rhs
849
	; bndr' <- newExtCoreBndr bndr
850
851
852
853
	; extendIfaceIdEnv [bndr'] $ do 
	{ core_binds <- thing_inside
	; return (NonRec bndr' rhs' : core_binds) }}

854
do_one (IfaceRec pairs) thing_inside
855
  = do	{ bndrs' <- mapM newExtCoreBndr bndrs
856
	; extendIfaceIdEnv bndrs' $ do
857
 	{ rhss' <- mapM tcIfaceExpr rhss
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	; core_binds <- thing_inside
	; return (Rec (bndrs' `zip` rhss') : core_binds) }}
  where
    (bndrs,rhss) = unzip pairs
\end{code}


%************************************************************************
%*									*
		IdInfo
%*									*
%************************************************************************

\begin{code}
872
873
874
875
876
877
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info 
  | ignore_prags = return vanillaIdInfo
  | otherwise    = case info of
			NoInfo       -> return vanillaIdInfo
			HasInfo info -> foldlM tcPrag init_info info
878
879
880
881
882
  where
    -- Set the CgInfo to something sensible but uninformative before
    -- we start; default assumption is that it has CAFs
    init_info = vanillaIdInfo

883
    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
884
885
886
    tcPrag info HsNoCafRefs         = return (info `setCafInfo`   NoCafRefs)
    tcPrag info (HsArity arity)     = return (info `setArityInfo` arity)
    tcPrag info (HsStrictness str)  = return (info `setAllStrictnessInfo` Just str)
887
888
889

	-- The next two are lazy, so they don't transitively suck stuff in
    tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
890
891
892
    tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
    tcPrag info (HsUnfold expr) = do
          maybe_expr' <- tcPragExpr name expr
893
894
895
896
897
898
	  let
		-- maybe_expr' doesn't get looked at if the unfolding
		-- is never inspected; so the typecheck doesn't even happen
		unfold_info = case maybe_expr' of
				Nothing    -> noUnfolding
				Just expr' -> mkTopUnfolding expr' 
899
          return (info `setUnfoldingInfoLazily` unfold_info)
900
901
902
\end{code}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
903
tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo
904
905
tcWorkerInfo ty info wkr arity
  = do 	{ mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
906
907
908
909
910
911
912
913

	-- We return without testing maybe_wkr_id, but as soon as info is
	-- looked at we will test it.  That's ok, because its outside the
	-- knot; and there seems no big reason to further defer the
	-- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
	-- over the unfolding until it's actually used does seem worth while.)
	; us <- newUniqueSupply

914
	; return (case mb_wkr_id of
915
916
917
		     Nothing     -> info
		     Just wkr_id -> add_wkr_info us wkr_id info) }
  where
918
    doc = text "Worker for" <+> ppr wkr
919
920
921
922
923
924
925
926
927
928
    add_wkr_info us wkr_id info
	= info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
	       `setWorkerInfo`           HasWorker wkr_id arity

    mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)

    	-- We are relying here on strictness info always appearing 
	-- before worker info,  fingers crossed ....
    strict_sig = case newStrictnessInfo info of
		   Just sig -> sig
929
		   Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
930
931
932
933
934
935
936
937
\end{code}

For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.

\begin{code}
tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr name expr
938
939
940
941
942
943
944
945
946
947
948
  = forkM_maybe doc $ do
    core_expr' <- tcIfaceExpr expr

                -- Check for type consistency in the unfolding
    ifOptM Opt_DoCoreLinting $ do
        in_scope <- get_in_scope_ids
        case lintUnfolding noSrcLoc in_scope core_expr' of
          Nothing       -> return ()
          Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)

    return core_expr'
949
950
  where
    doc = text "Unfolding of" <+> ppr name
951
952
953
954
955
956
957
958
    get_in_scope_ids 	-- Urgh; but just for linting
	= setLclEnv () $ 
	  do	{ env <- getGblEnv 
		; case if_rec_types env of {
			  Nothing -> return [] ;
			  Just (_, get_env) -> do
		{ type_env <- get_env
		; return (typeEnvIds type_env) }}}
959
960
961
962
\end{code}



963
964
965
966
967
968
969
%************************************************************************
%*									*
		Getting from Names to TyThings
%*									*
%************************************************************************

\begin{code}
970
tcIfaceGlobal :: Name -> IfL TyThing
971
tcIfaceGlobal name
972
  | Just thing <- wiredInNameTyThing_maybe name
973
	-- Wired-in things include TyCons, DataCons, and Ids
974
  = do { ifCheckWiredInThing name; return thing }
975
  | otherwise
976
977
  = do	{ env <- getGblEnv
	; case if_rec_types env of {	-- Note [Tying the knot]
978
979
980
	    Just (mod, get_type_env) 
		| nameIsLocalOrFrom mod name
		-> do 		-- It's defined in the module being compiled
981
	  	{ type_env <- setLclEnv () get_type_env		-- yuk
982
983
		; case lookupNameEnv type_env name of
			Just thing -> return thing
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
984
			Nothing	  -> pprPanic "tcIfaceGlobal (local): not found:"  
985
986
						(ppr name $$ ppr type_env) }

Ian Lynagh's avatar
Ian Lynagh committed
987
	  ; _ -> do
988

989
990
991
	{ hsc_env <- getTopEnv
        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
	; case mb_thing of {
992
993
994
	    Just thing -> return thing ;
	    Nothing    -> do

995
996
997
998
	{ mb_thing <- importDecl name 	-- It's imported; go get it
	; case mb_thing of
	    Failed err      -> failIfM err
	    Succeeded thing -> return thing
999
    }}}}}
1000

1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
-- Note [Tying the knot]
-- ~~~~~~~~~~~~~~~~~~~~~
-- The if_rec_types field is used in two situations:
--
-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T
--    Then we look up M.T in M's type environment, which is splatted into if_rec_types
--    after we've built M's type envt.
--
-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi
--    is up to date.  So we call typecheckIface on M.hi.  This splats M.T into 
--    if_rec_types so that the (lazily typechecked) decls see all the other decls
--
-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT
-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its
-- emasculated form (e.g. lacking data constructors).

1017
1018
1019
1020
ifCheckWiredInThing :: Name -> IfL ()
-- Even though we are in an interface file, we want to make
-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
-- Ditto want to ensure that RULES are loaded too
1021
-- See Note [Loading instances] in LoadIface
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
ifCheckWiredInThing name 
  = do	{ mod <- getIfModule
		-- Check whether we are typechecking the interface for this
		-- very module.  E.g when compiling the base library in --make mode
		-- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
		-- the HPT, so without the test we'll demand-load it into the PIT!
		-- C.f. the same test in checkWiredInTyCon above
	; unless (mod == nameModule name)
		 (loadWiredInHomeIface name) }

1032
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1033
1034
1035
1036
1037
1038
tcIfaceTyCon IfaceIntTc       	= tcWiredInTyCon intTyCon
tcIfaceTyCon IfaceBoolTc      	= tcWiredInTyCon boolTyCon
tcIfaceTyCon IfaceCharTc      	= tcWiredInTyCon charTyCon
tcIfaceTyCon IfaceListTc      	= tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc      	= tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
1039
tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name 
1040
1041
				     ; return (check_tc (tyThingTyCon thing)) }
  where
Ian Lynagh's avatar
Ian Lynagh committed
1042
1043
1044
    check_tc tc
     | debugIsOn = case toIfaceTyCon tc of
                   IfaceTc _ -> tc
Ian Lynagh's avatar
Ian Lynagh committed
1045
                   _         -> pprTrace "check_tc" (ppr tc) tc
Ian Lynagh's avatar
Ian Lynagh committed
1046
     | otherwise = tc
1047
1048
1049
1050
1051
1052
-- we should be okay just returning Kind constructors without extra loading
tcIfaceTyCon IfaceLiftedTypeKindTc   = return liftedTypeKindTyCon
tcIfaceTyCon IfaceOpenTypeKindTc     = return openTypeKindTyCon
tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
tcIfaceTyCon IfaceArgTypeKindTc      = return argTypeKindTyCon
tcIfaceTyCon IfaceUbxTupleKindTc     = return ubxTupleKindTyCon
1053
1054
1055
1056
1057

-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded 
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
1058
tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc)
1059
		       ; return tc }
1060

1061
1062
1063
tcIfaceClass :: Name -> IfL Class
tcIfaceClass name = do { thing <- tcIfaceGlobal name
		       ; return (tyThingClass thing) }
1064

1065
1066
1067
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
		 	 ; case thing of
1068
				ADataCon dc -> return dc
Ian Lynagh's avatar
Ian Lynagh committed
1069
				_       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1070

1071
1072
1073
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
		       ; case thing of
1074
			  AnId id -> return id
Ian Lynagh's avatar
Ian Lynagh committed
1075
			  _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1076
1077
\end{code}

1078
1079
1080
1081
1082
1083
1084
1085
%************************************************************************
%*									*
		Bindings
%*									*
%************************************************************************

\begin{code}
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1086
1087
1088
1089
1090
bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
  = do	{ name <- newIfaceName (mkVarOccFS fs)
	; ty' <- tcIfaceType ty
	; let id = mkLocalId name ty'
	; extendIfaceIdEnv [id] (thing_inside id) }
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
  = bindIfaceTyVar bndr thing_inside
    
bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs []     thing_inside = thing_inside []
bindIfaceBndrs (b:bs) thing_inside
  = bindIfaceBndr b	$ \ b' ->
    bindIfaceBndrs bs	$ \ bs' ->
    thing_inside (b':bs')

-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
1102
tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
1103
1104
tcIfaceLetBndr (IfLetBndr fs ty info)
  = do	{ name <- newIfaceName (mkVarOccFS fs)
1105
	; ty' <- tcIfaceType ty
1106
1107
1108
	; case info of
		NoInfo    -> return (mkLocalId name ty')
		HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } 
1109
  where
1110
1111
1112
1113
1114
1115
1116
	-- Similar to tcIdInfo, but much simpler
    tc_info [] = vanillaIdInfo
    tc_info (HsInline p     : i) = tc_info i `setInlinePragInfo` p 
    tc_info (HsArity a      : i) = tc_info i `setArityInfo` a 
    tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s 
    tc_info (other          : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" 
					    (ppr other) (tc_info i)
1117
1118

-----------------------
1119
newExtCoreBndr :: IfaceLetBndr -> IfL Id
1120
newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now
1121
  = do	{ mod <- getIfModule
1122
	; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
1123
1124
1125
1126
1127
1128
	; ty' <- tcIfaceType ty
	; return (mkLocalId name ty') }

-----------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
1129
  = do	{ name <- newIfaceName (mkTyVarOccFS occ)
1130
   	; tyvar <- mk_iface_tyvar name kind
1131
1132
1133
1134
	; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }

bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
1135
  = do	{ names <- newIfaceNames (map mkTyVarOccFS occs)
1136
  	; tyvars <- zipWithM mk_iface_tyvar names kinds
1137
1138
1139
1140
	; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
  where
    (occs,kinds) = unzip bndrs

1141
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1142
1143
1144
1145
1146
1147
mk_iface_tyvar name ifKind
   = do { kind <- tcIfaceType ifKind
	; if isCoercionKind kind then 
		return (Var.mkCoVar name kind)
	  else
		return (Var.mkTyVar name kind) }
1148
\end{code}
1149