RnExpr.lhs 31 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7
%
\section[RnExpr]{Renaming of expressions}

Basically dependency analysis.

8
Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
9 10 11 12 13
general, all of these functions return a renamed thing, and a set of
free variables.

\begin{code}
module RnExpr (
14 15
	rnMatch, rnGRHSs, rnExpr, rnExprs, rnStmts,
	checkPrecMatch
16 17
   ) where

18 19
#include "HsVersions.h"

20 21 22 23 24
import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindsAndThen, rnBinds ) 

-- 	RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
--	RnBinds	 imports RnExpr.rnMatch, etc
--	RnExpr	 imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
25 26 27 28

import HsSyn
import RdrHsSyn
import RnHsSyn
29
import TcRnMonad
30
import RnEnv
31
import RnNames		( importsFromLocalDecls )
32
import RnTypes		( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
33
			  dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
34
import CmdLineOpts	( DynFlag(..), opt_IgnoreAsserts )
chak's avatar
chak committed
35
import BasicTypes	( Fixity(..), FixityDirection(..), IPName(..),
36
			  defaultFixity, negateFixity, compareFixity )
37
import PrelNames	( hasKey, assertIdKey, 
38
			  foldrName, buildName, 
39
			  cCallableClassName, cReturnableClassName, 
40 41
			  enumClassName, 
			  splitName, fstName, sndName, ioDataConName, 
chak's avatar
chak committed
42
			  replicatePName, mapPName, filterPName,
43
			  crossPName, zipPName, toPName,
44
			  enumFromToPName, enumFromThenToPName, assertErrorName,
45
			  negateName, monadNames, mfixName )
46
import Name		( Name, nameOccName )
47
import NameSet
48
import UnicodeUtil	( stringToUtf8 )
49
import UniqFM		( isNullUFM )
50
import UniqSet		( emptyUniqSet )
51 52
import Util		( isSingleton )
import List		( intersectBy, unzip4 )
53
import ListSetOps	( removeDups )
sof's avatar
sof committed
54
import Outputable
55
import FastString
56 57 58 59 60 61 62 63 64 65
\end{code}


************************************************************************
*									*
\subsection{Match}
*									*
************************************************************************

\begin{code}
66
rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
67

68
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
69
  = addSrcLoc (getMatchLoc match)	$
70

71 72
	-- Deal with the rhs type signature
    bindPatSigTyVars rhs_sig_tys	$ 
73
    doptM Opt_GlasgowExts		`thenM` \ opt_GlasgowExts ->
74
    (case maybe_rhs_sig of
75 76 77 78 79 80
	Nothing -> returnM (Nothing, emptyFVs)
	Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty	`thenM` \ (ty', ty_fvs) ->
				     returnM (Just ty', ty_fvs)
		| otherwise	  -> addErr (patSigErr ty)	`thenM_`
				     returnM (Nothing, emptyFVs)
    )					`thenM` \ (maybe_rhs_sig', ty_fvs) ->
81

82 83
	-- Now the main event
    rnPatsAndThen ctxt pats	$ \ pats' ->
84
    rnGRHSs ctxt grhss		`thenM` \ (grhss', grhss_fvs) ->
85 86 87 88 89 90 91 92

    returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
	-- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs
  where
     rhs_sig_tys =  case maybe_rhs_sig of
			Nothing -> []
			Just ty -> [ty]
     doc_sig = text "In a result type-signature"
93 94
\end{code}

95

96 97
%************************************************************************
%*									*
98
\subsubsection{Guarded right-hand sides (GRHSs)}
99 100 101 102
%*									*
%************************************************************************

\begin{code}
103
rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
104

105
rnGRHSs ctxt (GRHSs grhss binds _)
106
  = rnBindsAndThen binds	$ \ binds' ->
107
    mapFvRn (rnGRHS ctxt) grhss	`thenM` \ (grhss', fvGRHSs) ->
108
    returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
109

110
rnGRHS ctxt (GRHS guarded locn)
111 112 113 114 115
  = addSrcLoc locn $		    
    doptM Opt_GlasgowExts		`thenM` \ opt_GlasgowExts ->
    checkM (opt_GlasgowExts || is_standard_guard guarded)
	   (addWarn (nonStdGuardErr guarded))	`thenM_` 

116
    rnStmts (PatGuard ctxt) guarded	`thenM` \ (guarded', fvs) ->
117
    returnM (GRHS guarded' locn, fvs)
118
  where
sof's avatar
sof committed
119 120 121
	-- Standard Haskell 1.4 guards are just a single boolean
	-- expression, rather than a list of qualifiers as in the
	-- Glasgow extension
122 123 124
    is_standard_guard [ResultStmt _ _]                 = True
    is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
    is_standard_guard other	      		       = False
125 126 127 128 129 130 131 132 133
\end{code}

%************************************************************************
%*									*
\subsubsection{Expressions}
%*									*
%************************************************************************

\begin{code}
134
rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
sof's avatar
sof committed
135 136
rnExprs ls = rnExprs' ls emptyUniqSet
 where
137
  rnExprs' [] acc = returnM ([], acc)
sof's avatar
sof committed
138
  rnExprs' (expr:exprs) acc
139
   = rnExpr expr 	        `thenM` \ (expr', fvExpr) ->
sof's avatar
sof committed
140 141 142 143

	-- Now we do a "seq" on the free vars because typically it's small
	-- or empty, especially in very long lists of constants
    let
144
	acc' = acc `plusFV` fvExpr
sof's avatar
sof committed
145
    in
146 147
    (grubby_seqNameSet acc' rnExprs') exprs acc'	`thenM` \ (exprs', fvExprs) ->
    returnM (expr':exprs', fvExprs)
sof's avatar
sof committed
148 149 150 151

-- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
grubby_seqNameSet ns result | isNullUFM ns = result
			    | otherwise    = result
152 153
\end{code}

154
Variables. We look up the variable and return the resulting name. 
155 156

\begin{code}
157
rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
158 159

rnExpr (HsVar v)
160
  = lookupOccRn v	`thenM` \ name ->
161 162 163
    if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
	-- We expand it to (GHC.Err.assertError location_string)
        mkAssertErrorExpr
164
    else
165 166 167
        -- The normal case.  Even if the Id was 'assert', if we are 
	-- ignoring assertions we leave it as GHC.Base.assert; 
	-- this function just ignores its first arg.
168
       returnM (HsVar name, unitFV name)
169

170
rnExpr (HsIPVar v)
171
  = newIPName v			`thenM` \ name ->
172 173
    let 
	fvs = case name of
chak's avatar
chak committed
174
		Linear _  -> mkFVs [splitName, fstName, sndName]
175 176
		Dupable _ -> emptyFVs 
    in   
177
    returnM (HsIPVar name, fvs)
178

179
rnExpr (HsLit lit) 
180 181
  = litFVs lit		`thenM` \ fvs -> 
    returnM (HsLit lit, fvs)
182

183
rnExpr (HsOverLit lit) 
184 185
  = rnOverLit lit		`thenM` \ (lit', fvs) ->
    returnM (HsOverLit lit', fvs)
186

187
rnExpr (HsLam match)
188 189
  = rnMatch LambdaExpr match	`thenM` \ (match', fvMatch) ->
    returnM (HsLam match', fvMatch)
190 191

rnExpr (HsApp fun arg)
192 193 194
  = rnExpr fun		`thenM` \ (fun',fvFun) ->
    rnExpr arg		`thenM` \ (arg',fvArg) ->
    returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
195

196
rnExpr (OpApp e1 op _ e2) 
197 198 199
  = rnExpr e1				`thenM` \ (e1', fv_e1) ->
    rnExpr e2				`thenM` \ (e2', fv_e2) ->
    rnExpr op				`thenM` \ (op'@(HsVar op_name), fv_op) ->
200

sof's avatar
sof committed
201 202 203 204
	-- Deal with fixity
	-- When renaming code synthesised from "deriving" declarations
	-- we're in Interface mode, and we should ignore fixity; assume
	-- that the deriving code generator got the association correct
205
	-- Don't even look up the fixity when in interface mode
206
    getModeRn				`thenM` \ mode -> 
207
    (if isInterfaceMode mode
208 209
	then returnM (OpApp e1' op' defaultFixity e2')
	else lookupFixityRn op_name		`thenM` \ fixity ->
210
	     mkOpAppRn e1' op' fixity e2'
211
    )					`thenM` \ final_e -> 
212

213
    returnM (final_e,
214
	      fv_e1 `plusFV` fv_op `plusFV` fv_e2)
215

216
rnExpr (NegApp e _)
217 218 219 220
  = rnExpr e			`thenM` \ (e', fv_e) ->
    lookupSyntaxName negateName	`thenM` \ (neg_name, fv_neg) ->
    mkNegAppRn e' neg_name	`thenM` \ final_e ->
    returnM (final_e, fv_e `plusFV` fv_neg)
221 222

rnExpr (HsPar e)
223 224 225 226
  = rnExpr e 		`thenM` \ (e', fvs_e) ->
    returnM (HsPar e', fvs_e)

-- Template Haskell extensions
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
rnExpr e@(HsBracket br_body loc)
  = addSrcLoc loc		$
    checkTH e "bracket"		`thenM_`
    rnBracket br_body		`thenM` \ (body', fvs_e) ->
    returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)

rnExpr e@(HsSplice n splice loc)
  = addSrcLoc loc		$
    checkTH e "splice"		`thenM_`
    newLocalsRn [(n,loc)]	`thenM` \ [n'] ->
    rnExpr splice 		`thenM` \ (splice', fvs_e) ->
    returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)

rnExpr e@(HsReify (Reify flavour name))
  = checkTH e "reify"		`thenM_`
    lookupGlobalOccRn name	`thenM` \ name' ->
245
	-- For now, we can only reify top-level things
246
    returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
247

248
rnExpr section@(SectionL expr op)
249 250 251 252
  = rnExpr expr	 				`thenM` \ (expr', fvs_expr) ->
    rnExpr op	 				`thenM` \ (op', fvs_op) ->
    checkSectionPrec InfixL section op' expr' `thenM_`
    returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
253

254
rnExpr section@(SectionR op expr)
255 256 257 258
  = rnExpr op	 				`thenM` \ (op',   fvs_op) ->
    rnExpr expr	 				`thenM` \ (expr', fvs_expr) ->
    checkSectionPrec InfixR section op' expr'	`thenM_`
    returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
259

260
rnExpr (HsCCall fun args may_gc is_casm _)
261
	-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
262 263
  = rnExprs args				`thenM` \ (args', fvs_args) ->
    returnM (HsCCall fun args' may_gc is_casm placeHolderType, 
264 265 266
	      fvs_args `plusFV` mkFVs [cCallableClassName, 
				       cReturnableClassName, 
				       ioDataConName])
267

268 269 270 271
rnExpr (HsCoreAnn ann expr)
  = rnExpr expr `thenM` \ (expr', fvs_expr) ->
    returnM (HsCoreAnn ann expr', fvs_expr)

272
rnExpr (HsSCC lbl expr)
273 274
  = rnExpr expr	 	`thenM` \ (expr', fvs_expr) ->
    returnM (HsSCC lbl expr', fvs_expr)
275 276

rnExpr (HsCase expr ms src_loc)
277 278 279 280
  = addSrcLoc src_loc $
    rnExpr expr		 		`thenM` \ (new_expr, e_fvs) ->
    mapFvRn (rnMatch CaseAlt) ms	`thenM` \ (new_ms, ms_fvs) ->
    returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
281 282

rnExpr (HsLet binds expr)
283
  = rnBindsAndThen binds	$ \ binds' ->
284 285
    rnExpr expr			 `thenM` \ (expr',fvExpr) ->
    returnM (HsLet binds' expr', fvExpr)
286

287
rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
288
  = addSrcLoc src_loc $
289
    rnStmts do_or_lc stmts		`thenM` \ (stmts', fvs) ->
290 291

	-- Check the statement list ends in an expression
292
    case last stmts' of {
293
	ResultStmt _ _ -> returnM () ;
294
	_              -> addErr (doStmtListErr do_or_lc e)
295
    }					`thenM_`
296 297

	-- Generate the rebindable syntax for the monad
298 299
    mapAndUnzipM lookupSyntaxName 
	 (syntax_names do_or_lc)	`thenM` \ (monad_names', monad_fvs) ->
300

301
    returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, 
302
	     fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
303
  where
304 305 306 307 308 309 310 311
    implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
    implicit_fvs ListComp = mkFVs [foldrName, buildName]
    implicit_fvs DoExpr   = emptyFVs
    implicit_fvs MDoExpr  = emptyFVs

    syntax_names DoExpr  = monadNames
    syntax_names MDoExpr = monadNames ++ [mfixName]
    syntax_names other   = []
312

313
rnExpr (ExplicitList _ exps)
314 315
  = rnExprs exps		 	`thenM` \ (exps', fvs) ->
    returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
316

chak's avatar
chak committed
317
rnExpr (ExplicitPArr _ exps)
318 319
  = rnExprs exps		 	`thenM` \ (exps', fvs) ->
    returnM  (ExplicitPArr placeHolderType exps', 
chak's avatar
chak committed
320 321
	       fvs `addOneFV` toPName `addOneFV` parrTyCon_name)

322 323 324
rnExpr e@(ExplicitTuple exps boxity)
  = checkTupSize tup_size			`thenM_`
    rnExprs exps	 			`thenM` \ (exps', fvs) ->
325
    returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
326
  where
327 328
    tup_size   = length exps
    tycon_name = tupleTyCon_name boxity tup_size
329

330
rnExpr (RecordCon con_id rbinds)
331 332 333
  = lookupOccRn con_id 			`thenM` \ conname ->
    rnRbinds "construction" rbinds	`thenM` \ (rbinds', fvRbinds) ->
    returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
334 335

rnExpr (RecordUpd expr rbinds)
336 337 338
  = rnExpr expr			`thenM` \ (expr', fvExpr) ->
    rnRbinds "update" rbinds	`thenM` \ (rbinds', fvRbinds) ->
    returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
339 340

rnExpr (ExprWithTySig expr pty)
341 342 343 344 345
  = rnExpr expr			`thenM` \ (expr', fvExpr) ->
    rnHsTypeFVs doc pty		`thenM` \ (pty', fvTy) ->
    returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
  where 
    doc = text "In an expression type signature"
346 347

rnExpr (HsIf p b1 b2 src_loc)
348 349 350 351 352
  = addSrcLoc src_loc $
    rnExpr p		`thenM` \ (p', fvP) ->
    rnExpr b1		`thenM` \ (b1', fvB1) ->
    rnExpr b2		`thenM` \ (b2', fvB2) ->
    returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
353

354
rnExpr (HsType a)
355 356
  = rnHsTypeFVs doc a	`thenM` \ (t, fvT) -> 
    returnM (HsType t, fvT)
357
  where 
358
    doc = text "In a type argument"
359

360
rnExpr (ArithSeqIn seq)
361
  = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
362
    returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
chak's avatar
chak committed
363 364

rnExpr (PArrSeqIn seq)
365
  = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
366
    returnM (PArrSeqIn new_seq, 
367
	     fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
368
\end{code}
369

370 371 372 373 374
These three are pattern syntax appearing in expressions.
Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.

\begin{code}
375 376
rnExpr e@EWildPat = addErr (patSynErr e)	`thenM_`
		    returnM (EWildPat, emptyFVs)
377

378 379
rnExpr e@(EAsPat _ _) = addErr (patSynErr e)	`thenM_`
		        returnM (EWildPat, emptyFVs)
380

381 382
rnExpr e@(ELazyPat _) = addErr (patSynErr e)	`thenM_`
		        returnM (EWildPat, emptyFVs)
383 384
\end{code}

385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412
%************************************************************************
%*									*
	Arithmetic sequences
%*									*
%************************************************************************

\begin{code}
rnArithSeq (From expr)
 = rnExpr expr 	`thenM` \ (expr', fvExpr) ->
   returnM (From expr', fvExpr)

rnArithSeq (FromThen expr1 expr2)
 = rnExpr expr1 	`thenM` \ (expr1', fvExpr1) ->
   rnExpr expr2	`thenM` \ (expr2', fvExpr2) ->
   returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)

rnArithSeq (FromTo expr1 expr2)
 = rnExpr expr1	`thenM` \ (expr1', fvExpr1) ->
   rnExpr expr2	`thenM` \ (expr2', fvExpr2) ->
   returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)

rnArithSeq (FromThenTo expr1 expr2 expr3)
 = rnExpr expr1	`thenM` \ (expr1', fvExpr1) ->
   rnExpr expr2	`thenM` \ (expr2', fvExpr2) ->
   rnExpr expr3	`thenM` \ (expr3', fvExpr3) ->
   returnM (FromThenTo expr1' expr2' expr3',
	    plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
413 414


415 416 417 418 419 420 421 422
%************************************************************************
%*									*
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
%*									*
%************************************************************************

\begin{code}
rnRbinds str rbinds 
423 424 425
  = mappM_ field_dup_err dup_fields	`thenM_`
    mapFvRn rn_rbind rbinds		`thenM` \ (rbinds', fvRbind) ->
    returnM (rbinds', fvRbind)
426
  where
427
    (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
428

429
    field_dup_err dups = addErr (dupFieldErr str dups)
430

431 432 433 434
    rn_rbind (field, expr)
      = lookupGlobalOccRn field	`thenM` \ fieldname ->
	rnExpr expr		`thenM` \ (expr', fvExpr) ->
	returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
435 436
\end{code}

437 438 439 440 441
%************************************************************************
%*									*
	Template Haskell brackets
%*									*
%************************************************************************
442

443 444 445 446 447 448 449 450 451
\begin{code}
rnBracket (ExpBr e) = rnExpr e		`thenM` \ (e', fvs) ->
		      returnM (ExpBr e', fvs)
rnBracket (PatBr p) = rnPat p		`thenM` \ (p', fvs) ->
		      returnM (PatBr p', fvs)
rnBracket (TypBr t) = rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
		      returnM (TypBr t', fvs)
		    where
		      doc = ptext SLIT("In a Template-Haskell quoted type")
452 453 454 455 456 457 458 459 460 461
rnBracket (DecBr group) 
  = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
	-- Discard avails (not useful here)

    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $

    rnSrcDecls group	`thenM` \ (tcg_env, group', fvs) ->
	-- Discard the tcg_env; it contains only extra info about fixity

    returnM (DecBr group', fvs)
462 463
\end{code}

464 465
%************************************************************************
%*									*
466
\subsubsection{@Stmt@s: in @do@ expressions}
467 468 469 470
%*									*
%************************************************************************

\begin{code}
471
rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
472 473 474 475

rnStmts MDoExpr stmts = rnMDoStmts         stmts
rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts

476
rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)	
477 478 479
-- Used for cases *other* than recursive mdo
-- Implements nested scopes

480 481 482
rnNormalStmts ctxt [] = returnM ([], emptyFVs)
	-- Happens at the end of the sub-lists of a ParStmts

483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
  = addSrcLoc src_loc 		$
    rnExpr expr			`thenM` \ (expr', fv_expr) ->
    rnNormalStmts ctxt stmts	`thenM` \ (stmts', fvs) ->
    returnM (ExprStmt expr' placeHolderType src_loc : stmts',
	     fv_expr `plusFV` fvs)

rnNormalStmts ctxt [ResultStmt expr src_loc]
  = addSrcLoc src_loc 	$
    rnExpr expr		`thenM` \ (expr', fv_expr) ->
    returnM ([ResultStmt expr' src_loc], fv_expr)

rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) 
  = addSrcLoc src_loc 			$
    rnExpr expr				`thenM` \ (expr', fv_expr) ->
	-- The binders do not scope over the expression

    rnPatsAndThen (StmtCtxt ctxt) [pat]	$ \ [pat'] ->
    rnNormalStmts ctxt stmts		`thenM` \ (stmts', fvs) ->
    returnM (BindStmt pat' expr' src_loc : stmts',
	     fv_expr `plusFV` fvs)	-- fv_expr shouldn't really be filtered by
					-- the rnPatsAndThen, but it does not matter

rnNormalStmts ctxt (LetStmt binds : stmts)
507 508 509 510 511 512 513 514 515
  = checkErr (ok ctxt binds) (badIpBinds binds)	`thenM_`
    rnBindsAndThen binds			( \ binds' ->
    rnNormalStmts ctxt stmts			`thenM` \ (stmts', fvs) ->
    returnM (LetStmt binds' : stmts', fvs))
  where
	-- We do not allow implicit-parameter bindings in a parallel
	-- list comprehension.  I'm not sure what it might mean.
    ok (ParStmtCtxt _) (IPBinds _ _) = False	
    ok _	       _	     = True
516 517

rnNormalStmts ctxt (ParStmt stmtss : stmts)
518
  = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss	`thenM` \ (stmtss', fv_stmtss) ->
519 520
    let
	bndrss = map collectStmtsBinders stmtss'
521
    in
522
    foldlM checkBndrs [] bndrss		`thenM` \ new_binders ->
523
    bindLocalNamesFV new_binders	$
524 525 526 527 528 529 530 531 532 533 534 535
	-- Note: binders are returned in scope order, so one may
	--       shadow the next; e.g. x <- xs; x <- ys
    rnNormalStmts ctxt stmts			`thenM` \ (stmts', fvs) ->
    returnM (ParStmtOut (bndrss `zip` stmtss') : stmts', 
	     fv_stmtss `plusFV` fvs)
	     
  where
    checkBndrs all_bndrs bndrs
	  = checkErr (null common) (err (head common)) `thenM_`
	    returnM (bndrs ++ all_bndrs)
	where
	  common = intersectBy eqOcc all_bndrs bndrs
536

537 538 539 540
    eqOcc n1 n2 = nameOccName n1 == nameOccName n2
    err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
	    <+> quotes (ppr v)

541 542 543 544 545 546 547 548 549
rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
\end{code}


%************************************************************************
%*									*
\subsubsection{Precedence Parsing}
%*									*
%************************************************************************
550

551
\begin{code}
552 553 554 555 556 557 558 559 560 561
type Defs    = NameSet
type Uses    = NameSet	-- Same as FreeVars really
type FwdRefs = NameSet
type Segment = (Defs,
		Uses, 		-- May include defs
		FwdRefs,	-- A subset of uses that are 
				--   (a) used before they are bound in this segment, or 
				--   (b) used here, and bound in subsequent segments
		[RenamedStmt])

562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595
----------------------------------------------------
rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
rnMDoStmts stmts
  = 	-- Step1: bring all the binders of the mdo into scope
    bindLocalsRn doc (collectStmtsBinders stmts)	$ \ _ ->
	
	-- Step 2: Rename each individual stmt, making a
	--	   singleton segment.  At this stage the FwdRefs field
	--	   isn't finished: it's empty for all except a BindStmt
	--	   for which it's the fwd refs within the bind itself
    mappM rn_mdo_stmt stmts				`thenM` \ segs ->
    let
	-- Step 3: Fill in the fwd refs.
	-- 	   The segments are all singletons, but their fwd-ref
	--	   field mentions all the things used by the segment
	--	   that are bound after their use
	segs_w_fwd_refs = addFwdRefs segs

	-- Step 4: Group together the segments to make bigger segments
	--	   Invariant: in the result, no segment uses a variable
	--	   	      bound in a later segment
	grouped_segs = glomSegments segs_w_fwd_refs

	-- Step 5: Turn the segments into Stmts
	--	   Use RecStmt when and only when there are fwd refs
	--	   Also gather up the uses from the end towards the
	--	   start, so we can tell the RecStmt which things are
	--	   used 'after' the RecStmt
	stmts_w_fvs = segsToStmts grouped_segs
    in
    returnM stmts_w_fvs
  where
    doc = text "In a mdo-expression"

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620
----------------------------------------------------
rn_mdo_stmt :: RdrNameStmt -> RnM Segment
	-- Assumes all binders are already in scope
	-- Turns each stmt into a singleton Stmt

rn_mdo_stmt (ExprStmt expr _ src_loc)
  = addSrcLoc src_loc (rnExpr expr)	`thenM` \ (expr', fvs) ->
    returnM (emptyNameSet, fvs, emptyNameSet,
	     [ExprStmt expr' placeHolderType src_loc])

rn_mdo_stmt (ResultStmt expr src_loc)
  = addSrcLoc src_loc (rnExpr expr)	`thenM` \ (expr', fvs) ->
    returnM (emptyNameSet, fvs, emptyNameSet,
	     [ResultStmt expr' src_loc])

rn_mdo_stmt (BindStmt pat expr src_loc)
  = addSrcLoc src_loc 	$
    rnExpr expr		`thenM` \ (expr', fv_expr) ->
    rnPat pat		`thenM` \ (pat', fv_pat) ->
    let
	bndrs = mkNameSet (collectPatBinders pat')
	fvs   = fv_expr `plusFV` fv_pat
    in
    returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
	     [BindStmt pat' expr' src_loc])
621

622 623 624 625
rn_mdo_stmt (LetStmt binds)
  = rnBinds binds		`thenM` \ (binds', fv_binds) ->
    returnM (mkNameSet (collectHsBinders binds'), 
	     fv_binds, emptyNameSet, [LetStmt binds'])
626

627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647
rn_mdo_stmt stmt@(ParStmt _)	-- Syntactically illegal in mdo
  = pprPanic "rn_mdo_stmt" (ppr stmt)


addFwdRefs :: [Segment] -> [Segment]
-- So far the segments only have forward refs *within* the Stmt
-- 	(which happens for bind:  x <- ...x...)
-- This function adds the cross-seg fwd ref info

addFwdRefs pairs 
  = fst (foldr mk_seg ([], emptyNameSet) pairs)
  where
    mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
	= (new_seg : segs, all_defs)
	where
	  new_seg = (defs, uses, new_fwds, stmts)
	  all_defs = seg_defs `unionNameSets` defs
	  new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
		-- Add the downstream fwd refs here

----------------------------------------------------
648 649 650 651 652
-- 	Glomming the singleton segments of an mdo into 
--	minimal recursive groups.
--
-- At first I thought this was just strongly connected components, but
-- there's an important constraint: the order of the stmts must not change.
653 654 655 656 657 658 659 660 661
--
-- Consider
--	mdo { x <- ...y...
--	      p <- z
--	      y <- ...x...
--	      q <- x
--	      z <- y
--	      r <- x }
--
662 663 664 665 666
-- Here, the first stmt mention 'y', which is bound in the third.  
-- But that means that the innocent second stmt (p <- z) gets caught
-- up in the recursion.  And that in turn means that the binding for
-- 'z' has to be included... and so on.
--
667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718
-- Start at the tail { r <- x }
-- Now add the next one { z <- y ; r <- x }
-- Now add one more     { q <- x ; z <- y ; r <- x }
-- Now one more... but this time we have to group a bunch into rec
--	{ rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
-- Now one more, which we can add on without a rec
--	{ p <- z ; 
--	  rec { y <- ...x... ; q <- x ; z <- y } ; 
-- 	  r <- x }
-- Finally we add the last one; since it mentions y we have to
-- glom it togeher with the first two groups
--	{ rec { x <- ...y...; p <- z ; y <- ...x... ; 
--		q <- x ; z <- y } ; 
-- 	  r <- x }

glomSegments :: [Segment] -> [Segment]

glomSegments [seg] = [seg]
glomSegments ((defs,uses,fwds,stmts) : segs)
	-- Actually stmts will always be a singleton
  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
  where
    segs'	     = glomSegments segs
    (extras, others) = grab uses segs'
    (ds, us, fs, ss) = unzip4 extras
    
    seg_defs  = plusFVs ds `plusFV` defs
    seg_uses  = plusFVs us `plusFV` uses
    seg_fwds  = plusFVs fs `plusFV` fwds
    seg_stmts = stmts ++ concat ss

    grab :: NameSet	 	-- The client
	 -> [Segment]
	 -> ([Segment],		-- Needed by the 'client'
	     [Segment])		-- Not needed by the client
	-- The result is simply a split of the input
    grab uses dus 
	= (reverse yeses, reverse noes)
	where
	  (noes, yeses) 	  = span not_needed (reverse dus)
	  not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)


----------------------------------------------------
segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)

segsToStmts [] = ([], emptyFVs)
segsToStmts ((defs, uses, fwds, ss) : segs)
  = (new_stmt : later_stmts, later_uses `plusFV` uses)
  where
    (later_stmts, later_uses) = segsToStmts segs
    new_stmt | non_rec	 = head ss
719
	     | otherwise = RecStmt rec_names ss []
720 721 722 723 724 725
	     where
	       non_rec   = isSingleton ss && isEmptyNameSet fwds
	       rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
		-- The names for the fixpoint are
		--	(a) the ones needed after the RecStmt
		--	(b) the forward refs within the fixpoint
726 727 728 729 730 731 732 733
\end{code}

%************************************************************************
%*									*
\subsubsection{Precedence Parsing}
%*									*
%************************************************************************

734 735 736 737 738 739 740
@mkOpAppRn@ deals with operator fixities.  The argument expressions
are assumed to be already correctly arranged.  It needs the fixities
recorded in the OpApp nodes, because fixity info applies to the things
the programmer actually wrote, so you can't find it out from the Name.

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
741 742
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
743

744
\begin{code}
745 746 747 748
mkOpAppRn :: RenamedHsExpr			-- Left operand; already rearranged
	  -> RenamedHsExpr -> Fixity 		-- Operator and fixity
	  -> RenamedHsExpr			-- Right operand (not an OpApp, but might
						-- be a NegApp)
749
	  -> RnM RenamedHsExpr
750

751 752 753
---------------------------
-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
754
  | nofix_error
755 756
  = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenM_`
    returnM (OpApp e1 op2 fix2 e2)
757

758
  | associate_right
759 760
  = mkOpAppRn e12 op2 fix2 e2		`thenM` \ new_e ->
    returnM (OpApp e11 op1 fix1 new_e)
761
  where
762
    (nofix_error, associate_right) = compareFixity fix1 fix2
763

764 765
---------------------------
--	(- neg_arg) `op` e2
766
mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
sof's avatar
sof committed
767
  | nofix_error
768 769
  = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))	`thenM_`
    returnM (OpApp e1 op2 fix2 e2)
sof's avatar
sof committed
770

771
  | associate_right
772 773
  = mkOpAppRn neg_arg op2 fix2 e2	`thenM` \ new_e ->
    returnM (NegApp new_e neg_name)
sof's avatar
sof committed
774
  where
775 776 777 778
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
--	e1 `op` - neg_arg
779 780
mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)	-- NegApp can occur on the right
  | not associate_right				-- We *want* right association
781 782
  = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))	`thenM_`
    returnM (OpApp e1 op1 fix1 e2)
783
  where
784
    (_, associate_right) = compareFixity fix1 negateFixity
785

786 787
---------------------------
--	Default case
788
mkOpAppRn e1 op fix e2 			-- Default case, no rearrangment
789 790
  = ASSERT2( right_op_ok fix e2,
	     ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
791
    )
792
    returnM (OpApp e1 op fix e2)
793 794 795 796 797 798 799 800 801 802

-- Parser left-associates everything, but 
-- derived instances may have correctly-associated things to
-- in the right operarand.  So we just check that the right operand is OK
right_op_ok fix1 (OpApp _ _ fix2 _)
  = not error_please && associate_right
  where
    (error_please, associate_right) = compareFixity fix1 fix2
right_op_ok fix1 other
  = True
803

804
-- Parser initially makes negation bind more tightly than any other operator
805
mkNegAppRn neg_arg neg_name
sof's avatar
sof committed
806 807
  = 
#ifdef DEBUG
808
    getModeRn			`thenM` \ mode ->
sof's avatar
sof committed
809 810
    ASSERT( not_op_app mode neg_arg )
#endif
811
    returnM (NegApp neg_arg neg_name)
812

813 814
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other	 	      = True
815
\end{code}
816

817
\begin{code}
818
checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
819

820
checkPrecMatch False fn match
821
  = returnM ()
822

823
checkPrecMatch True op (Match (p1:p2:_) _ _)
824
	-- True indicates an infix lhs
825
  = getModeRn 		`thenM` \ mode ->
826
	-- See comments with rnExpr (OpApp ...)
827
    if isInterfaceMode mode
828 829
	then returnM ()
	else checkPrec op p1 False	`thenM_`
830
	     checkPrec op p2 True
831

832
checkPrecMatch True op _ = panic "checkPrecMatch"
833

834 835 836
checkPrec op (ConPatIn op1 (InfixCon _ _)) right
  = lookupFixityRn op	`thenM` \  op_fix@(Fixity op_prec  op_dir) ->
    lookupFixityRn op1	`thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
837 838
    let
	inf_ok = op1_prec > op_prec || 
839
	         (op1_prec == op_prec &&
840 841
		  (op1_dir == InfixR && op_dir == InfixR && right ||
		   op1_dir == InfixL && op_dir == InfixL && not right))
842

843 844
	info  = (ppr_op op,  op_fix)
	info1 = (ppr_op op1, op1_fix)
845 846
	(infol, infor) = if right then (info, info1) else (info1, info)
    in
847
    checkErr inf_ok (precParseErr infol infor)
848 849

checkPrec op pat right
850
  = returnM ()
851 852

-- Check precedence of (arg op) or (op arg) respectively
853 854 855 856
-- If arg is itself an operator application, then either
--   (a) its precedence must be higher than that of op
--   (b) its precedency & associativity must be the same as that of op
checkSectionPrec direction section op arg
857 858
  = case arg of
	OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
859
	NegApp _ _	 -> go_for_it pp_prefix_minus negateFixity
860
	other		 -> returnM ()
861 862
  where
    HsVar op_name = op
863
    go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
864 865
	= lookupFixityRn op_name	`thenM` \ op_fix@(Fixity op_prec _) ->
	  checkErr (op_prec < arg_prec
866 867 868
		     || op_prec == arg_prec && direction == assoc)
		  (sectionPrecErr (ppr_op op_name, op_fix) 	
		  (pp_arg_op, arg_fix) section)
869 870
\end{code}

871

sof's avatar
sof committed
872 873 874 875 876 877 878
%************************************************************************
%*									*
\subsubsection{Assertion utils}
%*									*
%************************************************************************

\begin{code}
879 880 881
mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
882
  = getSrcLocM    			`thenM` \ sloc ->
883 884 885 886 887
    let
	expr = HsApp (HsVar assertErrorName) (HsLit msg)
	msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
    in
    returnM (expr, unitFV assertErrorName)
sof's avatar
sof committed
888
\end{code}
889 890 891 892 893 894 895

%************************************************************************
%*									*
\subsubsection{Errors}
%*									*
%************************************************************************

896
\begin{code}
897 898 899
ppr_op op = quotes (ppr op)	-- Here, op can be a Name or a (Var n), where n is a Name
pp_prefix_minus = ptext SLIT("prefix `-'")

900
nonStdGuardErr guard
901 902 903
  = hang (ptext
    SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
    ) 4 (ppr guard)
904

905 906 907
patSynErr e 
  = sep [ptext SLIT("Pattern syntax in expression context:"),
	 nest 4 (ppr e)]
908

909 910
doStmtListErr do_or_lc e
  = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
911
	 nest 4 (ppr e)]
912 913 914 915
  where
    binder_name = case do_or_lc of
			MDoExpr -> "mdo"
			other   -> "do"
916

917
#ifdef GHCI 
918
checkTH e what = returnM ()	-- OK
919 920 921 922 923 924
#else
checkTH e what 	-- Raise an error in a stage-1 compiler
  = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
	          ptext SLIT("illegal in a stage-1 compiler"),
	          nest 2 (ppr e)])
#endif   
925

926 927 928
badIpBinds binds
  = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
	 (ppr binds)
929
\end{code}