TcRnDriver.lhs 48.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 28 29
    ) where

#include "HsVersions.h"

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

35 36 37 38 39 40 41 42 43
import DynFlags
import StaticFlags
import HsSyn
import RdrHsSyn

import PrelNames
import RdrName
import TcHsSyn
import TcExpr
44
import TcRnMonad
45 46
import TcType
import Inst
47
import FamInst
48 49 50 51 52 53 54 55 56 57
import InstEnv
import FamInstEnv
import TcBinds
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import MkIface
58
import IfaceSyn
59 60
import TcSimplify
import TcTyClsDecls
61
import TcUnify	( withBox )
62 63 64 65 66 67 68 69 70 71
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
72
import Module
73
import LazyUniqFM
74
import Name
75
import NameEnv
76
import NameSet
77
import TyCon
78
import TysWiredIn
79 80
import SrcLoc
import HscTypes
81
import ListSetOps
82 83
import Outputable

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

100
import FastString
101
import Maybes
102 103
import Util
import Bag
104

105
import Control.Monad
106 107
import Data.Maybe	( isJust )

108 109 110 111 112 113 114 115 116 117 118 119
\end{code}



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


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

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

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

144 145 146 147 148 149 150 151 152
		-- 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 ;
153

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

162
		-- Report the use of any deprecated things
163
		-- We do this *before* processsing the export list so
164 165
		-- that we don't bleat about re-exporting a deprecated
		-- thing (especially via 'module Foo' export item)
166 167 168 169 170
		-- 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 ;
171

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

177 178 179 180
	-- 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 ;

181 182 183 184 185
	-- 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) ;

186 187
		-- Rename the Haddock documentation 
	tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
188 189

		-- Report unused names
190
 	reportUnusedNames export_ies tcg_env ;
191 192

		-- Dump output and return
193 194
	tcDump tcg_env ;
	return tcg_env
Simon Marlow's avatar
Simon Marlow committed
195
    }}}}
196 197 198
\end{code}


199 200 201 202 203 204 205 206 207
%************************************************************************
%*									*
		Import declarations
%*									*
%************************************************************************

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

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

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

	; 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")
256
	; let { dir_imp_mods = map (\ (mod, _) -> mod) 
257 258 259 260 261 262 263 264 265
			     . moduleEnvElts 
			     . imp_mods 
			     $ imports }
	; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;

	; getGblEnv } }
\end{code}


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

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

278 279 280
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" ;
281

282
   initTc hsc_env ExtCoreFile False this_mod $ do {
283

284
   let { ldecls  = map noLoc decls } ;
285

286 287 288 289 290 291 292
       -- 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)
293 294 295
   avails  <- getLocalNonValBinders (mkFakeGroup ldecls) ;
   tc_envs <- extendGlobalRdrEnvRn False avails 
			           emptyOccEnv {- no fixity decls -} ;
296

297
   setEnvs tc_envs $ do {
298

299
   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
300

301 302
	-- Dump trace of renaming part
   rnDump (ppr rn_decls) ;
303

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

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

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

320
	final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
321

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

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

346
   tcCoreDump mod_guts ;
347

348 349
   return mod_guts
   }}}}
350

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


356 357 358 359 360
%************************************************************************
%*									*
	Type-checking the top level of a module
%*									*
%************************************************************************
361

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

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

395 396 397 398
	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!

399
	(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
400

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

407
	return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) 
408
   }
409

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

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

	(tcg_env, tcl_env) <- setGblEnv tcg_env $ 
			      tcTopSrcDecls boot_details rn_decls ;
423 424

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

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

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

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

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

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

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

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

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

509 510
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).
511 512

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

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

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

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

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

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

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

571 572 573 574
	-- 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)
575
	         real_decl = tyThingToIfaceDecl real_thing
576
	   ; checkTc (checkBootDecl boot_decl real_decl)
577
		     (bootMisMatch real_thing boot_decl real_decl) }
578 579
		-- The easiest way to check compatibility is to convert to
		-- iface syntax, where we already have good comparison functions
580

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

592 593
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
594

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

608

609
----------------
610 611 612 613
missingBootThing thing what
  = ppr thing <+> ptext SLIT("is exported by the hs-boot file, but not") 
	      <+> text what <+> ptext SLIT("the module")

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

619
instMisMatch inst
620
  = hang (ppr inst)
621
       2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself"))
622 623
\end{code}

624

625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640
%************************************************************************
%*									*
	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.
641 642

\begin{code}
643 644
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
645
-- Fails if there are any errors
646
rnTopSrcDecls group
647
 = do { -- Rename the source decls (with no shadowing; error on duplicates)
648
	(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
649

650
        -- save the renamed syntax, if we want it
651 652 653 654 655 656
	let { tcg_env'
	        | Just grp <- tcg_rn_decls tcg_env
	          = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
	        | otherwise
	           = tcg_env };

657 658
		-- Dump trace of renaming part
	rnDump (ppr rn_decls) ;
659

660
	return (tcg_env', rn_decls)
661
   }
662

663
------------------------------------------------
664 665
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
666 667
	(HsGroup { hs_tyclds = tycl_decls, 
		   hs_instds = inst_decls,
668
                   hs_derivds = deriv_decls,
669 670 671 672 673 674 675
		   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") ;
676

677 678
	tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
		-- If there are any errors, tcTyAndClassDecls fails here
679 680 681
	
	-- 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) ;
682 683


684 685 686 687
	setGblEnv tcg_env	$ do {
		-- Source-language instances, including derivings,
		-- and import the supporting declarations
        traceTc (text "Tc3") ;
688 689
	(tcg_env, inst_infos, deriv_binds) 
            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
690
	setGblEnv tcg_env	$ do {
691

692 693 694 695 696
	        -- 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 {
697

698 699 700 701
		-- Default declarations
        traceTc (text "Tc4a") ;
	default_tys <- tcDefaults default_decls ;
	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
702
	
703 704 705 706
		-- Value declarations next
		-- We also typecheck any extra binds that came out 
		-- of the "deriving" process (deriv_binds)
        traceTc (text "Tc5") ;
707
	(tc_val_binds,   tcl_env) <- tcTopBinds val_binds ;
708
	setLclTypeEnv tcl_env 	$ do {
709

710 711 712 713
		-- Now GHC-generated derived bindings and generics.
		-- Do not generate warnings from compiler-generated code.
	(tc_deriv_binds, tcl_env) <- discardWarnings $
                                 tcTopBinds deriv_binds ;
714

715 716
	     	-- Second pass over class and instance declarations, 
        traceTc (text "Tc6") ;
717
	(inst_binds, tcl_env)     <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ;
718
	showLIE (text "after instDecls2") ;
719

720 721 722 723
		-- Foreign exports
		-- They need to be zonked, so we return them
        traceTc (text "Tc7") ;
	(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
724

725 726
		-- Rules
	rules <- tcRules rule_decls ;
727

728 729 730 731
		-- Wrap up
        traceTc (text "Tc7a") ;
	tcg_env <- getGblEnv ;
	let { all_binds = tc_val_binds	 `unionBags`
732
			  tc_deriv_binds `unionBags`
733 734 735 736 737 738 739 740
			  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 } } ;
741
  	return (tcg_env', tcl_env)
742
    }}}}}}
743 744
\end{code}

745

746 747
%************************************************************************
%*									*
748
	Checking for 'main'
749 750 751 752
%*									*
%************************************************************************

\begin{code}
753 754
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
755
checkMain 
756
  = do { tcg_env   <- getGblEnv ;
757
	 dflags    <- getDOpts ;
758
	 check_main dflags tcg_env
759
    }
760

761
check_main dflags tcg_env
762
 | mod /= main_mod
763 764
 = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
   return tcg_env
765

766
 | otherwise
767
 = do	{ mb_main <- lookupSrcOcc_maybe main_fn
768 769 770
		-- Check that 'main' is in scope
		-- It might be imported from another module!
	; case mb_main of {
771 772
	     Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
			   ; complain_no_main	
773 774
			   ; return tcg_env } ;
	     Just main_name -> do
775

776
	{ traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
777 778 779 780 781 782
	; 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])
783

784
		-- See Note [Root-main Id]
785 786 787
	   	-- Construct the binding
		-- 	:Main.main :: IO res_ty = runMainIO res_ty main 
	; run_main_id <- tcLookupId runMainIOName
788
	; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
789
				   (mkVarOccFS FSLIT("main")) 
790
				   (getSrcSpan main_name)
791 792 793 794 795
	      ; 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) }
796

797 798 799 800
	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
					`snocBag` main_bind,
			    tcg_dus   = tcg_dus tcg_env
				        `plusDU` usesOnly (unitFV main_name)
801 802
			-- Record the use of 'main', so that we don't 
			-- complain about it being defined but not used
803 804 805
		 }) 
    }}}
  where
806 807 808 809 810 811 812 813
    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

814 815
    complain_no_main | ghcLink dflags == LinkInMemory = return ()
		     | otherwise = failWithTc noMainMsg
816 817 818
	-- 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.
819

820 821
    mainCtxt  = ptext SLIT("When checking the type of the") <+> pp_main_fn
    noMainMsg = ptext SLIT("The") <+> pp_main_fn
822
		<+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
823 824
    pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn)
	       | otherwise 	     = ptext SLIT("function") <+> quotes (ppr main_fn)
825
\end{code}
826

827 828 829 830 831 832 833 834 835 836 837 838 839
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!


840 841 842 843 844
%*********************************************************
%*						 	 *
		GHCi stuff
%*							 *
%*********************************************************
845

846 847
\begin{code}
#ifdef GHCI
848 849
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside 
850 851 852
  = 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)
853 854
    in
    updGblEnv (\env -> env { 
855 856 857 858 859
	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 
      }) $
860

861 862
    tcExtendGhciEnv (ic_tmp_ids icxt) $
        -- tcExtendGhciEnv does lots: 
863 864 865 866 867 868
        --   - 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.
        --
869 870
        -- later ids in ic_tmp_ids must shadow earlier ones with the same
        -- OccName, and tcExtendIdEnv implements this behaviour.
871

872
    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
873
 	; thing_inside }
874
\end{code}
875

876

877 878 879 880
\begin{code}
tcRnStmt :: HscEnv
	 -> InteractiveContext
	 -> LStmt RdrName
881 882 883 884
	 -> 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.
885 886 887
		--
		-- The returned TypecheckedHsExpr is of type IO [ () ],
		-- a list of the bound values, coerced to ().
888

889 890
tcRnStmt hsc_env ictxt rdr_stmt
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
891
    setInteractiveContext hsc_env ictxt $ do {
892

893
    -- Rename; use CmdLineMode because tcRnStmt is only used interactively
894
    (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
895 896
    traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
    failIfErrsM ;
897
    rnDump (ppr rn_stmt) ;
898 899
    
    -- The real work is done here
900 901 902
    (bound_ids, tc_expr) <- mkPlan rn_stmt ;
    zonked_expr <- zonkTopLExpr tc_expr ;
    zonked_ids  <- zonkTopBndrs bound_ids ;
903
    
904 905
	-- None of the Ids should be of unboxed type, because we
	-- cast them all to HValues in the end!
906
    mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
907

908
    traceTc (text "tcs 1") ;
909
    let { global_ids = map globaliseAndTidy zonked_ids } ;
910
    
911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927
{- ---------------------------------------------
   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

928
-------------------------------------------------- -}
929

930 931
    dumpOptTcRn Opt_D_dump_tc 
    	(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
932
    	       text "Typechecked expr" <+> ppr zonked_expr]) ;
933

934
    return (global_ids, zonked_expr)
935
    }
936 937 938
  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))])
939

simonpj's avatar