2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnMatch, rnGRHSs, rnExpr, rnExprs, rnStmts,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindsAndThen, rnBinds )
22 -- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
23 -- RnBinds imports RnExpr.rnMatch, etc
24 -- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
31 import RnNames ( importsFromLocalDecls )
32 import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
33 dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
34 import CmdLineOpts ( DynFlag(..) )
35 import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
36 defaultFixity, negateFixity, compareFixity )
37 import PrelNames ( hasKey, assertIdKey,
40 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
41 splitName, fstName, sndName, ioDataConName,
42 replicatePName, mapPName, filterPName,
43 crossPName, zipPName, toPName,
44 enumFromToPName, enumFromThenToPName, assertErrorName,
45 negateName, monadNames, mfixName )
46 import Name ( Name, nameOccName )
48 import UnicodeUtil ( stringToUtf8 )
49 import UniqFM ( isNullUFM )
50 import UniqSet ( emptyUniqSet )
51 import Util ( isSingleton, mapAndUnzip )
52 import List ( intersectBy, unzip4 )
53 import ListSetOps ( removeDups )
55 import SrcLoc ( noSrcLoc )
60 ************************************************************************
64 ************************************************************************
67 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
69 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
70 = addSrcLoc (getMatchLoc match) $
72 -- Deal with the rhs type signature
73 bindPatSigTyVarsFV rhs_sig_tys $
74 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
75 (case maybe_rhs_sig of
76 Nothing -> returnM (Nothing, emptyFVs)
77 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
78 returnM (Just ty', ty_fvs)
79 | otherwise -> addErr (patSigErr ty) `thenM_`
80 returnM (Nothing, emptyFVs)
81 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
84 rnPatsAndThen ctxt pats $ \ pats' ->
85 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
87 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
88 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
90 rhs_sig_tys = case maybe_rhs_sig of
93 doc_sig = text "In a result type-signature"
97 %************************************************************************
99 \subsubsection{Guarded right-hand sides (GRHSs)}
101 %************************************************************************
104 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
106 rnGRHSs ctxt (GRHSs grhss binds _)
107 = rnBindsAndThen binds $ \ binds' ->
108 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
109 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
111 rnGRHS ctxt (GRHS guarded locn)
113 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
114 checkM (opt_GlasgowExts || is_standard_guard guarded)
115 (addWarn (nonStdGuardErr guarded)) `thenM_`
117 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
118 returnM (GRHS guarded' locn, fvs)
120 -- Standard Haskell 1.4 guards are just a single boolean
121 -- expression, rather than a list of qualifiers as in the
123 is_standard_guard [ResultStmt _ _] = True
124 is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
125 is_standard_guard other = False
128 %************************************************************************
130 \subsubsection{Expressions}
132 %************************************************************************
135 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
136 rnExprs ls = rnExprs' ls emptyUniqSet
138 rnExprs' [] acc = returnM ([], acc)
139 rnExprs' (expr:exprs) acc
140 = rnExpr expr `thenM` \ (expr', fvExpr) ->
142 -- Now we do a "seq" on the free vars because typically it's small
143 -- or empty, especially in very long lists of constants
145 acc' = acc `plusFV` fvExpr
147 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
148 returnM (expr':exprs', fvExprs)
150 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
151 grubby_seqNameSet ns result | isNullUFM ns = result
155 Variables. We look up the variable and return the resulting name.
158 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
161 = lookupOccRn v `thenM` \ name ->
162 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
163 if name `hasKey` assertIdKey && not ignore_asserts then
164 -- We expand it to (GHC.Err.assertError location_string)
165 mkAssertErrorExpr `thenM` \ (e, fvs) ->
166 returnM (e, fvs `addOneFV` name)
167 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
169 -- The normal case. Even if the Id was 'assert', if we are
170 -- ignoring assertions we leave it as GHC.Base.assert;
171 -- this function just ignores its first arg.
172 returnM (HsVar name, unitFV name)
175 = newIPName v `thenM` \ name ->
178 Linear _ -> mkFVs [splitName, fstName, sndName]
179 Dupable _ -> emptyFVs
181 returnM (HsIPVar name, fvs)
184 = litFVs lit `thenM` \ fvs ->
185 returnM (HsLit lit, fvs)
187 rnExpr (HsOverLit lit)
188 = rnOverLit lit `thenM` \ (lit', fvs) ->
189 returnM (HsOverLit lit', fvs)
192 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
193 returnM (HsLam match', fvMatch)
195 rnExpr (HsApp fun arg)
196 = rnExpr fun `thenM` \ (fun',fvFun) ->
197 rnExpr arg `thenM` \ (arg',fvArg) ->
198 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
200 rnExpr (OpApp e1 op _ e2)
201 = rnExpr e1 `thenM` \ (e1', fv_e1) ->
202 rnExpr e2 `thenM` \ (e2', fv_e2) ->
203 rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
206 -- When renaming code synthesised from "deriving" declarations
207 -- we're in Interface mode, and we should ignore fixity; assume
208 -- that the deriving code generator got the association correct
209 -- Don't even look up the fixity when in interface mode
210 getModeRn `thenM` \ mode ->
211 (if isInterfaceMode mode
212 then returnM (OpApp e1' op' defaultFixity e2')
213 else lookupFixityRn op_name `thenM` \ fixity ->
214 mkOpAppRn e1' op' fixity e2'
215 ) `thenM` \ final_e ->
218 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
221 = rnExpr e `thenM` \ (e', fv_e) ->
222 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
223 mkNegAppRn e' neg_name `thenM` \ final_e ->
224 returnM (final_e, fv_e `plusFV` fv_neg)
227 = rnExpr e `thenM` \ (e', fvs_e) ->
228 returnM (HsPar e', fvs_e)
230 -- Template Haskell extensions
231 -- Don't ifdef-GHCI them because we want to fail gracefully
232 -- (not with an rnExpr crash) in a stage-1 compiler.
233 rnExpr e@(HsBracket br_body loc)
235 checkTH e "bracket" `thenM_`
236 rnBracket br_body `thenM` \ (body', fvs_e) ->
237 returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
239 rnExpr e@(HsSplice n splice loc)
241 checkTH e "splice" `thenM_`
242 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
243 rnExpr splice `thenM` \ (splice', fvs_e) ->
244 returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
246 rnExpr e@(HsReify (Reify flavour name))
247 = checkTH e "reify" `thenM_`
248 lookupGlobalOccRn name `thenM` \ name' ->
249 -- For now, we can only reify top-level things
250 returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
252 rnExpr section@(SectionL expr op)
253 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
254 rnExpr op `thenM` \ (op', fvs_op) ->
255 checkSectionPrec InfixL section op' expr' `thenM_`
256 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
258 rnExpr section@(SectionR op expr)
259 = rnExpr op `thenM` \ (op', fvs_op) ->
260 rnExpr expr `thenM` \ (expr', fvs_expr) ->
261 checkSectionPrec InfixR section op' expr' `thenM_`
262 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
264 rnExpr (HsCoreAnn ann expr)
265 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
266 returnM (HsCoreAnn ann expr', fvs_expr)
268 rnExpr (HsSCC lbl expr)
269 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
270 returnM (HsSCC lbl expr', fvs_expr)
272 rnExpr (HsCase expr ms src_loc)
273 = addSrcLoc src_loc $
274 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
275 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
276 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
278 rnExpr (HsLet binds expr)
279 = rnBindsAndThen binds $ \ binds' ->
280 rnExpr expr `thenM` \ (expr',fvExpr) ->
281 returnM (HsLet binds' expr', fvExpr)
283 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
284 = addSrcLoc src_loc $
285 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
287 -- Check the statement list ends in an expression
288 case last stmts' of {
289 ResultStmt _ _ -> returnM () ;
290 _ -> addErr (doStmtListErr do_or_lc e)
293 -- Generate the rebindable syntax for the monad
294 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
296 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
297 fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs)
299 implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
300 implicit_fvs ListComp = mkFVs [foldrName, buildName]
301 implicit_fvs DoExpr = emptyFVs
302 implicit_fvs MDoExpr = emptyFVs
304 syntax_names = case do_or_lc of
306 MDoExpr -> monadNames ++ [mfixName]
309 rnExpr (ExplicitList _ exps)
310 = rnExprs exps `thenM` \ (exps', fvs) ->
311 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
313 rnExpr (ExplicitPArr _ exps)
314 = rnExprs exps `thenM` \ (exps', fvs) ->
315 returnM (ExplicitPArr placeHolderType exps',
316 fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
318 rnExpr e@(ExplicitTuple exps boxity)
319 = checkTupSize tup_size `thenM_`
320 rnExprs exps `thenM` \ (exps', fvs) ->
321 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
323 tup_size = length exps
324 tycon_name = tupleTyCon_name boxity tup_size
326 rnExpr (RecordCon con_id rbinds)
327 = lookupOccRn con_id `thenM` \ conname ->
328 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
329 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
331 rnExpr (RecordUpd expr rbinds)
332 = rnExpr expr `thenM` \ (expr', fvExpr) ->
333 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
334 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
336 rnExpr (ExprWithTySig expr pty)
337 = rnExpr expr `thenM` \ (expr', fvExpr) ->
338 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
339 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
341 doc = text "In an expression type signature"
343 rnExpr (HsIf p b1 b2 src_loc)
344 = addSrcLoc src_loc $
345 rnExpr p `thenM` \ (p', fvP) ->
346 rnExpr b1 `thenM` \ (b1', fvB1) ->
347 rnExpr b2 `thenM` \ (b2', fvB2) ->
348 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
351 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
352 returnM (HsType t, fvT)
354 doc = text "In a type argument"
356 rnExpr (ArithSeqIn seq)
357 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
358 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
360 rnExpr (PArrSeqIn seq)
361 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
362 returnM (PArrSeqIn new_seq,
363 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
366 These three are pattern syntax appearing in expressions.
367 Since all the symbols are reservedops we can simply reject them.
368 We return a (bogus) EWildPat in each case.
371 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
372 returnM (EWildPat, emptyFVs)
374 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
375 returnM (EWildPat, emptyFVs)
377 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
378 returnM (EWildPat, emptyFVs)
381 %************************************************************************
385 %************************************************************************
388 rnExpr (HsProc pat body src_loc)
389 = addSrcLoc src_loc $
390 rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
391 rnCmdTop body `thenM` \ (body',fvBody) ->
392 returnM (HsProc pat' body' src_loc, fvBody)
394 rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
395 = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
396 rnExpr arg `thenM` \ (arg',fvArg) ->
397 returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
398 fvArrow `plusFV` fvArg)
401 rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
402 = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
403 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
404 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
408 lookupFixityRn op_name `thenM` \ fixity ->
409 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
412 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
414 rnExpr (HsArrForm op fixity cmds srcloc)
415 = rnExpr op `thenM` \ (op',fvOp) ->
416 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
417 returnM (HsArrForm op' fixity cmds' srcloc,
418 fvOp `plusFV` fvCmds)
420 ---------------------------
421 -- Deal with fixity (cf mkOpAppRn for the method)
423 mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
424 -> RenamedHsExpr -> Fixity -- Operator and fixity
425 -> RenamedHsCmdTop -- Right operand (not an infix)
428 ---------------------------
429 -- (e11 `op1` e12) `op2` e2
430 mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
432 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
433 returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
436 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
437 returnM (HsArrForm op1 (Just fix1)
438 [a11, HsCmdTop new_c [] placeHolderType []] loc1)
440 (nofix_error, associate_right) = compareFixity fix1 fix2
442 ---------------------------
444 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
445 = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
450 %************************************************************************
454 %************************************************************************
457 rnCmdArgs [] = returnM ([], emptyFVs)
459 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
460 rnCmdArgs args `thenM` \ (args',fvArgs) ->
461 returnM (arg':args', fvArg `plusFV` fvArgs)
463 rnCmdTop (HsCmdTop cmd _ _ _)
464 = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
466 cmd_names = [arrAName, composeAName, firstAName] ++
467 nameSetToList (methodNamesCmd cmd')
469 -- Generate the rebindable syntax for the monad
470 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
472 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
473 fvCmd `plusFV` cmd_fvs)
475 ---------------------------------------------------
476 -- convert OpApp's in a command context to HsArrForm's
478 convertOpFormsCmd :: HsCmd id -> HsCmd id
480 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
482 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
484 convertOpFormsCmd (OpApp c1 op fixity c2)
486 arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
487 arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
489 HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
491 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
493 convertOpFormsCmd (HsCase exp matches locn)
494 = HsCase exp (map convertOpFormsMatch matches) locn
496 convertOpFormsCmd (HsIf exp c1 c2 locn)
497 = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
499 convertOpFormsCmd (HsLet binds cmd)
500 = HsLet binds (convertOpFormsCmd cmd)
502 convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
503 = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
505 -- Anything else is unchanged. This includes HsArrForm (already done),
506 -- things with no sub-commands, and illegal commands (which will be
507 -- caught by the type checker)
508 convertOpFormsCmd c = c
510 convertOpFormsStmt (BindStmt pat cmd locn)
511 = BindStmt pat (convertOpFormsCmd cmd) locn
512 convertOpFormsStmt (ResultStmt cmd locn)
513 = ResultStmt (convertOpFormsCmd cmd) locn
514 convertOpFormsStmt (ExprStmt cmd ty locn)
515 = ExprStmt (convertOpFormsCmd cmd) ty locn
516 convertOpFormsStmt (RecStmt stmts lvs rvs es)
517 = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
518 convertOpFormsStmt stmt = stmt
520 convertOpFormsMatch (Match pat mty grhss)
521 = Match pat mty (convertOpFormsGRHSs grhss)
523 convertOpFormsGRHSs (GRHSs grhss binds ty)
524 = GRHSs (map convertOpFormsGRHS grhss) binds ty
526 convertOpFormsGRHS (GRHS stmts locn)
528 (ResultStmt cmd locn') = last stmts
530 GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
532 ---------------------------------------------------
533 type CmdNeeds = FreeVars -- Only inhabitants are
534 -- appAName, choiceAName, loopAName
536 -- find what methods the Cmd needs (loop, choice, apply)
537 methodNamesCmd :: HsCmd Name -> CmdNeeds
539 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
541 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
543 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
545 methodNamesCmd (HsPar c) = methodNamesCmd c
547 methodNamesCmd (HsIf p c1 c2 loc)
548 = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
550 methodNamesCmd (HsLet b c) = methodNamesCmd c
552 methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
554 methodNamesCmd (HsApp c e) = methodNamesCmd c
556 methodNamesCmd (HsLam match) = methodNamesMatch match
558 methodNamesCmd (HsCase scrut matches loc)
559 = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
561 methodNamesCmd other = emptyFVs
562 -- Other forms can't occur in commands, but it's not convenient
563 -- to error here so we just do what's convenient.
564 -- The type checker will complain later
566 ---------------------------------------------------
567 methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
569 -------------------------------------------------
570 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
572 -------------------------------------------------
573 methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
575 ---------------------------------------------------
576 methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
578 ---------------------------------------------------
579 methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
580 methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
581 methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
582 methodNamesStmt (RecStmt stmts lvs rvs es)
583 = methodNamesStmts stmts `addOneFV` loopAName
584 methodNamesStmt (LetStmt b) = emptyFVs
585 methodNamesStmt (ParStmt ss) = emptyFVs
586 -- ParStmt can't occur in commands, but it's not convenient to error
587 -- here so we just do what's convenient
591 %************************************************************************
595 %************************************************************************
598 rnArithSeq (From expr)
599 = rnExpr expr `thenM` \ (expr', fvExpr) ->
600 returnM (From expr', fvExpr)
602 rnArithSeq (FromThen expr1 expr2)
603 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
604 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
605 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
607 rnArithSeq (FromTo expr1 expr2)
608 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
609 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
610 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
612 rnArithSeq (FromThenTo expr1 expr2 expr3)
613 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
614 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
615 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
616 returnM (FromThenTo expr1' expr2' expr3',
617 plusFVs [fvExpr1, fvExpr2, fvExpr3])
621 %************************************************************************
623 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
625 %************************************************************************
629 = mappM_ field_dup_err dup_fields `thenM_`
630 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
631 returnM (rbinds', fvRbind)
633 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
635 field_dup_err dups = addErr (dupFieldErr str dups)
637 rn_rbind (field, expr)
638 = lookupGlobalOccRn field `thenM` \ fieldname ->
639 rnExpr expr `thenM` \ (expr', fvExpr) ->
640 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
643 %************************************************************************
645 Template Haskell brackets
647 %************************************************************************
650 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
651 returnM (ExpBr e', fvs)
652 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
653 returnM (PatBr p', fvs)
654 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
655 returnM (TypBr t', fvs)
657 doc = ptext SLIT("In a Template-Haskell quoted type")
658 rnBracket (DecBr group)
659 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
660 -- Discard avails (not useful here)
662 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
664 rnSrcDecls group `thenM` \ (tcg_env, group', dus) ->
665 -- Discard the tcg_env; it contains only extra info about fixity
667 returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
670 %************************************************************************
672 \subsubsection{@Stmt@s: in @do@ expressions}
674 %************************************************************************
677 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
679 rnStmts MDoExpr stmts = rnMDoStmts stmts
680 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
682 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
683 -- Used for cases *other* than recursive mdo
684 -- Implements nested scopes
686 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
687 -- Happens at the end of the sub-lists of a ParStmts
689 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
690 = addSrcLoc src_loc $
691 rnExpr expr `thenM` \ (expr', fv_expr) ->
692 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
693 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
694 fv_expr `plusFV` fvs)
696 rnNormalStmts ctxt [ResultStmt expr src_loc]
697 = addSrcLoc src_loc $
698 rnExpr expr `thenM` \ (expr', fv_expr) ->
699 returnM ([ResultStmt expr' src_loc], fv_expr)
701 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
702 = addSrcLoc src_loc $
703 rnExpr expr `thenM` \ (expr', fv_expr) ->
704 -- The binders do not scope over the expression
706 rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
707 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
708 returnM (BindStmt pat' expr' src_loc : stmts',
709 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
710 -- the rnPatsAndThen, but it does not matter
712 rnNormalStmts ctxt (LetStmt binds : stmts)
713 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
714 rnBindsAndThen binds ( \ binds' ->
715 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
716 returnM (LetStmt binds' : stmts', fvs))
718 -- We do not allow implicit-parameter bindings in a parallel
719 -- list comprehension. I'm not sure what it might mean.
720 ok (ParStmtCtxt _) (IPBinds _ _) = False
723 rnNormalStmts ctxt (ParStmt stmtss : stmts)
724 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
725 checkM opt_GlasgowExts parStmtErr `thenM_`
726 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
728 bndrss :: [[Name]] -- NB: Name, not RdrName
729 bndrss = map collectStmtsBinders stmtss'
730 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
732 mappM dupErr dups `thenM` \ _ ->
733 bindLocalNamesFV bndrs $
734 -- Note: binders are returned in scope order, so one may
735 -- shadow the next; e.g. x <- xs; x <- ys
736 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
738 -- Cut down the exported binders to just the ones neede in the body
740 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
742 returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
743 fv_stmtss `plusFV` fvs)
746 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
748 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
749 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
752 rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
753 = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
754 rn_rec_stmts rec_stmts `thenM` \ segs ->
755 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
757 segs_w_fwd_refs = addFwdRefs segs
758 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
759 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
760 fwd_vars = nameSetToList (plusFVs fs)
763 returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
765 doc = text "In a recursive do statement"
769 %************************************************************************
771 \subsubsection{mdo expressions}
773 %************************************************************************
776 type FwdRefs = NameSet
777 type Segment stmts = (Defs,
778 Uses, -- May include defs
779 FwdRefs, -- A subset of uses that are
780 -- (a) used before they are bound in this segment, or
781 -- (b) used here, and bound in subsequent segments
782 stmts) -- Either Stmt or [Stmt]
785 ----------------------------------------------------
786 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
788 = -- Step1: bring all the binders of the mdo into scope
789 -- Remember that this also removes the binders from the
790 -- finally-returned free-vars
791 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
793 -- Step 2: Rename each individual stmt, making a
794 -- singleton segment. At this stage the FwdRefs field
795 -- isn't finished: it's empty for all except a BindStmt
796 -- for which it's the fwd refs within the bind itself
797 -- (This set may not be empty, because we're in a recursive
799 rn_rec_stmts stmts `thenM` \ segs ->
801 -- Step 3: Fill in the fwd refs.
802 -- The segments are all singletons, but their fwd-ref
803 -- field mentions all the things used by the segment
804 -- that are bound after their use
805 segs_w_fwd_refs = addFwdRefs segs
807 -- Step 4: Group together the segments to make bigger segments
808 -- Invariant: in the result, no segment uses a variable
809 -- bound in a later segment
810 grouped_segs = glomSegments segs_w_fwd_refs
812 -- Step 5: Turn the segments into Stmts
813 -- Use RecStmt when and only when there are fwd refs
814 -- Also gather up the uses from the end towards the
815 -- start, so we can tell the RecStmt which things are
816 -- used 'after' the RecStmt
817 stmts_w_fvs = segsToStmts grouped_segs
821 doc = text "In a mdo-expression"
824 ----------------------------------------------------
825 rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
826 -- Rename a Stmt that is inside a RecStmt (or mdo)
827 -- Assumes all binders are already in scope
828 -- Turns each stmt into a singleton Stmt
830 rn_rec_stmt (ExprStmt expr _ src_loc)
831 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
832 returnM [(emptyNameSet, fvs, emptyNameSet,
833 ExprStmt expr' placeHolderType src_loc)]
835 rn_rec_stmt (ResultStmt expr src_loc)
836 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
837 returnM [(emptyNameSet, fvs, emptyNameSet,
838 ResultStmt expr' src_loc)]
840 rn_rec_stmt (BindStmt pat expr src_loc)
841 = addSrcLoc src_loc $
842 rnExpr expr `thenM` \ (expr', fv_expr) ->
843 rnPat pat `thenM` \ (pat', fv_pat) ->
845 bndrs = mkNameSet (collectPatBinders pat')
846 fvs = fv_expr `plusFV` fv_pat
848 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
849 BindStmt pat' expr' src_loc)]
851 rn_rec_stmt (LetStmt binds)
852 = rnBinds binds `thenM` \ (binds', du_binds) ->
853 returnM [(duDefs du_binds, duUses du_binds,
854 emptyNameSet, LetStmt binds')]
856 rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec
859 rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
860 = pprPanic "rn_rec_stmt" (ppr stmt)
862 ---------------------------------------------
863 rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
864 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
865 returnM (concat segs_s)
868 ---------------------------------------------
869 addFwdRefs :: [Segment a] -> [Segment a]
870 -- So far the segments only have forward refs *within* the Stmt
871 -- (which happens for bind: x <- ...x...)
872 -- This function adds the cross-seg fwd ref info
875 = fst (foldr mk_seg ([], emptyNameSet) pairs)
877 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
878 = (new_seg : segs, all_defs)
880 new_seg = (defs, uses, new_fwds, stmts)
881 all_defs = later_defs `unionNameSets` defs
882 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
883 -- Add the downstream fwd refs here
885 ----------------------------------------------------
886 -- Glomming the singleton segments of an mdo into
887 -- minimal recursive groups.
889 -- At first I thought this was just strongly connected components, but
890 -- there's an important constraint: the order of the stmts must not change.
893 -- mdo { x <- ...y...
900 -- Here, the first stmt mention 'y', which is bound in the third.
901 -- But that means that the innocent second stmt (p <- z) gets caught
902 -- up in the recursion. And that in turn means that the binding for
903 -- 'z' has to be included... and so on.
905 -- Start at the tail { r <- x }
906 -- Now add the next one { z <- y ; r <- x }
907 -- Now add one more { q <- x ; z <- y ; r <- x }
908 -- Now one more... but this time we have to group a bunch into rec
909 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
910 -- Now one more, which we can add on without a rec
912 -- rec { y <- ...x... ; q <- x ; z <- y } ;
914 -- Finally we add the last one; since it mentions y we have to
915 -- glom it togeher with the first two groups
916 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
917 -- q <- x ; z <- y } ;
920 glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
923 glomSegments ((defs,uses,fwds,stmt) : segs)
924 -- Actually stmts will always be a singleton
925 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
927 segs' = glomSegments segs
928 (extras, others) = grab uses segs'
929 (ds, us, fs, ss) = unzip4 extras
931 seg_defs = plusFVs ds `plusFV` defs
932 seg_uses = plusFVs us `plusFV` uses
933 seg_fwds = plusFVs fs `plusFV` fwds
934 seg_stmts = stmt : concat ss
936 grab :: NameSet -- The client
938 -> ([Segment a], -- Needed by the 'client'
939 [Segment a]) -- Not needed by the client
940 -- The result is simply a split of the input
942 = (reverse yeses, reverse noes)
944 (noes, yeses) = span not_needed (reverse dus)
945 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
948 ----------------------------------------------------
949 segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
951 segsToStmts [] = ([], emptyFVs)
952 segsToStmts ((defs, uses, fwds, ss) : segs)
953 = (new_stmt : later_stmts, later_uses `plusFV` uses)
955 (later_stmts, later_uses) = segsToStmts segs
956 new_stmt | non_rec = head ss
957 | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
959 non_rec = isSingleton ss && isEmptyNameSet fwds
960 used_later = defs `intersectNameSet` later_uses
961 -- The ones needed after the RecStmt
964 %************************************************************************
966 \subsubsection{Precedence Parsing}
968 %************************************************************************
970 @mkOpAppRn@ deals with operator fixities. The argument expressions
971 are assumed to be already correctly arranged. It needs the fixities
972 recorded in the OpApp nodes, because fixity info applies to the things
973 the programmer actually wrote, so you can't find it out from the Name.
975 Furthermore, the second argument is guaranteed not to be another
976 operator application. Why? Because the parser parses all
977 operator appications left-associatively, EXCEPT negation, which
978 we need to handle specially.
981 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
982 -> RenamedHsExpr -> Fixity -- Operator and fixity
983 -> RenamedHsExpr -- Right operand (not an OpApp, but might
987 ---------------------------
988 -- (e11 `op1` e12) `op2` e2
989 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
991 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
992 returnM (OpApp e1 op2 fix2 e2)
995 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
996 returnM (OpApp e11 op1 fix1 new_e)
998 (nofix_error, associate_right) = compareFixity fix1 fix2
1000 ---------------------------
1001 -- (- neg_arg) `op` e2
1002 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
1004 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1005 returnM (OpApp e1 op2 fix2 e2)
1008 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1009 returnM (NegApp new_e neg_name)
1011 (nofix_error, associate_right) = compareFixity negateFixity fix2
1013 ---------------------------
1014 -- e1 `op` - neg_arg
1015 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
1016 | not associate_right -- We *want* right association
1017 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1018 returnM (OpApp e1 op1 fix1 e2)
1020 (_, associate_right) = compareFixity fix1 negateFixity
1022 ---------------------------
1024 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1025 = ASSERT2( right_op_ok fix e2,
1026 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1028 returnM (OpApp e1 op fix e2)
1030 -- Parser left-associates everything, but
1031 -- derived instances may have correctly-associated things to
1032 -- in the right operarand. So we just check that the right operand is OK
1033 right_op_ok fix1 (OpApp _ _ fix2 _)
1034 = not error_please && associate_right
1036 (error_please, associate_right) = compareFixity fix1 fix2
1037 right_op_ok fix1 other
1040 -- Parser initially makes negation bind more tightly than any other operator
1041 mkNegAppRn neg_arg neg_name
1044 getModeRn `thenM` \ mode ->
1045 ASSERT( not_op_app mode neg_arg )
1047 returnM (NegApp neg_arg neg_name)
1049 not_op_app SourceMode (OpApp _ _ _ _) = False
1050 not_op_app mode other = True
1054 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
1056 checkPrecMatch False fn match
1059 checkPrecMatch True op (Match (p1:p2:_) _ _)
1060 -- True indicates an infix lhs
1061 = getModeRn `thenM` \ mode ->
1062 -- See comments with rnExpr (OpApp ...)
1063 if isInterfaceMode mode
1065 else checkPrec op p1 False `thenM_`
1066 checkPrec op p2 True
1068 checkPrecMatch True op _ = panic "checkPrecMatch"
1070 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1071 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1072 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1074 inf_ok = op1_prec > op_prec ||
1075 (op1_prec == op_prec &&
1076 (op1_dir == InfixR && op_dir == InfixR && right ||
1077 op1_dir == InfixL && op_dir == InfixL && not right))
1079 info = (ppr_op op, op_fix)
1080 info1 = (ppr_op op1, op1_fix)
1081 (infol, infor) = if right then (info, info1) else (info1, info)
1083 checkErr inf_ok (precParseErr infol infor)
1085 checkPrec op pat right
1088 -- Check precedence of (arg op) or (op arg) respectively
1089 -- If arg is itself an operator application, then either
1090 -- (a) its precedence must be higher than that of op
1091 -- (b) its precedency & associativity must be the same as that of op
1092 checkSectionPrec direction section op arg
1094 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1095 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1099 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1100 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1101 checkErr (op_prec < arg_prec
1102 || op_prec == arg_prec && direction == assoc)
1103 (sectionPrecErr (ppr_op op_name, op_fix)
1104 (pp_arg_op, arg_fix) section)
1108 %************************************************************************
1110 \subsubsection{Assertion utils}
1112 %************************************************************************
1115 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
1116 -- Return an expression for (assertError "Foo.hs:27")
1118 = getSrcLocM `thenM` \ sloc ->
1120 expr = HsApp (HsVar assertErrorName) (HsLit msg)
1121 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1123 returnM (expr, unitFV assertErrorName)
1126 %************************************************************************
1128 \subsubsection{Errors}
1130 %************************************************************************
1133 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1134 pp_prefix_minus = ptext SLIT("prefix `-'")
1136 nonStdGuardErr guard
1138 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1142 = sep [ptext SLIT("Pattern syntax in expression context:"),
1145 doStmtListErr do_or_lc e
1146 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1149 binder_name = case do_or_lc of
1154 checkTH e what = returnM () -- OK
1156 checkTH e what -- Raise an error in a stage-1 compiler
1157 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1158 ptext SLIT("illegal in a stage-1 compiler"),
1162 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
1165 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4