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

\begin{code}
8
{-# OPTIONS -w #-}
9 10 11
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
12
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13 14
-- for details

15 16
module TcRnDriver (
#ifdef GHCI
17
	tcRnStmt, tcRnExpr, tcRnType,
18
	tcRnLookupRdrName,
19 20
	tcRnLookupName,
	tcRnGetInfo,
21
	getModuleExports, 
22
#endif
23 24
	tcRnModule, 
	tcTopSrcDecls,
25
	tcRnExtCore
26 27
    ) where

28
import IO
29
#ifdef GHCI
chak's avatar
chak committed
30
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
31 32
#endif

33 34 35 36 37 38 39 40 41
import DynFlags
import StaticFlags
import HsSyn
import RdrHsSyn

import PrelNames
import RdrName
import TcHsSyn
import TcExpr
42
import TcRnMonad
43 44
import TcType
import Inst
45
import FamInst
46 47 48 49 50 51 52 53 54 55
import InstEnv
import FamInstEnv
import TcBinds
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import MkIface
56
import IfaceSyn
57 58
import TcSimplify
import TcTyClsDecls
59
import TcUnify	( withBox )
60 61 62 63 64 65 66 67 68
import LoadIface
import RnNames
import RnEnv
import RnSource
import RnHsDoc
import PprCore
import CoreSyn
import ErrUtils
import Id
69
import VarEnv
70
import Var
Simon Marlow's avatar
Simon Marlow committed
71
import Module
72
import LazyUniqFM
73
import Name
74
import NameEnv
75
import NameSet
76
import TyCon
77
import TysWiredIn
78 79
import SrcLoc
import HscTypes
80
import ListSetOps
81
import Outputable
82 83 84
import DataCon
import Type
import Class
85
import Data.List ( sortBy )
86

87
#ifdef GHCI
mnislaih's avatar
mnislaih committed
88
import Linker
89 90 91 92 93 94 95 96 97 98
import TcHsType
import TcMType
import TcMatches
import RnTypes
import RnExpr
import IfaceEnv
import MkId
import IdInfo
import {- Kind parts of -} Type
import BasicTypes
99
import Foreign.Ptr( Ptr )
100 101
#endif

102
import FastString
103
import Maybes
104 105
import Util
import Bag
106

107
import Control.Monad
108 109
import Data.Maybe	( isJust )

110
#include "HsVersions.h"
111 112 113 114 115 116 117 118 119 120 121 122
\end{code}



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


\begin{code}
123
tcRnModule :: HscEnv 
124
	   -> HscSource
125
	   -> Bool 		-- True <=> save renamed syntax
126
	   -> Located (HsModule RdrName)
127
	   -> IO (Messages, Maybe TcGblEnv)
128

129
tcRnModule hsc_env hsc_src save_rn_syntax
130
	 (L loc (HsModule maybe_mod export_ies 
David Waern's avatar
David Waern committed
131
			  import_decls local_decls mod_deprec
132
			  module_info maybe_doc))
133 134
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

Simon Marlow's avatar
Simon Marlow committed
135 136 137 138 139
   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
140
		
141
   initTc hsc_env hsc_src save_rn_syntax this_mod $ 
142
   setSrcSpan loc $
143 144 145
   do {		-- Deal with imports;
	tcg_env <- tcRnImports hsc_env this_mod import_decls ;
	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 171 172 173
		-- 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 ;
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 183
	-- 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 ;

184 185 186 187 188
	-- 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) ;

189 190
		-- Rename the Haddock documentation 
	tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
191 192

		-- Report unused names
193
 	reportUnusedNames export_ies tcg_env ;
194 195

		-- Dump output and return
196 197
	tcDump tcg_env ;
	return tcg_env
Simon Marlow's avatar
Simon Marlow committed
198
    }}}}
199 200 201
\end{code}


202 203 204 205 206 207 208 209 210
%************************************************************************
%*									*
		Import declarations
%*									*
%************************************************************************

\begin{code}
tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env this_mod import_decls
211
  = do	{ (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
212 213 214 215 216 217 218 219 220 221 222

	; 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
223 224
	      ; (home_insts, home_fam_insts) = hptInstances hsc_env 
                                                            want_instances
225 226 227 228 229 230 231 232 233
	      } ;

		-- 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 -> 
234 235 236 237 238 239
	    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) 
240 241
                                                      home_fam_insts,
	      tcg_hpc          = hpc_info
242
	    }) $ do {
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258

	; 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")
259
	; let { dir_imp_mods = moduleEnvKeys
260 261 262 263 264 265 266 267
			     . imp_mods 
			     $ imports }
	; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;

	; getGblEnv } }
\end{code}


268 269
%************************************************************************
%*									*
270
	Type-checking external-core modules
271 272 273 274
%*									*
%************************************************************************

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

280 281 282
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" ;
283

284
   initTc hsc_env ExtCoreFile False this_mod $ do {
285

286
   let { ldecls  = map noLoc decls } ;
287

288 289 290 291 292 293 294
       -- bring the type and class decls into scope
       -- 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)
295 296
   avails  <- getLocalNonValBinders (mkFakeGroup ldecls) ;
   tc_envs <- extendGlobalRdrEnvRn False avails 
297
			           emptyFsEnv {- no fixity decls -} ;
298

299
   setEnvs tc_envs $ do {
300

301
   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
302

303 304
	-- Dump trace of renaming part
   rnDump (ppr rn_decls) ;
305

306 307
	-- Typecheck them all together so that
	-- any mutually recursive types are done right
308
   tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
309
	-- Make the new type env available to stuff slurped from interface files
310

311 312 313
   setGblEnv tcg_env $ do {
   
	-- Now the core bindings
314
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
315

316 317 318
	-- Wrap up
   let {
	bndrs 	   = bindersOfBinds core_binds ;
319
	my_exports = map (Avail . idName) bndrs ;
320
		-- ToDo: export the data types also?
321

322
	final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
323

324 325
	mod_guts = ModGuts {	mg_module    = this_mod,
				mg_boot	     = False,
Simon Marlow's avatar
Simon Marlow committed
326 327
				mg_used_names = emptyNameSet, -- ToDo: compute usage
				mg_dir_imps  = emptyModuleEnv, -- ??
328 329 330 331 332
				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,
333
				mg_inst_env  = tcg_inst_env tcg_env,
334
				mg_fam_inst_env = tcg_fam_inst_env tcg_env,
335 336
				mg_rules     = [],
				mg_binds     = core_binds,
337

338
				-- Stubs
339 340 341
				mg_rdr_env   = emptyGlobalRdrEnv,
				mg_fix_env   = emptyFixityEnv,
				mg_deprecs   = NoDeprecs,
andy@galois.com's avatar
andy@galois.com committed
342
				mg_foreign   = NoStubs,
343
				mg_hpc_info  = emptyHpcInfo False,
344 345
                                mg_modBreaks = emptyModBreaks,
                                mg_vect_info = noVectInfo
346
		    } } ;
347

348
   tcCoreDump mod_guts ;
349

350 351
   return mod_guts
   }}}}
352

353
mkFakeGroup decls -- Rather clumsy; lots of unused fields
354
  = emptyRdrGroup { hs_tyclds = decls }
355
\end{code}
356 357


358 359 360 361 362
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************
363

364
\begin{code}
365
tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
366 367
	-- Returns the variables free in the decls
	-- Reason: solely to report unused imports and bindings
368 369
tcRnSrcDecls boot_iface decls
 = do {   	-- Do all the declarations
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387
	(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) ;
388

389 390 391
	    -- Backsubstitution.  This must be done last.
	    -- Even tcSimplifyTop may do some unification.
        traceTc (text "Tc9") ;
392 393 394 395
	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 } ;
396

397 398 399 400
	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!

401
	(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
402

403 404
	let { final_type_env = extendTypeEnvWithIds type_env bind_ids
	    ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
405 406
			 	   tcg_binds = binds',
				   tcg_rules = rules', 
407
				   tcg_fords = fords' } } ;
408

409
	return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) 
410
   }
411

412
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
413 414
-- Loops around dealing with each top level inter-splice group 
-- in turn, until it's dealt with the entire module
415
tc_rn_src_decls boot_details ds
416 417
 = do { let { (first_group, group_tail) = findSplice ds } ;
		-- If ds is [] we get ([], Nothing)
418

419
	-- Deal with decls up to, but not including, the first splice
420 421
	(tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
		-- rnTopSrcDecls fails if there are any errors
422 423 424

	(tcg_env, tcl_env) <- setGblEnv tcg_env $ 
			      tcTopSrcDecls boot_details rn_decls ;
425 426

	-- If there is no splice, we're nearly done
427
	setEnvs (tcg_env, tcl_env) $ 
428
	case group_tail of {
429
	   Nothing -> do { tcg_env <- checkMain ;	-- Check for `main'
430
			   return (tcg_env, tcl_env) 
431
		      } ;
432 433

	-- If there's a splice, we must carry on
434
	   Just (SpliceDecl splice_expr, rest_ds) -> do {
435 436 437 438 439
#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
440 441
	(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
		-- checkNoErrs: don't typecheck if renaming failed
442
	rnDump (ppr rn_splice_expr) ;
443 444 445 446 447 448

	-- 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) $
449
	tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
450
#endif /* GHCI */
451
    } } }
452 453
\end{code}

454 455
%************************************************************************
%*									*
456 457
	Compiling hs-boot source files, and
	comparing the hi-boot interface with the real thing
458 459 460
%*									*
%************************************************************************

461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
\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
479
	; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
480 481 482 483
	; setGblEnv tcg_env	$ do {

		-- Typecheck instance decls
	; traceTc (text "Tc3")
484
	; (tcg_env, inst_infos, _deriv_binds) 
485
            <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
486 487 488 489
	; setGblEnv tcg_env	$ do {

		-- Typecheck value declarations
	; traceTc (text "Tc5") 
490
	; val_ids <- tcHsBootSigs (hs_valds rn_group)
491 492 493 494 495 496

		-- Wrap up
		-- No simplification or zonking to do
	; traceTc (text "Tc7a")
	; gbl_env <- getGblEnv 
	
497
		-- Make the final type-env
498
		-- Include the dfun_ids so that their type sigs
499 500 501 502 503 504
		-- 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 }) 
505 506 507
   }}}}

spliceInHsBootErr (SpliceDecl (L loc _), _)
Ian Lynagh's avatar
Ian Lynagh committed
508
  = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files"))
509 510
\end{code}

511 512
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).
513 514

\begin{code}
515
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
516 517
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
518 519
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
520 521 522 523
--
-- The bindings we return give bindings for the dfuns defined in the
-- hs-boot file, such as 	$fbEqT = $fEqT

524
checkHiBootIface
525 526 527
	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 })
528
	(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
529 530 531 532 533 534
		      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 $$ 
535 536 537 538 539 540
				ppr boot_exports)) ;

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

		-- Check instance declarations
541 542 543 544 545 546 547
	; 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 ]
548 549

		-- Check for no family instances
550 551 552 553 554 555
	; 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...
556

557
        ; failIfErrsM
558
	; return tcg_env' }
559
  where
560
    check_export boot_avail	-- boot_avail is exported by the boot iface
561 562 563 564 565 566
      | 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
567
      | not (null missing_names)
568 569
      = addErrAt (nameSrcSpan (head missing_names)) 
                 (missingBootThing (head missing_names) "exported by")
570 571 572 573

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

575 576
	-- Check that the actual module also defines the thing, and 
	-- then compare the definitions
577 578 579 580 581 582 583 584
      | 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)
585

586
      | otherwise
587
      = addErrTc (missingBootThing name "defined in")
588
      where
589
	name          = availName boot_avail
590
	mb_boot_thing = lookupTypeEnv boot_type_env name
591 592 593
	missing_names = case lookupNameEnv local_export_env name of
			  Nothing    -> [name]
			  Just avail -> availNames boot_avail `minusList` availNames avail
594
		 
595 596
    dfun_names = map getName boot_insts

597 598
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
599

600 601
    check_inst :: Instance -> TcM (Maybe (Id, Id))
	-- Returns a pair of the boot dfun in terms of the equivalent real dfun
602 603 604 605
    check_inst boot_inst
	= case [dfun | inst <- local_insts, 
		       let dfun = instanceDFunId inst,
		       idType dfun `tcEqType` boot_inst_ty ] of
606 607
	    [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
	    (dfun:_) -> return (Just (local_boot_dfun, dfun))
608 609 610
	where
	  boot_dfun = instanceDFunId boot_inst
	  boot_inst_ty = idType boot_dfun
611
	  local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
612

613

614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710
-- 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) 
    (idType id1 `tcEqType` idType id2)

checkBootDecl (ATyCon tc1) (ATyCon tc2)
  | isSynTyCon tc1 && isSynTyCon tc2
  = ASSERT(tc1 == tc2)
    let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
        env = rnBndrs2 env0 tvs1 tvs2

        eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _)
            = tcEqTypeX env k1 k2
        eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
            = tcEqTypeX env t1 t2
    in
    equalLength tvs1 tvs2 &&
    eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)

  | isAlgTyCon tc1 && isAlgTyCon tc2
  = ASSERT(tc1 == tc2)
    eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2)
    && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)

  | isForeignTyCon tc1 && isForeignTyCon tc2
  = tyConExtName tc1 == tyConExtName tc2
  where 
        env0 = mkRnEnv2 emptyInScopeSet

        eqAlgRhs AbstractTyCon _ = True
        eqAlgRhs OpenTyCon{} OpenTyCon{} = True
        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
          && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
                 tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
                 env = rnBndrs2 env0 tvs1 tvs2
             in
              equalLength tvs1 tvs2 &&              
              eqListBy (tcEqPredX env)
                        (dataConEqTheta c1 ++ dataConDictTheta c1)
                        (dataConEqTheta c2 ++ dataConDictTheta c2) &&
              eqListBy (tcEqTypeX env)
                        (dataConOrigArgTys c1)
                        (dataConOrigArgTys c2)

checkBootDecl (AClass c1)  (AClass c2)
  = let 
       (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) 
          = classExtraBigSig c1
       (clas_tyvars2, clas_fds2, sc_theta2, _, _, 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 &&
           tcEqTypeX env op_ty1 op_ty2
         where
	  (_, rho_ty1) = splitForAllTys (idType id1)
	  op_ty1 = funResultTy rho_ty1
	  (_, rho_ty2) = splitForAllTys (idType id2)
          op_ty2 = funResultTy rho_ty2

       eqFD (as1,bs1) (as2,bs2) = 
         eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
         eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
    in
       equalLength clas_tyvars1 clas_tyvars2 &&
       eqListBy eqFD clas_fds1 clas_fds2 &&
       (null sc_theta1 && null op_stuff1
        ||
        eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
        eqListBy eqSig op_stuff1 op_stuff2)

checkBootDecl (ADataCon dc1) (ADataCon dc2)
  = pprPanic "checkBootDecl" (ppr dc1)

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

711
----------------
712
missingBootThing thing what
Ian Lynagh's avatar
Ian Lynagh committed
713 714
  = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") 
	      <+> text what <+> ptext (sLit "the module")
715

716
bootMisMatch thing boot_decl real_decl
Ian Lynagh's avatar
Ian Lynagh committed
717 718 719
  = 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]
720

721
instMisMatch inst
722
  = hang (ppr inst)
Ian Lynagh's avatar
Ian Lynagh committed
723
       2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
724 725
\end{code}

726

727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742
%************************************************************************
%*									*
	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.
743 744

\begin{code}
745 746
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
747
-- Fails if there are any errors
748
rnTopSrcDecls group
749
 = do { -- Rename the source decls (with no shadowing; error on duplicates)
750
	(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
751

752
        -- save the renamed syntax, if we want it
753 754 755 756 757 758
	let { tcg_env'
	        | Just grp <- tcg_rn_decls tcg_env
	          = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
	        | otherwise
	           = tcg_env };

759 760
		-- Dump trace of renaming part
	rnDump (ppr rn_decls) ;
761

762
	return (tcg_env', rn_decls)
763
   }
764

765
------------------------------------------------
766 767
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
768 769
	(HsGroup { hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
770
                   hs_derivds = deriv_decls,
771 772 773 774 775 776 777
		   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") ;
778

779 780
	tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
		-- If there are any errors, tcTyAndClassDecls fails here
781 782 783
	
	-- 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) ;
784 785


786 787 788 789
	setGblEnv tcg_env	$ do {
		-- Source-language instances, including derivings,
		-- and import the supporting declarations
        traceTc (text "Tc3") ;
790 791
	(tcg_env, inst_infos, deriv_binds) 
            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
792
	setGblEnv tcg_env	$ do {
793

794 795 796 797 798
	        -- 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 {
799

800 801 802 803
		-- Default declarations
        traceTc (text "Tc4a") ;
	default_tys <- tcDefaults default_decls ;
	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
804
	
805 806 807 808
		-- Value declarations next
		-- We also typecheck any extra binds that came out 
		-- of the "deriving" process (deriv_binds)
        traceTc (text "Tc5") ;
809
	(tc_val_binds,   tcl_env) <- tcTopBinds val_binds ;
810
	setLclTypeEnv tcl_env 	$ do {
811

812 813 814 815
		-- Now GHC-generated derived bindings and generics.
		-- Do not generate warnings from compiler-generated code.
	(tc_deriv_binds, tcl_env) <- discardWarnings $
                                 tcTopBinds deriv_binds ;
816

817 818
	     	-- Second pass over class and instance declarations, 
        traceTc (text "Tc6") ;
819
	(inst_binds, tcl_env)     <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ;
820
	showLIE (text "after instDecls2") ;
821

822 823 824 825
		-- Foreign exports
		-- They need to be zonked, so we return them
        traceTc (text "Tc7") ;
	(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
826

827 828
		-- Rules
	rules <- tcRules rule_decls ;
829

830 831 832 833
		-- Wrap up
        traceTc (text "Tc7a") ;
	tcg_env <- getGblEnv ;
	let { all_binds = tc_val_binds	 `unionBags`
834
			  tc_deriv_binds `unionBags`
835 836 837 838 839 840 841 842
			  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 } } ;
843
  	return (tcg_env', tcl_env)
844
    }}}}}}
845 846
\end{code}

847

848 849
%************************************************************************
%*									*
850
	Checking for 'main'
851 852 853 854
%*									*
%************************************************************************

\begin{code}
855 856
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
857
checkMain 
858
  = do { tcg_env   <- getGblEnv ;
859
	 dflags    <- getDOpts ;
860
	 check_main dflags tcg_env
861
    }
862

863
check_main dflags tcg_env
864
 | mod /= main_mod
865 866
 = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
   return tcg_env
867

868
 | otherwise
869
 = do	{ mb_main <- lookupSrcOcc_maybe main_fn
870 871 872
		-- Check that 'main' is in scope
		-- It might be imported from another module!
	; case mb_main of {
873 874
	     Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
			   ; complain_no_main	
875 876
			   ; return tcg_env } ;
	     Just main_name -> do
877

878
	{ traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
879 880 881 882 883 884
	; let loc = srcLocSpan (getSrcLoc main_name)
	; ioTyCon <- tcLookupTyCon ioTyConName
	; (main_expr, res_ty) 
		<- addErrCtxt mainCtxt	  $
		   withBox liftedTypeKind $ \res_ty -> 
		   tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
885

886
		-- See Note [Root-main Id]
887 888 889
	   	-- Construct the binding
		-- 	:Main.main :: IO res_ty = runMainIO res_ty main 
	; run_main_id <- tcLookupId runMainIOName
890
	; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
Ian Lynagh's avatar
Ian Lynagh committed
891
				   (mkVarOccFS (fsLit "main")) 
892
				   (getSrcSpan main_name)
893 894 895 896 897
	      ; root_main_id = Id.mkExportedLocalId root_main_name 
						    (mkTyConApp ioTyCon [res_ty])
	      ; co  = mkWpTyApps [res_ty]
	      ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
	      ; main_bind = noLoc (VarBind root_main_id rhs) }
898

899 900 901 902
	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
					`snocBag` main_bind,
			    tcg_dus   = tcg_dus tcg_env
				        `plusDU` usesOnly (unitFV main_name)
903 904
			-- Record the use of 'main', so that we don't 
			-- complain about it being defined but not used
905 906 907
		 }) 
    }}}
  where
908 909 910 911 912 913 914 915
    mod 	 = tcg_mod tcg_env
    main_mod     = mainModIs dflags
    main_is_flag = mainFunIs dflags

    main_fn  = case main_is_flag of
		  Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
		  Nothing -> main_RDR_Unqual

916 917
    complain_no_main | ghcLink dflags == LinkInMemory = return ()
		     | otherwise = failWithTc noMainMsg
918 919 920
	-- 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.
921

Ian Lynagh's avatar
Ian Lynagh committed
922 923 924 925 926
    mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
    noMainMsg = ptext (sLit "The") <+> pp_main_fn
		<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
    pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn)
	       | otherwise 	     = ptext (sLit "function") <+> quotes (ppr main_fn)
927
\end{code}
928

929 930 931 932 933 934 935 936 937 938 939 940 941
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!


942 943 944 945 946
%*********************************************************
%*						 	 *
		GHCi stuff
%*							 *
%*********************************************************
947

948 949
\begin{code}
#ifdef GHCI
950 951
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside 
952 953 954
  = let -- Initialise the tcg_inst_env with instances from all home modules.  
        -- This mimics the more selective call to hptInstances in tcRnModule.
	(home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
955 956
    in
    updGblEnv (\env -> env { 
957 958 959 960 961
	tcg_rdr_env      = ic_rn_gbl_env icxt,
	tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
	tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
                                                home_fam_insts 
      }) $
962

963 964
    tcExtendGhciEnv (ic_tmp_ids icxt) $
        -- tcExtendGhciEnv does lots: 
965 966 967 968 969 970
        --   - 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.
        --
971 972
        -- later ids in ic_tmp_ids must shadow earlier ones with the same
        -- OccName, and tcExtendIdEnv implements this behaviour.
973

974
    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
975
 	; thing_inside }
976
\end{code}
977

978

979 980 981 982
\begin{code}
tcRnStmt :: HscEnv
	 -> InteractiveContext
	 -> LStmt RdrName
983 984 985 986
	 -> 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.
987 988 989
		--
		-- The returned TypecheckedHsExpr is of type IO [ () ],
		-- a list of the bound values, coerced to ().
990

991 992
tcRnStmt hsc_env ictxt rdr_stmt
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
993
    setInteractiveContext hsc_env ictxt $ do {
994