RnSource.lhs 30.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
		  rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
9
	) where
10

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

sof's avatar
sof committed
13
import RnExpr
14
import HsSyn
15
import HscTypes		( GlobalRdrEnv )
16
import HsTypes		( hsTyVarNames, pprHsContext )
17
import RdrName		( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv )
18
import RdrHsSyn		( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
19
			  extractRuleBndrsTyVars, extractHsTyRdrTyVars,
20
			  extractHsCtxtRdrTyVars, extractGenericPatTyVars
21
			)
22
import RnHsSyn
23
24
import HsCore

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

36
import Class		( FunDep, DefMeth (..) )
37
import DataCon		( dataConId )
38
import Name		( Name, OccName, nameOccName, NamedThing(..) )
39
import NameSet
40
import PrelInfo		( derivableClassKeys, cCallishClassKeys )
41
import PrelNames	( deRefStablePtr_RDR, newStablePtr_RDR,
42
			  bindIO_RDR, returnIO_RDR
sof's avatar
sof committed
43
			)
44
import TysWiredIn	( tupleCon )
45
import List		( partition, nub )
46
import Outputable
47
import SrcLoc		( SrcLoc )
48
import CmdLineOpts	( DynFlag(..) )
49
				-- Warn of unused for-all'd tyvars
50
import Unique		( Uniquable(..) )
51
52
import ErrUtils		( Message )
import CStrings		( isCLabelString )
53
import ListSetOps	( removeDupsEq )
54
55
\end{code}

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


72
73
%*********************************************************
%*							*
74
\subsection{Value declarations}
75
76
77
78
%*							*
%*********************************************************

\begin{code}
79
80
81
rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
	      -> [RdrNameHsDecl] 
	      -> RnMG ([RenamedHsDecl], FreeVars)
82
83
	-- The decls get reversed, but that's ok

84
85
rnSourceDecls gbl_env local_fixity_env decls
  = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls)
86
  where
87
88
89
90
	-- 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
91
    go fvs ds' (d:ds)         = rnSourceDecl d	`thenRn` \(d', fvs') ->
92
			        go (fvs `plusFV` fvs') (d':ds') ds
93
94
95
96
97
98
99
100
101
102
\end{code}


%*********************************************************
%*							*
\subsection{Value declarations}
%*							*
%*********************************************************

\begin{code}
103
104
-- rnSourceDecl does all the work
rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
105

106
107
rnSourceDecl (ValD binds) = rnTopBinds binds	`thenRn` \ (new_binds, fvs) ->
			    returnRn (ValD new_binds, fvs)
108

109
rnSourceDecl (TyClD tycl_decl)
110
111
  = rnTyClDecl tycl_decl		`thenRn` \ new_decl ->
    rnClassBinds tycl_decl new_decl	`thenRn` \ (new_decl', fvs) ->
112
    returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
113

114
rnSourceDecl (InstD inst)
115
  = rnInstDecl inst		`thenRn` \ new_inst ->
116
    rnInstBinds inst new_inst	`thenRn` \ (new_inst', fvs) ->
117
    returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
118

119
rnSourceDecl (RuleD rule)
120
121
  = rnHsRuleDecl rule		`thenRn` \ (new_rule, fvs) ->
    returnRn (RuleD new_rule, fvs)
122

123
rnSourceDecl (DefD (DefaultDecl tys src_loc))
124
  = pushSrcLocRn src_loc $
125
    mapFvRn (rnHsTypeFVs doc_str) tys		`thenRn` \ (tys', fvs) ->
126
    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
127
  where
128
129
    doc_str = text "a `default' declaration"

130
rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
131
132
133
134
  = pushSrcLocRn src_loc $
    lookupOccRn name		        `thenRn` \ name' ->
    let 
	extra_fvs FoExport 
135
	  | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
136
137
138
139
140
141
142
143
144
145
				     bindIO_RDR, returnIO_RDR]
	  | otherwise =
		lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
		returnRn (addOneFV fvs name')
	extra_fvs other = returnRn emptyFVs
    in
    checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)	`thenRn_`

    extra_fvs imp_exp					`thenRn` \ fvs1 -> 

146
    rnHsTypeFVs fo_decl_msg ty	       		`thenRn` \ (ty', fvs2) ->
147
148
149
    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
	      fvs1 `plusFV` fvs2)
 where
150
  fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
  isDyn	      = isDynamicExtName ext_nm

  ok_ext_nm Dynamic 		   = True
  ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
  ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
\end{code}


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

\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
  = pushSrcLocRn src_loc $
168
169
170
171
    rnHsSigType (text "an instance decl") inst_ty	`thenRn` \ inst_ty' ->

    (case maybe_dfun_rdr_name of
	Nothing		   -> returnRn Nothing
172
	Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name	`thenRn` \ dfun_name ->
173
174
175
176
			      returnRn (Just dfun_name)
    )							`thenRn` \ maybe_dfun_name ->

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

-- Compare rnClassBinds
rnInstBinds (InstDecl _       mbinds uprags _                   _      )
181
	    (InstDecl inst_ty _      _      maybe_dfun_rdr_name src_loc)
182
  = let
183
184
	meth_doc    = text "the bindings in an instance declaration"
	meth_names  = collectLocatedMonoBinders mbinds
185
	inst_tyvars = case inst_ty of
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
			HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
			other			          -> []
	-- (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) (		
	rnMethodBinds [] mbinds
    )						`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 (
210
       renameSigsFVs (okInstDclSig binder_set) uprags
211
    )							`thenRn` \ (uprags', prag_fvs) ->
212

213
214
    returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc,
	      meth_fvs `plusFV` prag_fvs)
215
216
217
218
219
220
221
222
223
\end{code}

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

\begin{code}
224
rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
225
226
227
  = pushSrcLocRn src_loc	$
    lookupOccRn fn		`thenRn` \ fn' ->
    rnCoreBndrs vars		$ \ vars' ->
228
    mapRn rnCoreExpr args	`thenRn` \ args' ->
229
230
    rnCoreExpr rhs		`thenRn` \ rhs' ->
    returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc)
231

232
rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
  = ASSERT( null tvs )
    pushSrcLocRn src_loc			$

    bindTyVarsFV2Rn doc (map UserTyVar sig_tvs)	$ \ sig_tvs' _ ->
    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_`
    returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
	      fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
  where
    doc = text "the transformation rule" <+> ptext rule_name
    sig_tvs = extractRuleBndrsTyVars vars
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

    rn_var (RuleBndr v, id)	 = returnRn (RuleBndr id, emptyFVs)
258
    rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t	`thenRn` \ (t', fvs) ->
259
				   returnRn (RuleBndrSig id t', fvs)
260
261
\end{code}

262

263
264
%*********************************************************
%*							*
265
\subsection{Type, class and iface sig declarations}
266
267
268
269
270
271
272
273
274
%*							*
%*********************************************************

@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
275
276
277
278
279
280
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.
281
282

\begin{code}
283
rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
284
285
  = pushSrcLocRn loc $
    lookupTopBndrRn name		`thenRn` \ name' ->
286
287
    rnHsType doc_str ty			`thenRn` \ ty' ->
    mapRn rnIdInfo id_infos		`thenRn` \ id_infos' -> 
288
    returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
289
290
291
  where
    doc_str = text "the interface signature for" <+> quotes (ppr name)

292
293
294
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
		    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
		    tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
295
  = pushSrcLocRn src_loc $
296
    lookupTopBndrRn tycon		    	`thenRn` \ tycon' ->
297
298
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
    rnContext data_doc context 			`thenRn` \ context' ->
299
    checkDupOrQualNames data_doc con_names	`thenRn_`
300
    mapRn rnConDecl condecls			`thenRn` \ condecls' ->
301
    mapRn lookupSysBinder sys_names	        `thenRn` \ sys_names' ->
302
    rnDerivs derivings				`thenRn` \ derivings' ->
303
304
305
    returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
		      tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
		      tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'})
sof's avatar
sof committed
306
  where
307
    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
sof's avatar
sof committed
308
    con_names = map conDeclName condecls
309

310
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
311
  = pushSrcLocRn src_loc $
312
    doptRn Opt_GlasgowExts			`thenRn` \ glaExts ->
313
    lookupTopBndrRn name			`thenRn` \ name' ->
314
315
    bindTyVarsRn syn_doc tyvars 		$ \ tyvars' ->
    rnHsType syn_doc (unquantify glaExts ty)	`thenRn` \ ty' ->
316
    returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
sof's avatar
sof committed
317
  where
318
    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
319

320
321
	-- For H98 we do *not* universally quantify on the RHS of a synonym
	-- Silently discard context... but the tyvars in the rest won't be in scope
322
	-- In interface files all types are quantified, so this is a no-op
323
324
    unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
    unquantify glaExys ty			     	      = ty
325

326
327
328
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
		       tcdSysNames = names, tcdLoc = src_loc})
329
  = pushSrcLocRn src_loc $
sof's avatar
sof committed
330

331
    lookupTopBndrRn cname			`thenRn` \ cname' ->
332

333
334
335
336
	-- 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!
337
    mapRn lookupSysBinder names			`thenRn` \ names' ->
sof's avatar
sof committed
338

339
	-- Tyvars scope over bindings and context
340
    bindTyVars2Rn cls_doc tyvars		$ \ clas_tyvar_names tyvars' ->
341
342

	-- Check the superclasses
343
    rnContext cls_doc context			`thenRn` \ context' ->
344

345
	-- Check the functional dependencies
346
    rnFds cls_doc fds				`thenRn` \ fds' ->
347

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

361
362
363
364
365
	-- 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.

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

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

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

rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
398
399
400
401
rnClassBinds (ClassDecl {tcdMeths = Just mbinds})		-- Get mbinds from here
 rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc})	-- Everything else is here
  -- There are some default-method bindings (abeit possibly empty) so 
  -- this is a source-code class declaration
402
  = 	-- The newLocals call is tiresome: given a generic class decl
403
404
405
406
407
408
409
410
	--	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 
411
    extendTyVarEnvFVRn (map hsTyVarName tyvars)		$
412
413
414
415
    getLocalNameEnv					`thenRn` \ name_env ->
    let
	meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
	gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
416
						not (tv `elemRdrEnv` name_env)]
417
    in
sof's avatar
sof committed
418
    checkDupOrQualNames meth_doc meth_rdr_names_w_locs	`thenRn_`
419
    newLocalsRn gen_rdr_tyvars_w_locs			`thenRn` \ gen_tyvars ->
420
    rnMethodBinds gen_tyvars mbinds			`thenRn` \ (mbinds', meth_fvs) ->
421
    returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
422
  where
423
    meth_doc = text "the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
424
425
426

rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
	-- Not a class declaration
427
428
429
430
431
\end{code}


%*********************************************************
%*							*
432
\subsection{Support code for type/data declarations}
433
434
435
%*							*
%*********************************************************

436
\begin{code}
437
rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name])
438
439

rnDerivs Nothing -- derivs not specified
440
  = returnRn Nothing
441

442
443
rnDerivs (Just clss)
  = mapRn do_one clss	`thenRn` \ clss' ->
444
    returnRn (Just clss')
445
  where
446
447
448
449
    do_one cls = lookupOccRn cls	`thenRn` \ clas_name ->
		 checkRn (getUnique clas_name `elem` derivableClassKeys)
			 (derivingNonStdClassErr clas_name)	`thenRn_`
		 returnRn clas_name
450
\end{code}
451
452

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

456
rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
457
rnConDecl (ConDecl name wkr tvs cxt details locn)
sof's avatar
sof committed
458
  = pushSrcLocRn locn $
459
460
    checkConName name		`thenRn_` 
    lookupTopBndrRn name	`thenRn` \ new_name ->
461

462
    lookupSysBinder wkr		`thenRn` \ new_wkr ->
463
464
	-- See comments with ClassDecl

465
466
467
468
    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)
469
470
  where
    doc = text "the definition of data constructor" <+> quotes (ppr name)
sof's avatar
sof committed
471

472
rnConDetails doc locn (VanillaCon tys)
473
474
  = mapRn (rnBangTy doc) tys	`thenRn` \ new_tys  ->
    returnRn (VanillaCon new_tys)
sof's avatar
sof committed
475

476
rnConDetails doc locn (InfixCon ty1 ty2)
477
478
479
  = rnBangTy doc ty1  		`thenRn` \ new_ty1 ->
    rnBangTy doc ty2  		`thenRn` \ new_ty2 ->
    returnRn (InfixCon new_ty1 new_ty2)
480

481
482
rnConDetails doc locn (RecCon fields)
  = checkDupOrQualNames doc field_names	`thenRn_`
483
484
    mapRn (rnField doc) fields		`thenRn` \ new_fields ->
    returnRn (RecCon new_fields)
sof's avatar
sof committed
485
486
  where
    field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
487

488
rnField doc (names, ty)
489
  = mapRn lookupTopBndrRn names	`thenRn` \ new_names ->
490
491
    rnBangTy doc ty		`thenRn` \ new_ty ->
    returnRn (new_names, new_ty) 
492

493
rnBangTy doc (Banged ty)
494
495
  = rnHsType doc ty		`thenRn` \ new_ty ->
    returnRn (Banged new_ty)
496

497
rnBangTy doc (Unbanged ty)
498
499
  = rnHsType doc ty 		`thenRn` \ new_ty ->
    returnRn (Unbanged new_ty)
500

501
rnBangTy doc (Unpacked ty)
502
503
  = rnHsType doc ty 		`thenRn` \ new_ty ->
    returnRn (Unpacked new_ty)
504

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

520

521
522
523
524
525
%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************
526

527
\begin{code}
528
529
530
531
532
533
534
535
536
537
538
rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
rnHsTypeFVs doc_str ty 
  = rnHsType doc_str ty		`thenRn` \ ty' ->
    returnRn (ty', extractHsTyNames ty')

rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
rnHsSigTypeFVs doc_str ty
  = rnHsSigType doc_str ty	`thenRn` \ ty' ->
    returnRn (ty', extractHsTyNames ty')

rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
539
540
541
	-- rnHsSigType is used for source-language type signatures,
	-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
542
  = rnHsType (text "the type signature for" <+> doc_str) ty
543
    
544
---------------------------------------
545
rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
546

547
rnHsType doc (HsForAllTy Nothing ctxt ty)
548
	-- Implicit quantifiction in source code (no kinds on tyvars)
549
550
	-- Given the signature  C => T  we universally quantify 
	-- over FV(T) \ {in-scope-tyvars} 
551
  = getLocalNameEnv		`thenRn` \ name_env ->
552
    let
553
554
555
	mentioned_in_tau  = extractHsTyRdrTyVars ty
	mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
	mentioned	  = nub (mentioned_in_tau ++ mentioned_in_ctxt)
556
	forall_tyvars	  = filter (not . (`elemRdrEnv` name_env)) mentioned
sof's avatar
sof committed
557
    in
558
    rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
559

560
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
561
	-- Explicit quantification.
562
563
	-- Check that the forall'd tyvars are actually 
	-- mentioned in the type, and produce a warning if not
564
  = let
565
566
567
	mentioned_in_tau		= extractHsTyRdrTyVars tau
	mentioned_in_ctxt		= extractHsCtxtRdrTyVars ctxt
	mentioned			= nub (mentioned_in_tau ++ mentioned_in_ctxt)
568
	forall_tyvar_names		= hsTyVarNames forall_tyvars
569

570
	-- Explicitly quantified but not mentioned in ctxt or tau
571
	warn_guys			= filter (`notElem` mentioned) forall_tyvar_names
572
    in
573
    mapRn_ (forAllWarn doc tau) warn_guys	`thenRn_`
574
    rnForAll doc forall_tyvars ctxt tau
575

576
577
rnHsType doc (HsTyVar tyvar)
  = lookupOccRn tyvar 		`thenRn` \ tyvar' ->
578
    returnRn (HsTyVar tyvar')
579

580
581
rnHsType doc (HsOpTy ty1 opname ty2)
  = lookupOccRn opname	`thenRn` \ name' ->
582
583
584
    rnHsType doc ty1	`thenRn` \ ty1' ->
    rnHsType doc ty2	`thenRn` \ ty2' -> 
    returnRn (HsOpTy ty1' name' ty2')
585
586

rnHsType doc (HsNumTy i)
587
588
  | i == 1    = returnRn (HsNumTy i)
  | otherwise = failWithRn (HsNumTy i)
589
590
			   (ptext SLIT("Only unit numeric type pattern is valid"))

591
rnHsType doc (HsFunTy ty1 ty2)
592
  = rnHsType doc ty1	`thenRn` \ ty1' ->
593
	-- Might find a for-all as the arg of a function type
594
    rnHsType doc ty2	`thenRn` \ ty2' ->
595
596
	-- Or as the result.  This happens when reading Prelude.hi
	-- when we find return :: forall m. Monad m -> forall a. a -> m a
597
    returnRn (HsFunTy ty1' ty2')
598

599
rnHsType doc (HsListTy ty)
600
601
  = rnHsType doc ty				`thenRn` \ ty' ->
    returnRn (HsListTy ty')
602

603
604
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
605
rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
606
607
	-- Don't do lookupOccRn, because this is built-in syntax
	-- so it doesn't need to be in scope
608
  = mapRn (rnHsType doc) tys	  	`thenRn` \ tys' ->
609
    returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
610
  where
611
    tup_name = tupleTyCon_name boxity arity
612
613
614
  

rnHsType doc (HsAppTy ty1 ty2)
615
616
617
  = rnHsType doc ty1		`thenRn` \ ty1' ->
    rnHsType doc ty2		`thenRn` \ ty2' ->
    returnRn (HsAppTy ty1' ty2')
618
619

rnHsType doc (HsPredTy pred)
620
621
  = rnPred doc pred	`thenRn` \ pred' ->
    returnRn (HsPredTy pred')
622

623
rnHsTypes doc tys = mapRn (rnHsType doc) tys
624
625
626
\end{code}

\begin{code}
627
rnForAll doc forall_tyvars ctxt ty
628
  = bindTyVarsRn doc forall_tyvars	$ \ new_tyvars ->
629
630
631
    rnContext doc ctxt			`thenRn` \ new_ctxt ->
    rnHsType doc ty			`thenRn` \ new_ty ->
    returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
632
633
634
\end{code}

\begin{code}
635
rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
636
rnContext doc ctxt
637
  = mapRn rn_pred ctxt		`thenRn` \ theta ->
638
    let
639
640
	(_, dups) = removeDupsEq theta
		-- We only have equality, not ordering
641
    in
sof's avatar
sof committed
642
643
	-- Check for duplicate assertions
	-- If this isn't an error, then it ought to be:
644
    mapRn (addWarnRn . dupClassAssertWarn theta) dups		`thenRn_`
645
    returnRn theta
646
647
648
649
650
651
  where
   	--Someone discovered that @CCallable@ and @CReturnable@
	-- could be used in contexts such as:
	--	foo :: CCallable a => a -> PrimIO Int
	-- Doing this utterly wrecks the whole point of introducing these
	-- classes so we specifically check that this isn't being done.
652
    rn_pred pred = rnPred doc pred				`thenRn` \ pred'->
653
654
		   checkRn (not (bad_pred pred'))
			   (naughtyCCallContextErr pred')	`thenRn_`
655
		   returnRn pred'
656
657
658
659

    bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
    bad_pred other	       = False

660

661
662
rnPred doc (HsPClass clas tys)
  = lookupOccRn clas		`thenRn` \ clas_name ->
663
664
    rnHsTypes doc tys		`thenRn` \ tys' ->
    returnRn (HsPClass clas_name tys')
665

666
rnPred doc (HsPIParam n ty)
667
  = newIPName n			`thenRn` \ name ->
668
669
    rnHsType doc ty		`thenRn` \ ty' ->
    returnRn (HsPIParam name ty')
670
671
\end{code}

672
\begin{code}
673
rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
674
675

rnFds doc fds
676
  = mapRn rn_fds fds
677
678
  where
    rn_fds (tys1, tys2)
679
680
681
      =	rnHsTyVars doc tys1		`thenRn` \ tys1' ->
	rnHsTyVars doc tys2		`thenRn` \ tys2' ->
	returnRn (tys1', tys2')
682

683
684
rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
685
\end{code}
686

687
%*********************************************************
688
%*							 *
689
\subsection{IdInfo}
690
%*							 *
691
692
%*********************************************************

693
\begin{code}
694
rnIdInfo (HsWorker worker)
695
  = lookupOccRn worker			`thenRn` \ worker' ->
696
697
698
699
700
701
702
703
    returnRn (HsWorker worker')

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
rnIdInfo HsCprInfo		= returnRn HsCprInfo
704
705
\end{code}

706
@UfCore@ expressions.
707
708

\begin{code}
709
rnCoreExpr (UfType ty)
710
711
  = rnHsType (text "unfolding type") ty	`thenRn` \ ty' ->
    returnRn (UfType ty')
712

713
rnCoreExpr (UfVar v)
sof's avatar
sof committed
714
  = lookupOccRn v 	`thenRn` \ v' ->
715
    returnRn (UfVar v')
716

717
rnCoreExpr (UfLit l)
718
  = returnRn (UfLit l)
719
720

rnCoreExpr (UfLitLit l ty)
721
722
  = rnHsType (text "litlit") ty	`thenRn` \ ty' ->
    returnRn (UfLitLit l ty')
723
724

rnCoreExpr (UfCCall cc ty)
725
726
  = rnHsType (text "ccall") ty	`thenRn` \ ty' ->
    returnRn (UfCCall cc ty')
727

728
729
730
731
732
733
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
734
735

rnCoreExpr (UfApp fun arg)
736
737
738
  = rnCoreExpr fun		`thenRn` \ fun' ->
    rnCoreExpr arg		`thenRn` \ arg' ->
    returnRn (UfApp fun' arg')
739
740

rnCoreExpr (UfCase scrut bndr alts)
741
  = rnCoreExpr scrut			`thenRn` \ scrut' ->
742
    bindCoreLocalRn bndr		$ \ bndr' ->
743
744
    mapRn rnCoreAlt alts		`thenRn` \ alts' ->
    returnRn (UfCase scrut' bndr' alts')
745

746
rnCoreExpr (UfNote note expr) 
747
748
749
  = rnNote note			`thenRn` \ note' ->
    rnCoreExpr expr		`thenRn` \ expr' ->
    returnRn  (UfNote note' expr')
750
751
752

rnCoreExpr (UfLam bndr body)
  = rnCoreBndr bndr 		$ \ bndr' ->
753
754
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLam bndr' body')
755
756

rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
757
758
759
760
  = rnCoreExpr rhs		`thenRn` \ rhs' ->
    rnCoreBndr bndr 		$ \ bndr' ->
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLet (UfNonRec bndr' rhs') body')
761
762
763

rnCoreExpr (UfLet (UfRec pairs) body)
  = rnCoreBndrs bndrs		$ \ bndrs' ->
764
765
766
    mapRn rnCoreExpr rhss	`thenRn` \ rhss' ->
    rnCoreExpr body		`thenRn` \ body' ->
    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
767
  where
768
769
770
771
772
    (bndrs, rhss) = unzip pairs
\end{code}

\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
773
  = rnHsType doc ty		`thenRn` \ ty' ->
774
775
    bindCoreLocalRn name	$ \ name' ->
    thing_inside (UfValBinder name' ty')
776
  where
777
    doc = text "unfolding id"
778
779
    
rnCoreBndr (UfTyBinder name kind) thing_inside
780
  = bindCoreLocalRn name		$ \ name' ->
781
782
    thing_inside (UfTyBinder name' kind)
    
783
784
785
786
rnCoreBndrs []     thing_inside = thing_inside []
rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b		$ \ name' ->
				  rnCoreBndrs bs 	$ \ names' ->
				  thing_inside (name':names')
787
788
789
\end{code}    

\begin{code}
790
rnCoreAlt (con, bndrs, rhs)
791
  = rnUfCon con 			`thenRn` \ con' ->
792
793
794
    bindCoreLocalsRn bndrs		$ \ bndrs' ->
    rnCoreExpr rhs			`thenRn` \ rhs' ->
    returnRn (con', bndrs', rhs')
795

796
rnNote (UfCoerce ty)
797
798
  = rnHsType (text "unfolding coerce") ty	`thenRn` \ ty' ->
    returnRn (UfCoerce ty')
799

800
801
802
rnNote (UfSCC cc)   = returnRn (UfSCC cc)
rnNote UfInlineCall = returnRn UfInlineCall
rnNote UfInlineMe   = returnRn UfInlineMe
803

804

805
rnUfCon UfDefault
806
  = returnRn UfDefault
807

808
809
810
811
rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
  = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
  where
    tup_name = getName (tupleCon boxity arity)
812

813
rnUfCon (UfDataAlt con)
814
  = lookupOccRn con		`thenRn` \ con' ->
815
    returnRn (UfDataAlt con')
816

817
rnUfCon (UfLitAlt lit)
818
  = returnRn (UfLitAlt lit)
819

820
rnUfCon (UfLitLitAlt lit ty)
821
822
  = rnHsType (text "litlit") ty		`thenRn` \ ty' ->
    returnRn (UfLitLitAlt lit ty')
823
\end{code}
824

825
%*********************************************************
826
%*							 *
827
\subsection{Rule shapes}
828
%*							 *
829
830
831
%*********************************************************

Check the shape of a transformation rule LHS.  Currently
832
833
we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
not one of the @forall@'d variables.
834
835
836
837
838
839
840
841
842
843
844

\begin{code}
validRuleLhs foralls lhs
  = check lhs
  where
    check (HsApp e1 e2) 		  = check e1
    check (HsVar v) | v `notElem` foralls = True
    check other				  = False
\end{code}


845
%*********************************************************
846
%*							 *
847
\subsection{Errors}
848
%*							 *
849
%*********************************************************
850

851
\begin{code}
852
853
derivingNonStdClassErr clas
  = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
854

855
856
badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
857

858
forAllWarn doc ty tyvar
859
860
861
862
863
  = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
    () | not warn_unused -> returnRn ()
       | otherwise
       -> getModeRn		`thenRn` \ mode ->
          case mode of {
864
#ifndef DEBUG
865
866
867
868
869
870
871
872
873
874
875
876
	     InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
		                            -- unless DEBUG is on, in which case it is slightly
					    -- informative.  They can arise from mkRhsTyLam,
#endif					    -- leading to (say) 	f :: forall a b. [b] -> [b]
	     other ->
		addWarnRn (
		   sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
		   nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
		   $$
		   (ptext SLIT("In") <+> doc)
                )
          }
877

878
879
880
881
882
883
884
885
886
887
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
  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
		ptext SLIT("does not appear on left hand side")]
888
889
890
891

badExtName :: ExtName -> Message
badExtName ext_nm
  = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
892
893
894
895
896

dupClassAssertWarn ctxt (assertion : dups)
  = sep [hsep [ptext SLIT("Duplicate class assertion"), 
	       quotes (ppr assertion),
	       ptext SLIT("in the context:")],
897
	 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
898
899
900
901

naughtyCCallContextErr (HsPClass clas _)
  = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), 
	 ptext SLIT("in a context")]
sof's avatar
sof committed
902
\end{code}