RnSource.lhs 25.7 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
import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
24
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, 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
        rn_fix_decls <- rnSrcFixityDecls fix_decls ;
84
	fix_env <- rnSrcFixityDeclsEnv rn_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
    = 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))
160
161
162
163
164
165
    = setSrcSpan nameLoc $
        -- 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
      do names <- lookupLocalDataTcNames rdr_name
166
167
168
         return [ L loc (FixitySig (L nameLoc name) fixity)
                      | name <- names ]

169
rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
170
rnSrcFixityDeclsEnv fix_decls
171
  = getGblEnv					`thenM` \ gbl_env ->
172
    foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) 
173
174
	    fix_decls				 	`thenM` \ fix_env ->
    traceRn (text "fixity env" <+> pprFixEnv fix_env)	`thenM_`
175
176
    returnM fix_env

177
178
179
180
181
182
183
184
185
rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
  = case lookupNameEnv fix_env name of
      Just (FixItem _ _ loc') 
	  -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
    	        return fix_env
      Nothing
          -> return (extendNameEnv fix_env name fix_item)
    where fix_item = FixItem (nameOccName name) fixity nameLoc
186
187
188
189
190

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

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

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

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

228
229
230
231
232
%*********************************************************
%*							*
\subsection{Source code declarations}
%*							*
%*********************************************************
233

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

242
243
244
245
246
247
248
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
249
rnHsForeignDecl (ForeignImport name ty spec)
250
  = lookupLocatedTopBndrRn name	        `thenM` \ name' ->
251
    rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
Simon Marlow's avatar
Simon Marlow committed
252
    returnM (ForeignImport name' ty' spec, fvs)
253

Simon Marlow's avatar
Simon Marlow committed
254
rnHsForeignDecl (ForeignExport name ty spec)
255
  = lookupLocatedOccRn name	        `thenM` \ name' ->
256
    rnHsTypeFVs (fo_decl_msg name) ty  	`thenM` \ (ty', fvs) ->
Simon Marlow's avatar
Simon Marlow committed
257
    returnM (ForeignExport name' ty' spec, fvs )
258
259
260
	-- 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
261

262
fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
263
264
265
266
267
268
269
270
271
272
\end{code}


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

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

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

305
306
    returnM (InstDecl inst_ty' mbinds' uprags',
	     meth_fvs `plusFV` hsSigsFVs uprags'
307
		      `plusFV` extractHsTyNames inst_ty')
308
309
\end{code}

310
311
312
313
314
315
316
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
317
	extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
318
319
320
321
322
    else
	thing_inside
\end{code}


323
324
325
326
327
328
329
%*********************************************************
%*							*
\subsection{Rules}
%*							*
%*********************************************************

\begin{code}
330
rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
331
  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)	$
332

333
    bindLocatedLocalsFV doc (map get_var vars)		$ \ ids ->
334
    mapFvRn rn_var (vars `zip` ids)		`thenM` \ (vars', fv_vars) ->
335

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

355
356
357
358
359
    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)
360
361
362
363
364

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")]
365
366
\end{code}

367
368
369
370
371
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a transformation rule LHS.  Currently we only allow
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
@forall@'d variables.  
372

373
374
375
We used restrict the form of the 'ei' to prevent you writing rules
with LHSs with a complicated desugaring (and hence unlikely to match);
(e.g. a case expression is not allowed: too elaborate.)
376

377
378
379
380
But there are legitimate non-trivial args ei, like sections and
lambdas.  So it seems simmpler not to check at all, and that is why
check_e is commented out.
	
381
\begin{code}
382
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
383
384
-- Nothing => OK
-- Just e  => Not ok, and e is the offending expression
385
validRuleLhs foralls lhs
386
  = checkl lhs
387
  where
388
389
390
391
    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
392
393
394
    check (HsVar v) | v `notElem` foralls = Nothing
    check other				  = Just other 	-- Failure

395
396
	-- Check an argument
    checkl_e (L loc e) = Nothing 	-- Was (check_e e); see Note [Rule LHS validity checking]
397

398
{-	Commented out; see Note [Rule LHS validity checking] above 
399
    check_e (HsVar v)     = Nothing
400
    check_e (HsPar e) 	  = checkl_e e
401
402
403
    check_e (HsLit e) 	  = Nothing
    check_e (HsOverLit e) = Nothing

404
405
406
407
408
    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
409
410
    check_e other		 = Just other	-- Fails

411
    checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
412
-}
413
414
415
416
417
418
419

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")
420
421
\end{code}

422

423
424
%*********************************************************
%*							*
425
\subsection{Type, class and iface sig declarations}
426
427
428
429
430
431
432
433
434
%*							*
%*********************************************************

@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
435
436
437
438
439
440
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.
441
442

\begin{code}
443
444
445
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
  = lookupLocatedTopBndrRn name		`thenM` \ name' ->
    returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
446
	     emptyFVs)
447

448
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
449
		    tcdTyVars = tyvars, tcdCons = condecls, 
450
		    tcdKindSig = sig, tcdDerivs = derivs})
451
  | is_vanilla	-- Normal Haskell data type decl
452
453
454
  = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
				-- data type is syntactically illegal
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
455
456
457
458
459
460
    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',
461
			   tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', 
462
463
464
465
466
467
468
			   tcdDerivs = derivs'}, 
		   delFVs (map hsLTyVarName tyvars')	$
	     	   extractHsCtxtTyNames context'	`plusFV`
	     	   plusFVs (map conDeclFVs condecls') `plusFV`
	     	   deriv_fvs) }

  | otherwise	-- GADT
469
470
471
  = do	{ tycon' <- lookupLocatedTopBndrRn tycon
	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
    	; tyvars' <- bindTyVarsRn data_doc tyvars 
472
473
474
475
476
477
478
479
				  (\ 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',
480
			   tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
481
482
483
			   tcdDerivs = derivs'}, 
	     	   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }

sof's avatar
sof committed
484
  where
485
486
    is_vanilla = case condecls of	-- Yuk
		     [] 		   -> True
487
		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
488
489
		     other		   -> False

490
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
491
492
    con_names = map con_names_helper condecls

493
    con_names_helper (L _ c) = con_name c
494

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

509
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
510
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
511
512
		       tcdMeths = mbinds})
  = lookupLocatedTopBndrRn cname		`thenM` \ cname' ->
sof's avatar
sof committed
513

514
	-- Tyvars scope over superclass context and method signatures
515
516
517
    bindTyVarsRn cls_doc tyvars			( \ tyvars' ->
	rnContext cls_doc context	`thenM` \ context' ->
	rnFds cls_doc fds		`thenM` \ fds' ->
518
	renameSigs okClsDclSig sigs	`thenM` \ sigs' ->
519
520
	returnM   (tyvars', context', fds', sigs')
    )	`thenM` \ (tyvars', context', fds', sigs') ->
521

522
	-- Check the signatures
523
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
524
    let
525
	sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
526
    in
527
    checkDupNames sig_doc sig_rdr_names_w_locs	`thenM_` 
528
529
530
531
532
	-- 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.

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

    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
			 tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
	     delFVs (map hsLTyVarName tyvars')	$
557
	     extractHsCtxtTyNames context'	    `plusFV`
558
	     plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
559
560
561
562
563
564
	     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
565
566
567
568

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.)")]
569
570
\end{code}

571
572
%*********************************************************
%*							*
573
\subsection{Support code for type/data declarations}
574
575
576
577
%*							*
%*********************************************************

\begin{code}
578
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
579
rnConDecls tycon condecls
580
  = mappM (wrapLocM rnConDecl) condecls
581

582
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
583
584
rnConDecl (ConDecl name expl tvs cxt details res_ty)
  = do	{ addLocM checkConName name
sof's avatar
sof committed
585

586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
	; 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
605
606
        ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
607
608
  where
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
609
610
    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))

611
612
613
rnConResult _ details ResTyH98 = return (details, ResTyH98)

rnConResult doc details (ResTyGADT ty) = do
614
    ty' <- rnHsSigType doc ty
615
616
617
618
619
620
    let (arg_tys, res_ty) = splitHsFunType ty'
	-- We can split it up, now the renamer has dealt with fixities
    case details of
	PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
	RecCon fields -> return (details, ResTyGADT ty')
	InfixCon {}   -> panic "rnConResult"
621

622
rnConDetails doc (PrefixCon tys)
623
  = mappM (rnLHsType doc) tys	`thenM` \ new_tys  ->
624
    returnM (PrefixCon new_tys)
sof's avatar
sof committed
625

626
rnConDetails doc (InfixCon ty1 ty2)
627
628
  = rnLHsType doc ty1  		`thenM` \ new_ty1 ->
    rnLHsType doc ty2  		`thenM` \ new_ty2 ->
629
    returnM (InfixCon new_ty1 new_ty2)
630

631
rnConDetails doc (RecCon fields)
632
  = checkDupNames doc field_names	`thenM_`
633
634
    mappM (rnField doc) fields		`thenM` \ new_fields ->
    returnM (RecCon new_fields)
sof's avatar
sof committed
635
  where
636
    field_names = [fld | (fld, _) <- fields]
637

638
rnField doc (name, ty)
639
  = lookupLocatedTopBndrRn name	`thenM` \ new_name ->
640
    rnLHsType doc ty		`thenM` \ new_ty ->
641
    returnM (new_name, new_ty) 
642

643
644
645
646
647
648
649
650
651
652
-- 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

653
654
655
656
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)

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

659

660
661
662
663
664
%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************
665

666
\begin{code}
667
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
668
669

rnFds doc fds
670
  = mappM (wrapLocM rn_fds) fds
671
672
  where
    rn_fds (tys1, tys2)
673
674
675
      =	rnHsTyVars doc tys1		`thenM` \ tys1' ->
	rnHsTyVars doc tys2		`thenM` \ tys2' ->
	returnM (tys1', tys2')
676

677
rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
678
rnHsTyvar doc tyvar = lookupOccRn tyvar
679
\end{code}
680

681
682
683
684
685
686
687

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

688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
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.

707
708
709
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
710
711
712
713
714
715
716
717
718
719
720
721
722
  = 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) }
723
724
725
726
727
728
729
730
731

#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   
732
\end{code}