RnSource.lhs 25.3 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 9
	rnSrcDecls, addTcgDUs, 
	rnTyClDecls, checkModDeprec,
10
	rnSplice, checkTH
11
    ) where
12

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

15 16
import {-# SOURCE #-} RnExpr( rnLExpr )

17
import HsSyn
18 19
import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
			  GlobalRdrElt(..), isLocalGRE )
20
import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
21
import RnHsSyn
22
import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
23 24
import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv		( lookupLocalDataTcNames,
25
			  lookupLocatedTopBndrRn, lookupLocatedOccRn,
26
			  lookupOccRn, newLocalsRn, 
27
			  bindLocatedLocalsFV, bindPatSigTyVarsFV,
28
			  bindTyVarsRn, extendTyVarEnvFVRn,
29
			  bindLocalNames, checkDupNames, mapFvRn
30
			)
31
import TcRnMonad
32

33 34 35
import HscTypes		( FixityEnv, FixItem(..),
			  Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
import Class		( FunDep )
36
import Name		( Name, nameOccName )
37
import NameSet
38
import NameEnv
39
import OccName		( occEnvElts )
40
import Outputable
41
import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
42
import DynFlags	( DynFlag(..) )
43
import Maybes		( seqMaybe )
44
import Maybe            ( isNothing )
45
import BasicTypes       ( Boxity(..) )
46 47
\end{code}

48
@rnSourceDecl@ `renames' declarations.
49 50 51 52 53 54
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.
55 56
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
57 58 59
\item
Checks that all variable occurences are defined.
\item 
60
Checks the @(..)@ etc constraints in the export list.
61 62 63
\end{enumerate}


64
\begin{code}
65
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
66

67
rnSrcDecls (HsGroup { hs_valds  = val_decls,
68 69 70 71 72 73
		      hs_tyclds = tycl_decls,
		      hs_instds = inst_decls,
		      hs_fixds  = fix_decls,
		      hs_depds  = deprec_decls,
		      hs_fords  = foreign_decls,
		      hs_defds  = default_decls,
74
		      hs_ruleds = rule_decls })
75 76 77

 = do {		-- Deal with deprecations (returns only the extra deprecations)
	deprecs <- rnSrcDeprecDecls deprec_decls ;
78 79 80 81 82
	updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
		  $ do {

		-- Deal with top-level fixity decls 
		-- (returns the total new fixity env)
83 84
	fix_env <- rnSrcFixityDeclsEnv fix_decls ;
        rn_fix_decls <- rnSrcFixityDecls fix_decls ;
85 86 87
	updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
		  $ do {

88
		-- Rename other declarations
89
	traceRn (text "Start rnmono") ;
90
	(rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
91
	traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
92 93 94 95 96 97 98 99

		-- You might think that we could build proper def/use information
		-- for type and class declarations, but they can be involved
		-- in mutual recursion across modules, and we only do the SCC
		-- analysis for them in the type checker.
		-- So we content ourselves with gathering uses only; that
		-- means we'll only report a declaration as unused if it isn't
		-- mentioned at all.  Ah well.
100 101 102 103 104 105 106 107 108 109
	(rn_tycl_decls,    src_fvs1)
	   <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
	(rn_inst_decls,    src_fvs2)
	   <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
	(rn_rule_decls,    src_fvs3)
	   <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
	(rn_foreign_decls, src_fvs4)
	   <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
	(rn_default_decls, src_fvs5)
	   <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
110 111 112 113 114
	
	let {
	   rn_group = HsGroup { hs_valds  = rn_val_decls,
			    	hs_tyclds = rn_tycl_decls,
			    	hs_instds = rn_inst_decls,
115
			    	hs_fixds  = rn_fix_decls,
116 117 118
			    	hs_depds  = [],
			    	hs_fords  = rn_foreign_decls,
			    	hs_defds  = rn_default_decls,
119
			    	hs_ruleds = rn_rule_decls } ;
120

121
	   other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, 
122
				src_fvs4, src_fvs5] ;
123
	   src_dus = bind_dus `plusDU` usesOnly other_fvs 
124 125 126 127
		-- Note: src_dus will contain *uses* for locally-defined types
		-- and classes, but no *defs* for them.  (Because rnTyClDecl 
		-- returns only the uses.)  This is a little 
		-- surprising but it doesn't actually matter at all.
128 129
	} ;

130
	traceRn (text "finish rnSrc" <+> ppr rn_group) ;
131
	traceRn (text "finish Dus" <+> ppr src_dus ) ;
132
	tcg_env <- getGblEnv ;
133
	return (tcg_env `addTcgDUs` src_dus, rn_group)
134
    }}}
135 136 137 138 139

rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
rnTyClDecls tycl_decls = do 
  (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
  return decls'
140 141 142

addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
143 144 145 146 147 148 149 150 151 152
\end{code}


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

\begin{code}
153
rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
154
rnSrcFixityDecls fix_decls
155 156 157 158 159 160 161 162 163 164 165
    = do fix_decls <- mapM rnFixityDecl fix_decls
         return (concat fix_decls)

rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
    = do names <- lookupLocalDataTcNames rdr_name
         return [ L loc (FixitySig (L nameLoc name) fixity)
                      | name <- names ]

rnSrcFixityDeclsEnv :: [LFixitySig RdrName] -> RnM FixityEnv
rnSrcFixityDeclsEnv fix_decls
166
  = getGblEnv					`thenM` \ gbl_env ->
167
    foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) 
168 169
	    fix_decls				 	`thenM` \ fix_env ->
    traceRn (text "fixity env" <+> pprFixEnv fix_env)	`thenM_`
170 171
    returnM fix_env

172 173
rnFixityDeclEnv :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
rnFixityDeclEnv fix_env (L loc (FixitySig rdr_name fixity))
174
  = setSrcSpan loc $
175
        -- GHC extension: look up both the tycon and data con 
176 177 178
	-- for con-like things
	-- If neither are in scope, report an error; otherwise
	-- add both to the fixity env
179 180
     addLocM lookupLocalDataTcNames rdr_name	`thenM` \ names ->
     foldlM add fix_env names
181
  where
182
    add fix_env name
183
      = case lookupNameEnv fix_env name of
184
          Just (FixItem _ _ loc') 
185
		  -> addLocErr rdr_name (dupFixityDecl loc')	`thenM_`
186 187 188
    		     returnM fix_env
    	  Nothing -> returnM (extendNameEnv fix_env name fix_item)
      where
189
	fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
190 191 192 193 194

pprFixEnv :: FixityEnv -> SDoc
pprFixEnv env 
  = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
		  (nameEnvElts env)
195

196
dupFixityDecl loc rdr_name
197
  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
198 199
	  ptext SLIT("also at ") <+> ppr loc
	]
200 201 202 203 204 205 206 207 208 209 210 211 212 213
\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}
214
rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
215 216 217 218
rnSrcDeprecDecls [] 
  = returnM NoDeprecs

rnSrcDeprecDecls decls
219 220
  = mappM (addLocM rn_deprec) decls	`thenM` \ pairs_s ->
    returnM (DeprecSome (mkNameEnv (concat pairs_s)))
221
 where
222
   rn_deprec (Deprecation rdr_name txt)
223 224
     = lookupLocalDataTcNames rdr_name	`thenM` \ names ->
       returnM [(name, (nameOccName name, txt)) | name <- names]
225 226 227 228

checkModDeprec :: Maybe DeprecTxt -> Deprecations
-- Check for a module deprecation; done once at top level
checkModDeprec Nothing    = NoDeprecs
229
checkModDeprec (Just txt) = DeprecAll txt
230
\end{code}
231

232 233 234 235 236
%*********************************************************
%*							*
\subsection{Source code declarations}
%*							*
%*********************************************************
237

238
\begin{code}
239 240 241
rnDefaultDecl (DefaultDecl tys)
  = mapFvRn (rnHsTypeFVs doc_str) tys	`thenM` \ (tys', fvs) ->
    returnM (DefaultDecl tys', fvs)
242
  where
243
    doc_str = text "In a `default' declaration"
244 245
\end{code}

246 247 248 249 250 251 252
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
253 254
rnHsForeignDecl (ForeignImport name ty spec isDeprec)
  = lookupLocatedTopBndrRn name	        `thenM` \ name' ->
255
    rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
256
    returnM (ForeignImport name' ty' spec isDeprec, fvs)
257

258 259
rnHsForeignDecl (ForeignExport name ty spec isDeprec)
  = lookupLocatedOccRn name	        `thenM` \ name' ->
260
    rnHsTypeFVs (fo_decl_msg name) ty  	`thenM` \ (ty', fvs) ->
261
    returnM (ForeignExport name' ty' spec isDeprec, fvs )
262 263 264
	-- 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
265

266
fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
267 268 269 270 271 272 273 274 275 276
\end{code}


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

\begin{code}
277
rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
278
	-- Used for both source and interface file decls
279
  = rnHsSigType (text "an instance decl") inst_ty	`thenM` \ inst_ty' ->
280

281 282 283
	-- Rename the bindings
	-- The typechecker (not the renamer) checks that all 
	-- the bindings are for the right class
284
    let
285
	meth_doc    = text "In the bindings in an instance declaration"
286 287
	meth_names  = collectHsBindLocatedBinders mbinds
	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
288
    in
289
    checkDupNames meth_doc meth_names 	`thenM_`
290
    extendTyVarEnvForMethodBinds inst_tyvars (		
291 292
	-- (Slightly strangely) the forall-d tyvars scope over
	-- the method bindings too
293
	rnMethodBinds cls [] mbinds
294
    )						`thenM` \ (mbinds', meth_fvs) ->
295 296 297 298 299 300 301
	-- 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
302
    let 
303
	binders = collectHsBindBinders mbinds'
304
	ok_sig  = okInstDclSig (mkNameSet binders)
305
    in
306
    bindLocalNames binders (renameSigs ok_sig uprags)	`thenM` \ uprags' ->
307

308 309
    returnM (InstDecl inst_ty' mbinds' uprags',
	     meth_fvs `plusFV` hsSigsFVs uprags'
310
		      `plusFV` extractHsTyNames inst_ty')
311 312
\end{code}

313 314 315 316 317 318 319
For the method bindings in class and instance decls, we extend the 
type variable environment iff -fglasgow-exts

\begin{code}
extendTyVarEnvForMethodBinds tyvars thing_inside
  = doptM Opt_GlasgowExts			`thenM` \ opt_GlasgowExts ->
    if opt_GlasgowExts then
320
	extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
321 322 323 324 325
    else
	thing_inside
\end{code}


326 327 328 329 330 331 332
%*********************************************************
%*							*
\subsection{Rules}
%*							*
%*********************************************************

\begin{code}
333
rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
334
  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)	$
335

336
    bindLocatedLocalsFV doc (map get_var vars)		$ \ ids ->
337
    mapFvRn rn_var (vars `zip` ids)		`thenM` \ (vars', fv_vars) ->
338

339 340
    rnLExpr lhs					`thenM` \ (lhs', fv_lhs') ->
    rnLExpr rhs					`thenM` \ (rhs', fv_rhs') ->
341 342 343 344 345
    let
	mb_bad = validRuleLhs ids lhs'
    in
    checkErr (isNothing mb_bad)
	     (badRuleLhsErr rule_name lhs' mb_bad)	`thenM_`
346
    let
347
	bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
348
    in
349
    mappM (addErr . badRuleVar rule_name) bad_vars	`thenM_`
350 351
    returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
	     fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
352
  where
353
    doc = text "In the transformation rule" <+> ftext rule_name
354 355 356 357
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

358 359 360 361 362
    rn_var (RuleBndr (L loc v), id)
	= returnM (RuleBndr (L loc id), emptyFVs)
    rn_var (RuleBndrSig (L loc v) t, id)
	= rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
	  returnM (RuleBndrSig (L loc id) t', fvs)
363 364 365 366
\end{code}

Check the shape of a transformation rule LHS.  Currently
we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
367 368 369
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.)
370

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

373
\begin{code}
374
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
375 376
-- Nothing => OK
-- Just e  => Not ok, and e is the offending expression
377
validRuleLhs foralls lhs
378
  = checkl lhs
379
  where
380 381 382 383
    checkl (L loc e) = check e

    check (OpApp e1 op _ e2)		  = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
    check (HsApp e1 e2) 		  = checkl e1 `seqMaybe` checkl_e e2
384 385 386
    check (HsVar v) | v `notElem` foralls = Nothing
    check other				  = Just other 	-- Failure

387 388
    checkl_e (L loc e) = check_e e

389
    check_e (HsVar v)     = Nothing
390
    check_e (HsPar e) 	  = checkl_e e
391 392 393
    check_e (HsLit e) 	  = Nothing
    check_e (HsOverLit e) = Nothing

394 395 396 397 398
    check_e (OpApp e1 op _ e2) 	 = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
    check_e (HsApp e1 e2)      	 = checkl_e e1 `seqMaybe` checkl_e e2
    check_e (NegApp e _)       	 = checkl_e e
    check_e (ExplicitList _ es)	 = checkl_es es
    check_e (ExplicitTuple es _) = checkl_es es
399 400
    check_e other		 = Just other	-- Fails

401
    checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
402 403 404 405 406 407 408 409 410 411 412 413

badRuleLhsErr name lhs (Just bad_e)
  = sep [ptext SLIT("Rule") <+> ftext name <> colon,
	 nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
		       ptext SLIT("in left-hand side:") <+> ppr lhs])]
    $$
    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")

badRuleVar name var
  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
		ptext SLIT("does not appear on left hand side")]
414 415
\end{code}

416

417 418
%*********************************************************
%*							*
419
\subsection{Type, class and iface sig declarations}
420 421 422 423 424 425 426 427 428
%*							*
%*********************************************************

@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
429 430 431 432 433 434
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.
435 436

\begin{code}
437 438 439
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
  = lookupLocatedTopBndrRn name		`thenM` \ name' ->
    returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
440
	     emptyFVs)
441

442
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
443
		    tcdTyVars = tyvars, tcdCons = condecls, 
444
		    tcdKindSig = sig, tcdDerivs = derivs})
445
  | is_vanilla	-- Normal Haskell data type decl
446 447 448
  = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
				-- data type is syntactically illegal
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
449 450 451 452 453 454
    do	{ tycon' <- lookupLocatedTopBndrRn tycon
	; context' <- rnContext data_doc context
	; (derivs', deriv_fvs) <- rn_derivs derivs
	; checkDupNames data_doc con_names
	; condecls' <- rnConDecls (unLoc tycon') condecls
	; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
455
			   tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', 
456 457 458 459 460 461 462
			   tcdDerivs = derivs'}, 
		   delFVs (map hsLTyVarName tyvars')	$
	     	   extractHsCtxtTyNames context'	`plusFV`
	     	   plusFVs (map conDeclFVs condecls') `plusFV`
	     	   deriv_fvs) }

  | otherwise	-- GADT
463 464 465
  = do	{ tycon' <- lookupLocatedTopBndrRn tycon
	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
    	; tyvars' <- bindTyVarsRn data_doc tyvars 
466 467 468 469 470 471 472 473
				  (\ tyvars' -> return tyvars')
		-- For GADTs, the type variables in the declaration 
		-- do not scope over the constructor signatures
		-- 	data T a where { T1 :: forall b. b-> b }
	; (derivs', deriv_fvs) <- rn_derivs derivs
	; checkDupNames data_doc con_names
	; condecls' <- rnConDecls (unLoc tycon') condecls
	; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
474
			   tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
475 476 477
			   tcdDerivs = derivs'}, 
	     	   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }

sof's avatar
sof committed
478
  where
479 480
    is_vanilla = case condecls of	-- Yuk
		     [] 		   -> True
481
		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
482 483
		     other		   -> False

484
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
485 486
    con_names = map con_names_helper condecls

487
    con_names_helper (L _ c) = con_name c
488

489
    rn_derivs Nothing   = returnM (Nothing, emptyFVs)
490 491
    rn_derivs (Just ds) = rnLHsTypes data_doc ds	`thenM` \ ds' -> 
			  returnM (Just ds', extractHsTyNames_s ds')
492
    
493 494
rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
  = lookupLocatedTopBndrRn name			`thenM` \ name' ->
495
    bindTyVarsRn syn_doc tyvars 		$ \ tyvars' ->
496
    rnHsTypeFVs syn_doc ty			`thenM` \ (ty', fvs) ->
497 498 499
    returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
			tcdSynRhs = ty'},
	     delFVs (map hsLTyVarName tyvars') fvs)
sof's avatar
sof committed
500
  where
501
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
502

503
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
504
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
505 506
		       tcdMeths = mbinds})
  = lookupLocatedTopBndrRn cname		`thenM` \ cname' ->
sof's avatar
sof committed
507

508
	-- Tyvars scope over superclass context and method signatures
509 510 511
    bindTyVarsRn cls_doc tyvars			( \ tyvars' ->
	rnContext cls_doc context	`thenM` \ context' ->
	rnFds cls_doc fds		`thenM` \ fds' ->
512
	renameSigs okClsDclSig sigs	`thenM` \ sigs' ->
513 514
	returnM   (tyvars', context', fds', sigs')
    )	`thenM` \ (tyvars', context', fds', sigs') ->
515

516
	-- Check the signatures
517
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
518
    let
519
	sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
520
    in
521
    checkDupNames sig_doc sig_rdr_names_w_locs	`thenM_` 
522 523 524 525 526
	-- 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.

527
   	-- The newLocals call is tiresome: given a generic class decl
528 529 530 531 532 533 534
	--	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.  
535 536 537
    extendTyVarEnvForMethodBinds tyvars' (
   	 getLocalRdrEnv					`thenM` \ name_env ->
   	 let
538 539 540 541
 	     meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 	     gen_rdr_tyvars_w_locs = 
		[ tv | tv <- extractGenericPatTyVars mbinds,
 		      not (unLoc tv `elemLocalRdrEnv` name_env) ]
542 543
   	 in
   	 checkDupNames meth_doc meth_rdr_names_w_locs	`thenM_`
544 545 546 547 548 549 550
   	 newLocalsRn gen_rdr_tyvars_w_locs	`thenM` \ gen_tyvars ->
   	 rnMethodBinds (unLoc cname') gen_tyvars mbinds
    ) `thenM` \ (mbinds', meth_fvs) ->

    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
			 tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
	     delFVs (map hsLTyVarName tyvars')	$
551
	     extractHsCtxtTyNames context'	    `plusFV`
552
	     plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
553 554 555 556 557 558
	     hsSigsFVs sigs'		  	    `plusFV`
	     meth_fvs)
  where
    meth_doc = text "In the default-methods for class"	<+> ppr cname
    cls_doc  = text "In the declaration for class" 	<+> ppr cname
    sig_doc  = text "In the signatures for class"  	<+> ppr cname
559 560 561 562

badGadtStupidTheta tycon
  = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
	  ptext SLIT("(You can put a context on each contructor, though.)")]
563 564
\end{code}

565 566
%*********************************************************
%*							*
567
\subsection{Support code for type/data declarations}
568 569 570 571
%*							*
%*********************************************************

\begin{code}
572
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
573
rnConDecls tycon condecls
574
  = mappM (wrapLocM rnConDecl) condecls
575

576
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
577 578
rnConDecl (ConDecl name expl tvs cxt details res_ty)
  = do	{ addLocM checkConName name
sof's avatar
sof committed
579

580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602
	; new_name <- lookupLocatedTopBndrRn name
	; name_env <- getLocalRdrEnv
	
	-- For H98 syntax, the tvs are the existential ones
	-- For GADT syntax, the tvs are all the quantified tyvars
	-- Hence the 'filter' in the ResTyH98 case only
	; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
	      arg_tys       = hsConArgs details
	      implicit_tvs  = case res_ty of
	      	    		ResTyH98 -> filter not_in_scope $
						get_rdr_tvs arg_tys
	      	    		ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
	      tvs' = case expl of
	        	Explicit -> tvs
		    	Implicit -> userHsTyVarBndrs implicit_tvs

	; bindTyVarsRn doc tvs' $ \new_tyvars -> do
	{ new_context <- rnContext doc cxt
        ; new_details <- rnConDetails doc details
        ; new_res_ty  <- rnConResult doc res_ty
        ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
        ; traceRn (text "****** - autrijus" <> ppr rv)
        ; return rv } }
603 604
  where
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
605 606 607 608 609 610
    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))

rnConResult _ ResTyH98 = return ResTyH98
rnConResult doc (ResTyGADT ty) = do
    ty' <- rnHsSigType doc ty
    return $ ResTyGADT ty'
611

612
rnConDetails doc (PrefixCon tys)
613
  = mappM (rnLHsType doc) tys	`thenM` \ new_tys  ->
614
    returnM (PrefixCon new_tys)
sof's avatar
sof committed
615

616
rnConDetails doc (InfixCon ty1 ty2)
617 618
  = rnLHsType doc ty1  		`thenM` \ new_ty1 ->
    rnLHsType doc ty2  		`thenM` \ new_ty2 ->
619
    returnM (InfixCon new_ty1 new_ty2)
620

621
rnConDetails doc (RecCon fields)
622
  = checkDupNames doc field_names	`thenM_`
623 624
    mappM (rnField doc) fields		`thenM` \ new_fields ->
    returnM (RecCon new_fields)
sof's avatar
sof committed
625
  where
626
    field_names = [fld | (fld, _) <- fields]
627

628
rnField doc (name, ty)
629
  = lookupLocatedTopBndrRn name	`thenM` \ new_name ->
630
    rnLHsType doc ty		`thenM` \ new_ty ->
631
    returnM (new_name, new_ty) 
632

633 634 635 636 637 638 639 640 641 642
-- 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

643 644 645 646
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)

badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
647 648
\end{code}

649

650 651 652 653 654
%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************
655

656
\begin{code}
657
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
658 659

rnFds doc fds
660
  = mappM (wrapLocM rn_fds) fds
661 662
  where
    rn_fds (tys1, tys2)
663 664 665
      =	rnHsTyVars doc tys1		`thenM` \ tys1' ->
	rnHsTyVars doc tys2		`thenM` \ tys2' ->
	returnM (tys1', tys2')
666

667
rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
668
rnHsTyvar doc tyvar = lookupOccRn tyvar
669
\end{code}
670

671 672 673 674 675 676 677

%*********************************************************
%*							*
		Splices
%*							*
%*********************************************************

678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696
Note [Splices]
~~~~~~~~~~~~~~
Consider
	f = ...
	h = ...$(thing "f")...

The splice can expand into literally anything, so when we do dependency
analysis we must assume that it might mention 'f'.  So we simply treat
all locally-defined names as mentioned by any splice.  This is terribly
brutal, but I don't see what else to do.  For example, it'll mean
that every locally-defined thing will appear to be used, so no unused-binding
warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
and that will crash the type checker because 'f' isn't in scope.

Currently, I'm not treating a splice as also mentioning every import,
which is a bit inconsistent -- but there are a lot of them.  We might
thereby get some bogus unused-import warnings, but we won't crash the
type checker.  Not very satisfactory really.

697 698 699
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
700 701 702 703 704 705 706 707 708 709 710 711 712
  = do	{ checkTH expr "splice"
	; loc  <- getSrcSpanM
	; [n'] <- newLocalsRn [L loc n]
	; (expr', fvs) <- rnLExpr expr

	-- Ugh!  See Note [Splices] above
	; lcl_rdr <- getLocalRdrEnv
	; gbl_rdr <- getGlobalRdrEnv
	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
						    isLocalGRE gre]
	      lcl_names = mkNameSet (occEnvElts lcl_rdr)

	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
713 714 715 716 717 718 719 720 721

#ifdef GHCI 
checkTH e what = returnM ()	-- OK
#else
checkTH e what 	-- Raise an error in a stage-1 compiler
  = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
	          ptext SLIT("illegal in a stage-1 compiler"),
	          nest 2 (ppr e)])
#endif   
722
\end{code}