RnSource.lhs 24.5 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 ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, 
8
	) where
9

10
#include "HsVersions.h"
sof's avatar
sof committed
11

sof's avatar
sof committed
12
import RnExpr
13
import HsSyn
14
import HscTypes		( GlobalRdrEnv, AvailEnv )
15
16
import RdrName		( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn		( RdrNameConDecl, RdrNameTyClDecl,
17
			  extractGenericPatTyVars
18
			)
19
import RnHsSyn
20
21
import HsCore

22
23
import RnTypes		( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )

24
import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
25
import RnEnv		( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
26
			  lookupOrigNames, lookupSysBinder, newLocalsRn,
27
			  bindLocalsFVRn, bindPatSigTyVars,
28
			  bindTyVarsRn, extendTyVarEnvFVRn,
29
30
			  bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
			  checkDupOrQualNames, checkDupNames, mapFvRn
31
			)
32
import RnMonad
33

34
import Class		( FunDep, DefMeth (..) )
35
import DataCon		( dataConId )
36
import Name		( Name, NamedThing(..) )
37
import NameSet
38
import PrelInfo		( derivableClassKeys )
39
40
import PrelNames	( deRefStablePtrName, newStablePtrName,
			  bindIOName, returnIOName
sof's avatar
sof committed
41
			)
42
import TysWiredIn	( tupleCon )
43
import List		( partition )
44
import Outputable
45
import SrcLoc		( SrcLoc )
46
import CmdLineOpts	( DynFlag(..) )
47
				-- Warn of unused for-all'd tyvars
48
import Unique		( Uniquable(..) )
49
import Maybes		( maybeToBool )
50
51
\end{code}

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


68
69
%*********************************************************
%*							*
70
\subsection{Source code declarations}
71
72
73
74
%*							*
%*********************************************************

\begin{code}
75
rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
76
77
	      -> [RdrNameHsDecl] 
	      -> RnMG ([RenamedHsDecl], FreeVars)
78
79
	-- The decls get reversed, but that's ok

80
81
rnSourceDecls gbl_env avails local_fixity_env decls
  = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
82
  where
83
84
85
86
	-- Fixity and deprecations have been dealt with already; ignore them
    go fvs ds' []             = returnRn (ds', fvs)
    go fvs ds' (FixD _:ds)    = go fvs ds' ds
    go fvs ds' (DeprecD _:ds) = go fvs ds' ds
87
    go fvs ds' (d:ds)         = rnSourceDecl d	`thenRn` \(d', fvs') ->
88
			        go (fvs `plusFV` fvs') (d':ds') ds
89
90


91
rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
92

93
94
rnSourceDecl (ValD binds) = rnTopBinds binds	`thenRn` \ (new_binds, fvs) ->
			    returnRn (ValD new_binds, fvs)
95

96
rnSourceDecl (TyClD tycl_decl)
97
98
  = rnTyClDecl tycl_decl			`thenRn` \ new_decl ->
    finishSourceTyClDecl tycl_decl new_decl	`thenRn` \ (new_decl', fvs) ->
99
    returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
100

101
rnSourceDecl (InstD inst)
102
103
  = rnInstDecl inst			`thenRn` \ new_inst ->
    finishSourceInstDecl inst new_inst	`thenRn` \ (new_inst', fvs) ->
104
    returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
105

106
rnSourceDecl (RuleD rule)
107
108
  = rnHsRuleDecl rule		`thenRn` \ (new_rule, fvs) ->
    returnRn (RuleD new_rule, fvs)
109

110
111
112
113
rnSourceDecl (ForD ford)
  = rnHsForeignDecl ford		`thenRn` \ (new_ford, fvs) ->
    returnRn (ForD new_ford, fvs)

114
rnSourceDecl (DefD (DefaultDecl tys src_loc))
115
  = pushSrcLocRn src_loc $
116
    mapFvRn (rnHsTypeFVs doc_str) tys		`thenRn` \ (tys', fvs) ->
117
    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
118
  where
119
    doc_str = text "In a `default' declaration"
120
\end{code}
121
122


123
124
125
126
127
128
129
130
131
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
rnHsForeignDecl (ForeignImport name ty spec src_loc)
  = pushSrcLocRn src_loc 		$
sof's avatar
sof committed
132
    lookupTopBndrRn name	        `thenRn` \ name' ->
133
134
    rnHsTypeFVs (fo_decl_msg name) ty	`thenRn` \ (ty', fvs) ->
    returnRn (ForeignImport name' ty' spec src_loc, fvs `plusFV` extras spec)
135
  where
136
137
    extras (CDynImport _) = mkFVs [newStablePtrName, deRefStablePtrName, bindIOName, returnIOName]
    extras other	  = emptyFVs
138

139
140
141
rnHsForeignDecl (ForeignExport name ty spec src_loc)
  = pushSrcLocRn src_loc 			$
    lookupOccRn name		        	`thenRn` \ name' ->
142
143
144
    rnHsTypeFVs (fo_decl_msg name) ty  		`thenRn` \ (ty', fvs) ->
    returnRn (ForeignExport name' ty' spec src_loc, 
	      mkFVs [bindIOName, returnIOName] `plusFV` fvs)
145

146
fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
147
148
149
150
151
152
153
154
155
156
157
\end{code}


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

\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
158
	-- Used for both source and interface file decls
159
  = pushSrcLocRn src_loc $
160
161
162
163
    rnHsSigType (text "an instance decl") inst_ty	`thenRn` \ inst_ty' ->

    (case maybe_dfun_rdr_name of
	Nothing		   -> returnRn Nothing
164
	Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name	`thenRn` \ dfun_name ->
165
166
167
168
			      returnRn (Just dfun_name)
    )							`thenRn` \ maybe_dfun_name ->

    -- The typechecker checks that all the bindings are for the right class.
169
    returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
170

171
172
173
-- Compare finishSourceTyClDecl
finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
		     (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
174
175
176
	-- Used for both source decls only
  = ASSERT( not (maybeToBool maybe_dfun_name) )	-- Source decl!
    let
177
	meth_doc    = text "In the bindings in an instance declaration"
178
	meth_names  = collectLocatedMonoBinders mbinds
179
	(inst_tyvars, (cls,_)) = getHsInstHead inst_ty
180
181
182
183
184
185
186
187
	-- (Slightly strangely) the forall-d tyvars scope over
	-- the method bindings too
    in

	-- Rename the bindings
	-- NB meth_names can be qualified!
    checkDupNames meth_doc meth_names 		`thenRn_`
    extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (		
188
	rnMethodBinds cls [] mbinds
189
190
191
192
193
194
195
196
197
198
199
200
201
    )						`thenRn` \ (mbinds', meth_fvs) ->
    let 
	binders    = collectMonoBinders mbinds'
	binder_set = mkNameSet binders
    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
    bindLocalNames binders (
202
       renameSigsFVs (okInstDclSig binder_set) uprags
203
    )							`thenRn` \ (uprags', prag_fvs) ->
204

205
    returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
206
	      meth_fvs `plusFV` prag_fvs)
207
208
209
210
211
212
213
214
215
\end{code}

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

\begin{code}
216
rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
217
218
219
  = pushSrcLocRn src_loc	$
    lookupOccRn fn		`thenRn` \ fn' ->
    rnCoreBndrs vars		$ \ vars' ->
220
    mapRn rnCoreExpr args	`thenRn` \ args' ->
221
    rnCoreExpr rhs		`thenRn` \ rhs' ->
222
    returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
223

224
225
226
227
rnIfaceRuleDecl (IfaceRuleOut fn rule)		-- Builtin rules come this way
  = lookupOccRn fn		`thenRn` \ fn' ->
    returnRn (IfaceRuleOut fn' rule)

228
229
230
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
  = pushSrcLocRn src_loc				$
    bindPatSigTyVars (collectRuleBndrSigTys vars)	$
231
232
233
234
235
236
237
238
239
240
241
242

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

    rnExpr lhs					`thenRn` \ (lhs', fv_lhs) ->
    rnExpr rhs					`thenRn` \ (rhs', fv_rhs) ->
    checkRn (validRuleLhs ids lhs')
	    (badRuleLhsErr rule_name lhs')	`thenRn_`
    let
	bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
    in
    mapRn (addErrRn . badRuleVar rule_name) bad_vars	`thenRn_`
243
    returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
244
245
	      fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
  where
246
    doc = text "In the transformation rule" <+> ptext rule_name
247
248
249
250
251
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

    rn_var (RuleBndr v, id)	 = returnRn (RuleBndr id, emptyFVs)
252
    rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t	`thenRn` \ (t', fvs) ->
253
				   returnRn (RuleBndrSig id t', fvs)
254
255
\end{code}

256

257
258
%*********************************************************
%*							*
259
\subsection{Type, class and iface sig declarations}
260
261
262
263
264
265
266
267
268
%*							*
%*********************************************************

@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
269
270
271
272
273
274
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.
275
276

\begin{code}
277
rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
278
279
  = pushSrcLocRn loc $
    lookupTopBndrRn name		`thenRn` \ name' ->
280
281
    rnHsType doc_str ty			`thenRn` \ ty' ->
    mapRn rnIdInfo id_infos		`thenRn` \ id_infos' -> 
282
    returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
283
  where
284
    doc_str = text "In the interface signature for" <+> quotes (ppr name)
285

286
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
287
288
  = pushSrcLocRn loc 			$
    lookupTopBndrRn name		`thenRn` \ name' ->
289
    returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
290

291
292
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
		    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
293
		    tcdLoc = src_loc, tcdSysNames = sys_names})
294
  = pushSrcLocRn src_loc $
295
    lookupTopBndrRn tycon		    	`thenRn` \ tycon' ->
296
297
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
    rnContext data_doc context 			`thenRn` \ context' ->
298
    checkDupOrQualNames data_doc con_names	`thenRn_`
299
300
301
302
303
304
305
306
307
308
309

	-- Check that there's at least one condecl,
	-- or else we're reading an interface file, or -fglasgow-exts
    (if null condecls then
	doptRn Opt_GlasgowExts	`thenRn` \ glaExts ->
	getModeRn		`thenRn` \ mode ->
	checkRn (glaExts || isInterfaceMode mode)
		(emptyConDeclsErr tycon)
     else returnRn ()
    )						`thenRn_` 

310
    mapRn rnConDecl condecls			`thenRn` \ condecls' ->
311
312
313
    mapRn lookupSysBinder sys_names	        `thenRn` \ sys_names' ->
    returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
		      tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
314
		      tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
sof's avatar
sof committed
315
  where
316
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
sof's avatar
sof committed
317
    con_names = map conDeclName condecls
318

319
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
320
  = pushSrcLocRn src_loc $
321
    lookupTopBndrRn name			`thenRn` \ name' ->
322
    bindTyVarsRn syn_doc tyvars 		$ \ tyvars' ->
323
    rnHsType syn_doc ty				`thenRn` \ ty' ->
324
    returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
sof's avatar
sof committed
325
  where
326
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
327

328
329
330
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
		       tcdSysNames = names, tcdLoc = src_loc})
331
	-- Used for both source and interface file decls
332
  = pushSrcLocRn src_loc $
sof's avatar
sof committed
333

334
    lookupTopBndrRn cname			`thenRn` \ cname' ->
335

336
337
338
339
	-- Deal with the implicit tycon and datacon name
	-- They aren't in scope (because they aren't visible to the user)
	-- and what we want to do is simply look them up in the cache;
	-- we jolly well ought to get a 'hit' there!
340
    mapRn lookupSysBinder names			`thenRn` \ names' ->
sof's avatar
sof committed
341

342
	-- Tyvars scope over bindings and context
343
    bindTyVarsRn cls_doc tyvars			$ \ tyvars' ->
344
345

	-- Check the superclasses
346
    rnContext cls_doc context			`thenRn` \ context' ->
347

348
	-- Check the functional dependencies
349
    rnFds cls_doc fds				`thenRn` \ fds' ->
350

351
	-- Check the signatures
352
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
353
    let
354
355
	(op_sigs, non_op_sigs) = partition isClassOpSig sigs
	sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
356
    in
357
358
    checkDupOrQualNames sig_doc sig_rdr_names_w_locs	`thenRn_` 
    mapRn (rnClassOp cname' fds') op_sigs		`thenRn` \ sigs' ->
sof's avatar
sof committed
359
    let
360
	binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
sof's avatar
sof committed
361
    in
362
    renameSigs (okClsDclSig binders) non_op_sigs	  `thenRn` \ non_ops' ->
sof's avatar
sof committed
363

364
365
366
367
368
	-- 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.

369
370
371
    returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
			  tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, 
			  tcdSysNames = names', tcdLoc = src_loc})
372
  where
373
374
    cls_doc  = text "In the declaration for class" 	<+> ppr cname
    sig_doc  = text "In the signatures for class"  	<+> ppr cname
375

376
rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
377
378
379
380
381
382
383
  = pushSrcLocRn locn $
    lookupTopBndrRn op			`thenRn` \ op_name ->
    
    	-- Check the signature
    rnHsSigType (quotes (ppr op)) ty	`thenRn` \ new_ty ->
    
    	-- Make the default-method name
384
385
    (case dm_stuff of 
        DefMeth dm_rdr_name
386
387
388
    	    -> 	-- Imported class that has a default method decl
    		-- See comments with tname, snames, above
    	    	lookupSysBinder dm_rdr_name 	`thenRn` \ dm_name ->
389
		returnRn (DefMeth dm_name)
390
391
392
393
	    		-- 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

394
395
396
        GenDefMeth -> returnRn GenDefMeth
        NoDefMeth  -> returnRn NoDefMeth
    )						`thenRn` \ dm_stuff' ->
397
    
398
    returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
399

400
finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
401
	-- Used for source file decls only
402
403
404
405
406
407
408
409
410
	-- Renames the default-bindings of a class decl
	--	   the derivings of a data decl
finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc})	-- Derivings in here
		     rn_ty_decl							-- Everything else is here
  = pushSrcLocRn src_loc	 $
    mapRn rnDeriv derivs	`thenRn` \ derivs' ->
    returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')

finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})	-- Get mbinds from here
411
	 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars})		-- Everything else is here
412
413
  -- There are some default-method bindings (abeit possibly empty) so 
  -- this is a source-code class declaration
414
  = 	-- The newLocals call is tiresome: given a generic class decl
415
416
417
418
419
420
421
422
	--	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 
423
    pushSrcLocRn src_loc				$
424
    extendTyVarEnvFVRn (map hsTyVarName tyvars)		$
425
426
427
428
    getLocalNameEnv					`thenRn` \ name_env ->
    let
	meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
	gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
429
						not (tv `elemRdrEnv` name_env)]
430
    in
sof's avatar
sof committed
431
    checkDupOrQualNames meth_doc meth_rdr_names_w_locs	`thenRn_`
432
    newLocalsRn gen_rdr_tyvars_w_locs			`thenRn` \ gen_tyvars ->
433
    rnMethodBinds cls gen_tyvars mbinds			`thenRn` \ (mbinds', meth_fvs) ->
434
    returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
435
  where
436
    meth_doc = text "In the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
437

438
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
439
	-- Not a class or data type declaration
440
441
442
443
444
\end{code}


%*********************************************************
%*							*
445
\subsection{Support code for type/data declarations}
446
447
448
%*							*
%*********************************************************

449
\begin{code}
450
451
452
453
454
455
rnDeriv :: RdrName -> RnMS Name
rnDeriv cls
  = lookupOccRn cls	`thenRn` \ clas_name ->
    checkRn (getUnique clas_name `elem` derivableClassKeys)
	    (derivingNonStdClassErr clas_name)	`thenRn_`
    returnRn clas_name
456
\end{code}
457
458

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

462
rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
463
rnConDecl (ConDecl name wkr tvs cxt details locn)
sof's avatar
sof committed
464
  = pushSrcLocRn locn $
465
466
    checkConName name		`thenRn_` 
    lookupTopBndrRn name	`thenRn` \ new_name ->
467

468
    lookupSysBinder wkr		`thenRn` \ new_wkr ->
469
470
	-- See comments with ClassDecl

471
472
473
474
    bindTyVarsRn doc tvs 		$ \ new_tyvars ->
    rnContext doc cxt			`thenRn` \ new_context ->
    rnConDetails doc locn details	`thenRn` \ new_details -> 
    returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
475
  where
476
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
sof's avatar
sof committed
477

478
rnConDetails doc locn (VanillaCon tys)
479
480
  = mapRn (rnBangTy doc) tys	`thenRn` \ new_tys  ->
    returnRn (VanillaCon new_tys)
sof's avatar
sof committed
481

482
rnConDetails doc locn (InfixCon ty1 ty2)
483
484
485
  = rnBangTy doc ty1  		`thenRn` \ new_ty1 ->
    rnBangTy doc ty2  		`thenRn` \ new_ty2 ->
    returnRn (InfixCon new_ty1 new_ty2)
486

487
488
rnConDetails doc locn (RecCon fields)
  = checkDupOrQualNames doc field_names	`thenRn_`
489
490
    mapRn (rnField doc) fields		`thenRn` \ new_fields ->
    returnRn (RecCon new_fields)
sof's avatar
sof committed
491
492
  where
    field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
493

494
rnField doc (names, ty)
495
  = mapRn lookupTopBndrRn names	`thenRn` \ new_names ->
496
497
    rnBangTy doc ty		`thenRn` \ new_ty ->
    returnRn (new_names, new_ty) 
498

499
rnBangTy doc (BangType s ty)
500
  = rnHsType doc ty		`thenRn` \ new_ty ->
501
    returnRn (BangType s new_ty)
502

503
504
505
506
507
508
509
510
511
512
513
-- 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
514
  = checkRn (isRdrDataCon name)
515
	    (badDataCon name)
516
517
\end{code}

518

519
520
521
522
523
%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************
524

525
\begin{code}
526
rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
527
528

rnFds doc fds
529
  = mapRn rn_fds fds
530
531
  where
    rn_fds (tys1, tys2)
532
533
534
      =	rnHsTyVars doc tys1		`thenRn` \ tys1' ->
	rnHsTyVars doc tys2		`thenRn` \ tys2' ->
	returnRn (tys1', tys2')
535

536
537
rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
538
\end{code}
539

540
%*********************************************************
541
%*							 *
542
\subsection{IdInfo}
543
%*							 *
544
545
%*********************************************************

546
\begin{code}
547
rnIdInfo (HsWorker worker arity)
548
  = lookupOccRn worker			`thenRn` \ worker' ->
549
    returnRn (HsWorker worker' arity)
550
551
552
553
554
555

rnIdInfo (HsUnfold inline expr)	= rnCoreExpr expr `thenRn` \ expr' ->
				  returnRn (HsUnfold inline expr')
rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
rnIdInfo (HsArity arity)	= returnRn (HsArity arity)
rnIdInfo HsNoCafRefs		= returnRn HsNoCafRefs
556
557
\end{code}

558
@UfCore@ expressions.
559
560

\begin{code}
561
rnCoreExpr (UfType ty)
562
563
  = rnHsType (text "unfolding type") ty	`thenRn` \ ty' ->
    returnRn (UfType ty')
564

565
rnCoreExpr (UfVar v)
sof's avatar
sof committed
566
  = lookupOccRn v 	`thenRn` \ v' ->
567
    returnRn (UfVar v')
568

569
rnCoreExpr (UfLit l)
570
  = returnRn (UfLit l)
571
572

rnCoreExpr (UfLitLit l ty)
573
574
  = rnHsType (text "litlit") ty	`thenRn` \ ty' ->
    returnRn (UfLitLit l ty')
575

576
rnCoreExpr (UfFCall cc ty)
577
  = rnHsType (text "ccall") ty	`thenRn` \ ty' ->
578
    returnRn (UfFCall cc ty')
579

580
581
582
583
584
585
rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) 
  = mapRn rnCoreExpr args		`thenRn` \ args' ->
    returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
  where
    tup_name = getName (dataConId (tupleCon boxity arity))
	-- Get the *worker* name and use that
586
587

rnCoreExpr (UfApp fun arg)
588
589
590
  = rnCoreExpr fun		`thenRn` \ fun' ->
    rnCoreExpr arg		`thenRn` \ arg' ->
    returnRn (UfApp fun' arg')
591
592

rnCoreExpr (UfCase scrut bndr alts)
593
  = rnCoreExpr scrut			`thenRn` \ scrut' ->
594
    bindCoreLocalRn bndr		$ \ bndr' ->
595
596
    mapRn rnCoreAlt alts		`thenRn` \ alts' ->
    returnRn (UfCase scrut' bndr' alts')
597

598
rnCoreExpr (UfNote note expr) 
599
600
601
  = rnNote note			`thenRn` \ note' ->
    rnCoreExpr expr		`thenRn` \ expr' ->
    returnRn  (UfNote note' expr')
602
603
604

rnCoreExpr (UfLam bndr body)
  = rnCoreBndr bndr 		$ \ bndr' ->
605
606
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLam bndr' body')
607
608

rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
609
610
611
612
  = rnCoreExpr rhs		`thenRn` \ rhs' ->
    rnCoreBndr bndr 		$ \ bndr' ->
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLet (UfNonRec bndr' rhs') body')
613
614
615

rnCoreExpr (UfLet (UfRec pairs) body)
  = rnCoreBndrs bndrs		$ \ bndrs' ->
616
617
618
    mapRn rnCoreExpr rhss	`thenRn` \ rhss' ->
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
619
  where
620
621
622
623
624
    (bndrs, rhss) = unzip pairs
\end{code}

\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
625
  = rnHsType doc ty		`thenRn` \ ty' ->
626
627
    bindCoreLocalRn name	$ \ name' ->
    thing_inside (UfValBinder name' ty')
628
  where
629
    doc = text "unfolding id"
630
631
    
rnCoreBndr (UfTyBinder name kind) thing_inside
632
  = bindCoreLocalRn name		$ \ name' ->
633
634
    thing_inside (UfTyBinder name' kind)
    
635
636
637
638
rnCoreBndrs []     thing_inside = thing_inside []
rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b		$ \ name' ->
				  rnCoreBndrs bs 	$ \ names' ->
				  thing_inside (name':names')
639
640
641
\end{code}    

\begin{code}
642
rnCoreAlt (con, bndrs, rhs)
643
  = rnUfCon con 			`thenRn` \ con' ->
644
645
646
    bindCoreLocalsRn bndrs		$ \ bndrs' ->
    rnCoreExpr rhs			`thenRn` \ rhs' ->
    returnRn (con', bndrs', rhs')
647

648
rnNote (UfCoerce ty)
649
650
  = rnHsType (text "unfolding coerce") ty	`thenRn` \ ty' ->
    returnRn (UfCoerce ty')
651

652
653
654
rnNote (UfSCC cc)   = returnRn (UfSCC cc)
rnNote UfInlineCall = returnRn UfInlineCall
rnNote UfInlineMe   = returnRn UfInlineMe
655

656

657
rnUfCon UfDefault
658
  = returnRn UfDefault
659

660
661
662
663
rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
  = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
  where
    tup_name = getName (tupleCon boxity arity)
664

665
rnUfCon (UfDataAlt con)
666
  = lookupOccRn con		`thenRn` \ con' ->
667
    returnRn (UfDataAlt con')
668

669
rnUfCon (UfLitAlt lit)
670
  = returnRn (UfLitAlt lit)
671

672
rnUfCon (UfLitLitAlt lit ty)
673
674
  = rnHsType (text "litlit") ty		`thenRn` \ ty' ->
    returnRn (UfLitLitAlt lit ty')
675
\end{code}
676

677
%*********************************************************
678
%*							 *
679
\subsection{Rule shapes}
680
%*							 *
681
682
683
%*********************************************************

Check the shape of a transformation rule LHS.  Currently
684
685
we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
not one of the @forall@'d variables.
686
687
688
689
690

\begin{code}
validRuleLhs foralls lhs
  = check lhs
  where
691
    check (OpApp _ op _ _)		  = check op
692
693
694
695
696
697
    check (HsApp e1 e2) 		  = check e1
    check (HsVar v) | v `notElem` foralls = True
    check other				  = False
\end{code}


698
%*********************************************************
699
%*							 *
700
\subsection{Errors}
701
%*							 *
702
%*********************************************************
703

704
\begin{code}
705
706
derivingNonStdClassErr clas
  = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
707

708
709
badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
710
711
712
713
714
715
716
badRuleLhsErr name lhs
  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
	 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
    $$
    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")

badRuleVar name var
717
  = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
718
719
	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
		ptext SLIT("does not appear on left hand side")]
720

721
722
723
emptyConDeclsErr tycon
  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
	 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
sof's avatar
sof committed
724
\end{code}