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

\begin{code}
module TcRnDriver (
#ifdef GHCI
10
	tcRnStmt, tcRnExpr, tcRnType,
11
	tcRnLookupRdrName,
12
13
	tcRnLookupName,
	tcRnGetInfo,
14
	getModuleExports, 
mnislaih's avatar
mnislaih committed
15
        tcRnRecoverDataCon,
16
#endif
17
18
	tcRnModule, 
	tcTopSrcDecls,
19
	tcRnExtCore
20
21
22
23
    ) where

#include "HsVersions.h"

24
import IO
25
#ifdef GHCI
chak's avatar
chak committed
26
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
27
28
#endif

29
30
31
32
33
34
35
36
37
import DynFlags
import StaticFlags
import HsSyn
import RdrHsSyn

import PrelNames
import RdrName
import TcHsSyn
import TcExpr
38
import TcRnMonad
39
40
import TcType
import Inst
41
import FamInst
42
43
44
45
46
47
48
49
50
51
import InstEnv
import FamInstEnv
import TcBinds
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import MkIface
52
import IfaceSyn
53
54
55
56
57
58
59
60
61
62
63
64
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import RnHsDoc
import PprCore
import CoreSyn
import ErrUtils
import Id
import Var
Simon Marlow's avatar
Simon Marlow committed
65
import Module
66
67
import UniqFM
import Name
68
import NameEnv
69
import NameSet
70
71
72
import TyCon
import SrcLoc
import HscTypes
73
import ListSetOps
74
75
import Outputable

76
#ifdef GHCI
mnislaih's avatar
mnislaih committed
77
78
import Linker
import DataCon
79
80
81
82
83
84
85
86
87
88
89
90
import TcHsType
import TcMType
import TcMatches
import TcGadt
import RnTypes
import RnExpr
import IfaceEnv
import MkId
import TysWiredIn
import IdInfo
import {- Kind parts of -} Type
import BasicTypes
91
92
#endif

93
import FastString
94
import Maybes
95
96
import Util
import Bag
97

98
import Control.Monad    ( unless )
99
100
101
import Data.Maybe	( isJust )
import Foreign.Ptr      ( Ptr )

102
103
104
105
106
107
108
109
110
111
112
113
\end{code}



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


\begin{code}
114
tcRnModule :: HscEnv 
115
	   -> HscSource
116
	   -> Bool 		-- True <=> save renamed syntax
117
	   -> Located (HsModule RdrName)
118
	   -> IO (Messages, Maybe TcGblEnv)
119

120
tcRnModule hsc_env hsc_src save_rn_syntax
121
	 (L loc (HsModule maybe_mod export_ies 
122
123
			  import_decls local_decls mod_deprec _ 
			  module_info maybe_doc))
124
125
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

Simon Marlow's avatar
Simon Marlow committed
126
127
128
129
130
   let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
	 this_mod = case maybe_mod of
			Nothing  -> mAIN	-- 'module M where' is omitted
			Just (L _ mod) -> mkModule this_pkg mod } ;
						-- The normal case
131
		
132
   initTc hsc_env hsc_src save_rn_syntax this_mod $ 
133
   setSrcSpan loc $
134
135
136
   do {		-- Deal with imports;
	tcg_env <- tcRnImports hsc_env this_mod import_decls ;
	setGblEnv tcg_env		$ do {
137

138
139
140
141
142
143
144
145
146
		-- 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
		--
		-- Do this *after* tcRnImports, so that we know whether
		-- a module that we import imports us; and hence whether to
		-- look for a hi-boot file
	boot_iface <- tcHiBootIface hsc_src this_mod ;
147

148
		-- Rename and type check the declarations
149
	traceRn (text "rn1a") ;
150
151
152
	tcg_env <- if isHsBoot hsc_src then
			tcRnHsBootDecls local_decls
		   else	
153
			tcRnSrcDecls boot_iface local_decls ;
154
155
	setGblEnv tcg_env		$ do {

156
		-- Report the use of any deprecated things
157
		-- We do this *before* processsing the export list so
158
159
		-- that we don't bleat about re-exporting a deprecated
		-- thing (especially via 'module Foo' export item)
160
161
162
163
164
		-- That is, only uses in the *body* of the module are complained about
	traceRn (text "rn3") ;
	failIfErrsM ;	-- finishDeprecations crashes sometimes 
			-- as a result of typechecker repairs (e.g. unboundNames)
	tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ;
165

166
		-- Process the export list
167
	tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
168
169
	traceRn (text "rn4") ;

170
171
172
173
	-- Compare the hi-boot iface (if any) with the real thing
	-- Must be done after processing the exports
 	tcg_env <- checkHiBootIface tcg_env boot_iface ;

174
175
176
177
178
	-- Make the new type env available to stuff slurped from interface files
	-- Must do this after checkHiBootIface, because the latter might add new
	-- bindings for boot_dfuns, which may be mentioned in imported unfoldings
	writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;

179
180
		-- Rename the Haddock documentation 
	tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
181
182

		-- Report unused names
183
 	reportUnusedNames export_ies tcg_env ;
184
185

		-- Dump output and return
186
187
	tcDump tcg_env ;
	return tcg_env
Simon Marlow's avatar
Simon Marlow committed
188
    }}}}
189
190
191
\end{code}


192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
%************************************************************************
%*									*
		Import declarations
%*									*
%************************************************************************

\begin{code}
tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env this_mod import_decls
  = do	{ (rn_imports, rdr_env, imports) <- rnImports import_decls ;

	; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
	      ; dep_mods = imp_dep_mods imports

		-- We want instance declarations from all home-package
		-- modules below this one, including boot modules, except
		-- ourselves.  The 'except ourselves' is so that we don't
		-- get the instances from this module's hs-boot file
	      ; want_instances :: ModuleName -> Bool
	      ; want_instances mod = mod `elemUFM` dep_mods
				   && mod /= moduleName this_mod
213
214
	      ; (home_insts, home_fam_insts) = hptInstances hsc_env 
                                                            want_instances
215
216
217
218
219
220
221
222
223
	      } ;

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

		-- Update the gbl env
	; updGblEnv ( \ gbl -> 
224
225
226
227
228
229
230
231
	    gbl { 
              tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
	      tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
              tcg_rn_imports   = fmap (const rn_imports) (tcg_rn_imports gbl),
	      tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
	      tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
                                                      home_fam_insts
	    }) $ do {
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

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

		-- Load any orphan-module and family instance-module
		-- interfaces, so that their rules and instance decls will be
		-- found.
	; loadOrphanModules (imp_orphs  imports) False
	; loadOrphanModules (imp_finsts imports) True 

		-- Check type-familily consistency
	; traceRn (text "rn1: checking family instance consistency")
	; let { dir_imp_mods = map (\ (mod, _, _) -> mod) 
			     . moduleEnvElts 
			     . imp_mods 
			     $ imports }
	; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;

	; getGblEnv } }
\end{code}


258
259
%************************************************************************
%*									*
260
	Type-checking external-core modules
261
262
263
264
%*									*
%************************************************************************

\begin{code}
265
266
267
268
tcRnExtCore :: HscEnv 
	    -> HsExtCore RdrName
	    -> IO (Messages, Maybe ModGuts)
	-- Nothing => some error occurred 
269

270
271
272
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" ;
273

274
   initTc hsc_env ExtCoreFile False this_mod $ do {
275

276
   let { ldecls  = map noLoc decls } ;
277

278
279
	-- Deal with the type declarations; first bring their stuff
	-- into scope, then rname them, then type check them
280
   tcg_env  <- importsFromLocalDecls (mkFakeGroup ldecls) ;
281

282
   setGblEnv tcg_env $ do {
283

284
285
   rn_decls <- rnTyClDecls ldecls ;
   failIfErrsM ;
286

287
288
	-- Dump trace of renaming part
   rnDump (ppr rn_decls) ;
289

290
291
	-- Typecheck them all together so that
	-- any mutually recursive types are done right
292
   tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
293
	-- Make the new type env available to stuff slurped from interface files
294

295
296
297
   setGblEnv tcg_env $ do {
   
	-- Now the core bindings
298
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
299

300
301
302
	-- Wrap up
   let {
	bndrs 	   = bindersOfBinds core_binds ;
303
	my_exports = map (Avail . idName) bndrs ;
304
		-- ToDo: export the data types also?
305

306
	final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
307

308
309
310
311
312
313
314
315
316
	mod_guts = ModGuts {	mg_module    = this_mod,
				mg_boot	     = False,
				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_fam_insts = tcg_fam_insts tcg_env,
317
				mg_fam_inst_env = tcg_fam_inst_env tcg_env,
318
319
				mg_rules     = [],
				mg_binds     = core_binds,
320

321
				-- Stubs
322
323
324
				mg_rdr_env   = emptyGlobalRdrEnv,
				mg_fix_env   = emptyFixityEnv,
				mg_deprecs   = NoDeprecs,
andy@galois.com's avatar
andy@galois.com committed
325
				mg_foreign   = NoStubs,
mnislaih's avatar
mnislaih committed
326
				mg_hpc_info  = noHpcInfo,
327
328
                                mg_modBreaks = emptyModBreaks,
                                mg_vect_info = noVectInfo
329
		    } } ;
330

331
   tcCoreDump mod_guts ;
332

333
334
   return mod_guts
   }}}}
335

336
mkFakeGroup decls -- Rather clumsy; lots of unused fields
337
  = emptyRdrGroup { hs_tyclds = decls }
338
\end{code}
339
340


341
342
343
344
345
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************
346

347
\begin{code}
348
tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
349
350
	-- Returns the variables free in the decls
	-- Reason: solely to report unused imports and bindings
351
352
tcRnSrcDecls boot_iface decls
 = do {   	-- Do all the declarations
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
	(tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;

	     -- 	Finish simplifying class constraints
	     -- 
	     -- 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.
	     --
	     -- We do this after checkMain, so that we use the type info 
	     -- thaat checkMain adds
	     -- 
	     -- We do it with both global and local env in scope:
	     --	 * the global env exposes the instances to tcSimplifyTop
	     --  * the local env exposes the local Ids to tcSimplifyTop, 
	     --    so that we get better error messages (monomorphism restriction)
        traceTc (text "Tc8") ;
	inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
371

372
373
374
	    -- Backsubstitution.  This must be done last.
	    -- Even tcSimplifyTop may do some unification.
        traceTc (text "Tc9") ;
375
376
377
378
	let { (tcg_env, _) = tc_envs
	    ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
		         tcg_rules = rules, tcg_fords = fords } = tcg_env
	    ; all_binds = binds `unionBags` inst_binds } ;
379

380
	(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
381

382
383
	let { final_type_env = extendTypeEnvWithIds type_env bind_ids
	    ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
384
385
			 	   tcg_binds = binds',
				   tcg_rules = rules', 
386
				   tcg_fords = fords' } } ;
387

388
	return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) 
389
   }
390

391
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
392
393
-- Loops around dealing with each top level inter-splice group 
-- in turn, until it's dealt with the entire module
394
tc_rn_src_decls boot_details ds
395
396
 = do { let { (first_group, group_tail) = findSplice ds } ;
		-- If ds is [] we get ([], Nothing)
397

398
	-- Deal with decls up to, but not including, the first splice
399
	(tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
400
401
402
403
		-- checkNoErrs: stop if renaming fails

	(tcg_env, tcl_env) <- setGblEnv tcg_env $ 
			      tcTopSrcDecls boot_details rn_decls ;
404
405

	-- If there is no splice, we're nearly done
406
	setEnvs (tcg_env, tcl_env) $ 
407
	case group_tail of {
408
	   Nothing -> do { tcg_env <- checkMain ;	-- Check for `main'
409
			   return (tcg_env, tcl_env) 
410
		      } ;
411
412

	-- If there's a splice, we must carry on
413
	   Just (SpliceDecl splice_expr, rest_ds) -> do {
414
415
416
417
418
#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
419
420
	(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
		-- checkNoErrs: don't typecheck if renaming failed
421
	rnDump (ppr rn_splice_expr) ;
422
423
424
425
426
427

	-- 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) $
428
	tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
429
#endif /* GHCI */
430
    } } }
431
432
\end{code}

433
434
%************************************************************************
%*									*
435
436
	Compiling hs-boot source files, and
	comparing the hi-boot interface with the real thing
437
438
439
%*									*
%************************************************************************

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
\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
458
	; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
459
460
461
462
	; setGblEnv tcg_env	$ do {

		-- Typecheck instance decls
	; traceTc (text "Tc3")
463
	; (tcg_env, inst_infos, _deriv_binds) 
464
            <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
465
466
467
468
	; setGblEnv tcg_env	$ do {

		-- Typecheck value declarations
	; traceTc (text "Tc5") 
469
	; val_ids <- tcHsBootSigs (hs_valds rn_group)
470
471
472
473
474
475

		-- Wrap up
		-- No simplification or zonking to do
	; traceTc (text "Tc7a")
	; gbl_env <- getGblEnv 
	
476
		-- Make the final type-env
477
		-- Include the dfun_ids so that their type sigs
478
479
480
481
482
483
		-- are written into the interface file
	; let { type_env0 = tcg_type_env gbl_env
	      ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
	      ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
	      ; dfun_ids = map iDFunId inst_infos }
	; return (gbl_env { tcg_type_env = type_env2 }) 
484
485
486
487
488
489
   }}}}

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

490
491
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 details (if any).
492
493

\begin{code}
494
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
495
496
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
497
498
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
499
500
501
502
--
-- The bindings we return give bindings for the dfuns defined in the
-- hs-boot file, such as 	$fbEqT = $fEqT

503
checkHiBootIface
504
505
506
	tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
			    tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
			    tcg_type_env = local_type_env, tcg_exports = local_exports })
507
	(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
508
509
510
511
512
513
		      md_types = boot_type_env, md_exports = boot_exports })
  | isHsBoot hs_src	-- Current module is already a hs-boot file!
  = return tcg_env	

  | otherwise
  = do	{ traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ 
514
515
516
517
518
519
				ppr boot_exports)) ;

		-- Check the exports of the boot module, one by one
	; mapM_ check_export boot_exports

		-- Check instance declarations
520
521
522
523
524
525
526
	; mb_dfun_prs <- mapM check_inst boot_insts
	; let tcg_env' = tcg_env { tcg_binds    = binds `unionBags` dfun_binds,
				   tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
	      dfun_prs   = catMaybes mb_dfun_prs
	      boot_dfuns = map fst dfun_prs
	      dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
				     | (boot_dfun, dfun) <- dfun_prs ]
527
528

		-- Check for no family instances
529
530
531
532
533
534
	; unless (null boot_fam_insts) $
	    panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
		   "instances in boot files yet...")
            -- FIXME: Why?  The actual comparison is not hard, but what would
            --	      be the equivalent to the dfun bindings returned for class
            --	      instances?  We can't easily equate tycons...
535

536
	; return tcg_env' }
537
  where
538
    check_export boot_avail	-- boot_avail is exported by the boot iface
539
540
541
542
543
544
      | name `elem` dfun_names = return ()	
      | isWiredInName name     = return ()	-- No checking for wired-in names.  In particular,
						-- 'error' is handled by a rather gross hack
						-- (see comments in GHC.Err.hs-boot)

	-- Check that the actual module exports the same thing
545
546
      | not (null missing_names)
      = addErrTc (missingBootThing (head missing_names) "exported by")
547
548
549
550

	-- If the boot module does not *define* the thing, we are done
	-- (it simply re-exports it, and names match, so nothing further to do)
      | isNothing mb_boot_thing = return ()
551

552
553
554
555
	-- Check that the actual module also defines the thing, and 
	-- then compare the definitions
      | Just real_thing <- lookupTypeEnv local_type_env name
      = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
556
	         real_decl = tyThingToIfaceDecl real_thing
557
	   ; checkTc (checkBootDecl boot_decl real_decl)
558
		     (bootMisMatch real_thing boot_decl real_decl) }
559
560
		-- The easiest way to check compatibility is to convert to
		-- iface syntax, where we already have good comparison functions
561

562
      | otherwise
563
      = addErrTc (missingBootThing name "defined in")
564
      where
565
	name          = availName boot_avail
566
	mb_boot_thing = lookupTypeEnv boot_type_env name
567
568
569
	missing_names = case lookupNameEnv local_export_env name of
			  Nothing    -> [name]
			  Just avail -> availNames boot_avail `minusList` availNames avail
570
		 
571
572
    dfun_names = map getName boot_insts

573
574
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
575

576
577
    check_inst :: Instance -> TcM (Maybe (Id, Id))
	-- Returns a pair of the boot dfun in terms of the equivalent real dfun
578
579
580
581
    check_inst boot_inst
	= case [dfun | inst <- local_insts, 
		       let dfun = instanceDFunId inst,
		       idType dfun `tcEqType` boot_inst_ty ] of
582
583
	    [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
	    (dfun:_) -> return (Just (local_boot_dfun, dfun))
584
585
586
	where
	  boot_dfun = instanceDFunId boot_inst
	  boot_inst_ty = idType boot_dfun
587
	  local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
588

589

590
----------------
591
592
593
594
missingBootThing thing what
  = ppr thing <+> ptext SLIT("is exported by the hs-boot file, but not") 
	      <+> text what <+> ptext SLIT("the module")

595
bootMisMatch thing boot_decl real_decl
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
596
  = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"),
597
598
599
	  ptext SLIT("Main module:") <+> ppr real_decl,
	  ptext SLIT("Boot file:  ") <+> ppr boot_decl]

600
instMisMatch inst
601
  = hang (ppr inst)
602
       2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself"))
603
604
\end{code}

605

606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
%************************************************************************
%*									*
	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.
622
623

\begin{code}
624
625
626
627
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls group
 = do { 	-- Bring top level binders into scope
628
629
	tcg_env <- importsFromLocalDecls group ;
	setGblEnv tcg_env $ do {
630

631
	failIfErrsM ;	-- No point in continuing if (say) we have duplicate declarations
632

633
634
635
		-- Rename the source decls
	(tcg_env, rn_decls) <- rnSrcDecls group ;
	failIfErrsM ;
636

637
638
639
640
641
642
643
		-- save the renamed syntax, if we want it
	let { tcg_env'
	        | Just grp <- tcg_rn_decls tcg_env
	          = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
	        | otherwise
	           = tcg_env };

644
645
		-- Dump trace of renaming part
	rnDump (ppr rn_decls) ;
646

647
	return (tcg_env', rn_decls)
648
   }}
649

650
------------------------------------------------
651
652
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
653
654
	(HsGroup { hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
655
                   hs_derivds = deriv_decls,
656
657
658
659
660
661
662
		   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") ;
663

664
	tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
665
666
667
668
669
	-- 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) ;
670
671


672
673
674
675
	setGblEnv tcg_env	$ do {
		-- Source-language instances, including derivings,
		-- and import the supporting declarations
        traceTc (text "Tc3") ;
676
677
	(tcg_env, inst_infos, deriv_binds) 
            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
678
	setGblEnv tcg_env	$ do {
679

680
681
682
683
684
	        -- 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 {
685

686
687
688
689
		-- Default declarations
        traceTc (text "Tc4a") ;
	default_tys <- tcDefaults default_decls ;
	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
690
	
691
692
693
694
		-- Value declarations next
		-- We also typecheck any extra binds that came out 
		-- of the "deriving" process (deriv_binds)
        traceTc (text "Tc5") ;
695
	(tc_val_binds,   tcl_env) <- tcTopBinds val_binds ;
696
	setLclTypeEnv tcl_env 	$ do {
697

698
699
700
701
702
		-- Now GHC-generated derived bindings and generics
		-- Do not generate warnings from compiler-generated code
	(tc_deriv_binds, tcl_env) <- discardWarnings $ setOptM Opt_GlasgowExts $ 
				     tcTopBinds deriv_binds ;

703
704
	     	-- Second pass over class and instance declarations, 
        traceTc (text "Tc6") ;
705
	(inst_binds, tcl_env)     <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ;
706
	showLIE (text "after instDecls2") ;
707

708
709
710
711
		-- Foreign exports
		-- They need to be zonked, so we return them
        traceTc (text "Tc7") ;
	(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
712

713
714
		-- Rules
	rules <- tcRules rule_decls ;
715

716
717
718
719
		-- Wrap up
        traceTc (text "Tc7a") ;
	tcg_env <- getGblEnv ;
	let { all_binds = tc_val_binds	 `unionBags`
720
			  tc_deriv_binds `unionBags`
721
722
723
724
725
726
727
728
			  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 } } ;
729
  	return (tcg_env', tcl_env)
730
    }}}}}}
731
732
\end{code}

733

734
735
%************************************************************************
%*									*
736
	Checking for 'main'
737
738
739
740
%*									*
%************************************************************************

\begin{code}
741
742
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
743
checkMain 
744
  = do { tcg_env   <- getGblEnv ;
745
	 dflags    <- getDOpts ;
746
	 let { main_mod = mainModIs dflags ;
747
	       main_fn  = case mainFunIs dflags of {
748
				Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
749
750
				Nothing -> main_RDR_Unqual } } ;
	
751
	 check_main dflags tcg_env main_mod main_fn
752
    }
753

754

755
check_main dflags tcg_env main_mod main_fn
756
 | mod /= main_mod
757
758
 = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
   return tcg_env
759

760
761
762
763
764
765
 | 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 {
766
767
	     Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
			   ; complain_no_main	
768
769
			   ; return tcg_env } ;
	     Just main_name -> do
770
771
	{ traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
	; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
772
		   	-- :Main.main :: IO () = runMainIO main 
773

774
	; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
775
			     tcInferRho rhs
776

777
		-- See Note [Root-main Id]
778
	; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
779
				   (mkVarOccFS FSLIT("main")) 
780
				   (getSrcLoc main_name)
781
	      ; root_main_id = Id.mkExportedLocalId root_main_name ty
782
	      ; main_bind    = noLoc (VarBind root_main_id main_expr) }
783

784
785
786
787
	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
					`snocBag` main_bind,
			    tcg_dus   = tcg_dus tcg_env
				        `plusDU` usesOnly (unitFV main_name)
788
789
			-- Record the use of 'main', so that we don't 
			-- complain about it being defined but not used
790
791
792
		 }) 
    }}}
  where
793
    mod = tcg_mod tcg_env
794
 
795
796
    complain_no_main | ghcLink dflags == LinkInMemory = return ()
		     | otherwise = failWithTc noMainMsg
797
798
799
	-- 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.
800

801
802
803
804
    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}
805

806
807
808
809
810
811
812
813
814
815
816
817
818
Note [Root-main Id]
~~~~~~~~~~~~~~~~~~~
The function that the RTS invokes is always :Main.main, which we call
root_main_id.  (Because GHC allows the user to have a module not
called Main as the main module, we can't rely on the main function
being called "Main.main".  That's why root_main_id has a fixed module
":Main".)  

This is unusual: it's a LocalId whose Name has a Module from another
module.  Tiresomely, we must filter it out again in MkIface, les we
get two defns for 'main' in the interface file!


819
820
821
822
823
%*********************************************************
%*						 	 *
		GHCi stuff
%*							 *
%*********************************************************
824

825
826
\begin{code}
#ifdef GHCI
827
828
829
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside 
  = let 
830
831
832
	-- Initialise the tcg_inst_env with instances 
	-- from all home modules.  This mimics the more selective
	-- call to hptInstances in tcRnModule
833
	dfuns = fst (hptInstances hsc_env (\mod -> True))
834
835
836
837
838
    in
    updGblEnv (\env -> env { 
	tcg_rdr_env  = ic_rn_gbl_env icxt,
	tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $

839

840
    tcExtendIdEnv (ic_tmp_ids icxt) $
841
842
843
844
845
846
847
        -- tcExtendIdEnv does lots: 
        --   - it extends the local type env (tcl_env) with the given Ids,
        --   - it extends the local rdr env (tcl_rdr) with the Names from 
        --     the given Ids
        --   - it adds the free tyvars of the Ids to the tcl_tyvars
        --     set.
        --
848
849
        -- later ids in ic_tmp_ids must shadow earlier ones with the same
        -- OccName, and tcExtendIdEnv implements this behaviour.
850

851
    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
852
 	; thing_inside }
853
\end{code}
854

855

856
857
858
859
\begin{code}
tcRnStmt :: HscEnv
	 -> InteractiveContext
	 -> LStmt RdrName
860
861
862
863
	 -> IO (Maybe ([Id], LHsExpr Id))
		-- The returned [Id] is the list of new Ids bound by
                -- this statement.  It can be used to extend the
                -- InteractiveContext via extendInteractiveContext.
864
865
866
		--
		-- The returned TypecheckedHsExpr is of type IO [ () ],
		-- a list of the bound values, coerced to ().
867

868
869
tcRnStmt hsc_env ictxt rdr_stmt
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
870
    setInteractiveContext hsc_env ictxt $ do {
871

872
    -- Rename; use CmdLineMode because tcRnStmt is only used interactively
873
    (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
874
875
876
877
    traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
    failIfErrsM ;
    
    -- The real work is done here
878
879
880
    (bound_ids, tc_expr) <- mkPlan rn_stmt ;
    zonked_expr <- zonkTopLExpr tc_expr ;
    zonked_ids  <- zonkTopBndrs bound_ids ;
881
    
882
883
884
885
	-- 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) ;

886
    traceTc (text "tcs 1") ;
887
888
889
890
891
892
893
894
895
    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
896
	global_ids = map globaliseAndTidy zonked_ids ;
897
    
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
{- ---------------------------------------------
   At one stage I removed any shadowed bindings from the type_env;
   they are inaccessible but might, I suppose, cause a space leak if we leave them there.
   However, with Template Haskell they aren't necessarily inaccessible.  Consider this
   GHCi session
	 Prelude> let f n = n * 2 :: Int
	 Prelude> fName <- runQ [| f |]
	 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
	 14
	 Prelude> let f n = n * 3 :: Int
	 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
   In the last line we use 'fName', which resolves to the *first* 'f'
   in scope. If we delete it from the type env, GHCi crashes because
   it doesn't expect that.
 
   Hence this code is commented out

915
-------------------------------------------------- -}
916
    } ;
917

918
919
    dumpOptTcRn Opt_D_dump_tc 
    	(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
920
    	       text "Typechecked expr" <+> ppr zonked_expr]) ;
921

922
    returnM (global_ids, zonked_expr)
923
    }
924
925
926
  where
    bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
				  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
927

928
929
930
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
-- Give the Id a Global Name, and tidy its type
931
  = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
932
933
934
  where
    tidy_type = tidyTopType (idType id)
\end{code}
935

936
Here is the grand plan, implemented in tcUserStmt
937

938
939
940
941
	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,...]
942

943
944
	pat <- expr		==> 	expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]
945

946
947
948
949
950
	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]
951

952
953
	expr (of non-IO type, 
	  result not showable)	==>	error
954

955

956
957
\begin{code}
---------------------------
958
959
960
961
962
963
964
965
966
967
968
969
type PlanResult = ([Id], LHsExpr Id)
type Plan = TcM PlanResult

runPlans :: [Plan] -> TcM PlanResult
-- Try the plans in order.  If one fails (by raising an exn), try the next.
-- If one succeeds, take it.
runPlans []     = panic "runPlans"
runPlans [p]    = p
runPlans (p:ps) = tryTcLIE_ (runPlans ps) p

--------------------
mkPlan :: LStmt Name -> TcM PlanResult
970
971
mkPlan (L loc (ExprStmt expr _ _))	-- An expression typed at the prompt 
  = do	{ uniq <- newUnique		-- is treated very specially
972
	; let fresh_it  = itName uniq
973
974
	      the_bind  = L loc $ mkFunBind (L loc fresh_it) matches
	      matches   = [mkMatch [] expr emptyLocalBinds]
975
	      let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
976
977
978
979
980
981
982
983
984
	      bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
					   (HsVar bindIOName) noSyntaxExpr 
	      print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
			          	   (HsVar thenIOName) placeHolderType

	-- The plans are:
	--	[it <- e; print it]	but not if it::()
	--	[it <- e]		
	--	[let it = e; print it]	
985
986
	; runPlans [	-- Plan A
		    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
987
988
989
		       ; it_ty <- zonkTcType (idType it_id)
		       ; ifM (isUnitTy it_ty) failM
		       ; return stuff },
990
991
992
993
994
995
996
997

			-- Plan B; a naked bind statment
		    tcGhciStmts [bind_stmt],	

			-- Plan C; check that the let-binding is typeable all by itself.
			-- If not, fail; if so, try to print it.
			-- The two-step process avoids getting two errors: one from
			-- the expression itself, and one from the 'print it' part
998
999
1000
1001
			-- This two-step story is very clunky, alas
		    do { checkNoErrs (tcGhciStmts [let_stmt]) 
				--- checkNoErrs defeats the error recovery of let-bindings
		       ; tcGhciStmts [let_stmt, print_it] }
1002
1003
	  ]}

1004
1005
mkPlan stmt@(L loc (BindStmt {}))
  | [L _ v] <- collectLStmtBinders stmt		-- One binder, for a bind stmt 
1006
1007
  = do	{ let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
			          	   (HsVar thenIOName) placeHolderType
1008
1009
1010
1011
1012
1013
1014
1015

	; print_bind_result <- doptM Opt_PrintBindResult
	; let print_plan = do
		  { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
		  ; v_ty <- zonkTcType (idType v_id)
		  ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
		  ; return stuff }

1016
1017
1018
	-- The plans are:
	--	[stmt; print v]		but not if v::()
	--	[stmt]
1019
1020
1021
	; runPlans ((if print_bind_result then [print_plan] else []) ++
		    [tcGhciStmts [stmt]])
	}
1022
1023

mkPlan stmt
1024
  = tcGhciStmts [stmt]
1025

1026
---------------------------
1027
1028
tcGhciStmts :: [LStmt Name] -> TcM PlanResult
tcGhciStmts stmts
1029
 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1030
	ret_id  <- tcLookupId returnIOName ;		-- return @ IO
1031
	let {
1032
	    io_ty     = mkTyConApp ioTyCon [] ;
1033
1034
	    ret_ty    = mkListTy unitTy ;
	    io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
1035
1036
	    tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
				        (emptyRefinement, io_ret_ty) ;
1037

1038
	    names = map unLoc (collectLStmtsBinders stmts) ;
1039

1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
		-- 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.)
1051
	    mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
1052
			 	    (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1053
1054
	    mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
		    	         (nlHsVar id) 
1055
	 } ;
1056

1057
1058
	-- OK, we're ready to typecheck the stmts
	traceTc (text "tcs 2") ;
1059
1060
	((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
					   mappM tcLookupId names ;
1061
1062
1063
1064
1065
1066
1067
					-- Look up the names right in the middle,
					-- where they will all be in scope

	-- Simplify the context
	const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
		-- checkNoErrs ensures that the plan fails if context redn fails

1068
	return (ids, mkHsDictLet const_binds $
1069
1070
		     noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
    }
1071
\end{code}
1072
1073


1074
tcRnExpr just finds the type of an expression
1075

1076
1077
1078
1079
1080
1081
1082
\begin{code}
tcRnExpr :: HscEnv
	 -> InteractiveContext
	 -> LHsExpr RdrName
	 -> IO (Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
1083
    setInteractiveContext hsc_env ictxt $ do {
1084

1085
1086
    (rn_expr, fvs) <- rnLExpr rdr_expr ;
    failIfErrsM ;
1087

1088
1089
1090
	-- Now typecheck the expression; 
	-- it might have a rank-2 type (e.g. :t runST)
    ((tc_expr, res_ty), lie)	   <- getLIE (tcInferRho rn_expr) ;
1091
    ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
1092
    tcSimplifyInteractive lie_top ;
1093

1094
    let { all_expr_ty = mkForAllTys qtvs $
1095
    		        mkFunTys (map (idType . instToId) dict_insts)	$
1096
1097
1098
1099
1100
1101
    		        res_ty } ;
    zonkTcType all_expr_ty
    }
  where
    smpl_doc = ptext SLIT("main expression")
\end{code}
1102

1103
tcRnType just finds the kind of a type
1104

1105
1106
1107
1108
1109
1110
1111
\begin{code}
tcRnType :: HscEnv
	 -> InteractiveContext
	 -> LHsType RdrName
	 -> IO (Maybe Kind)
tcRnType hsc_env ictxt rdr_type
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
1112
    setInteractiveContext hsc_env ictxt $ do {
1113

1114
1115
    rn_type <- rnLHsType doc rdr_type ;
    failIfErrsM ;
1116

1117
1118
1119
1120
1121
1122
	-- Now kind-check the type
    (ty', kind) <- kcHsType rn_type ;
    return kind
    }
  where
    doc = ptext SLIT("In GHCi input")
1123

1124
#endif /* GHCi */
1125
1126
1127
\end{code}


1128
1129
1130
1131
1132
%************************************************************************
%*									*
	More GHCi stuff, to do with browsing and getting info
%*									*
%************************************************************************
1133
1134
1135

\begin{code}
#ifdef GHCI