RnSource.lhs 33.8 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6
%
\section[RnSource]{Main pass of renamer}

\begin{code}
7
module RnSource ( 
8
	rnSrcDecls, checkModDeprec,
9
	rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, 
10
	rnBinds, rnBindsAndThen, rnStats,
11
    ) where
12

13
#include "HsVersions.h"
sof's avatar
sof committed
14

15
import HsSyn
16
import RdrName		( RdrName, isRdrDataCon, elemRdrEnv )
17
import RdrHsSyn		( RdrNameConDecl, RdrNameTyClDecl, 
18 19
			  RdrNameDeprecation, RdrNameFixitySig,
			  RdrNameHsBinds,
20
			  extractGenericPatTyVars
21
			)
22
import RnHsSyn
23
import HsCore
24
import RnExpr		( rnExpr )
25 26
import RnTypes		( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )

27
import RnBinds		( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, 
28
			  rnMonoBindsAndThen, renameSigs, checkSigs )
29 30
import RnEnv		( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
			  newLocalsRn, lookupGlobalOccRn,
31
			  bindLocalsFVRn, bindPatSigTyVars,
32
			  bindTyVarsRn, extendTyVarEnvFVRn,
33
			  bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
34 35
			  checkDupOrQualNames, checkDupNames, mapFvRn,
			  lookupTopSrcBndr_maybe, lookupTopSrcBndr,
36
			  dataTcOccs, newIPName, unknownNameErr
37
			)
38
import TcRnMonad
39

40 41 42 43
import BasicTypes	( FixitySig(..) )
import HscTypes		( ExternalPackageState(..), FixityEnv, 
			  Deprecations(..), plusDeprecs )
import Module		( moduleEnvElts )
44
import Class		( FunDep, DefMeth (..) )
45
import TyCon		( DataConDetails(..), visibleDataCons )
46
import Name		( Name )
47
import NameSet
48 49 50
import NameEnv
import ErrUtils		( dumpIfSet )
import PrelNames	( newStablePtrName, bindIOName, returnIOName )
51
import List		( partition )
52
import Bag		( bagToList )
53
import Outputable
54
import SrcLoc		( SrcLoc )
55
import CmdLineOpts	( DynFlag(..) )
56
				-- Warn of unused for-all'd tyvars
57 58
import Maybes		( maybeToBool, seqMaybe )
import Maybe            ( maybe, catMaybes, isNothing )
59 60
\end{code}

61
@rnSourceDecl@ `renames' declarations.
62 63 64 65 66 67
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\item
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
68 69
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
70 71 72
\item
Checks that all variable occurences are defined.
\item 
73
Checks the @(..)@ etc constraints in the export list.
74 75 76
\end{enumerate}


77
\begin{code}
78 79 80 81 82 83 84 85 86 87 88 89 90 91
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)

rnSrcDecls (HsGroup { hs_valds  = MonoBind binds sigs _,
		      hs_tyclds = tycl_decls,
		      hs_instds = inst_decls,
		      hs_fixds  = fix_decls,
		      hs_depds  = deprec_decls,
		      hs_fords  = foreign_decls,
		      hs_defds  = default_decls,
		      hs_ruleds = rule_decls,
		      hs_coreds = core_decls })

 = do {		-- Deal with deprecations (returns only the extra deprecations)
	deprecs <- rnSrcDeprecDecls deprec_decls ;
92 93 94 95 96
	updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
		  $ do {

		-- Deal with top-level fixity decls 
		-- (returns the total new fixity env)
97
	fix_env <- rnSrcFixityDecls fix_decls ;
98 99 100
	updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
		  $ do {

101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
		-- Rename other declarations
	(rn_val_decls, src_fvs1)     <- rnTopMonoBinds binds sigs ;
	(rn_inst_decls, src_fvs2)    <- mapFvRn rnSrcInstDecl inst_decls ;
	(rn_tycl_decls, src_fvs3)    <- mapFvRn rnSrcTyClDecl tycl_decls ;
	(rn_rule_decls, src_fvs4)    <- mapFvRn rnHsRuleDecl rule_decls ;
	(rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
	(rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
	(rn_core_decls,    src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
	
	let {
	   rn_group = HsGroup { hs_valds  = rn_val_decls,
			    	hs_tyclds = rn_tycl_decls,
			    	hs_instds = rn_inst_decls,
			    	hs_fixds  = [],
			    	hs_depds  = [],
			    	hs_fords  = rn_foreign_decls,
			    	hs_defds  = rn_default_decls,
			    	hs_ruleds = rn_rule_decls,
			    	hs_coreds = rn_core_decls } ;
	   src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
			      src_fvs5, src_fvs6, src_fvs7] } ;
122

123
	traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
124
	tcg_env <- getGblEnv ;
125 126
	return (tcg_env, rn_group, src_fvs)
    }}}
127 128 129 130 131 132 133 134 135 136
\end{code}


%*********************************************************
%*						 	 *
	Source-code fixity declarations
%*							 *
%*********************************************************

\begin{code}
137 138
rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
rnSrcFixityDecls fix_decls
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
  = getGblEnv					`thenM` \ gbl_env ->
    foldlM rnFixityDecl (tcg_fix_env gbl_env) 
	    fix_decls				`thenM` \ fix_env ->
    traceRn (text "fixity env" <+> ppr fix_env)	`thenM_`
    returnM fix_env

rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
  =	-- GHC extension: look up both the tycon and data con 
	-- for con-like things
	-- If neither are in scope, report an error; otherwise
	-- add both to the fixity env
     mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name)	`thenM` \ maybe_ns ->
     case catMaybes maybe_ns of
	  [] -> addSrcLoc loc 			$
		addErr (unknownNameErr rdr_name)	`thenM_`
	        returnM fix_env
	  ns -> foldlM add fix_env ns
  where
    add fix_env name 
      = case lookupNameEnv fix_env name of
          Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc')	`thenM_`
    				       returnM fix_env
    	  Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))

dupFixityDecl rdr_name loc1 loc2
  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
	  ptext SLIT("at ") <+> ppr loc1,
	  ptext SLIT("and") <+> ppr loc2]
\end{code}


%*********************************************************
%*						 	 *
	Source-code deprecations declarations
%*							 *
%*********************************************************

For deprecations, all we do is check that the names are in scope.
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.

\begin{code}
rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
rnSrcDeprecDecls [] 
  = returnM NoDeprecs

rnSrcDeprecDecls decls
  = mappM rn_deprec decls	`thenM` \ pairs ->
    returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
 where
   rn_deprec (Deprecation rdr_name txt loc)
     = addSrcLoc loc			$
       lookupTopSrcBndr rdr_name	`thenM` \ name ->
       returnM (Just (name, (name,txt)))

checkModDeprec :: Maybe DeprecTxt -> Deprecations
-- Check for a module deprecation; done once at top level
checkModDeprec Nothing    = NoDeprecs
checkModdeprec (Just txt) = DeprecAll txt

badDeprec d
  = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
	 nest 4 (ppr d)]
\end{code}
204

205 206 207 208 209
%*********************************************************
%*							*
\subsection{Source code declarations}
%*							*
%*********************************************************
210

211
\begin{code}
212
rnSrcTyClDecl tycl_decl
213 214
  = rnTyClDecl tycl_decl			`thenM` \ new_decl ->
    finishSourceTyClDecl tycl_decl new_decl	`thenM` \ (new_decl', fvs) ->
215
    returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
216

217
rnSrcInstDecl inst
218 219
  = rnInstDecl inst			`thenM` \ new_inst ->
    finishSourceInstDecl inst new_inst	`thenM` \ (new_inst', fvs) ->
220
    returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
221

222
rnDefaultDecl (DefaultDecl tys src_loc)
223 224
  = addSrcLoc src_loc $
    mapFvRn (rnHsTypeFVs doc_str) tys		`thenM` \ (tys', fvs) ->
225
    returnM (DefaultDecl tys' src_loc, fvs)
226
  where
227
    doc_str = text "In a `default' declaration"
228 229


230
rnCoreDecl (CoreDecl name ty rhs loc)
231 232 233 234
  = addSrcLoc loc $
    lookupTopBndrRn name		`thenM` \ name' ->
    rnHsTypeFVs doc_str ty		`thenM` \ (ty', ty_fvs) ->
    rnCoreExpr rhs                      `thenM` \ rhs' ->
235
    returnM (CoreDecl name' ty' rhs' loc, 
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
	     ty_fvs `plusFV` ufExprFVs rhs')
  where
    doc_str = text "In the Core declaration for" <+> quotes (ppr name)
\end{code}

%*********************************************************
%*							*
		Bindings
%*							*
%*********************************************************

These chaps are here, rather than in TcBinds, so that there
is just one hi-boot file (for RnSource).  rnSrcDecls is part
of the loop too, and it must be defined in this module.

\begin{code}
rnTopBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
rnTopBinds EmptyBinds		  = returnM (EmptyBinds, emptyFVs)
rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
  -- The parser doesn't produce other forms

257 258
rnBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
-- This version assumes that the binders are already in scope
259
-- It's used only in 'mdo'
260 261
rnBinds EmptyBinds	       = returnM (EmptyBinds, emptyFVs)
rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
262 263
rnBinds b@(IPBinds bind _)     = addErr (badIpBinds b)	`thenM_` 
			         returnM (EmptyBinds, emptyFVs)
264 265 266 267 268 269

rnBindsAndThen	:: RdrNameHsBinds 
		-> (RenamedHsBinds -> RnM (result, FreeVars))
		-> RnM (result, FreeVars)
-- This version (a) assumes that the binding vars are not already in scope
--		(b) removes the binders from the free vars of the thing inside
270 271 272 273 274
-- The parser doesn't produce ThenBinds
rnBindsAndThen EmptyBinds	       thing_inside = thing_inside EmptyBinds
rnBindsAndThen (MonoBind bind sigs _)  thing_inside = rnMonoBindsAndThen bind sigs thing_inside
rnBindsAndThen (IPBinds binds is_with) thing_inside
  = warnIf is_with withWarning			`thenM_`
275 276 277
    rnIPBinds binds				`thenM` \ (binds',fv_binds) ->
    thing_inside (IPBinds binds' is_with)	`thenM` \ (thing, fvs_thing) ->
    returnM (thing, fvs_thing `plusFV` fv_binds)
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
\end{code}


%************************************************************************
%*									*
\subsubsection{@rnIPBinds@s: in implicit parameter bindings}		*
%*									*
%************************************************************************

\begin{code}
rnIPBinds [] = returnM ([], emptyFVs)
rnIPBinds ((n, expr) : binds)
  = newIPName n			`thenM` \ name ->
    rnExpr expr			`thenM` \ (expr',fvExpr) ->
    rnIPBinds binds		`thenM` \ (binds',fvBinds) ->
    returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)

295
\end{code}
296 297


298 299 300 301 302 303 304
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
chak's avatar
chak committed
305
rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
306 307 308 309
  = addSrcLoc src_loc 		$
    lookupTopBndrRn name	        `thenM` \ name' ->
    rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
    returnM (ForeignImport name' ty' spec isDeprec src_loc, 
chak's avatar
chak committed
310
	      fvs `plusFV` extras spec)
311
  where
chak's avatar
chak committed
312 313 314
    extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
					       bindIOName, returnIOName]
    extras _			      = emptyFVs
315

chak's avatar
chak committed
316
rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
317 318 319 320
  = addSrcLoc src_loc 			$
    lookupOccRn name		        	`thenM` \ name' ->
    rnHsTypeFVs (fo_decl_msg name) ty  		`thenM` \ (ty', fvs) ->
    returnM (ForeignExport name' ty' spec isDeprec src_loc, 
321 322 323 324
	      mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
	-- NB: a foreign export is an *occurrence site* for name, so 
	--     we add it to the free-variable list.  It might, for example,
	--     be imported from another module
325

326
fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
327 328 329 330 331 332 333 334 335 336 337
\end{code}


%*********************************************************
%*							*
\subsection{Instance declarations}
%*							*
%*********************************************************

\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
338
	-- Used for both source and interface file decls
339 340
  = addSrcLoc src_loc $
    rnHsSigType (text "an instance decl") inst_ty	`thenM` \ inst_ty' ->
341 342

    (case maybe_dfun_rdr_name of
343 344 345 346
	Nothing		   -> returnM Nothing
	Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name	`thenM` \ dfun_name ->
			      returnM (Just dfun_name)
    )							`thenM` \ maybe_dfun_name ->
347 348

    -- The typechecker checks that all the bindings are for the right class.
349
    returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
350

351 352 353
-- Compare finishSourceTyClDecl
finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
		     (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
354 355 356
	-- Used for both source decls only
  = ASSERT( not (maybeToBool maybe_dfun_name) )	-- Source decl!
    let
357
	meth_doc    = text "In the bindings in an instance declaration"
358
	meth_names  = collectLocatedMonoBinders mbinds
359
	(inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
360 361 362 363 364 365
	-- (Slightly strangely) the forall-d tyvars scope over
	-- the method bindings too
    in

	-- Rename the bindings
	-- NB meth_names can be qualified!
366
    checkDupNames meth_doc meth_names 		`thenM_`
367
    extendTyVarEnvForMethodBinds inst_tyvars (		
368
	rnMethodBinds cls [] mbinds
369
    )						`thenM` \ (mbinds', meth_fvs) ->
370
    let 
371
	binders = collectMonoBinders mbinds'
372 373 374 375 376 377 378 379
    in
	-- Rename the prags and signatures.
	-- Note that the type variables are not in scope here,
	-- so that	instance Eq a => Eq (T a) where
	--			{-# SPECIALISE instance Eq a => Eq (T [a]) #-}
	-- works OK. 
	--
	-- But the (unqualified) method names are in scope
380 381
    bindLocalNames binders (renameSigs uprags)			`thenM` \ uprags' ->
    checkSigs okInstDclSig (mkNameSet binders) uprags'		`thenM_`
382

383
    returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
384
	      meth_fvs `plusFV` hsSigsFVs uprags')
385 386 387 388 389 390 391 392 393
\end{code}

%*********************************************************
%*							*
\subsection{Rules}
%*							*
%*********************************************************

\begin{code}
394
rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
395 396
  = addSrcLoc src_loc	$
    lookupOccRn fn		`thenM` \ fn' ->
397
    rnCoreBndrs vars		$ \ vars' ->
398 399 400
    mappM rnCoreExpr args	`thenM` \ args' ->
    rnCoreExpr rhs		`thenM` \ rhs' ->
    returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
401

402
rnIfaceRuleDecl (IfaceRuleOut fn rule)		-- Builtin rules come this way
403 404
  = lookupOccRn fn		`thenM` \ fn' ->
    returnM (IfaceRuleOut fn' rule)
405

406
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
407
  = addSrcLoc src_loc				$
408
    bindPatSigTyVars (collectRuleBndrSigTys vars)	$
409 410

    bindLocalsFVRn doc (map get_var vars)	$ \ ids ->
411
    mapFvRn rn_var (vars `zip` ids)		`thenM` \ (vars', fv_vars) ->
412

413 414
    rnExpr lhs					`thenM` \ (lhs', fv_lhs) ->
    rnExpr rhs					`thenM` \ (rhs', fv_rhs) ->
415 416 417 418 419
    let
	mb_bad = validRuleLhs ids lhs'
    in
    checkErr (isNothing mb_bad)
	     (badRuleLhsErr rule_name lhs' mb_bad)	`thenM_`
420 421 422
    let
	bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
    in
423 424
    mappM (addErr . badRuleVar rule_name) bad_vars	`thenM_`
    returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
425 426
	      fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
  where
427
    doc = text "In the transformation rule" <+> ftext rule_name
428 429 430 431
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

432 433 434 435 436 437 438
    rn_var (RuleBndr v, id)	 = returnM (RuleBndr id, emptyFVs)
    rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
				   returnM (RuleBndrSig id t', fvs)
\end{code}

Check the shape of a transformation rule LHS.  Currently
we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
439 440 441
not one of the @forall@'d variables.  We also restrict the form of the LHS so
that it may be plausibly matched.  Basically you only get to write ordinary 
applications.  (E.g. a case expression is not allowed: too elaborate.)
442

443 444
NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs

445
\begin{code}
446 447 448
validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
-- Nothing => OK
-- Just e  => Not ok, and e is the offending expression
449 450 451
validRuleLhs foralls lhs
  = check lhs
  where
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469
    check (OpApp e1 op _ e2)		  = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
    check (HsApp e1 e2) 		  = check e1 `seqMaybe` check_e e2
    check (HsVar v) | v `notElem` foralls = Nothing
    check other				  = Just other 	-- Failure

    check_e (HsVar v)     = Nothing
    check_e (HsPar e) 	  = check_e e
    check_e (HsLit e) 	  = Nothing
    check_e (HsOverLit e) = Nothing

    check_e (OpApp e1 op _ e2) 	 = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
    check_e (HsApp e1 e2)      	 = check_e e1 `seqMaybe` check_e e2
    check_e (NegApp e _)       	 = check_e e
    check_e (ExplicitList _ es)	 = check_es es
    check_e (ExplicitTuple es _) = check_es es
    check_e other		 = Just other	-- Fails

    check_es es = foldr (seqMaybe . check_e) Nothing es
470 471
\end{code}

472

473 474
%*********************************************************
%*							*
475
\subsection{Type, class and iface sig declarations}
476 477 478 479 480 481 482 483 484
%*							*
%*********************************************************

@rnTyDecl@ uses the `global name function' to create a new type
declaration in which local names have been replaced by their original
names, reporting any unknown names.

Renaming type variables is a pain. Because they now contain uniques,
it is necessary to pass in an association list which maps a parsed
485 486 487 488 489 490
tyvar to its @Name@ representation.
In some cases (type signatures of values),
it is even necessary to go over the type first
in order to get the set of tyvars used by it, make an assoc list,
and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
491 492

\begin{code}
493
rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
494 495 496 497 498
  = addSrcLoc loc $
    lookupTopBndrRn name		`thenM` \ name' ->
    rnHsType doc_str ty			`thenM` \ ty' ->
    mappM rnIdInfo id_infos		`thenM` \ id_infos' -> 
    returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
499
  where
500
    doc_str = text "In the interface signature for" <+> quotes (ppr name)
501

502
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
503 504 505
  = addSrcLoc loc 			$
    lookupTopBndrRn name		`thenM` \ name' ->
    returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
506

507
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
508 509 510 511
		    tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
		    tcdDerivs = derivs, tcdLoc = src_loc})
  = addSrcLoc src_loc $
    lookupTopBndrRn tycon		    	`thenM` \ tycon' ->
512
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
513 514 515 516 517 518 519 520
    rnContext data_doc context 			`thenM` \ context' ->
    rn_derivs derivs 				`thenM` \ derivs' ->
    checkDupOrQualNames data_doc con_names	`thenM_`

    rnConDecls tycon' condecls			`thenM` \ condecls' ->
    returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
		     tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
		     tcdDerivs = derivs', tcdLoc = src_loc})
sof's avatar
sof committed
521
  where
522
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
523
    con_names = map conDeclName (visibleDataCons condecls)
524

525 526
    rn_derivs Nothing   = returnM Nothing
    rn_derivs (Just ds) = rnContext data_doc ds	`thenM` \ ds' -> returnM (Just ds')
527
    
528
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
529 530
  = addSrcLoc src_loc $
    lookupTopBndrRn name			`thenM` \ name' ->
531
    bindTyVarsRn syn_doc tyvars 		$ \ tyvars' ->
532 533
    rnHsType syn_doc ty				`thenM` \ ty' ->
    returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
sof's avatar
sof committed
534
  where
535
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
536

537 538
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
539
		       tcdLoc = src_loc})
540
	-- Used for both source and interface file decls
541
  = addSrcLoc src_loc $
sof's avatar
sof committed
542

543
    lookupTopBndrRn cname			`thenM` \ cname' ->
sof's avatar
sof committed
544

545
	-- Tyvars scope over superclass context and method signatures
546
    bindTyVarsRn cls_doc tyvars			$ \ tyvars' ->
547 548

	-- Check the superclasses
549
    rnContext cls_doc context			`thenM` \ context' ->
550

551
	-- Check the functional dependencies
552
    rnFds cls_doc fds				`thenM` \ fds' ->
553

554
	-- Check the signatures
555
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
556
    let
557 558
	(op_sigs, non_op_sigs) = partition isClassOpSig sigs
	sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
559
    in
560 561
    checkDupOrQualNames sig_doc sig_rdr_names_w_locs	`thenM_` 
    mappM (rnClassOp cname' fds') op_sigs		`thenM` \ sigs' ->
sof's avatar
sof committed
562
    let
563
	binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
sof's avatar
sof committed
564
    in
565 566
    renameSigs non_op_sigs			`thenM` \ non_ops' ->
    checkSigs okClsDclSig binders non_ops'	`thenM_`
567 568 569 570 571
	-- Typechecker is responsible for checking that we only
	-- give default-method bindings for things in this class.
	-- The renamer *could* check this for class decls, but can't
	-- for instance decls.

572 573 574
    returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
			 tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, 
			 tcdLoc = src_loc})
575
  where
576 577
    cls_doc  = text "In the declaration for class" 	<+> ppr cname
    sig_doc  = text "In the signatures for class"  	<+> ppr cname
578

579
rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
580 581
  = addSrcLoc locn $
    lookupTopBndrRn op			`thenM` \ op_name ->
582 583
    
    	-- Check the signature
584
    rnHsSigType (quotes (ppr op)) ty	`thenM` \ new_ty ->
585 586
    
    	-- Make the default-method name
587 588
    (case dm_stuff of 
        DefMeth dm_rdr_name
589
    	    -> 	-- Imported class that has a default method decl
590 591
    	    	lookupSysBndr dm_rdr_name 	`thenM` \ dm_name ->
		returnM (DefMeth dm_name)
592 593 594 595
	    		-- An imported class decl for a class decl that had an explicit default
	    		-- method, mentions, rather than defines,
	    		-- the default method, so we must arrange to pull it in

596 597 598
        GenDefMeth -> returnM GenDefMeth
        NoDefMeth  -> returnM NoDefMeth
    )						`thenM` \ dm_stuff' ->
599
    
600
    returnM (ClassOpSig op_name dm_stuff' new_ty locn)
601

602
finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
603
	-- Used for source file decls only
604 605
	-- Renames the default-bindings of a class decl
finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})	-- Get mbinds from here
606
	 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars})		-- Everything else is here
607 608
  -- There are some default-method bindings (abeit possibly empty) so 
  -- this is a source-code class declaration
609
  = 	-- The newLocals call is tiresome: given a generic class decl
610 611 612 613 614 615 616 617
	--	class C a where
	--	  op :: a -> a
	--	  op {| x+y |} (Inl a) = ...
	--	  op {| x+y |} (Inr b) = ...
	--	  op {| a*b |} (a*b)   = ...
	-- we want to name both "x" tyvars with the same unique, so that they are
	-- easy to group together in the typechecker.  
	-- Hence the 
618
    addSrcLoc src_loc				$
619
    extendTyVarEnvForMethodBinds tyvars			$
620
    getLocalRdrEnv					`thenM` \ name_env ->
621 622 623
    let
	meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
	gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
624
						not (tv `elemRdrEnv` name_env)]
625
    in
626 627 628 629
    checkDupOrQualNames meth_doc meth_rdr_names_w_locs	`thenM_`
    newLocalsRn gen_rdr_tyvars_w_locs			`thenM` \ gen_tyvars ->
    rnMethodBinds cls gen_tyvars mbinds			`thenM` \ (mbinds', meth_fvs) ->
    returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
630
  where
631
    meth_doc = text "In the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
632

633 634 635 636 637 638
finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
  -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
  -- This is important, because tyClDeclFVs should contain only the
  -- FVs that are `needed' by the interface file declaration, and
  -- derivings do not appear in this.  It also means that the tcGroups
  -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
639
  = returnM (tycl_decl,
640 641
              maybe emptyFVs extractHsCtxtTyNames derivings)

642
finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
643
	-- Not a class declaration
644 645
\end{code}

646 647 648 649 650
For the method bindings in class and instance decls, we extend the 
type variable environment iff -fglasgow-exts

\begin{code}
extendTyVarEnvForMethodBinds tyvars thing_inside
651
  = doptM Opt_GlasgowExts			`thenM` \ opt_GlasgowExts ->
652 653 654 655 656 657
    if opt_GlasgowExts then
	extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
    else
	thing_inside
\end{code}

658 659 660

%*********************************************************
%*							*
661
\subsection{Support code for type/data declarations}
662 663 664 665
%*							*
%*********************************************************

\begin{code}
sof's avatar
sof committed
666
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
667
conDeclName (ConDecl n _ _ _ l) = (n,l)
668

669 670 671
rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
rnConDecls tycon Unknown     = returnM Unknown
rnConDecls tycon (HasCons n) = returnM (HasCons n)
672 673 674 675
rnConDecls tycon (DataCons condecls)
  = 	-- Check that there's at least one condecl,
	-- or else we're reading an interface file, or -fglasgow-exts
    (if null condecls then
676 677 678
	doptM Opt_GlasgowExts	`thenM` \ glaExts ->
	getModeRn		`thenM` \ mode ->
	checkErr (glaExts || isInterfaceMode mode)
679
		(emptyConDeclsErr tycon)
680 681
     else returnM ()
    )						`thenM_` 
682

683 684
    mappM rnConDecl condecls			`thenM` \ condecls' ->
    returnM (DataCons condecls')
685

686 687 688 689 690
rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
rnConDecl (ConDecl name tvs cxt details locn)
  = addSrcLoc locn $
    checkConName name		`thenM_` 
    lookupTopBndrRn name	`thenM` \ new_name ->
691

692
    bindTyVarsRn doc tvs 		$ \ new_tyvars ->
693 694 695
    rnContext doc cxt			`thenM` \ new_context ->
    rnConDetails doc locn details	`thenM` \ new_details -> 
    returnM (ConDecl new_name new_tyvars new_context new_details locn)
696
  where
697
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
sof's avatar
sof committed
698

699 700 701
rnConDetails doc locn (PrefixCon tys)
  = mappM (rnBangTy doc) tys	`thenM` \ new_tys  ->
    returnM (PrefixCon new_tys)
sof's avatar
sof committed
702

703
rnConDetails doc locn (InfixCon ty1 ty2)
704 705 706
  = rnBangTy doc ty1  		`thenM` \ new_ty1 ->
    rnBangTy doc ty2  		`thenM` \ new_ty2 ->
    returnM (InfixCon new_ty1 new_ty2)
707

708
rnConDetails doc locn (RecCon fields)
709 710 711
  = checkDupOrQualNames doc field_names	`thenM_`
    mappM (rnField doc) fields		`thenM` \ new_fields ->
    returnM (RecCon new_fields)
sof's avatar
sof committed
712
  where
713
    field_names = [(fld, locn) | (fld, _) <- fields]
714

715 716 717 718
rnField doc (name, ty)
  = lookupTopBndrRn name	`thenM` \ new_name ->
    rnBangTy doc ty		`thenM` \ new_ty ->
    returnM (new_name, new_ty) 
719

720
rnBangTy doc (BangType s ty)
721 722
  = rnHsType doc ty		`thenM` \ new_ty ->
    returnM (BangType s new_ty)
723

724 725 726 727 728 729 730 731 732 733 734
-- This data decl will parse OK
--	data T = a Int
-- treating "a" as the constructor.
-- It is really hard to make the parser spot this malformation.
-- So the renamer has to check that the constructor is legal
--
-- We can get an operator as the constructor, even in the prefix form:
--	data T = :% Int Int
-- from interface files, which always print in prefix form

checkConName name
735
  = checkErr (isRdrDataCon name) (badDataCon name)
736 737
\end{code}

738

739 740 741 742 743
%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************
744

745
\begin{code}
746
rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
747 748

rnFds doc fds
749
  = mappM rn_fds fds
750 751
  where
    rn_fds (tys1, tys2)
752 753 754
      =	rnHsTyVars doc tys1		`thenM` \ tys1' ->
	rnHsTyVars doc tys2		`thenM` \ tys2' ->
	returnM (tys1', tys2')
755

756
rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
757
rnHsTyvar doc tyvar = lookupOccRn tyvar
758
\end{code}
759

760
%*********************************************************
761
%*							 *
762
\subsection{IdInfo}
763
%*							 *
764 765
%*********************************************************

766
\begin{code}
767
rnIdInfo (HsWorker worker arity)
768 769 770 771 772 773 774 775
  = lookupOccRn worker			`thenM` \ worker' ->
    returnM (HsWorker worker' arity)

rnIdInfo (HsUnfold inline expr)	= rnCoreExpr expr `thenM` \ expr' ->
				  returnM (HsUnfold inline expr')
rnIdInfo (HsStrictness str)     = returnM (HsStrictness str)
rnIdInfo (HsArity arity)	= returnM (HsArity arity)
rnIdInfo HsNoCafRefs		= returnM HsNoCafRefs
776 777
\end{code}

778
@UfCore@ expressions.
779 780

\begin{code}
781
rnCoreExpr (UfType ty)
782 783
  = rnHsType (text "unfolding type") ty	`thenM` \ ty' ->
    returnM (UfType ty')
784

785
rnCoreExpr (UfVar v)
786 787
  = lookupOccRn v 	`thenM` \ v' ->
    returnM (UfVar v')
788

789
rnCoreExpr (UfLit l)
790
  = returnM (UfLit l)
791 792

rnCoreExpr (UfLitLit l ty)
793 794
  = rnHsType (text "litlit") ty	`thenM` \ ty' ->
    returnM (UfLitLit l ty')
795

796
rnCoreExpr (UfFCall cc ty)
797 798
  = rnHsType (text "ccall") ty	`thenM` \ ty' ->
    returnM (UfFCall cc ty')
799

800 801 802
rnCoreExpr (UfTuple (HsTupCon boxity arity) args) 
  = mappM rnCoreExpr args		`thenM` \ args' ->
    returnM (UfTuple (HsTupCon boxity arity) args')
803 804

rnCoreExpr (UfApp fun arg)
805 806 807
  = rnCoreExpr fun		`thenM` \ fun' ->
    rnCoreExpr arg		`thenM` \ arg' ->
    returnM (UfApp fun' arg')
808 809

rnCoreExpr (UfCase scrut bndr alts)
810
  = rnCoreExpr scrut			`thenM` \ scrut' ->
811
    bindCoreLocalRn bndr		$ \ bndr' ->
812 813
    mappM rnCoreAlt alts		`thenM` \ alts' ->
    returnM (UfCase scrut' bndr' alts')
814

815
rnCoreExpr (UfNote note expr) 
816 817 818
  = rnNote note			`thenM` \ note' ->
    rnCoreExpr expr		`thenM` \ expr' ->
    returnM  (UfNote note' expr')
819 820 821

rnCoreExpr (UfLam bndr body)
  = rnCoreBndr bndr 		$ \ bndr' ->
822 823
    rnCoreExpr body		`thenM` \ body' ->
    returnM (UfLam bndr' body')
824 825

rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
826
  = rnCoreExpr rhs		`thenM` \ rhs' ->
827
    rnCoreBndr bndr 		$ \ bndr' ->
828 829
    rnCoreExpr body		`thenM` \ body' ->
    returnM (UfLet (UfNonRec bndr' rhs') body')
830 831 832

rnCoreExpr (UfLet (UfRec pairs) body)
  = rnCoreBndrs bndrs		$ \ bndrs' ->
833 834 835
    mappM rnCoreExpr rhss	`thenM` \ rhss' ->
    rnCoreExpr body		`thenM` \ body' ->
    returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
836
  where
837 838 839 840 841
    (bndrs, rhss) = unzip pairs
\end{code}

\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
842
  = rnHsType doc ty		`thenM` \ ty' ->
843 844
    bindCoreLocalRn name	$ \ name' ->
    thing_inside (UfValBinder name' ty')
845
  where
846
    doc = text "unfolding id"
847 848
    
rnCoreBndr (UfTyBinder name kind) thing_inside
849
  = bindCoreLocalRn name		$ \ name' ->
850 851
    thing_inside (UfTyBinder name' kind)
    
852 853 854 855
rnCoreBndrs []     thing_inside = thing_inside []
rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b		$ \ name' ->
				  rnCoreBndrs bs 	$ \ names' ->
				  thing_inside (name':names')
856 857 858
\end{code}    

\begin{code}
859
rnCoreAlt (con, bndrs, rhs)
860
  = rnUfCon con 			`thenM` \ con' ->
861
    bindCoreLocalsRn bndrs		$ \ bndrs' ->
862 863
    rnCoreExpr rhs			`thenM` \ rhs' ->
    returnM (con', bndrs', rhs')
864

865
rnNote (UfCoerce ty)
866 867
  = rnHsType (text "unfolding coerce") ty	`thenM` \ ty' ->
    returnM (UfCoerce ty')
868

869 870 871
rnNote (UfSCC cc)   = returnM (UfSCC cc)
rnNote UfInlineCall = returnM UfInlineCall
rnNote UfInlineMe   = returnM UfInlineMe
872
rnNote (UfCoreNote s) = returnM (UfCoreNote s)
873

874
rnUfCon UfDefault
875
  = returnM UfDefault
876

877 878
rnUfCon (UfTupleAlt tup_con)
  = returnM (UfTupleAlt tup_con)
879

880
rnUfCon (UfDataAlt con)
881 882
  = lookupOccRn con		`thenM` \ con' ->
    returnM (UfDataAlt con')
883

884
rnUfCon (UfLitAlt lit)
885
  = returnM (UfLitAlt lit)
886

887
rnUfCon (UfLitLitAlt lit ty)
888 889
  = rnHsType (text "litlit") ty		`thenM` \ ty' ->
    returnM (UfLitLitAlt lit ty')
890
\end{code}
891

892
%*********************************************************
893 894 895
%*							*
\subsection{Statistics}
%*							*
896 897 898
%*********************************************************

\begin{code}
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914
rnStats :: [RenamedHsDecl]	-- Imported decls
	-> TcRn m ()
rnStats imp_decls
  = doptM Opt_D_dump_rn_trace 	`thenM` \ dump_rn_trace ->
    doptM Opt_D_dump_rn_stats 	`thenM` \ dump_rn_stats ->
    doptM Opt_D_dump_rn 	`thenM` \ dump_rn ->
    getEps			`thenM` \ eps ->

    ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
		        "Renamer statistics"
		        (getRnStats eps imp_decls))	`thenM_`
    returnM ()

getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
getRnStats eps imported_decls
  = hcat [text "Renamer stats: ", stats]
915
  where
916 917
    n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
	-- This is really only right for a one-shot compile
918

919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943
    (decls_map, n_decls_slurped) = eps_decls eps
    
    n_decls_left   = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
    			-- Data, newtype, and class decls are in the decls_fm
    			-- under multiple names; the tycon/class, and each
    			-- constructor/class op too.
    			-- The 'True' selects just the 'main' decl
    		     ]
    
    (insts_left, n_insts_slurped) = eps_insts eps
    n_insts_left  = length (bagToList insts_left)
    
    (rules_left, n_rules_slurped) = eps_rules eps
    n_rules_left  = length (bagToList rules_left)
    
    stats = vcat 
    	[int n_mods <+> text "interfaces read",
    	 hsep [ int n_decls_slurped, text "type/class/variable imported, out of", 
    	        int (n_decls_slurped + n_decls_left), text "read"],
    	 hsep [ int n_insts_slurped, text "instance decls imported, out of",  
    	        int (n_insts_slurped + n_insts_left), text "read"],
    	 hsep [ int n_rules_slurped, text "rule decls imported, out of",  
    	        int (n_rules_slurped + n_rules_left), text "read"]
	]
\end{code}    
944

945
%*********************************************************
946
%*							 *
947
\subsection{Errors}
948
%*							 *
949
%*********************************************************
950

951
\begin{code}
952 953
badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
954

955
badRuleLhsErr name lhs (Just bad_e)