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

\begin{code}
module TcRnDriver (
#ifdef GHCI
10
	tcRnStmt, tcRnExpr, tcRnType,
11
	tcRnImportDecls,
12
	tcRnLookupRdrName,
13
	getModuleInterface,
14
	tcRnDeclsi,
15
#endif
16
17
	tcRnLookupName,
	tcRnGetInfo,
18
19
	tcRnModule, 
	tcTopSrcDecls,
20
	tcRnExtCore
21
22
    ) where

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

27
28
29
30
31
32
33
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
34
import TcRnMonad
35
import Coercion
36
import FamInst
37
38
import InstEnv
import FamInstEnv
39
import TcAnnotations
40
import TcBinds
41
import HeaderInfo       ( mkPrelImports )
42
import TcType	( tidyTopType )
43
44
45
46
47
48
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
49
import TcMType
50
import MkIface
51
import IfaceSyn
52
53
54
55
56
57
58
59
60
61
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import PprCore
import CoreSyn
import ErrUtils
import Id
62
import VarEnv
63
import Var
Simon Marlow's avatar
Simon Marlow committed
64
import Module
65
import UniqFM
66
import Name
67
import NameEnv
68
import NameSet
69
import Avail
70
71
72
import TyCon
import SrcLoc
import HscTypes
73
import ListSetOps
74
import Outputable
75
76
77
import DataCon
import Type
import Class
78
import TcType   ( orphNamesOfDFunHead )
79
import Inst	( tcGetInstEnvs )
80
import Data.List ( sortBy )
81

82
#ifdef GHCI
83
84
import TcType   ( isUnitTy, isTauTy )
import CoreUtils( mkPiTypes )
85
86
87
88
89
90
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import MkId
import BasicTypes
91
92
import TidyPgm	  ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
93
94
#endif

95
import FastString
96
import Maybes
97
98
import Util
import Bag
99

100
import Control.Monad
101

102
#include "HsVersions.h"
103
104
105
106
107
108
109
110
111
112
\end{code}

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


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

119
tcRnModule hsc_env hsc_src save_rn_syntax
120
	 (L loc (HsModule maybe_mod export_ies 
David Waern's avatar
David Waern committed
121
			  import_decls local_decls mod_deprec
122
			  maybe_doc_hdr))
123
124
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

Simon Marlow's avatar
Simon Marlow committed
125
   let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
126
127
128
129
130
131
132
	 (this_mod, prel_imp_loc) 
            = case maybe_mod of
		Nothing -- 'module M where' is omitted  
                    ->  (mAIN, srcLocSpan (srcSpanStart loc))	
			    	   
		Just (L mod_loc mod)  -- The normal case
                    -> (mkModule this_pkg mod, mod_loc) } ;
133
		
134
   initTc hsc_env hsc_src save_rn_syntax this_mod $ 
135
   setSrcSpan loc $
136
137
138
139
140
141
142
143
144
   do {		-- Deal with imports; first add implicit prelude
        implicit_prelude <- xoptM Opt_ImplicitPrelude;
        let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
                                         implicit_prelude import_decls } ;

        ifWOptM Opt_WarnImplicitPrelude $
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

	tcg_env <- tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
145
	setGblEnv tcg_env		$ do {
146

147
148
149
150
151
152
153
154
155
		-- 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 ;
156

157
		-- Rename and type check the declarations
158
	traceRn (text "rn1a") ;
159
160
161
	tcg_env <- if isHsBoot hsc_src then
			tcRnHsBootDecls local_decls
		   else	
162
			tcRnSrcDecls boot_iface local_decls ;
163
164
	setGblEnv tcg_env		$ do {

165
		-- Report the use of any deprecated things
166
		-- We do this *before* processsing the export list so
167
168
		-- that we don't bleat about re-exporting a deprecated
		-- thing (especially via 'module Foo' export item)
169
170
		-- That is, only uses in the *body* of the module are complained about
	traceRn (text "rn3") ;
Ian Lynagh's avatar
Ian Lynagh committed
171
	failIfErrsM ;	-- finishWarnings crashes sometimes 
172
			-- as a result of typechecker repairs (e.g. unboundNames)
Ian Lynagh's avatar
Ian Lynagh committed
173
	tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
174

175
		-- Process the export list
176
        traceRn (text "rn4a: before exports");
177
	tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
178
	traceRn (text "rn4b: after exportss") ;
179

180
181
182
                -- Check that main is exported (must be after rnExports)
        checkMainExported tcg_env ;

183
184
185
186
	-- 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 ;

187
188
189
190
191
	-- The new type env is already available to stuff slurped from 
	-- interface files, via TcEnv.updateGlobalTypeEnv
	-- It's important that this includes the stuff in checkHiBootIface, 
	-- because the latter might add new bindings for boot_dfuns, 
	-- which may be mentioned in imported unfoldings
192

193
194
195
		-- Don't need to rename the Haddock documentation,
		-- it's not parsed by GHC anymore.
	tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
196
197

		-- Report unused names
198
 	reportUnusedNames export_ies tcg_env ;
199
200

		-- Dump output and return
201
202
	tcDump tcg_env ;
	return tcg_env
Simon Marlow's avatar
Simon Marlow committed
203
    }}}}
204
205
206
207
208


implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = ptext (sLit "Module `Prelude' implicitly imported")
209
210
211
\end{code}


212
213
214
215
216
217
218
%************************************************************************
%*									*
		Import declarations
%*									*
%************************************************************************

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

	; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
225
226
227
228
229
230
231
232
233
	        -- Make sure we record the dependencies from the DynFlags in the EPS or we
	        -- end up hitting the sanity check in LoadIface.loadInterface that
	        -- checks for unknown home-package modules being loaded. We put
	        -- these dependencies on the left so their (non-source) imports
	        -- take precedence over the (possibly-source) imports on the right.
	        -- We don't add them to any other field (e.g. the imp_dep_mods of
	        -- imports) because we don't want to load their instances etc.
	      ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
	                        `plusUFM` imp_dep_mods imports
234
235
236
237
238
239
240
241

		-- 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
242
243
	      ; (home_insts, home_fam_insts) = hptInstances hsc_env 
                                                            want_instances
244
245
246
247
248
249
250
251
252
	      } ;

		-- 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 -> 
253
254
255
	    gbl { 
              tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
	      tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
256
              tcg_rn_imports   = rn_imports,
257
258
	      tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
	      tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
259
260
                                                      home_fam_insts,
	      tcg_hpc          = hpc_info
261
	    }) $ do {
262
263
264
265
266
267
268
269
270
271
272

	; 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.
273
274
	; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) 
                               (imp_orphs imports)
275

Simon Marlow's avatar
Simon Marlow committed
276
                -- Check type-family consistency
277
	; traceRn (text "rn1: checking family instance consistency")
278
	; let { dir_imp_mods = moduleEnvKeys
279
280
281
282
283
284
285
286
			     . imp_mods 
			     $ imports }
	; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;

	; getGblEnv } }
\end{code}


287
288
%************************************************************************
%*									*
289
	Type-checking external-core modules
290
291
292
293
%*									*
%************************************************************************

\begin{code}
294
295
296
297
tcRnExtCore :: HscEnv 
	    -> HsExtCore RdrName
	    -> IO (Messages, Maybe ModGuts)
	-- Nothing => some error occurred 
298

299
300
301
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" ;
302

303
   initTc hsc_env ExtCoreFile False this_mod $ do {
304

305
   let { ldecls  = map noLoc decls } ;
306

307
       -- Bring the type and class decls into scope
308
309
310
311
312
313
       -- ToDo: check that this doesn't need to extract the val binds.
       --       It seems that only the type and class decls need to be in scope below because
       --          (a) tcTyAndClassDecls doesn't need the val binds, and 
       --          (b) tcExtCoreBindings doesn't need anything
       --              (in fact, it might not even need to be in the scope of
       --               this tcg_env at all)
314
315
   (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} 
                                              (mkFakeGroup ldecls) ;
316
   setEnvs tc_envs $ do {
317

318
   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
319

320
321
	-- Dump trace of renaming part
   rnDump (ppr rn_decls) ;
322

323
324
	-- Typecheck them all together so that
	-- any mutually recursive types are done right
325
326
	-- Just discard the auxiliary bindings; they are generated 
	-- only for Haskell source code, and should already be in Core
327
   (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
328

329
   setGblEnv tcg_env $ do {
330
	-- Make the new type env available to stuff slurped from interface files
331
332
   
	-- Now the core bindings
333
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
334

335
336
337
	-- Wrap up
   let {
	bndrs 	   = bindersOfBinds core_binds ;
338
	my_exports = map (Avail . idName) bndrs ;
339
		-- ToDo: export the data types also?
340

341
        mod_guts = ModGuts {    mg_module    = this_mod,
342
343
                                mg_boot	     = False,
                                mg_used_names = emptyNameSet, -- ToDo: compute usage
344
345
                                mg_used_th   = False,
                                mg_dir_imps  = emptyModuleEnv, -- ??
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
                                mg_deps      = noDependencies,	-- ??
                                mg_exports   = my_exports,
                                mg_tcs       = tcg_tcs tcg_env,
                                mg_clss      = tcg_clss tcg_env,
                                mg_insts     = tcg_insts tcg_env,
                                mg_fam_insts = tcg_fam_insts tcg_env,
                                mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],
                                mg_vect_decls = [],
                                mg_anns      = [],
                                mg_binds     = core_binds,

                                -- Stubs
                                mg_rdr_env   = emptyGlobalRdrEnv,
                                mg_fix_env   = emptyFixityEnv,
                                mg_warns     = NoWarnings,
                                mg_foreign   = NoStubs,
                                mg_hpc_info  = emptyHpcInfo False,
365
                                mg_modBreaks = emptyModBreaks,
366
367
                                mg_vect_info = noVectInfo,
                                mg_trust_pkg = False
368
                            } } ;
369

370
   tcCoreDump mod_guts ;
371

372
373
   return mod_guts
   }}}}
374

375
mkFakeGroup :: [LTyClDecl a] -> HsGroup a
376
mkFakeGroup decls -- Rather clumsy; lots of unused fields
377
  = emptyRdrGroup { hs_tyclds = [decls] }
378
\end{code}
379
380


381
382
383
384
385
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************
386

387
\begin{code}
388
tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
389
390
	-- Returns the variables free in the decls
	-- Reason: solely to report unused imports and bindings
391
392
tcRnSrcDecls boot_iface decls
 = do {   	-- Do all the declarations
393
	((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
394
      ; traceTc "Tc8" empty ;
395
      ; setEnvs (tcg_env, tcl_env) $ 
396
   do { 
397
398
399

	     -- 	Finish simplifying class constraints
	     -- 
400
	     -- simplifyTop deals with constant or ambiguous InstIds.  
401
402
403
404
405
	     -- 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 
406
	     -- that checkMain adds
407
408
	     -- 
	     -- We do it with both global and local env in scope:
409
410
	     --	 * the global env exposes the instances to simplifyTop
	     --  * the local env exposes the local Ids to simplifyTop, 
411
	     --    so that we get better error messages (monomorphism restriction)
412
	new_ev_binds <- simplifyTop lie ;
413
        traceTc "Tc9" empty ;
414
415
416
417
418

	failIfErrsM ;	-- Don't zonk if there have been errors
			-- It's a waste of time; and we may get debug warnings
			-- about strangely-typed TyCons!

419
420
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
421
        -- This pass also warns about missing type signatures
422
        let { TcGblEnv { tcg_type_env  = type_env,
423
424
425
426
427
428
429
                         tcg_binds     = binds,
                         tcg_sigs      = sig_ns,
                         tcg_ev_binds  = cur_ev_binds,
                         tcg_imp_specs = imp_specs,
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_fords     = fords } = tcg_env
430
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
431

432
433
434
435
436
437
438
439
440
441
442
        (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
            <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
        
        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
                                   tcg_imp_specs = imp_specs',
                                   tcg_rules    = rules', 
                                   tcg_vects    = vects', 
                                   tcg_fords    = fords' } } ;

443
        setGlobalTypeEnv tcg_env' final_type_env
444
   } }
445

446
447
448
tc_rn_src_decls :: ModDetails 
                    -> [LHsDecl RdrName] 
                    -> TcM (TcGblEnv, TcLclEnv)
449
450
-- Loops around dealing with each top level inter-splice group 
-- in turn, until it's dealt with the entire module
451
tc_rn_src_decls boot_details ds
452
 = do { (first_group, group_tail) <- findSplice ds  ;
453
		-- If ds is [] we get ([], Nothing)
454
        
455
	-- Deal with decls up to, but not including, the first splice
456
457
	(tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
		-- rnTopSrcDecls fails if there are any errors
458
        
459
460
	(tcg_env, tcl_env) <- setGblEnv tcg_env $ 
			      tcTopSrcDecls boot_details rn_decls ;
461
462

	-- If there is no splice, we're nearly done
463
	setEnvs (tcg_env, tcl_env) $ 
464
	case group_tail of {
465
	   Nothing -> do { tcg_env <- checkMain ;	-- Check for `main'
466
			   return (tcg_env, tcl_env) 
467
		      } ;
468
469

#ifndef GHCI
470
471
	-- There shouldn't be a splice
	   Just (SpliceDecl {}, _) -> do {
472
473
	failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
474
	-- If there's a splice, we must carry on
475
	   Just (SpliceDecl splice_expr _, rest_ds) -> do {
476
477

	-- Rename the splice expression, and get its supporting decls
478
479
	(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
		-- checkNoErrs: don't typecheck if renaming failed
480
	rnDump (ppr rn_splice_expr) ;
481
482
483
484
485
486

	-- 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) $
487
	tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
488
#endif /* GHCI */
489
    } } }
490
491
\end{code}

492
493
%************************************************************************
%*									*
494
495
	Compiling hs-boot source files, and
	comparing the hi-boot interface with the real thing
496
497
498
%*									*
%************************************************************************

499
500
501
\begin{code}
tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls decls
502
   = do { (first_group, group_tail) <- findSplice decls
503
504

		-- Rename the declarations
505
        ; (tcg_env, HsGroup { 
506
507
508
		   hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
		   hs_derivds = deriv_decls,
509
510
511
		   hs_fords  = for_decls,
		   hs_defds  = def_decls,  
		   hs_ruleds = rule_decls, 
512
		   hs_vects  = vect_decls, 
513
514
		   hs_annds  = _,
		   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
515
	; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
516
517


518
519
		-- Check for illegal declarations
	; case group_tail of
520
521
	     Just (SpliceDecl d _, _) -> badBootDecl "splice" d
	     Nothing                  -> return ()
522
523
524
	; mapM_ (badBootDecl "foreign") for_decls
	; mapM_ (badBootDecl "default") def_decls
	; mapM_ (badBootDecl "rule")    rule_decls
525
	; mapM_ (badBootDecl "vect")    vect_decls
526

527
		-- Typecheck type/class decls
528
	; traceTc "Tc2" empty
529
	; (tcg_env, aux_binds) 
530
               <- tcTyAndClassDecls emptyModDetails tycl_decls
531
	; setGblEnv tcg_env    $ do {
532
533

		-- Typecheck instance decls
534
		-- Family instance declarations are rejected here
535
	; traceTc "Tc3" empty
536
	; (tcg_env, inst_infos, _deriv_binds) 
537
            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
538

539
540
541
	; setGblEnv tcg_env	$ do {

		-- Typecheck value declarations
542
	; traceTc "Tc5" empty 
543
	; val_ids <- tcHsBootSigs val_binds
544
545
546

		-- Wrap up
		-- No simplification or zonking to do
547
	; traceTc "Tc7a" empty
548
549
	; gbl_env <- getGblEnv 
	
550
		-- Make the final type-env
551
		-- Include the dfun_ids so that their type sigs
552
553
		-- are written into the interface file. 
		-- And similarly the aux_ids from aux_binds
554
555
556
	; let { type_env0 = tcg_type_env gbl_env
	      ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
	      ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
557
	      ; type_env3 = extendTypeEnvWithIds type_env2 aux_ids 
558
559
560
561
562
563
	      ; dfun_ids = map iDFunId inst_infos
	      ; aux_ids  = case aux_binds of
	      		     ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
			     _		   	-> panic "tcRnHsBoodDecls"
	      }

564
	; setGlobalTypeEnv gbl_env type_env3
565
566
   }}}
   ; traceTc "boot" (ppr lie); return gbl_env }
567

568
569
570
571
badBootDecl :: String -> Located decl -> TcM ()
badBootDecl what (L loc _) 
  = addErrAt loc (char 'A' <+> text what 
      <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
572
573
\end{code}

574
575
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).
576
577

\begin{code}
578
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
579
580
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
581
582
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
583
584
585
586
--
-- The bindings we return give bindings for the dfuns defined in the
-- hs-boot file, such as 	$fbEqT = $fEqT

587
checkHiBootIface
588
	tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
589
			    tcg_insts = local_insts, 
590
			    tcg_type_env = local_type_env, tcg_exports = local_exports })
591
	(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
592
593
594
595
596
		      md_types = boot_type_env, md_exports = boot_exports })
  | isHsBoot hs_src	-- Current module is already a hs-boot file!
  = return tcg_env	

  | otherwise
597
598
  = do	{ traceTc "checkHiBootIface" $ vcat
             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
599
600
601
602
603

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

		-- Check for no family instances
604
605
606
607
608
609
	; 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...
610

611
612
		-- Check instance declarations
	; mb_dfun_prs <- mapM check_inst boot_insts
613
614
615
616
617
618
        ; let dfun_prs   = catMaybes mb_dfun_prs
              boot_dfuns = map fst dfun_prs
              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                     | (boot_dfun, dfun) <- dfun_prs ]
              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
              tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
619

620
        ; failIfErrsM
621
622
623
624
625
	; setGlobalTypeEnv tcg_env' type_env' }
	     -- Update the global type env *including* the knot-tied one
             -- so that if the source module reads in an interface unfolding
             -- mentioning one of the dfuns from the boot module, then it
             -- can "see" that boot dfun.   See Trac #4003
626
  where
627
    check_export boot_avail	-- boot_avail is exported by the boot iface
628
629
630
631
632
633
      | 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
634
      | not (null missing_names)
635
636
      = addErrAt (nameSrcSpan (head missing_names)) 
                 (missingBootThing (head missing_names) "exported by")
637
638
639
640

	-- 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 ()
641

642
643
	-- Check that the actual module also defines the thing, and 
	-- then compare the definitions
644
645
646
647
648
649
650
651
      | Just real_thing <- lookupTypeEnv local_type_env name,
        Just boot_thing <- mb_boot_thing
      = when (not (checkBootDecl boot_thing real_thing))
            $ addErrAt (nameSrcSpan (getName boot_thing))
                       (let boot_decl = tyThingToIfaceDecl 
                                               (fromJust mb_boot_thing)
                            real_decl = tyThingToIfaceDecl real_thing
                        in bootMisMatch real_thing boot_decl real_decl)
652

653
      | otherwise
654
      = addErrTc (missingBootThing name "defined in")
655
      where
656
	name          = availName boot_avail
657
	mb_boot_thing = lookupTypeEnv boot_type_env name
658
659
660
	missing_names = case lookupNameEnv local_export_env name of
			  Nothing    -> [name]
			  Just avail -> availNames boot_avail `minusList` availNames avail
661
		 
662
663
    dfun_names = map getName boot_insts

664
665
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
666

667
668
    check_inst :: Instance -> TcM (Maybe (Id, Id))
	-- Returns a pair of the boot dfun in terms of the equivalent real dfun
669
670
671
    check_inst boot_inst
	= case [dfun | inst <- local_insts, 
		       let dfun = instanceDFunId inst,
672
		       idType dfun `eqType` boot_inst_ty ] of
673
674
675
676
677
	    [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
                                                  , text "boot_inst"   <+> ppr boot_inst
                                                  , text "boot_inst_ty" <+> ppr boot_inst_ty
                                                  ]) 
                     ; addErrTc (instMisMatch boot_inst); return Nothing }
678
	    (dfun:_) -> return (Just (local_boot_dfun, dfun))
679
680
681
	where
	  boot_dfun = instanceDFunId boot_inst
	  boot_inst_ty = idType boot_dfun
682
	  local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
683

684

685
686
687
688
689
690
691
692
693
694
695
-- This has to compare the TyThing from the .hi-boot file to the TyThing
-- in the current source file.  We must be careful to allow alpha-renaming
-- where appropriate, and also the boot declaration is allowed to omit
-- constructors and class methods.
--
-- See rnfail055 for a good test of this stuff.

checkBootDecl :: TyThing -> TyThing -> Bool

checkBootDecl (AnId id1) (AnId id2)
  = ASSERT(id1 == id2) 
696
    (idType id1 `eqType` idType id2)
697
698

checkBootDecl (ATyCon tc1) (ATyCon tc2)
699
700
  = checkBootTyCon tc1 tc2

batterseapower's avatar
batterseapower committed
701
702
703
704
705
706
707
708
709
710
711
712
713
checkBootDecl (ADataCon dc1) (ADataCon _)
  = pprPanic "checkBootDecl" (ppr dc1)

checkBootDecl _ _ = False -- probably shouldn't happen

----------------
checkBootTyCon :: TyCon -> TyCon -> Bool
checkBootTyCon tc1 tc2
  | not (eqKind (tyConKind tc1) (tyConKind tc2))
  = False	-- First off, check the kind

  | Just c1 <- tyConClass_maybe tc1
  , Just c2 <- tyConClass_maybe tc2
714
715
716
717
718
719
720
721
722
723
724
  = let 
       (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) 
          = classExtraBigSig c1
       (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) 
          = classExtraBigSig c2

       env0 = mkRnEnv2 emptyInScopeSet
       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2

       eqSig (id1, def_meth1) (id2, def_meth2)
         = idName id1 == idName id2 &&
725
           eqTypeX env op_ty1 op_ty2 &&
726
           def_meth1 == def_meth2
727
         where
batterseapower's avatar
batterseapower committed
728
729
730
          (_, rho_ty1) = splitForAllTys (idType id1)
          op_ty1 = funResultTy rho_ty1
          (_, rho_ty2) = splitForAllTys (idType id2)
731
732
          op_ty2 = funResultTy rho_ty2

733
734
735
736
737
738
739
740
741
742
       eqAT (tc1, def_ats1) (tc2, def_ats2)
         = checkBootTyCon tc1 tc2 &&
           eqListBy eqATDef def_ats1 def_ats2

       eqATDef (ATD tvs1 ty_pats1 ty1) (ATD tvs2 ty_pats2 ty2)
         = eqListBy same_kind tvs1 tvs2 &&
           eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
           eqTypeX env ty1 ty2
         where env = rnBndrs2 env0 tvs1 tvs2

743
       eqFD (as1,bs1) (as2,bs2) = 
744
745
         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
746
747
748
749

       same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
    in
       eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
batterseapower's avatar
batterseapower committed
750
             -- Checks kind of class
751
752
753
       eqListBy eqFD clas_fds1 clas_fds2 &&
       (null sc_theta1 && null op_stuff1 && null ats1
        ||   -- Above tests for an "abstract" class
754
        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
755
        eqListBy eqSig op_stuff1 op_stuff2 &&
756
        eqListBy eqAT ats1 ats2) 
757

758
759
760
761
762
  | isSynTyCon tc1 && isSynTyCon tc2
  = ASSERT(tc1 == tc2)
    let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
        env = rnBndrs2 env0 tvs1 tvs2

763
764
        eqSynRhs SynFamilyTyCon SynFamilyTyCon
            = True
765
        eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
766
            = eqTypeX env t1 t2
767
        eqSynRhs _ _ = False
768
769
770
771
772
773
    in
    equalLength tvs1 tvs2 &&
    eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)

  | isAlgTyCon tc1 && isAlgTyCon tc2
  = ASSERT(tc1 == tc2)
774
    eqKind (tyConKind tc1) (tyConKind tc2) &&
775
    eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
776
    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
777
778

  | isForeignTyCon tc1 && isForeignTyCon tc2
779
780
  = eqKind (tyConKind tc1) (tyConKind tc2) &&
    tyConExtName tc1 == tyConExtName tc2
781
782

  | otherwise = False
783
784
785
  where 
        env0 = mkRnEnv2 emptyInScopeSet

786
787
788
        eqAlgRhs (AbstractTyCon dis1) rhs2 
          | dis1      = isDistinctAlgRhs rhs2	--Check compatibility
          | otherwise = True
789
        eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
790
791
792
793
794
795
796
797
798
799
800
        eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
            eqListBy eqCon (data_cons tc1) (data_cons tc2)
        eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
            eqCon (data_con tc1) (data_con tc2)
        eqAlgRhs _ _ = False

        eqCon c1 c2
          =  dataConName c1 == dataConName c2
          && dataConIsInfix c1 == dataConIsInfix c2
          && dataConStrictMarks c1 == dataConStrictMarks c2
          && dataConFieldLabels c1 == dataConFieldLabels c2
801
          && eqType (dataConUserType c1) (dataConUserType c2)
802

803
----------------
804
805
806
missingBootThing :: Name -> String -> SDoc
missingBootThing name what
  = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") 
Ian Lynagh's avatar
Ian Lynagh committed
807
	      <+> text what <+> ptext (sLit "the module")
808

809
bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
810
bootMisMatch thing boot_decl real_decl
Ian Lynagh's avatar
Ian Lynagh committed
811
812
813
  = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
	  ptext (sLit "Main module:") <+> ppr real_decl,
	  ptext (sLit "Boot file:  ") <+> ppr boot_decl]
814

815
instMisMatch :: Instance -> SDoc
816
instMisMatch inst
817
  = hang (ppr inst)
Ian Lynagh's avatar
Ian Lynagh committed
818
       2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
819
820
\end{code}

821

822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
%************************************************************************
%*									*
	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.
838
839

\begin{code}
840
841
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
842
-- Fails if there are any errors
843
rnTopSrcDecls group
844
 = do { -- Rename the source decls
845
        traceTc "rn12" empty ;
846
	(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
847
        traceTc "rn13" empty ;
848

849
        -- save the renamed syntax, if we want it
850
851
852
853
854
855
	let { tcg_env'
	        | Just grp <- tcg_rn_decls tcg_env
	          = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
	        | otherwise
	           = tcg_env };

856
857
		-- Dump trace of renaming part
	rnDump (ppr rn_decls) ;
858

859
	return (tcg_env', rn_decls)
860
   }
861

862
------------------------------------------------
863
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
864
tcTopSrcDecls boot_details 
865
866
	(HsGroup { hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
867
                   hs_derivds = deriv_decls,
868
869
		   hs_fords  = foreign_decls,
		   hs_defds  = default_decls,
870
		   hs_annds  = annotation_decls,
871
		   hs_ruleds = rule_decls,
872
		   hs_vects  = vect_decls,
873
874
875
		   hs_valds  = val_binds })
 = do {		-- Type-check the type and class decls, and all imported decls
		-- The latter come in via tycl_decls
876
        traceTc "Tc2" empty ;
877

878
	(tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
879
		-- If there are any errors, tcTyAndClassDecls fails here
880
	
881
	setGblEnv tcg_env	$ do {
882

883
884
		-- Source-language instances, including derivings,
		-- and import the supporting declarations
885
        traceTc "Tc3" empty ;
886
	(tcg_env, inst_infos, deriv_binds) 
887
            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
888
	setGblEnv tcg_env	$ do {
889

890
	        -- Foreign import declarations next. 
891
        traceTc "Tc4" empty ;
892
893
	(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
	tcExtendGlobalValEnv fi_ids	$ do {
894

895
		-- Default declarations
896
        traceTc "Tc4a" empty ;
897
898
	default_tys <- tcDefaults default_decls ;
	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
899
	
900
901
902
		-- Now GHC-generated derived bindings, generics, and selectors
		-- Do not generate warnings from compiler-generated code;
		-- hence the use of discardWarnings
903
904
905
	(tc_aux_binds,   specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
	(tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ 
			 	             discardWarnings (tcTopBinds deriv_binds) ;
906

907
		-- Value declarations next
908
        traceTc "Tc5" empty ;
909
910
	(tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
			 	           tcTopBinds val_binds;
911

912
913
        setLclTypeEnv tcl_env $ do {	-- Environment doesn't change now

914
                -- Second pass over class and instance declarations, 
915
                -- now using the kind-checked decls
916
        traceTc "Tc6" empty ;
917
        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
918

919
                -- Foreign exports
920
        traceTc "Tc7" empty ;
921
        (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
922

923
                -- Annotations
924
        annotations <- tcAnnotations annotation_decls ;
925

926
927
                -- Rules
        rules <- tcRules rule_decls ;
928

929
930
931
932
                -- Vectorisation declarations
        vects <- tcVectDecls vect_decls ;

                -- Wrap up
933
        traceTc "Tc7a" empty ;
934
935
	tcg_env <- getGblEnv ;
	let { all_binds = tc_val_binds	 `unionBags`
936
			  tc_deriv_binds `unionBags`
937
			  tc_aux_binds   `unionBags`
938
			  inst_binds	 `unionBags`
939
940
941
942
			  foe_binds

            ; sig_names = mkNameSet (collectHsValBinders val_binds) 
                          `minusNameSet` getTypeSigNames val_binds
943

944
945
946
947
948
                -- 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_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
                                                   specs3
949
                                 , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
950
951
952
953
954
                                 , tcg_rules = tcg_rules tcg_env ++ rules
                                 , tcg_vects = tcg_vects tcg_env ++ vects
                                 , tcg_anns  = tcg_anns tcg_env ++ annotations
                                 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
        return (tcg_env', tcl_env)
955
    }}}}}}
956
957
\end{code}

958

959
960
%************************************************************************
%*									*
961
	Checking for 'main'
962
963
964
965
%*									*
%************************************************************************

\begin{code}
966
967
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
968
checkMain 
969
  = do { tcg_env   <- getGblEnv ;
970
	 dflags    <- getDOpts ;
971
	 check_main dflags tcg_env
972
    }
973

974
check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
975
check_main dflags tcg_env
976
 | mod /= main_mod
977
 = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
978
   return tcg_env
979

980
 | otherwise
981
 = do	{ mb_main <- lookupGlobalOccRn_maybe main_fn
982
983
984
		-- Check that 'main' is in scope
		-- It might be imported from another module!
	; case mb_main of {
985
	     Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
986
			   ; complain_no_main	
987
988
			   ; return tcg_env } ;
	     Just main_name -> do
989

990
	{ traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
991
992
	; let loc = srcLocSpan (getSrcLoc main_name)
	; ioTyCon <- tcLookupTyCon ioTyConName
993
994
        ; res_ty <- newFlexiTyVarTy liftedTypeKind
	; main_expr
995
996
		<- addErrCtxt mainCtxt	  $
		   tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
997

998
		-- See Note [Root-main Id]
999
1000
1001