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 rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
15 checkPrecMatch, checkTH
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice )
22 -- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
23 -- RnBinds imports RnExpr.rnMatch, etc
24 -- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
30 import OccName ( plusOccEnv )
31 import RnNames ( importsFromLocalDecls )
32 import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
33 dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
35 import DynFlags ( DynFlag(..) )
36 import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
37 import PrelNames ( hasKey, assertIdKey, assertErrorName,
38 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
39 negateName, thenMName, bindMName, failMName )
40 import Name ( Name, nameOccName )
42 import RdrName ( RdrName )
43 import UnicodeUtil ( stringToUtf8 )
44 import UniqFM ( isNullUFM )
45 import UniqSet ( emptyUniqSet )
46 import Util ( isSingleton )
47 import ListSetOps ( removeDups )
49 import SrcLoc ( Located(..), unLoc, getLoc, combineLocs, cmpLocated )
52 import List ( unzip4 )
56 ************************************************************************
60 ************************************************************************
63 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
64 rnMatchGroup ctxt (MatchGroup ms _)
65 = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
66 returnM (MatchGroup new_ms placeHolderType, ms_fvs)
68 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
69 rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
71 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
73 -- Deal with the rhs type signature
74 bindPatSigTyVarsFV rhs_sig_tys $
75 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
76 (case maybe_rhs_sig of
77 Nothing -> returnM (Nothing, emptyFVs)
78 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
79 returnM (Just ty', ty_fvs)
80 | otherwise -> addLocErr ty patSigErr `thenM_`
81 returnM (Nothing, emptyFVs)
82 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
85 rnPatsAndThen ctxt True pats $ \ pats' ->
86 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
88 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
89 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
91 rhs_sig_tys = case maybe_rhs_sig of
94 doc_sig = text "In a result type-signature"
98 %************************************************************************
100 \subsubsection{Guarded right-hand sides (GRHSs)}
102 %************************************************************************
105 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
108 rnGRHSs ctxt (GRHSs grhss binds)
109 = rnBindGroupsAndThen binds $ \ binds' ->
110 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
111 returnM (GRHSs grhss' binds', fvGRHSs)
113 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
114 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
116 rnGRHS' ctxt (GRHS guards rhs)
117 = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
118 ; checkM (opt_GlasgowExts || is_standard_guard guards)
119 (addWarn (nonStdGuardErr guards))
121 ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
123 ; return (GRHS guards' rhs', fvs) }
125 -- Standard Haskell 1.4 guards are just a single boolean
126 -- expression, rather than a list of qualifiers as in the
128 is_standard_guard [] = True
129 is_standard_guard [L _ (ExprStmt _ _ _)] = True
130 is_standard_guard other = False
133 %************************************************************************
135 \subsubsection{Expressions}
137 %************************************************************************
140 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
141 rnExprs ls = rnExprs' ls emptyUniqSet
143 rnExprs' [] acc = returnM ([], acc)
144 rnExprs' (expr:exprs) acc
145 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
147 -- Now we do a "seq" on the free vars because typically it's small
148 -- or empty, especially in very long lists of constants
150 acc' = acc `plusFV` fvExpr
152 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
153 returnM (expr':exprs', fvExprs)
155 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
156 grubby_seqNameSet ns result | isNullUFM ns = result
160 Variables. We look up the variable and return the resulting name.
163 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
164 rnLExpr = wrapLocFstM rnExpr
166 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
169 = lookupOccRn v `thenM` \ name ->
170 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
171 if name `hasKey` assertIdKey && not ignore_asserts then
172 -- We expand it to (GHC.Err.assertError location_string)
173 mkAssertErrorExpr `thenM` \ (e, fvs) ->
174 returnM (e, fvs `addOneFV` name)
175 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
177 -- The normal case. Even if the Id was 'assert', if we are
178 -- ignoring assertions we leave it as GHC.Base.assert;
179 -- this function just ignores its first arg.
180 returnM (HsVar name, unitFV name)
183 = newIPNameRn v `thenM` \ name ->
184 returnM (HsIPVar name, emptyFVs)
188 returnM (HsLit lit, emptyFVs)
190 rnExpr (HsOverLit lit)
191 = rnOverLit lit `thenM` \ (lit', fvs) ->
192 returnM (HsOverLit lit', fvs)
194 rnExpr (HsApp fun arg)
195 = rnLExpr fun `thenM` \ (fun',fvFun) ->
196 rnLExpr arg `thenM` \ (arg',fvArg) ->
197 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
199 rnExpr (OpApp e1 op _ e2)
200 = rnLExpr e1 `thenM` \ (e1', fv_e1) ->
201 rnLExpr e2 `thenM` \ (e2', fv_e2) ->
202 rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
205 -- When renaming code synthesised from "deriving" declarations
206 -- we used to avoid fixity stuff, but we can't easily tell any
207 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
208 -- should prevent bad things happening.
209 lookupFixityRn op_name `thenM` \ fixity ->
210 mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
213 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
216 = rnLExpr e `thenM` \ (e', fv_e) ->
217 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
218 mkNegAppRn e' neg_name `thenM` \ final_e ->
219 returnM (final_e, fv_e `plusFV` fv_neg)
222 = rnLExpr e `thenM` \ (e', fvs_e) ->
223 returnM (HsPar e', fvs_e)
225 -- Template Haskell extensions
226 -- Don't ifdef-GHCI them because we want to fail gracefully
227 -- (not with an rnExpr crash) in a stage-1 compiler.
228 rnExpr e@(HsBracket br_body)
229 = checkTH e "bracket" `thenM_`
230 rnBracket br_body `thenM` \ (body', fvs_e) ->
231 returnM (HsBracket body', fvs_e)
233 rnExpr e@(HsSpliceE splice)
234 = rnSplice splice `thenM` \ (splice', fvs) ->
235 returnM (HsSpliceE splice', fvs)
237 rnExpr section@(SectionL expr op)
238 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
239 rnLExpr op `thenM` \ (op', fvs_op) ->
240 checkSectionPrec InfixL section op' expr' `thenM_`
241 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
243 rnExpr section@(SectionR op expr)
244 = rnLExpr op `thenM` \ (op', fvs_op) ->
245 rnLExpr expr `thenM` \ (expr', fvs_expr) ->
246 checkSectionPrec InfixR section op' expr' `thenM_`
247 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
249 rnExpr (HsCoreAnn ann expr)
250 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
251 returnM (HsCoreAnn ann expr', fvs_expr)
253 rnExpr (HsSCC lbl expr)
254 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
255 returnM (HsSCC lbl expr', fvs_expr)
257 rnExpr (HsLam matches)
258 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
259 returnM (HsLam matches', fvMatch)
261 rnExpr (HsCase expr matches)
262 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
263 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
264 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
266 rnExpr (HsLet binds expr)
267 = rnBindGroupsAndThen binds $ \ binds' ->
268 rnLExpr expr `thenM` \ (expr',fvExpr) ->
269 returnM (HsLet binds' expr', fvExpr)
271 rnExpr e@(HsDo do_or_lc stmts body _)
272 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
274 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
276 rnExpr (ExplicitList _ exps)
277 = rnExprs exps `thenM` \ (exps', fvs) ->
278 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
280 rnExpr (ExplicitPArr _ exps)
281 = rnExprs exps `thenM` \ (exps', fvs) ->
282 returnM (ExplicitPArr placeHolderType exps', fvs)
284 rnExpr e@(ExplicitTuple exps boxity)
285 = checkTupSize tup_size `thenM_`
286 rnExprs exps `thenM` \ (exps', fvs) ->
287 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
289 tup_size = length exps
290 tycon_name = tupleTyCon_name boxity tup_size
292 rnExpr (RecordCon con_id _ rbinds)
293 = lookupLocatedOccRn con_id `thenM` \ conname ->
294 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
295 returnM (RecordCon conname noPostTcExpr rbinds',
296 fvRbinds `addOneFV` unLoc conname)
298 rnExpr (RecordUpd expr rbinds _ _)
299 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
300 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
301 returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType,
302 fvExpr `plusFV` fvRbinds)
304 rnExpr (ExprWithTySig expr pty)
305 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
306 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
307 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
309 doc = text "In an expression type signature"
311 rnExpr (HsIf p b1 b2)
312 = rnLExpr p `thenM` \ (p', fvP) ->
313 rnLExpr b1 `thenM` \ (b1', fvB1) ->
314 rnLExpr b2 `thenM` \ (b2', fvB2) ->
315 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
318 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
319 returnM (HsType t, fvT)
321 doc = text "In a type argument"
323 rnExpr (ArithSeq _ seq)
324 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
325 returnM (ArithSeq noPostTcExpr new_seq, fvs)
327 rnExpr (PArrSeq _ seq)
328 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
329 returnM (PArrSeq noPostTcExpr new_seq, fvs)
332 These three are pattern syntax appearing in expressions.
333 Since all the symbols are reservedops we can simply reject them.
334 We return a (bogus) EWildPat in each case.
337 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
338 returnM (EWildPat, emptyFVs)
340 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
341 returnM (EWildPat, emptyFVs)
343 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
344 returnM (EWildPat, emptyFVs)
347 %************************************************************************
351 %************************************************************************
354 rnExpr (HsProc pat body)
355 = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
356 rnCmdTop body `thenM` \ (body',fvBody) ->
357 returnM (HsProc pat' body', fvBody)
359 rnExpr (HsArrApp arrow arg _ ho rtl)
360 = rnLExpr arrow `thenM` \ (arrow',fvArrow) ->
361 rnLExpr arg `thenM` \ (arg',fvArg) ->
362 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
363 fvArrow `plusFV` fvArg)
366 rnExpr (HsArrForm op (Just _) [arg1, arg2])
367 = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
368 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
369 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
373 lookupFixityRn op_name `thenM` \ fixity ->
374 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
377 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
379 rnExpr (HsArrForm op fixity cmds)
380 = rnLExpr op `thenM` \ (op',fvOp) ->
381 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
382 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
384 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
385 -- DictApp, DictLam, TyApp, TyLam
387 ---------------------------
388 -- Deal with fixity (cf mkOpAppRn for the method)
390 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
391 -> LHsExpr Name -> Fixity -- Operator and fixity
392 -> LHsCmdTop Name -- Right operand (not an infix)
395 ---------------------------
396 -- (e11 `op1` e12) `op2` e2
397 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
400 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
401 returnM (HsArrForm op2 (Just fix2) [a1, a2])
404 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
405 returnM (HsArrForm op1 (Just fix1)
406 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
407 -- TODO: locs are wrong
409 (nofix_error, associate_right) = compareFixity fix1 fix2
411 ---------------------------
413 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
414 = returnM (HsArrForm op (Just fix) [arg1, arg2])
419 %************************************************************************
423 %************************************************************************
426 rnCmdArgs [] = returnM ([], emptyFVs)
428 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
429 rnCmdArgs args `thenM` \ (args',fvArgs) ->
430 returnM (arg':args', fvArg `plusFV` fvArgs)
433 rnCmdTop = wrapLocFstM rnCmdTop'
435 rnCmdTop' (HsCmdTop cmd _ _ _)
436 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
438 cmd_names = [arrAName, composeAName, firstAName] ++
439 nameSetToList (methodNamesCmd (unLoc cmd'))
441 -- Generate the rebindable syntax for the monad
442 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
444 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
445 fvCmd `plusFV` cmd_fvs)
447 ---------------------------------------------------
448 -- convert OpApp's in a command context to HsArrForm's
450 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
451 convertOpFormsLCmd = fmap convertOpFormsCmd
453 convertOpFormsCmd :: HsCmd id -> HsCmd id
455 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
456 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
457 convertOpFormsCmd (OpApp c1 op fixity c2)
459 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
460 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
462 HsArrForm op (Just fixity) [arg1, arg2]
464 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
467 convertOpFormsCmd (HsCase exp matches)
468 = HsCase exp (convertOpFormsMatch matches)
470 convertOpFormsCmd (HsIf exp c1 c2)
471 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
473 convertOpFormsCmd (HsLet binds cmd)
474 = HsLet binds (convertOpFormsLCmd cmd)
476 convertOpFormsCmd (HsDo ctxt stmts body ty)
477 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
478 (convertOpFormsLCmd body) ty
480 -- Anything else is unchanged. This includes HsArrForm (already done),
481 -- things with no sub-commands, and illegal commands (which will be
482 -- caught by the type checker)
483 convertOpFormsCmd c = c
485 convertOpFormsStmt (BindStmt pat cmd _ _)
486 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
487 convertOpFormsStmt (ExprStmt cmd _ _)
488 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
489 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
490 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
491 convertOpFormsStmt stmt = stmt
493 convertOpFormsMatch (MatchGroup ms ty)
494 = MatchGroup (map (fmap convert) ms) ty
495 where convert (Match pat mty grhss)
496 = Match pat mty (convertOpFormsGRHSs grhss)
498 convertOpFormsGRHSs (GRHSs grhss binds)
499 = GRHSs (map convertOpFormsGRHS grhss) binds
501 convertOpFormsGRHS = fmap convert
503 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
505 ---------------------------------------------------
506 type CmdNeeds = FreeVars -- Only inhabitants are
507 -- appAName, choiceAName, loopAName
509 -- find what methods the Cmd needs (loop, choice, apply)
510 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
511 methodNamesLCmd = methodNamesCmd . unLoc
513 methodNamesCmd :: HsCmd Name -> CmdNeeds
515 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
517 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
519 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
521 methodNamesCmd (HsPar c) = methodNamesLCmd c
523 methodNamesCmd (HsIf p c1 c2)
524 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
526 methodNamesCmd (HsLet b c) = methodNamesLCmd c
528 methodNamesCmd (HsDo sc stmts body ty)
529 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
531 methodNamesCmd (HsApp c e) = methodNamesLCmd c
533 methodNamesCmd (HsLam match) = methodNamesMatch match
535 methodNamesCmd (HsCase scrut matches)
536 = methodNamesMatch matches `addOneFV` choiceAName
538 methodNamesCmd other = emptyFVs
539 -- Other forms can't occur in commands, but it's not convenient
540 -- to error here so we just do what's convenient.
541 -- The type checker will complain later
543 ---------------------------------------------------
544 methodNamesMatch (MatchGroup ms ty)
545 = plusFVs (map do_one ms)
547 do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
549 -------------------------------------------------
551 methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
553 -------------------------------------------------
554 methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs
556 ---------------------------------------------------
557 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
559 ---------------------------------------------------
560 methodNamesLStmt = methodNamesStmt . unLoc
562 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
563 methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd
564 methodNamesStmt (RecStmt stmts _ _ _ _)
565 = methodNamesStmts stmts `addOneFV` loopAName
566 methodNamesStmt (LetStmt b) = emptyFVs
567 methodNamesStmt (ParStmt ss) = emptyFVs
568 -- ParStmt can't occur in commands, but it's not convenient to error
569 -- here so we just do what's convenient
573 %************************************************************************
577 %************************************************************************
580 rnArithSeq (From expr)
581 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
582 returnM (From expr', fvExpr)
584 rnArithSeq (FromThen expr1 expr2)
585 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
586 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
587 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
589 rnArithSeq (FromTo expr1 expr2)
590 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
591 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
592 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
594 rnArithSeq (FromThenTo expr1 expr2 expr3)
595 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
596 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
597 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
598 returnM (FromThenTo expr1' expr2' expr3',
599 plusFVs [fvExpr1, fvExpr2, fvExpr3])
603 %************************************************************************
605 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
607 %************************************************************************
611 = mappM_ field_dup_err dup_fields `thenM_`
612 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
613 returnM (rbinds', fvRbind)
615 (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
617 field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
619 rn_rbind (field, expr)
620 = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
621 rnLExpr expr `thenM` \ (expr', fvExpr) ->
622 returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
625 %************************************************************************
627 Template Haskell brackets
629 %************************************************************************
632 rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
633 returnM (VarBr name, unitFV name)
634 rnBracket (ExpBr e) = rnLExpr e `thenM` \ (e', fvs) ->
635 returnM (ExpBr e', fvs)
636 rnBracket (PatBr p) = rnLPat p `thenM` \ (p', fvs) ->
637 returnM (PatBr p', fvs)
638 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
639 returnM (TypBr t', fvs)
641 doc = ptext SLIT("In a Template-Haskell quoted type")
642 rnBracket (DecBr group)
643 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
644 -- Discard avails (not useful here)
646 updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
647 -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
648 -- to *shadow* top-level bindings. E.g.
650 -- bar = [d| foo = 1|]
651 -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
653 rnSrcDecls group `thenM` \ (tcg_env, group') ->
654 -- Discard the tcg_env; it contains only extra info about fixity
656 dus = tcg_dus tcg_env
658 returnM (DecBr group', allUses dus)
661 %************************************************************************
663 \subsubsection{@Stmt@s: in @do@ expressions}
665 %************************************************************************
668 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
669 -> RnM (thing, FreeVars)
670 -> RnM (([LStmt Name], thing), FreeVars)
672 rnStmts (MDoExpr _) = rnMDoStmts
673 rnStmts ctxt = rnNormalStmts ctxt
675 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
676 -> RnM (thing, FreeVars)
677 -> RnM (([LStmt Name], thing), FreeVars)
678 -- Used for cases *other* than recursive mdo
679 -- Implements nested scopes
681 rnNormalStmts ctxt [] thing_inside
682 = do { (thing, fvs) <- thing_inside
683 ; return (([],thing), fvs) }
685 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
686 = do { ((stmt', (stmts', thing)), fvs)
687 <- rnStmt ctxt stmt $
688 rnNormalStmts ctxt stmts thing_inside
689 ; return (((L loc stmt' : stmts'), thing), fvs) }
691 rnStmt :: HsStmtContext Name -> Stmt RdrName
692 -> RnM (thing, FreeVars)
693 -> RnM ((Stmt Name, thing), FreeVars)
695 rnStmt ctxt (ExprStmt expr _ _) thing_inside
696 = do { (expr', fv_expr) <- rnLExpr expr
697 ; (then_op, fvs1) <- lookupSyntaxName thenMName
698 ; (thing, fvs2) <- thing_inside
699 ; return ((ExprStmt expr' then_op placeHolderType, thing),
700 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
702 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
703 = do { (expr', fv_expr) <- rnLExpr expr
704 -- The binders do not scope over the expression
705 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
706 ; (fail_op, fvs2) <- lookupSyntaxName failMName
708 ; let reportUnused = case ctxt of
709 ParStmtCtxt{} -> False
711 ; rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> do
712 { (thing, fvs3) <- thing_inside
713 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
714 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
715 -- fv_expr shouldn't really be filtered by
716 -- the rnPatsAndThen, but it does not matter
718 rnStmt ctxt (LetStmt binds) thing_inside
719 = do { checkErr (ok ctxt binds) (badIpBinds binds)
720 ; rnBindGroupsAndThen binds $ \ binds' -> do
721 { (thing, fvs) <- thing_inside
722 ; return ((LetStmt binds', thing), fvs) }}
724 -- We do not allow implicit-parameter bindings in a parallel
725 -- list comprehension. I'm not sure what it might mean.
726 ok (ParStmtCtxt _) binds = not (any is_ip_bind binds)
729 is_ip_bind (HsIPBinds _) = True
732 rnStmt ctxt (ParStmt stmtss) thing_inside
733 = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
734 ; checkM opt_GlasgowExts parStmtErr
735 ; (stmtss'_w_unit, fv_stmtss) <- mapFvRn rn_branch stmtss
737 bndrss :: [[Name]] -- NB: Name, not RdrName
738 bndrss = map (map unLoc . collectLStmtsBinders) stmtss'
739 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
740 stmtss' = map fst stmtss'_w_unit
743 ; bindLocalNamesFV bndrs $ do
744 { (thing, fvs) <- thing_inside
745 -- Note: binders are returned in scope order, so one may
746 -- shadow the next; e.g. x <- xs; x <- ys
748 -- Cut down the exported binders to just the ones needed in the body
749 ; let used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
750 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
752 -- With processing of the branches and the tail of comprehension done,
753 -- we can finally compute&report any unused ParStmt binders.
754 ; warnUnusedMatches unused_bndrs
755 ; return ((ParStmt (stmtss' `zip` used_bndrs_s), thing),
756 fv_stmtss `plusFV` fvs) }}
758 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts $
759 return ((), emptyFVs)
761 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
762 dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
763 <+> quotes (ppr (head vs)))
765 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
766 = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ _ ->
767 rn_rec_stmts rec_stmts `thenM` \ segs ->
768 thing_inside `thenM` \ (thing, fvs) ->
770 segs_w_fwd_refs = addFwdRefs segs
771 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
772 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
773 fwd_vars = nameSetToList (plusFVs fs)
775 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
777 returnM ((rec_stmt, thing), uses `plusFV` fvs)
779 doc = text "In a recursive do statement"
783 %************************************************************************
785 \subsubsection{mdo expressions}
787 %************************************************************************
790 type FwdRefs = NameSet
791 type Segment stmts = (Defs,
792 Uses, -- May include defs
793 FwdRefs, -- A subset of uses that are
794 -- (a) used before they are bound in this segment, or
795 -- (b) used here, and bound in subsequent segments
796 stmts) -- Either Stmt or [Stmt]
799 ----------------------------------------------------
800 rnMDoStmts :: [LStmt RdrName]
801 -> RnM (thing, FreeVars)
802 -> RnM (([LStmt Name], thing), FreeVars)
803 rnMDoStmts stmts thing_inside
804 = -- Step1: bring all the binders of the mdo into scope
805 -- Remember that this also removes the binders from the
806 -- finally-returned free-vars
807 bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ _ ->
809 -- Step 2: Rename each individual stmt, making a
810 -- singleton segment. At this stage the FwdRefs field
811 -- isn't finished: it's empty for all except a BindStmt
812 -- for which it's the fwd refs within the bind itself
813 -- (This set may not be empty, because we're in a recursive
815 segs <- rn_rec_stmts stmts
817 ; (thing, fvs_later) <- thing_inside
820 -- Step 3: Fill in the fwd refs.
821 -- The segments are all singletons, but their fwd-ref
822 -- field mentions all the things used by the segment
823 -- that are bound after their use
824 segs_w_fwd_refs = addFwdRefs segs
826 -- Step 4: Group together the segments to make bigger segments
827 -- Invariant: in the result, no segment uses a variable
828 -- bound in a later segment
829 grouped_segs = glomSegments segs_w_fwd_refs
831 -- Step 5: Turn the segments into Stmts
832 -- Use RecStmt when and only when there are fwd refs
833 -- Also gather up the uses from the end towards the
834 -- start, so we can tell the RecStmt which things are
835 -- used 'after' the RecStmt
836 (stmts', fvs) = segsToStmts grouped_segs fvs_later
838 ; return ((stmts', thing), fvs) }
840 doc = text "In a recursive mdo-expression"
843 ----------------------------------------------------
844 rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)]
845 -- Rename a Stmt that is inside a RecStmt (or mdo)
846 -- Assumes all binders are already in scope
847 -- Turns each stmt into a singleton Stmt
849 rn_rec_stmt (L loc (ExprStmt expr _ _))
850 = rnLExpr expr `thenM` \ (expr', fvs) ->
851 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
852 returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
853 L loc (ExprStmt expr' then_op placeHolderType))]
855 rn_rec_stmt (L loc (BindStmt pat expr _ _))
856 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
857 rnLPat pat `thenM` \ (pat', fv_pat) ->
858 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
859 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
861 bndrs = mkNameSet (collectPatBinders pat')
862 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
864 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
865 L loc (BindStmt pat' expr' bind_op fail_op))]
867 rn_rec_stmt (L loc (LetStmt binds))
868 = rnBindGroups binds `thenM` \ (binds', du_binds) ->
869 returnM [(duDefs du_binds, duUses du_binds,
870 emptyNameSet, L loc (LetStmt binds'))]
872 rn_rec_stmt (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
875 rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
876 = pprPanic "rn_rec_stmt" (ppr stmt)
878 ---------------------------------------------
879 rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)]
880 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
881 returnM (concat segs_s)
884 ---------------------------------------------
885 addFwdRefs :: [Segment a] -> [Segment a]
886 -- So far the segments only have forward refs *within* the Stmt
887 -- (which happens for bind: x <- ...x...)
888 -- This function adds the cross-seg fwd ref info
891 = fst (foldr mk_seg ([], emptyNameSet) pairs)
893 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
894 = (new_seg : segs, all_defs)
896 new_seg = (defs, uses, new_fwds, stmts)
897 all_defs = later_defs `unionNameSets` defs
898 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
899 -- Add the downstream fwd refs here
901 ----------------------------------------------------
902 -- Glomming the singleton segments of an mdo into
903 -- minimal recursive groups.
905 -- At first I thought this was just strongly connected components, but
906 -- there's an important constraint: the order of the stmts must not change.
909 -- mdo { x <- ...y...
916 -- Here, the first stmt mention 'y', which is bound in the third.
917 -- But that means that the innocent second stmt (p <- z) gets caught
918 -- up in the recursion. And that in turn means that the binding for
919 -- 'z' has to be included... and so on.
921 -- Start at the tail { r <- x }
922 -- Now add the next one { z <- y ; r <- x }
923 -- Now add one more { q <- x ; z <- y ; r <- x }
924 -- Now one more... but this time we have to group a bunch into rec
925 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
926 -- Now one more, which we can add on without a rec
928 -- rec { y <- ...x... ; q <- x ; z <- y } ;
930 -- Finally we add the last one; since it mentions y we have to
931 -- glom it togeher with the first two groups
932 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
933 -- q <- x ; z <- y } ;
936 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
939 glomSegments ((defs,uses,fwds,stmt) : segs)
940 -- Actually stmts will always be a singleton
941 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
943 segs' = glomSegments segs
944 (extras, others) = grab uses segs'
945 (ds, us, fs, ss) = unzip4 extras
947 seg_defs = plusFVs ds `plusFV` defs
948 seg_uses = plusFVs us `plusFV` uses
949 seg_fwds = plusFVs fs `plusFV` fwds
950 seg_stmts = stmt : concat ss
952 grab :: NameSet -- The client
954 -> ([Segment a], -- Needed by the 'client'
955 [Segment a]) -- Not needed by the client
956 -- The result is simply a split of the input
958 = (reverse yeses, reverse noes)
960 (noes, yeses) = span not_needed (reverse dus)
961 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
964 ----------------------------------------------------
965 segsToStmts :: [Segment [LStmt Name]]
966 -> FreeVars -- Free vars used 'later'
967 -> ([LStmt Name], FreeVars)
969 segsToStmts [] fvs_later = ([], fvs_later)
970 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
971 = ASSERT( not (null ss) )
972 (new_stmt : later_stmts, later_uses `plusFV` uses)
974 (later_stmts, later_uses) = segsToStmts segs fvs_later
975 new_stmt | non_rec = head ss
976 | otherwise = L (getLoc (head ss)) $
977 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
980 non_rec = isSingleton ss && isEmptyNameSet fwds
981 used_later = defs `intersectNameSet` later_uses
982 -- The ones needed after the RecStmt
985 %************************************************************************
987 \subsubsection{Precedence Parsing}
989 %************************************************************************
991 @mkOpAppRn@ deals with operator fixities. The argument expressions
992 are assumed to be already correctly arranged. It needs the fixities
993 recorded in the OpApp nodes, because fixity info applies to the things
994 the programmer actually wrote, so you can't find it out from the Name.
996 Furthermore, the second argument is guaranteed not to be another
997 operator application. Why? Because the parser parses all
998 operator appications left-associatively, EXCEPT negation, which
999 we need to handle specially.
1002 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
1003 -> LHsExpr Name -> Fixity -- Operator and fixity
1004 -> LHsExpr Name -- Right operand (not an OpApp, but might
1006 -> RnM (HsExpr Name)
1008 ---------------------------
1009 -- (e11 `op1` e12) `op2` e2
1010 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1012 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
1013 returnM (OpApp e1 op2 fix2 e2)
1016 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
1017 returnM (OpApp e11 op1 fix1 (L loc' new_e))
1019 loc'= combineLocs e12 e2
1020 (nofix_error, associate_right) = compareFixity fix1 fix2
1022 ---------------------------
1023 -- (- neg_arg) `op` e2
1024 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1026 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1027 returnM (OpApp e1 op2 fix2 e2)
1030 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1031 returnM (NegApp (L loc' new_e) neg_name)
1033 loc' = combineLocs neg_arg e2
1034 (nofix_error, associate_right) = compareFixity negateFixity fix2
1036 ---------------------------
1037 -- e1 `op` - neg_arg
1038 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right
1039 | not associate_right -- We *want* right association
1040 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1041 returnM (OpApp e1 op1 fix1 e2)
1043 (_, associate_right) = compareFixity fix1 negateFixity
1045 ---------------------------
1047 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1048 = ASSERT2( right_op_ok fix (unLoc e2),
1049 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1051 returnM (OpApp e1 op fix e2)
1053 -- Parser left-associates everything, but
1054 -- derived instances may have correctly-associated things to
1055 -- in the right operarand. So we just check that the right operand is OK
1056 right_op_ok fix1 (OpApp _ _ fix2 _)
1057 = not error_please && associate_right
1059 (error_please, associate_right) = compareFixity fix1 fix2
1060 right_op_ok fix1 other
1063 -- Parser initially makes negation bind more tightly than any other operator
1064 -- And "deriving" code should respect this (use HsPar if not)
1065 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
1066 mkNegAppRn neg_arg neg_name
1067 = ASSERT( not_op_app (unLoc neg_arg) )
1068 returnM (NegApp neg_arg neg_name)
1070 not_op_app (OpApp _ _ _ _) = False
1071 not_op_app other = True
1075 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
1076 -- True indicates an infix lhs
1077 -- See comments with rnExpr (OpApp ...) about "deriving"
1079 checkPrecMatch False fn match
1081 checkPrecMatch True op (MatchGroup ms _)
1084 check (L _ (Match (p1:p2:_) _ _))
1085 = checkPrec op (unLoc p1) False `thenM_`
1086 checkPrec op (unLoc p2) True
1088 check _ = panic "checkPrecMatch"
1090 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1091 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1092 lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1094 inf_ok = op1_prec > op_prec ||
1095 (op1_prec == op_prec &&
1096 (op1_dir == InfixR && op_dir == InfixR && right ||
1097 op1_dir == InfixL && op_dir == InfixL && not right))
1099 info = (ppr_op op, op_fix)
1100 info1 = (ppr_op op1, op1_fix)
1101 (infol, infor) = if right then (info, info1) else (info1, info)
1103 checkErr inf_ok (precParseErr infol infor)
1105 checkPrec op pat right
1108 -- Check precedence of (arg op) or (op arg) respectively
1109 -- If arg is itself an operator application, then either
1110 -- (a) its precedence must be higher than that of op
1111 -- (b) its precedency & associativity must be the same as that of op
1112 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1113 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1114 checkSectionPrec direction section op arg
1116 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1117 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1120 L _ (HsVar op_name) = op
1121 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1122 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1123 checkErr (op_prec < arg_prec
1124 || op_prec == arg_prec && direction == assoc)
1125 (sectionPrecErr (ppr_op op_name, op_fix)
1126 (pp_arg_op, arg_fix) section)
1130 %************************************************************************
1132 \subsubsection{Assertion utils}
1134 %************************************************************************
1137 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1138 -- Return an expression for (assertError "Foo.hs:27")
1140 = getSrcSpanM `thenM` \ sloc ->
1142 expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
1143 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1145 returnM (expr, emptyFVs)
1148 %************************************************************************
1150 \subsubsection{Errors}
1152 %************************************************************************
1155 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1156 pp_prefix_minus = ptext SLIT("prefix `-'")
1158 nonStdGuardErr guard
1160 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1164 = sep [ptext SLIT("Pattern syntax in expression context:"),
1168 checkTH e what = returnM () -- OK
1170 checkTH e what -- Raise an error in a stage-1 compiler
1171 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1172 ptext SLIT("illegal in a stage-1 compiler"),
1176 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1179 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4