TcRnDriver.lhs 45.6 KB
Newer Older
1
%
2
3
4
5
6
7
8
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}

\begin{code}
module TcRnDriver (
#ifdef GHCI
9
	mkExportEnv, getModuleContents, tcRnStmt, 
10
11
	tcRnGetInfo, GetInfoResult,
	tcRnExpr, tcRnType,
12
#endif
13
14
	tcRnModule, 
	tcTopSrcDecls,
15
	tcRnExtCore
16
17
18
19
    ) where

#include "HsVersions.h"

20
import IO
21
#ifdef GHCI
chak's avatar
chak committed
22
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
23
24
#endif

25
import CmdLineOpts	( DynFlag(..), opt_PprStyle_Debug, dopt )
26
27
import Packages		( moduleToPackageConfig, mkPackageId, package,
			  isHomeModule )
28
import DriverState	( v_MainModIs, v_MainFunIs )
29
import HsSyn		( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
30
			  nlHsApp, nlHsVar, pprLHsBinds )
31
import RdrHsSyn		( findSplice )
32

33
import PrelNames	( runMainIOName, rootMainName, mAIN,
34
			  main_RDR_Unqual )
35
36
37
38
import RdrName		( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, 
			  plusGlobalRdrEnv )
import TcHsSyn		( zonkTopDecls )
import TcExpr 		( tcInferRho )
39
import TcRnMonad
40
import TcType		( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
41
import Inst		( showLIE )
42
import InstEnv		( extendInstEnvList )
43
import TcBinds		( tcTopBinds, tcHsBootSigs )
44
import TcDefaults	( tcDefaults )
45
import TcEnv		( tcExtendGlobalValEnv )
46
47
import TcRules		( tcRules )
import TcForeign	( tcForeignImports, tcForeignExports )
48
import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
49
import TcIface		( tcExtCoreBindings )
50
import TcSimplify	( tcSimplifyTop )
51
import TcTyClsDecls	( tcTyAndClassDecls )
52
import LoadIface	( loadOrphanModules, loadHiBootInterface )
53
import RnNames		( importsFromLocalDecls, rnImports, exportsFromAvail,
54
			  reportUnusedNames, reportDeprecations )
55
56
import RnEnv		( lookupSrcOcc_maybe )
import RnSource		( rnSrcDecls, rnTyClDecls, checkModDeprec )
57
import PprCore		( pprIdRules, pprCoreBindings )
58
import CoreSyn		( IdCoreRule, bindersOfBinds )
59
import DataCon		( dataConWrapId )
60
import ErrUtils		( Messages, mkDumpDoc, showPass )
61
import Id		( mkExportedLocalId, isLocalId, idName, idType )
62
import Var		( Var )
63
import VarEnv		( varEnvElts )
64
import Module           ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
65
import OccName		( mkVarOcc )
66
import Name		( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
67
import NameSet
68
import TyCon		( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
69
import SrcLoc		( srcLocSpan, Located(..), noLoc )
70
import DriverPhases	( HscSource(..), isHsBoot )
71
import HscTypes		( ModGuts(..), HscEnv(..), ExternalPackageState(..),
72
			  GhciMode(..), IsBootInterface, noDependencies, 
73
			  Deprecs( NoDeprecs ), plusDeprecs,
74
			  ForeignStubs(NoStubs), TyThing(..), 
75
			  TypeEnv, lookupTypeEnv, hptInstances, lookupType,
76
			  extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, 
77
			  emptyFixityEnv
78
			)
79
80
import Outputable

81
#ifdef GHCI
82
import HsSyn		( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), 
83
			  LStmt, LHsExpr, LHsType, mkMatchGroup,
84
			  collectStmtsBinders, mkSimpleMatch, 
85
			  nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
86
87
88
89
import RdrName		( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
			  Provenance(..), ImportSpec(..),
			  lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource		( addTcgDUs )
90
import TcHsSyn		( mkHsLet, zonkTopLExpr, zonkTopBndrs )
91
import TcHsType		( kcHsType )
92
import TcExpr		( tcCheckRho )
93
import TcIface		( loadImportedInsts )
94
import TcMType		( zonkTcType, zonkQuantifiedTyVar )
95
import TcUnify		( unifyTyConApp )
96
import TcMatches	( tcStmtsAndThen, TcStmtCtxt(..) )
97
import TcSimplify	( tcSimplifyInteractive, tcSimplifyInfer )
98
99
import TcType		( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, 
			  isUnLiftedType, tyClsNamesOfDFunHead )
100
import TcEnv		( tcLookupTyCon, tcLookupId, tcLookupGlobal )
101
import RnTypes		( rnLHsType )
102
import Inst		( tcStdSyntaxName, tcGetInstEnvs )
103
import InstEnv		( DFunId, classInstances, instEnvElts )
104
import RnExpr		( rnStmts, rnLExpr )
105
import RnNames		( exportsToAvails )
106
import LoadIface	( loadSrcInterface, ifaceInstGates )
107
import IfaceSyn		( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), 
108
109
			  IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
			  tyThingToIfaceDecl, dfunToIfaceInst )
110
111
import IfaceType	( IfaceTyCon(..), IfaceType, toIfaceType, 
			  interactiveExtNameFun, isLocalIfaceExtName )
112
import IfaceEnv		( lookupOrig )
113
import RnEnv		( lookupOccRn, dataTcOccs, lookupFixityRn )
114
import Id		( Id, isImplicitId, setIdType, globalIdDetails )
115
import MkId		( unsafeCoerceId )
116
import DataCon		( dataConTyCon )
117
import TyCon		( tyConName )
118
119
import TysWiredIn	( mkListTy, unitTy )
import IdInfo		( GlobalIdDetails(..) )
120
import SrcLoc		( interactiveSrcLoc, unLoc )
121
import Kind		( Kind )
122
import Var		( globaliseId )
123
import Name		( nameOccName )
124
import OccName		( occNameUserString )
125
import NameEnv		( delListFromNameEnv )
126
import PrelNames	( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
127
import HscTypes		( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
128
			  availNames, availName, ModIface(..), icPrintUnqual,
129
			  ModDetails(..), Dependencies(..) )
130
import BasicTypes	( RecFlag(..), Fixity )
131
import Bag		( unitBag )
132
import ListSetOps	( removeDups )
133
import Panic		( ghcError, GhcException(..) )
134
import SrcLoc		( SrcLoc )
135
136
#endif

137
import FastString	( mkFastString )
138
import Util		( sortLe )
139
import Bag		( unionBags, snocBag )
140
141

import Maybe		( isJust )
142
143
144
145
146
147
148
149
150
151
152
153
\end{code}



%************************************************************************
%*									*
	Typecheck and rename a module
%*									*
%************************************************************************


\begin{code}
154
tcRnModule :: HscEnv 
155
	   -> HscSource
156
	   -> Located (HsModule RdrName)
157
	   -> IO (Messages, Maybe TcGblEnv)
158

159
tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies 
160
				import_decls local_decls mod_deprec))
161
162
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

163
   let { this_mod = case maybe_mod of
164
165
			Nothing  -> mAIN	  -- 'module M where' is omitted
			Just (L _ mod) -> mod }	; -- The normal case
166
		
167
   initTc hsc_env hsc_src this_mod $ 
168
   setSrcSpan loc $
169
170
171
172
   do {
	checkForPackageModule (hsc_dflags hsc_env) this_mod;

		-- Deal with imports; sets tcg_rdr_env, tcg_imports
173
	(rdr_env, imports) <- rnImports import_decls ;
174

175
176
177
178
179
180
181
182
183
184
	let { dep_mods :: ModuleEnv (Module, IsBootInterface)
	    ; dep_mods = imp_dep_mods imports

	    ; is_dep_mod :: Module -> Bool
	    ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
				Nothing		  -> False
				Just (_, is_boot) -> not is_boot 
	    ; home_insts = hptInstances hsc_env is_dep_mod
	    } ;

185
186
187
		-- Record boot-file info in the EPS, so that it's 
		-- visible to loadHiBootInterface in tcRnSrcDecls,
		-- and any other incrementally-performed imports
188
	updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
189
190

		-- Update the gbl env
191
192
193
194
195
196
	updGblEnv ( \ gbl -> 
		gbl { tcg_rdr_env  = rdr_env,
		      tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
		      tcg_imports  = tcg_imports gbl `plusImportAvails` imports }) 
		$ do {

197
	traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
198
199
200
201
202
		-- Fail if there are any errors so far
		-- The error printing (if needed) takes advantage 
		-- of the tcg_env we have now set
	failIfErrsM ;

203
204
205
206
		-- Load any orphan-module interfaces, so that
		-- their rules and instance decls will be found
	loadOrphanModules (imp_orphs imports) ;

207
208
	traceRn (text "rn1a") ;
		-- Rename and type check the declarations
209
210
211
212
	tcg_env <- if isHsBoot hsc_src then
			tcRnHsBootDecls local_decls
		   else	
			tcRnSrcDecls local_decls ;
213
214
215
216
	setGblEnv tcg_env		$ do {

	traceRn (text "rn3") ;

217
218
219
220
221
222
223
		-- Report the use of any deprecated things
		-- We do this before processsing the export list so
		-- that we don't bleat about re-exporting a deprecated
		-- thing (especially via 'module Foo' export item)
		-- Only uses in the body of the module are complained about
	reportDeprecations tcg_env ;

224
		-- Process the export list
225
	exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
226

227
228
229
230
231
		-- Check whether the entire module is deprecated
		-- This happens only once per module
	let { mod_deprecs = checkModDeprec mod_deprec } ;

		-- Add exports and deprecations to envt
232
233
	let { final_env  = tcg_env { tcg_exports = exports,
				     tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
234
235
236
237
				     tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` 
						   mod_deprecs }
		-- A module deprecation over-rides the earlier ones
	     } ;
238
239

		-- Report unused names
240
 	reportUnusedNames export_ies final_env ;
241
242

		-- Dump output and return
243
244
245
	tcDump final_env ;
	return final_env
    }}}}
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261

-- This is really a sanity check that the user has given -package-name
-- if necessary.  -package-name is only necessary when the package database
-- already contains the current package, because then we can't tell
-- whether a given module is in the current package or not, without knowing
-- the name of the current package.
checkForPackageModule dflags this_mod
  | not (isHomeModule dflags this_mod),
    Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
	let 
		ppr_pkg = ppr (mkPackageId (package pkg))
	in
	addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
	        ptext SLIT("is a member of package") <+>  ppr_pkg <> char '.' $$
		ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
  | otherwise = return ()
262
263
264
265
266
\end{code}


%************************************************************************
%*									*
267
	Type-checking external-core modules
268
269
270
271
%*									*
%************************************************************************

\begin{code}
272
273
274
275
tcRnExtCore :: HscEnv 
	    -> HsExtCore RdrName
	    -> IO (Messages, Maybe ModGuts)
	-- Nothing => some error occurred 
276

277
278
279
tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
	-- The decls are IfaceDecls; all names are original names
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
280

281
   initTc hsc_env ExtCoreFile this_mod $ do {
282

283
   let { ldecls  = map noLoc decls } ;
284

285
286
287
	-- Deal with the type declarations; first bring their stuff
	-- into scope, then rname them, then type check them
   (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
288

289
290
291
   updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
			    tcg_imports = imports `plusImportAvails` tcg_imports gbl }) 
		  $ do {
292

293
294
   rn_decls <- rnTyClDecls ldecls ;
   failIfErrsM ;
295

296
297
	-- Dump trace of renaming part
   rnDump (ppr rn_decls) ;
298

299
300
	-- Typecheck them all together so that
	-- any mutually recursive types are done right
301
   tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
302
	-- Make the new type env available to stuff slurped from interface files
303

304
305
306
   setGblEnv tcg_env $ do {
   
	-- Now the core bindings
307
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
308

309
310
311
312
313
	-- Wrap up
   let {
	bndrs 	   = bindersOfBinds core_binds ;
	my_exports = mkNameSet (map idName bndrs) ;
		-- ToDo: export the data types also?
314

315
	final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
316

317
	mod_guts = ModGuts {	mg_module   = this_mod,
318
				mg_boot	    = False,
319
320
321
322
323
324
325
326
				mg_usages   = [],		-- ToDo: compute usage
				mg_dir_imps = [],		-- ??
				mg_deps     = noDependencies,	-- ??
				mg_exports  = my_exports,
				mg_types    = final_type_env,
				mg_insts    = tcg_insts tcg_env,
				mg_rules    = [],
				mg_binds    = core_binds,
327

328
329
330
331
332
333
				-- Stubs
				mg_rdr_env  = emptyGlobalRdrEnv,
				mg_fix_env  = emptyFixityEnv,
				mg_deprecs  = NoDeprecs,
				mg_foreign  = NoStubs
		    } } ;
334

335
   tcCoreDump mod_guts ;
336

337
338
   return mod_guts
   }}}}
339

340
341
342
343
344
345
mkFakeGroup decls -- Rather clumsy; lots of unused fields
  = HsGroup {	hs_tyclds = decls, 	-- This is the one we want
		hs_valds = [], hs_fords = [],
		hs_instds = [], hs_fixds = [], hs_depds = [],
		hs_ruleds = [], hs_defds = [] }
\end{code}
346
347


348
349
350
351
352
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************
353

354
355
356
357
358
\begin{code}
tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
	-- Returns the variables free in the decls
	-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
359
360
361
362
363
 = do { 	-- Load the hi-boot interface for this module, if any
		-- We do this now so that the boot_names can be passed
		-- to tcTyAndClassDecls, because the boot_names are 
		-- automatically considered to be loop breakers
	boot_names <- loadHiBootInterface ;
364
365

	  	-- Do all the declarations
366
	(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
367

368
369
370
371
372
373
374
375
376
377
378
	     -- tcSimplifyTop deals with constant or ambiguous InstIds.  
	     -- How could there be ambiguous ones?  They can only arise if a
	     -- top-level decl falls under the monomorphism
	     -- restriction, and no subsequent decl instantiates its
	     -- type.  (Usually, ambiguous type variables are resolved
	     -- during the generalisation step.)
        traceTc (text "Tc8") ;
	inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
		-- Setting the global env exposes the instances to tcSimplifyTop
		-- Setting the local env exposes the local Ids to tcSimplifyTop, 
		-- so that we get better error messages (monomorphism restriction)
379

380
381
382
383
384
385
	    -- Backsubstitution.  This must be done last.
	    -- Even tcSimplifyTop may do some unification.
        traceTc (text "Tc9") ;
	let { (tcg_env, _) = tc_envs ;
	      TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
		         tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
386

387
388
	(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
							   rules fords ;
389

390
	let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
391

392
	-- Compre the hi-boot iface (if any) with the real thing
393
 	checkHiBootIface final_type_env boot_names ;
394

395
396
	-- Make the new type env available to stuff slurped from interface files
	writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
397

398
399
400
	return (tcg_env { tcg_type_env = final_type_env,
			  tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) 
   }
401

402
tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
403
404
-- Loops around dealing with each top level inter-splice group 
-- in turn, until it's dealt with the entire module
405
tc_rn_src_decls boot_names ds
406
407
 = do { let { (first_group, group_tail) = findSplice ds } ;
		-- If ds is [] we get ([], Nothing)
408

409
	-- Type check the decls up to, but not including, the first splice
410
	tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
411

412
413
414
415
	-- Bale out if errors; for example, error recovery when checking
	-- the RHS of 'main' can mean that 'main' is not in the envt for 
	-- the subsequent checkMain test
	failIfErrsM ;
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
	setEnvs tc_envs $

	-- If there is no splice, we're nearly done
	case group_tail of {
	   Nothing -> do { 	-- Last thing: check for `main'
			   tcg_env <- checkMain ;
			   return (tcg_env, tcl_env) 
		      } ;

	-- If there's a splice, we must carry on
	   Just (SpliceDecl splice_expr, rest_ds) -> do {
#ifndef GHCI
	failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else

	-- Rename the splice expression, and get its supporting decls
	(rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
	failIfErrsM ;	-- Don't typecheck if renaming failed

	-- Execute the splice
	spliced_decls <- tcSpliceDecls rn_splice_expr ;

	-- Glue them on the front of the remaining decls and loop
	setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
441
	tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
442
443
#endif /* GHCI */
    }}}
444
445
\end{code}

446
447
%************************************************************************
%*									*
448
449
	Compiling hs-boot source files, and
	comparing the hi-boot interface with the real thing
450
451
452
%*									*
%************************************************************************

453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
\begin{code}
tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls decls
   = do { let { (first_group, group_tail) = findSplice decls }

	; case group_tail of
	     Just stuff -> spliceInHsBootErr stuff
	     Nothing    -> return ()

		-- Rename the declarations
	; (tcg_env, rn_group) <- rnTopSrcDecls first_group
	; setGblEnv tcg_env $ do {

	-- Todo: check no foreign decls, no rules, no default decls

		-- Typecheck type/class decls
	; traceTc (text "Tc2")
	; let tycl_decls = hs_tyclds rn_group
	; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
	; setGblEnv tcg_env	$ do {

		-- Typecheck instance decls
	; traceTc (text "Tc3")
	; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
	; setGblEnv tcg_env	$ do {

		-- Typecheck value declarations
	; traceTc (text "Tc5") 
481
	; new_ids <- tcHsBootSigs (hs_valds rn_group)
482
483
484
485
486
487

		-- Wrap up
		-- No simplification or zonking to do
	; traceTc (text "Tc7a")
	; gbl_env <- getGblEnv 
	
488
	; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
489
490
491
492
493
494
495
	; return (gbl_env { tcg_type_env = final_type_env }) 
   }}}}

spliceInHsBootErr (SpliceDecl (L loc _), _)
  = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
\end{code}

496
497
498
499
500
501
502
In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
into the External Package Table.  Once we've typechecked the body of the
module, we want to compare what we've found (gathered in a TypeEnv) with
the hi-boot stuff in the EPT.  We do so here, using the export list of 
the hi-boot interface as our checklist.

\begin{code}
503
checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
504
505
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
506
507
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
508
509
checkHiBootIface env boot_names
  = mapM_ (check_one env) boot_names
510
511

----------------
512
check_one local_env name
513
514
515
516
  | isWiredInName name	-- No checking for wired-in names.  In particular, 'error' 
  = return ()		-- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
  | otherwise	
  = do	{ (eps,hpt)  <- getEpsAndHpt
517
518
519

		-- Look up the hi-boot one; 
		-- it should jolly well be there (else GHC bug)
520
       ; case lookupType hpt (eps_PTE eps) name of {
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
	    Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
	    Just boot_thing ->

		-- Look it up in the local type env
		-- It should be there, but it's a programmer error if not
         case lookupTypeEnv local_env name of
	   Nothing 	   -> addErrTc (missingBootThing boot_thing)
	   Just real_thing -> check_thing boot_thing real_thing
    } }

----------------
check_thing (ATyCon boot_tc) (ATyCon real_tc)
  | isSynTyCon boot_tc && isSynTyCon real_tc,
    defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
  = return ()

  | tyConKind boot_tc == tyConKind real_tc
  = return ()
  where
    (tvs1, defn1) = getSynTyConDefn boot_tc
    (tvs2, defn2) = getSynTyConDefn boot_tc

check_thing (AnId boot_id) (AnId real_id)
  | idType boot_id `tcEqType` idType real_id
  = return ()

547
548
549
550
551
552
check_thing (ADataCon dc1) (ADataCon dc2)
  | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
  = return ()

	-- Can't declare a class in a hi-boot file

553
554
555
556
557
558
check_thing boot_thing real_thing	-- Default case; failure
  = addErrAt (srcLocSpan (getSrcLoc real_thing))
	     (bootMisMatch real_thing)

----------------
missingBootThing thing
559
  = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
560
bootMisMatch thing
561
  = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
562
563
\end{code}

564

565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************

tcRnGroup takes a bunch of top-level source-code declarations, and
 * renames them
 * gets supporting declarations from interface files
 * typechecks them
 * zonks them
 * and augments the TcGblEnv with the results

In Template Haskell it may be called repeatedly for each group of
declarations.  It expects there to be an incoming TcGblEnv in the
monad; it augments it and returns the new TcGblEnv.
581
582

\begin{code}
583
tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
584
	-- Returns the variables free in the decls, for unused-binding reporting
585
tcRnGroup boot_names decls
586
587
588
 = do {		-- Rename the declarations
	(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
	setGblEnv tcg_env $ do {
589

590
		-- Typecheck the declarations
591
	tcTopSrcDecls boot_names rn_decls 
592
  }}
593

594
595
596
597
598
599
600
601
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls group
 = do { 	-- Bring top level binders into scope
	(rdr_env, imports) <- importsFromLocalDecls group ;
	updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
				 tcg_imports = imports `plusImportAvails` tcg_imports gbl }) 
		  $ do {
602

603
604
	traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
	failIfErrsM ;	-- No point in continuing if (say) we have duplicate declarations
605

606
607
608
		-- Rename the source decls
	(tcg_env, rn_decls) <- rnSrcDecls group ;
	failIfErrsM ;
609

610
611
		-- Dump trace of renaming part
	rnDump (ppr rn_decls) ;
612

613
614
	return (tcg_env, rn_decls)
   }}
615

616
------------------------------------------------
617
618
tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_names
619
620
621
622
623
624
625
626
627
	(HsGroup { hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
		   hs_fords  = foreign_decls,
		   hs_defds  = default_decls,
		   hs_ruleds = rule_decls,
		   hs_valds  = val_binds })
 = do {		-- Type-check the type and class decls, and all imported decls
		-- The latter come in via tycl_decls
        traceTc (text "Tc2") ;
628

629
	tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
630
631
632
633
634
	-- tcTyAndClassDecls recovers internally, but if anything gave rise to
	-- an error we'd better stop now, to avoid a cascade
	
	-- Make these type and class decls available to stuff slurped from interface files
	writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
635
636


637
638
639
640
641
642
	setGblEnv tcg_env	$ do {
		-- Source-language instances, including derivings,
		-- and import the supporting declarations
        traceTc (text "Tc3") ;
	(tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
	setGblEnv tcg_env	$ do {
643

644
645
646
647
648
	        -- Foreign import declarations next.  No zonking necessary
		-- here; we can tuck them straight into the global environment.
        traceTc (text "Tc4") ;
	(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
	tcExtendGlobalValEnv fi_ids	$ do {
649

650
651
652
653
		-- Default declarations
        traceTc (text "Tc4a") ;
	default_tys <- tcDefaults default_decls ;
	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
654
	
655
656
657
658
659
660
		-- Value declarations next
		-- We also typecheck any extra binds that came out 
		-- of the "deriving" process (deriv_binds)
        traceTc (text "Tc5") ;
	(tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
	setLclTypeEnv lcl_env 	$ do {
661

662
663
664
665
	     	-- Second pass over class and instance declarations, 
        traceTc (text "Tc6") ;
	(tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
	showLIE (text "after instDecls2") ;
666

667
668
669
670
		-- Foreign exports
		-- They need to be zonked, so we return them
        traceTc (text "Tc7") ;
	(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
671

672
673
		-- Rules
	rules <- tcRules rule_decls ;
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
		-- Wrap up
        traceTc (text "Tc7a") ;
	tcg_env <- getGblEnv ;
	let { all_binds = tc_val_binds	 `unionBags`
			  inst_binds	 `unionBags`
			  foe_binds  ;

		-- Extend the GblEnv with the (as yet un-zonked) 
		-- bindings, rules, foreign decls
	      tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
				    tcg_rules = tcg_rules tcg_env ++ rules,
				    tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
  	return (tcg_env', lcl_env)
    }}}}}}
689
690
\end{code}

691

692
693
%************************************************************************
%*									*
694
	Checking for 'main'
695
696
697
698
%*									*
%************************************************************************

\begin{code}
699
700
701
checkMain 
  = do { ghci_mode <- getGhciMode ;
	 tcg_env   <- getGblEnv ;
702

703
704
705
	 mb_main_mod <- readMutVar v_MainModIs ;
	 mb_main_fn  <- readMutVar v_MainFunIs ;
	 let { main_mod = case mb_main_mod of {
706
707
				Just mod -> mkModule mod ;
				Nothing  -> mAIN } ;
708
709
710
711
712
713
	       main_fn  = case mb_main_fn of {
				Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
				Nothing -> main_RDR_Unqual } } ;
	
	 check_main ghci_mode tcg_env main_mod main_fn
    }
714

715

716
717
718
719
720
721
check_main ghci_mode tcg_env main_mod main_fn
     -- If we are in module Main, check that 'main' is defined.
     -- It may be imported from another module!
     --
     -- 
     -- Blimey: a whole page of code to do this...
722
 | mod /= main_mod
723
 = return tcg_env
724

725
726
727
728
729
730
731
732
733
 | otherwise
 = addErrCtxt mainCtxt			$
   do	{ mb_main <- lookupSrcOcc_maybe main_fn
		-- Check that 'main' is in scope
		-- It might be imported from another module!
	; case mb_main of {
	     Nothing -> do { complain_no_main	
			   ; return tcg_env } ;
	     Just main_name -> do
734
735
	{ let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
		   	-- :Main.main :: IO () = runMainIO main 
736

737
	; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
738
			     tcInferRho rhs
739

740
741
	; let { root_main_id = mkExportedLocalId rootMainName ty ;
	        main_bind    = noLoc (VarBind root_main_id main_expr) }
742

743
744
745
746
	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
					`snocBag` main_bind,
			    tcg_dus   = tcg_dus tcg_env
				        `plusDU` usesOnly (unitFV main_name)
747
748
			-- Record the use of 'main', so that we don't 
			-- complain about it being defined but not used
749
750
751
		 }) 
    }}}
  where
752
    mod = tcg_mod tcg_env
753
754
755
756
757
758
 
    complain_no_main | ghci_mode == Interactive = return ()
		     | otherwise 		= failWithTc noMainMsg
	-- In interactive mode, don't worry about the absence of 'main'
	-- In other modes, fail altogether, so that we don't go on
	-- and complain a second time when processing the export list.
759

760
761
762
763
    mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
    noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) 
		<+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
\end{code}
764
765


766
767
768
769
770
%*********************************************************
%*						 	 *
		GHCi stuff
%*							 *
%*********************************************************
771

772
773
\begin{code}
#ifdef GHCI
774
775
776
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside 
  = let 
777
778
779
780
	-- Initialise the tcg_inst_env with instances 
	-- from all home modules.  This mimics the more selective
	-- call to hptInstances in tcRnModule
	dfuns = hptInstances hsc_env (\mod -> True)
781
782
783
784
785
786
787
788
789
790
    in
    updGblEnv (\env -> env { 
	tcg_rdr_env  = ic_rn_gbl_env icxt,
	tcg_type_env = ic_type_env   icxt,
	tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $

    updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt })	$

    do	{ traceTc (text "setIC" <+> ppr (ic_type_env icxt))
 	; thing_inside }
791
\end{code}
792

793

794
795
796
797
798
799
800
801
802
803
\begin{code}
tcRnStmt :: HscEnv
	 -> InteractiveContext
	 -> LStmt RdrName
	 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
		-- The returned [Name] is the same as the input except for
		-- ExprStmt, in which case the returned [Name] is [itName]
		--
		-- The returned TypecheckedHsExpr is of type IO [ () ],
		-- a list of the bound values, coerced to ().
804

805
806
tcRnStmt hsc_env ictxt rdr_stmt
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
807
    setInteractiveContext hsc_env ictxt $ do {
808

809
810
811
812
813
814
815
816
817
    -- Rename; use CmdLineMode because tcRnStmt is only used interactively
    ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
    traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
    failIfErrsM ;
    
    -- The real work is done here
    (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
    
    traceTc (text "tcs 1") ;
818
819
820
821
822
823
824
825
826
827
    let {	-- (a) Make all the bound ids "global" ids, now that
    		--     they're notionally top-level bindings.  This is
	    	--     important: otherwise when we come to compile an expression
	    	--     using these ids later, the byte code generator will consider
	    	--     the occurrences to be free rather than global.
		-- 
		-- (b) Tidy their types; this is important, because :info may
		--     ask to look at them, and :info expects the things it looks
		--     up to have tidy types
	global_ids = map globaliseAndTidy bound_ids ;
828
829
830
831
    
		-- Update the interactive context
	rn_env   = ic_rn_local_env ictxt ;
	type_env = ic_type_env ictxt ;
832

833
834
	bound_names = map idName global_ids ;
	new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
835

836
837
838
839
840
841
		-- Remove any shadowed bindings from the type_env;
		-- they are inaccessible but might, I suppose, cause 
		-- a space leak if we leave them there
	shadowed = [ n | name <- bound_names,
			 let rdr_name = mkRdrUnqual (nameOccName name),
			 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
842

843
844
	filtered_type_env = delListFromNameEnv type_env shadowed ;
	new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
845

846
847
848
	new_ic = ictxt { ic_rn_local_env = new_rn_env, 
		  	 ic_type_env     = new_type_env }
    } ;
849

850
851
852
    dumpOptTcRn Opt_D_dump_tc 
    	(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
    	       text "Typechecked expr" <+> ppr tc_expr]) ;
853

854
855
    returnM (new_ic, bound_names, tc_expr)
    }
856

857
858
859
860
861
862
863
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
-- Give the Id a Global Name, and tidy its type
  = setIdType (globaliseId VanillaGlobal id) tidy_type
  where
    tidy_type = tidyTopType (idType id)
\end{code}
864

865
Here is the grand plan, implemented in tcUserStmt
866

867
868
869
870
	What you type			The IO [HValue] that hscStmt returns
	-------------			------------------------------------
	let pat = expr		==> 	let pat = expr in return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]
871

872
873
	pat <- expr		==> 	expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]
874

875
876
877
878
879
	expr (of IO type)	==>	expr >>= \ it -> return [coerce HVal it]
	  [NB: result not printed]	bindings: [it]
	  
	expr (of non-IO type,	==>	let it = expr in print it >> return [coerce HVal it]
	  result showable)		bindings: [it]
880

881
882
	expr (of non-IO type, 
	  result not showable)	==>	error
883

884

885
886
887
888
889
890
891
892
\begin{code}
---------------------------
tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
tcUserStmt (L _ (ExprStmt expr _))
  = newUnique 		`thenM` \ uniq ->
    let 
	fresh_it = itName uniq
        the_bind = noLoc $ FunBind (noLoc fresh_it) False 
893
			     (mkMatchGroup [mkSimpleMatch [] expr])
894
895
896
897
898
899
900
901
902
903
904
    in
    tryTcLIE_ (do { 	-- Try this if the other fails
		traceTc (text "tcs 1b") ;
		tc_stmts [
		    nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
		    nlExprStmt (nlHsApp (nlHsVar printName) 
					      (nlHsVar fresh_it)) 	
	] })
	  (do { 	-- Try this first 
		traceTc (text "tcs 1a") ;
		tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
905

906
tcUserStmt stmt = tc_stmts [stmt]
907

908
909
910
911
912
913
---------------------------
tc_stmts stmts
 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
	let {
	    ret_ty    = mkListTy unitTy ;
	    io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
914

915
	    names = map unLoc (collectStmtsBinders stmts) ;
916

917
	    stmt_ctxt = SC { sc_what = DoExpr, 
918
			     sc_rhs  = infer_rhs,
919
920
			     sc_body = check_body,
			     sc_ty   = ret_ty } ;
921

922
923
924
925
	    infer_rhs rhs   = do { (rhs', rhs_ty) <- tcInferRho rhs
				 ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
				 ; return (rhs', pat_ty) } ;
	    check_body body = tcCheckRho body io_ret_ty ;
926

927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
		-- mk_return builds the expression
		--	returnIO @ [()] [coerce () x, ..,  coerce () z]
		--
		-- Despite the inconvenience of building the type applications etc,
		-- this *has* to be done in type-annotated post-typecheck form
		-- because we are going to return a list of *polymorphic* values
		-- coerced to type (). If we built a *source* stmt
		--	return [coerce x, ..., coerce z]
		-- then the type checker would instantiate x..z, and we wouldn't
		-- get their *polymorphic* values.  (And we'd get ambiguity errs
		-- if they were overloaded, since they aren't applied to anything.)
	    mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) 
			      		   (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
	    mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
		    	       (nlHsVar id) ;
942

943
944
	    io_ty = mkTyConApp ioTyCon []
	 } ;
945

946
947
948
949
950
951
952
953
954
955
	-- OK, we're ready to typecheck the stmts
	traceTc (text "tcs 2") ;
	((ids, tc_expr), lie) <- getLIE $ do {
	    (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts	$ 
			do {
			    -- Look up the names right in the middle,
			    -- where they will all be in scope
			    ids <- mappM tcLookupId names ;
			    ret_id <- tcLookupId returnIOName ;		-- return @ IO
			    return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
956

957
958
959
	    io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
	    return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
	} ;
960

961
962
963
964
965
966
967
968
	-- Simplify the context right here, so that we fail
	-- if there aren't enough instances.  Notably, when we see
	--		e
	-- we use recoverTc_ to try	it <- e
	-- and then			let it = e
	-- It's the simplify step that rejects the first.
	traceTc (text "tcs 3") ;
	const_binds <- tcSimplifyInteractive lie ;
969

970
971
972
973
	-- Build result expression and zonk it
	let { expr = mkHsLet const_binds tc_expr } ;
	zonked_expr <- zonkTopLExpr expr ;
	zonked_ids  <- zonkTopBndrs ids ;
974

975
976
977
	-- None of the Ids should be of unboxed type, because we
	-- cast them all to HValues in the end!
	mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
978

979
980
981
982
983
984
985
	return (zonked_ids, zonked_expr)
	}
  where
    combine stmt (ids, stmts) = (ids, stmt:stmts)
    bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
				  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
\end{code}
986
987


988
tcRnExpr just finds the type of an expression
989

990
991
992
993
994
995
996
\begin{code}
tcRnExpr :: HscEnv
	 -> InteractiveContext
	 -> LHsExpr RdrName
	 -> IO (Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
997
    setInteractiveContext hsc_env ictxt $ do {
998

999
1000
    (rn_expr, fvs) <- rnLExpr rdr_expr ;
    failIfErrsM ;
1001

1002
1003
1004
1005
1006
	-- Now typecheck the expression; 
	-- it might have a rank-2 type (e.g. :t runST)
    ((tc_expr, res_ty), lie)	   <- getLIE (tcInferRho rn_expr) ;
    ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
    tcSimplifyInteractive lie_top ;
1007
    qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1008

1009
    let { all_expr_ty = mkForAllTys qtvs' $
1010
1011
1012
1013
1014
1015
1016
    		        mkFunTys (map idType dict_ids)	$
    		        res_ty } ;
    zonkTcType all_expr_ty
    }
  where
    smpl_doc = ptext SLIT("main expression")
\end{code}
1017

1018
tcRnType just finds the kind of a type
1019

1020
1021
1022
1023
1024
1025
1026
\begin{code}
tcRnType :: HscEnv
	 -> InteractiveContext
	 -> LHsType RdrName
	 -> IO (Maybe Kind)
tcRnType hsc_env ictxt rdr_type
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
1027
    setInteractiveContext hsc_env ictxt $ do {
1028

1029
1030
    rn_type <- rnLHsType doc rdr_type ;
    failIfErrsM ;
1031

1032
1033
1034
1035
1036
1037
	-- Now kind-check the type
    (ty', kind) <- kcHsType rn_type ;
    return kind
    }
  where
    doc = ptext SLIT("In GHCi input")
1038

1039
#endif /* GHCi */
1040
1041
1042
\end{code}


1043
1044
1045
1046
1047
%************************************************************************
%*									*
	More GHCi stuff, to do with browsing and getting info
%*									*
%************************************************************************
1048
1049
1050

\begin{code}
#ifdef GHCI
1051
mkExportEnv :: HscEnv -> [Module]	-- Expose these modules' exports only
1052
 	    -> IO GlobalRdrEnv
1053
mkExportEnv hsc_env exports
1054
  = do	{ mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1055
1056
1057
1058
1059
		     mappM getModuleExports exports 
	; case mb_envs of
	     Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
	     Nothing   -> return emptyGlobalRdrEnv
			     -- Some error; initTc will have printed it
1060
1061
    }

1062
getModuleExports :: Module -> TcM GlobalRdrEnv
1063
getModuleExports mod 
1064
  = do	{ iface <- load_iface mod
1065
1066
1067
	; loadOrphanModules (dep_orphs (mi_deps iface))
			-- Load any orphan-module interfaces,
			-- so their instances are visible
1068
	; names <- exportsToAvails (mi_exports iface)
1069
	; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1070
			| name <- nameSetToList names ] }
1071
1072
	; returnM (mkGlobalRdrEnv gres) }

1073
vanillaProv :: Module -> Provenance
1074
1075
-- We're building a GlobalRdrEnv as if the user imported
-- all the specified modules into the global interactive module
1076
1077
vanillaProv mod = Imported [ImportSpec mod mod False 
			     (srcLocSpan interactiveSrcLoc)] False
1078
1079
1080
1081
1082
\end{code}

\begin{code}
getModuleContents
  :: HscEnv
1083
  -> InteractiveContext
1084
  -> Module			-- Module to inspect
1085
  -> Bool			-- Grab just the exports, or the whole toplev
1086
  -> IO (Maybe [IfaceDecl])
1087
1088

getModuleContents hsc_env ictxt mod exports_only
1089
 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1090
1091
 where
   get_mod_contents exports_only
1092
      | not exports_only  -- We want the whole top-level type env
1093
1094
 			  -- so it had better be a home module
      = do { hpt <- getHpt
1095
 	   ; case lookupModuleEnv hpt mod of
1096
 	       Just mod_info -> return (map (toIfaceDecl ext_nm) $
1097
1098
1099
1100
1101
1102
1103
1104
1105
					filter wantToSee $
 				        typeEnvElts $
 				        md_types (hm_details mod_info))
 	       Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 			  -- This is a system error; the module should be in the HPT
 	   }
  
      | otherwise		-- Want the exports only
      = do { iface <- load_iface mod
1106
1107
 	   ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
					  , avail <- avails ]
1108
1109
    	}

1110
1111
1112
   get_decl (mod, avail)
	= do { main_name <- lookupOrig mod (availName avail) 
	     ; thing     <- tcLookupGlobal main_name
1113
1114
1115
	     ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }

   ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
1116
1117
1118
1119

---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
  = decl { ifSigs = filter (keep_sig occs) sigs }
1120
1121
filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
  = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1122
1123
1124
filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
  | keep_con occs con = decl
  | otherwise	      = decl {ifCons = IfAbstractTyCon}	-- Hmm?
1125
1126
1127
filter_decl occs decl
  = decl

1128
1129
keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
keep_con occs con		     = ifConOcc con `elem` occs
1130
1131
1132
1133
1134
1135

wantToSee (AnId id)    = not (isImplicitId id)
wantToSee (ADataCon _) = False	-- They'll come via their TyCon
wantToSee _ 	       = True

---------------------
1136
1137
1138
load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
	       where
		 doc = ptext SLIT("context for compiling statements")
1139
1140

---------------------
1141
1142
1143
1144
1145
noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") 
		  <+> quotes (ppr mod)
\end{code}

\begin{code}
1146
1147
1148
1149
type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, 
			      [(IfaceType,SrcLoc)]	-- Instances
		     )

1150
1151
1152
tcRnGetInfo :: HscEnv
	    -> InteractiveContext
	    -> RdrName
1153
1154
	    -> IO (Maybe [GetInfoResult])

1155
1156
1157
1158
1159
1160
1161
1162
1163
-- Used to implemnent :info in GHCi
--
-- Look up a RdrName and return all the TyThings it might be
-- A capitalised RdrName is given to us in the DataName namespace,
-- but we want to treat it as *both* a data constructor 
-- *and* as a type or class constructor; 
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env ictxt rdr_name
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
1164
    setInteractiveContext hsc_env ictxt $ do {
1165

1166
1167
1168
1169
	-- If the identifier is a constructor (begins with an
	-- upper-case letter), then we need to consider both
	-- constructor and type class identifiers.
    let { rdr_names = dataTcOccs rdr_name } ;
1170

1171
1172
	-- results :: [(Messages, Maybe Name)]
    results <- mapM (tryTc . lookupOccRn) rdr_names ;
1173

1174
1175
1176
1177
1178
    traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
	-- The successful lookups will be (Just name)
    let { (warns_s, good_names) = unzip [ (msgs, name) 
					| (msgs, Just name) <- results] ;
	  errs_s = [msgs | (msgs, Nothing) <- results] } ;
1179

1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
	-- Fail if nothing good happened, else add warnings
    if null good_names then
		-- No lookup succeeded, so
		-- pick the first error message and report it
		-- ToDo: If one of the errors is "could be Foo.X or Baz.X",
		--	 while the other is "X is not in scope", 
		--	 we definitely want the former; but we might pick the latter
	do { addMessages (head errs_s) ; failM }
      else 			-- Add deprecation warnings
	mapM_ addMessages warns_s ;
	
	-- And lookup up the entities, avoiding duplicates, which arise
	-- because constructors and record selectors are represented by
	-- their parent declaration