RnSource.lhs 24.6 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, bindTyVars2Rn,
29
			  extendTyVarEnvFVRn,
30 31
			  bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
			  checkDupOrQualNames, checkDupNames, mapFvRn
32
			)
33
import RnMonad
34

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

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


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

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

81 82
rnSourceDecls gbl_env avails local_fixity_env decls
  = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
83
  where
84 85 86 87
	-- 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
88
    go fvs ds' (d:ds)         = rnSourceDecl d	`thenRn` \(d', fvs') ->
89
			        go (fvs `plusFV` fvs') (d':ds') ds
90 91


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

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

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

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

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

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

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


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

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

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

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


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

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

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

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

172 173 174
-- Compare finishSourceTyClDecl
finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
		     (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
175 176 177
	-- Used for both source decls only
  = ASSERT( not (maybeToBool maybe_dfun_name) )	-- Source decl!
    let
178
	meth_doc    = text "In the bindings in an instance declaration"
179
	meth_names  = collectLocatedMonoBinders mbinds
180
	(inst_tyvars, (cls,_)) = getHsInstHead inst_ty
181 182 183 184 185 186 187 188
	-- (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) (		
189
	rnMethodBinds cls [] mbinds
190 191 192 193 194 195 196 197 198 199 200 201 202
    )						`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 (
203
       renameSigsFVs (okInstDclSig binder_set) uprags
204
    )							`thenRn` \ (uprags', prag_fvs) ->
205

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

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

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

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

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

    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_`
244
    returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
245 246
	      fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
  where
247
    doc = text "In the transformation rule" <+> ptext rule_name
248 249 250 251 252
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

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

257

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

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

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

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

292 293
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
		    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
294
		    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 301 302 303 304 305 306 307 308 309 310

	-- 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_` 

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

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

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

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

337 338 339 340
	-- 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!
341
    mapRn lookupSysBinder names			`thenRn` \ names' ->
sof's avatar
sof committed
342

343
	-- Tyvars scope over bindings and context
344
    bindTyVars2Rn cls_doc tyvars		$ \ clas_tyvar_names tyvars' ->
345 346

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

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

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

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

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

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

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

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

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


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

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

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

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

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

472 473 474 475
    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)
476
  where
477
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
sof's avatar
sof committed
478

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

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

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

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

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

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

519

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

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

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

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

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

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

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
557 558
\end{code}

559
@UfCore@ expressions.
560 561

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

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

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

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

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

581 582 583 584 585 586
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
587 588

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

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

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

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

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

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

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

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

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

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

657

658
rnUfCon UfDefault
659
  = returnRn UfDefault
660

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

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

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

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

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

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

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


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

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

709 710
badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
711 712 713 714 715 716 717
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
718
  = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
719 720
	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
		ptext SLIT("does not appear on left hand side")]
721

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