RnEnv refactoring
[ghc.git] / compiler / rename / RnExpr.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[RnExpr]{Renaming of expressions}
5
6 Basically dependency analysis.
7
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
10 free variables.
11 -}
12
13 {-# LANGUAGE CPP #-}
14 {-# LANGUAGE ScopedTypeVariables #-}
15 {-# LANGUAGE MultiWayIf #-}
16
17 module RnExpr (
18 rnLExpr, rnExpr, rnStmts
19 ) where
20
21 #include "HsVersions.h"
22
23 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
24 rnMatchGroup, rnGRHS, makeMiniFixityEnv)
25 import HsSyn
26 import TcRnMonad
27 import Module ( getModule )
28 import RnEnv
29 import RnFixity
30 import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
31 , bindLocalNames
32 , mapMaybeFvRn, mapFvRn
33 , warnUnusedLocalBinds )
34 import RnUnbound ( reportUnboundName )
35 import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
36 import RnTypes
37 import RnPat
38 import DynFlags
39 import PrelNames
40
41 import BasicTypes
42 import Name
43 import NameSet
44 import RdrName
45 import UniqSet
46 import Data.List
47 import Util
48 import ListSetOps ( removeDups )
49 import ErrUtils
50 import Outputable
51 import SrcLoc
52 import FastString
53 import Control.Monad
54 import TysWiredIn ( nilDataConName )
55 import qualified GHC.LanguageExtensions as LangExt
56
57 import Data.Ord
58 import Data.Array
59
60 {-
61 ************************************************************************
62 * *
63 \subsubsection{Expressions}
64 * *
65 ************************************************************************
66 -}
67
68 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
69 rnExprs ls = rnExprs' ls emptyUniqSet
70 where
71 rnExprs' [] acc = return ([], acc)
72 rnExprs' (expr:exprs) acc =
73 do { (expr', fvExpr) <- rnLExpr expr
74 -- Now we do a "seq" on the free vars because typically it's small
75 -- or empty, especially in very long lists of constants
76 ; let acc' = acc `plusFV` fvExpr
77 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
78 ; return (expr':exprs', fvExprs) }
79
80 -- Variables. We look up the variable and return the resulting name.
81
82 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
83 rnLExpr = wrapLocFstM rnExpr
84
85 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
86
87 finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
88 -- Separated from rnExpr because it's also used
89 -- when renaming infix expressions
90 finishHsVar (L l name)
91 = do { this_mod <- getModule
92 ; when (nameIsLocalOrFrom this_mod name) $
93 checkThLocalName name
94 ; return (HsVar (L l name), unitFV name) }
95
96 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
97 rnUnboundVar v
98 = do { if isUnqual v
99 then -- Treat this as a "hole"
100 -- Do not fail right now; instead, return HsUnboundVar
101 -- and let the type checker report the error
102 do { let occ = rdrNameOcc v
103 ; uv <- if startsWithUnderscore occ
104 then return (TrueExprHole occ)
105 else OutOfScope occ <$> getGlobalRdrEnv
106 ; return (HsUnboundVar uv, emptyFVs) }
107
108 else -- Fail immediately (qualified name)
109 do { n <- reportUnboundName v
110 ; return (HsVar (noLoc n), emptyFVs) } }
111
112 rnExpr (HsVar (L l v))
113 = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
114 ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
115 ; case mb_name of {
116 Nothing -> rnUnboundVar v ;
117 Just (Left name)
118 | name == nilDataConName -- Treat [] as an ExplicitList, so that
119 -- OverloadedLists works correctly
120 -> rnExpr (ExplicitList placeHolderType Nothing [])
121
122 | otherwise
123 -> finishHsVar (L l name) ;
124 Just (Right [s]) ->
125 return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
126 , unitFV s) ;
127 Just (Right fs@(_:_:_)) ->
128 return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
129 , mkFVs fs);
130 Just (Right []) -> panic "runExpr/HsVar" } }
131
132 rnExpr (HsIPVar v)
133 = return (HsIPVar v, emptyFVs)
134
135 rnExpr (HsOverLabel _ v)
136 = do { rebindable_on <- xoptM LangExt.RebindableSyntax
137 ; if rebindable_on
138 then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
139 ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
140 else return (HsOverLabel Nothing v, emptyFVs) }
141
142 rnExpr (HsLit lit@(HsString src s))
143 = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
144 ; if opt_OverloadedStrings then
145 rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
146 else do {
147 ; rnLit lit
148 ; return (HsLit lit, emptyFVs) } }
149
150 rnExpr (HsLit lit)
151 = do { rnLit lit
152 ; return (HsLit lit, emptyFVs) }
153
154 rnExpr (HsOverLit lit)
155 = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
156 ; case mb_neg of
157 Nothing -> return (HsOverLit lit', fvs)
158 Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
159 , fvs ) }
160
161 rnExpr (HsApp fun arg)
162 = do { (fun',fvFun) <- rnLExpr fun
163 ; (arg',fvArg) <- rnLExpr arg
164 ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
165
166 rnExpr (HsAppType fun arg)
167 = do { (fun',fvFun) <- rnLExpr fun
168 ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
169 ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
170
171 rnExpr (OpApp e1 op _ e2)
172 = do { (e1', fv_e1) <- rnLExpr e1
173 ; (e2', fv_e2) <- rnLExpr e2
174 ; (op', fv_op) <- rnLExpr op
175
176 -- Deal with fixity
177 -- When renaming code synthesised from "deriving" declarations
178 -- we used to avoid fixity stuff, but we can't easily tell any
179 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
180 -- should prevent bad things happening.
181 ; fixity <- case op' of
182 L _ (HsVar (L _ n)) -> lookupFixityRn n
183 L _ (HsRecFld f) -> lookupFieldFixityRn f
184 _ -> return (Fixity NoSourceText minPrecedence InfixL)
185 -- c.f. lookupFixity for unbound
186
187 ; final_e <- mkOpAppRn e1' op' fixity e2'
188 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
189
190 rnExpr (NegApp e _)
191 = do { (e', fv_e) <- rnLExpr e
192 ; (neg_name, fv_neg) <- lookupSyntaxName negateName
193 ; final_e <- mkNegAppRn e' neg_name
194 ; return (final_e, fv_e `plusFV` fv_neg) }
195
196 ------------------------------------------
197 -- Template Haskell extensions
198 -- Don't ifdef-GHCI them because we want to fail gracefully
199 -- (not with an rnExpr crash) in a stage-1 compiler.
200 rnExpr e@(HsBracket br_body) = rnBracket e br_body
201
202 rnExpr (HsSpliceE splice) = rnSpliceExpr splice
203
204 ---------------------------------------------
205 -- Sections
206 -- See Note [Parsing sections] in Parser.y
207 rnExpr (HsPar (L loc (section@(SectionL {}))))
208 = do { (section', fvs) <- rnSection section
209 ; return (HsPar (L loc section'), fvs) }
210
211 rnExpr (HsPar (L loc (section@(SectionR {}))))
212 = do { (section', fvs) <- rnSection section
213 ; return (HsPar (L loc section'), fvs) }
214
215 rnExpr (HsPar e)
216 = do { (e', fvs_e) <- rnLExpr e
217 ; return (HsPar e', fvs_e) }
218
219 rnExpr expr@(SectionL {})
220 = do { addErr (sectionErr expr); rnSection expr }
221 rnExpr expr@(SectionR {})
222 = do { addErr (sectionErr expr); rnSection expr }
223
224 ---------------------------------------------
225 rnExpr (HsCoreAnn src ann expr)
226 = do { (expr', fvs_expr) <- rnLExpr expr
227 ; return (HsCoreAnn src ann expr', fvs_expr) }
228
229 rnExpr (HsSCC src lbl expr)
230 = do { (expr', fvs_expr) <- rnLExpr expr
231 ; return (HsSCC src lbl expr', fvs_expr) }
232 rnExpr (HsTickPragma src info srcInfo expr)
233 = do { (expr', fvs_expr) <- rnLExpr expr
234 ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
235
236 rnExpr (HsLam matches)
237 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
238 ; return (HsLam matches', fvMatch) }
239
240 rnExpr (HsLamCase matches)
241 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
242 ; return (HsLamCase matches', fvs_ms) }
243
244 rnExpr (HsCase expr matches)
245 = do { (new_expr, e_fvs) <- rnLExpr expr
246 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
247 ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
248
249 rnExpr (HsLet (L l binds) expr)
250 = rnLocalBindsAndThen binds $ \binds' _ -> do
251 { (expr',fvExpr) <- rnLExpr expr
252 ; return (HsLet (L l binds') expr', fvExpr) }
253
254 rnExpr (HsDo do_or_lc (L l stmts) _)
255 = do { ((stmts', _), fvs) <-
256 rnStmtsWithPostProcessing do_or_lc rnLExpr
257 postProcessStmtsForApplicativeDo stmts
258 (\ _ -> return ((), emptyFVs))
259 ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
260
261 rnExpr (ExplicitList _ _ exps)
262 = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
263 ; (exps', fvs) <- rnExprs exps
264 ; if opt_OverloadedLists
265 then do {
266 ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
267 ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
268 , fvs `plusFV` fvs') }
269 else
270 return (ExplicitList placeHolderType Nothing exps', fvs) }
271
272 rnExpr (ExplicitPArr _ exps)
273 = do { (exps', fvs) <- rnExprs exps
274 ; return (ExplicitPArr placeHolderType exps', fvs) }
275
276 rnExpr (ExplicitTuple tup_args boxity)
277 = do { checkTupleSection tup_args
278 ; checkTupSize (length tup_args)
279 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
280 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
281 where
282 rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
283 ; return (L l (Present e'), fvs) }
284 rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
285 , emptyFVs)
286
287 rnExpr (ExplicitSum alt arity expr _)
288 = do { (expr', fvs) <- rnLExpr expr
289 ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }
290
291 rnExpr (RecordCon { rcon_con_name = con_id
292 , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
293 = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
294 ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
295 ; (flds', fvss) <- mapAndUnzipM rn_field flds
296 ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
297 ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
298 , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
299 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
300 where
301 mk_hs_var l n = HsVar (L l n)
302 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
303 ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
304
305 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
306 = do { (expr', fvExpr) <- rnLExpr expr
307 ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
308 ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
309 , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
310 , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
311 , fvExpr `plusFV` fvRbinds) }
312
313 rnExpr (ExprWithTySig expr pty)
314 = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
315 ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
316 rnLExpr expr
317 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
318
319 rnExpr (HsIf _ p b1 b2)
320 = do { (p', fvP) <- rnLExpr p
321 ; (b1', fvB1) <- rnLExpr b1
322 ; (b2', fvB2) <- rnLExpr b2
323 ; (mb_ite, fvITE) <- lookupIfThenElse
324 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
325
326 rnExpr (HsMultiIf _ty alts)
327 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
328 -- ; return (HsMultiIf ty alts', fvs) }
329 ; return (HsMultiIf placeHolderType alts', fvs) }
330
331 rnExpr (ArithSeq _ _ seq)
332 = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
333 ; (new_seq, fvs) <- rnArithSeq seq
334 ; if opt_OverloadedLists
335 then do {
336 ; (from_list_name, fvs') <- lookupSyntaxName fromListName
337 ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
338 else
339 return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
340
341 rnExpr (PArrSeq _ seq)
342 = do { (new_seq, fvs) <- rnArithSeq seq
343 ; return (PArrSeq noPostTcExpr new_seq, fvs) }
344
345 {-
346 These three are pattern syntax appearing in expressions.
347 Since all the symbols are reservedops we can simply reject them.
348 We return a (bogus) EWildPat in each case.
349 -}
350
351 rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
352 rnExpr e@(EAsPat {})
353 = do { opt_TypeApplications <- xoptM LangExt.TypeApplications
354 ; let msg | opt_TypeApplications
355 = "Type application syntax requires a space before '@'"
356 | otherwise
357 = "Did you mean to enable TypeApplications?"
358 ; patSynErr e (text msg)
359 }
360 rnExpr e@(EViewPat {}) = patSynErr e empty
361 rnExpr e@(ELazyPat {}) = patSynErr e empty
362
363 {-
364 ************************************************************************
365 * *
366 Static values
367 * *
368 ************************************************************************
369
370 For the static form we check that the free variables are all top-level
371 value bindings. This is done by checking that the name is external or
372 wired-in. See the Notes about the NameSorts in Name.hs.
373 -}
374
375 rnExpr e@(HsStatic _ expr) = do
376 (expr',fvExpr) <- rnLExpr expr
377 stage <- getStage
378 case stage of
379 Splice _ -> addErr $ sep
380 [ text "static forms cannot be used in splices:"
381 , nest 2 $ ppr e
382 ]
383 _ -> return ()
384 mod <- getModule
385 let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
386 return (HsStatic fvExpr' expr', fvExpr)
387
388 {-
389 ************************************************************************
390 * *
391 Arrow notation
392 * *
393 ************************************************************************
394 -}
395
396 rnExpr (HsProc pat body)
397 = newArrowScope $
398 rnPat ProcExpr pat $ \ pat' -> do
399 { (body',fvBody) <- rnCmdTop body
400 ; return (HsProc pat' body', fvBody) }
401
402 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
403 rnExpr e@(HsArrApp {}) = arrowFail e
404 rnExpr e@(HsArrForm {}) = arrowFail e
405
406 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
407 -- HsWrap
408
409 hsHoleExpr :: HsExpr id
410 hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
411
412 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
413 arrowFail e
414 = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
415 , nest 2 (ppr e) ])
416 -- Return a place-holder hole, so that we can carry on
417 -- to report other errors
418 ; return (hsHoleExpr, emptyFVs) }
419
420 ----------------------
421 -- See Note [Parsing sections] in Parser.y
422 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
423 rnSection section@(SectionR op expr)
424 = do { (op', fvs_op) <- rnLExpr op
425 ; (expr', fvs_expr) <- rnLExpr expr
426 ; checkSectionPrec InfixR section op' expr'
427 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
428
429 rnSection section@(SectionL expr op)
430 = do { (expr', fvs_expr) <- rnLExpr expr
431 ; (op', fvs_op) <- rnLExpr op
432 ; checkSectionPrec InfixL section op' expr'
433 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
434
435 rnSection other = pprPanic "rnSection" (ppr other)
436
437 {-
438 ************************************************************************
439 * *
440 Arrow commands
441 * *
442 ************************************************************************
443 -}
444
445 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
446 rnCmdArgs [] = return ([], emptyFVs)
447 rnCmdArgs (arg:args)
448 = do { (arg',fvArg) <- rnCmdTop arg
449 ; (args',fvArgs) <- rnCmdArgs args
450 ; return (arg':args', fvArg `plusFV` fvArgs) }
451
452 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
453 rnCmdTop = wrapLocFstM rnCmdTop'
454 where
455 rnCmdTop' (HsCmdTop cmd _ _ _)
456 = do { (cmd', fvCmd) <- rnLCmd cmd
457 ; let cmd_names = [arrAName, composeAName, firstAName] ++
458 nameSetElemsStable (methodNamesCmd (unLoc cmd'))
459 -- Generate the rebindable syntax for the monad
460 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
461
462 ; return (HsCmdTop cmd' placeHolderType placeHolderType
463 (cmd_names `zip` cmd_names'),
464 fvCmd `plusFV` cmd_fvs) }
465
466 rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
467 rnLCmd = wrapLocFstM rnCmd
468
469 rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
470
471 rnCmd (HsCmdArrApp arrow arg _ ho rtl)
472 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
473 ; (arg',fvArg) <- rnLExpr arg
474 ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
475 fvArrow `plusFV` fvArg) }
476 where
477 select_arrow_scope tc = case ho of
478 HsHigherOrderApp -> tc
479 HsFirstOrderApp -> escapeArrowScope tc
480 -- See Note [Escaping the arrow scope] in TcRnTypes
481 -- Before renaming 'arrow', use the environment of the enclosing
482 -- proc for the (-<) case.
483 -- Local bindings, inside the enclosing proc, are not in scope
484 -- inside 'arrow'. In the higher-order case (-<<), they are.
485
486 -- infix form
487 rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
488 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
489 ; let L _ (HsVar (L _ op_name)) = op'
490 ; (arg1',fv_arg1) <- rnCmdTop arg1
491 ; (arg2',fv_arg2) <- rnCmdTop arg2
492 -- Deal with fixity
493 ; fixity <- lookupFixityRn op_name
494 ; final_e <- mkOpFormRn arg1' op' fixity arg2'
495 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
496
497 rnCmd (HsCmdArrForm op f fixity cmds)
498 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
499 ; (cmds',fvCmds) <- rnCmdArgs cmds
500 ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
501
502 rnCmd (HsCmdApp fun arg)
503 = do { (fun',fvFun) <- rnLCmd fun
504 ; (arg',fvArg) <- rnLExpr arg
505 ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
506
507 rnCmd (HsCmdLam matches)
508 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
509 ; return (HsCmdLam matches', fvMatch) }
510
511 rnCmd (HsCmdPar e)
512 = do { (e', fvs_e) <- rnLCmd e
513 ; return (HsCmdPar e', fvs_e) }
514
515 rnCmd (HsCmdCase expr matches)
516 = do { (new_expr, e_fvs) <- rnLExpr expr
517 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
518 ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
519
520 rnCmd (HsCmdIf _ p b1 b2)
521 = do { (p', fvP) <- rnLExpr p
522 ; (b1', fvB1) <- rnLCmd b1
523 ; (b2', fvB2) <- rnLCmd b2
524 ; (mb_ite, fvITE) <- lookupIfThenElse
525 ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
526
527 rnCmd (HsCmdLet (L l binds) cmd)
528 = rnLocalBindsAndThen binds $ \ binds' _ -> do
529 { (cmd',fvExpr) <- rnLCmd cmd
530 ; return (HsCmdLet (L l binds') cmd', fvExpr) }
531
532 rnCmd (HsCmdDo (L l stmts) _)
533 = do { ((stmts', _), fvs) <-
534 rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
535 ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
536
537 rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
538
539 ---------------------------------------------------
540 type CmdNeeds = FreeVars -- Only inhabitants are
541 -- appAName, choiceAName, loopAName
542
543 -- find what methods the Cmd needs (loop, choice, apply)
544 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
545 methodNamesLCmd = methodNamesCmd . unLoc
546
547 methodNamesCmd :: HsCmd Name -> CmdNeeds
548
549 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
550 = emptyFVs
551 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
552 = unitFV appAName
553 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
554 methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
555
556 methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
557
558 methodNamesCmd (HsCmdIf _ _ c1 c2)
559 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
560
561 methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
562 methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
563 methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
564 methodNamesCmd (HsCmdLam match) = methodNamesMatch match
565
566 methodNamesCmd (HsCmdCase _ matches)
567 = methodNamesMatch matches `addOneFV` choiceAName
568
569 --methodNamesCmd _ = emptyFVs
570 -- Other forms can't occur in commands, but it's not convenient
571 -- to error here so we just do what's convenient.
572 -- The type checker will complain later
573
574 ---------------------------------------------------
575 methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
576 methodNamesMatch (MG { mg_alts = L _ ms })
577 = plusFVs (map do_one ms)
578 where
579 do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
580
581 -------------------------------------------------
582 -- gaw 2004
583 methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
584 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
585
586 -------------------------------------------------
587
588 methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
589 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
590
591 ---------------------------------------------------
592 methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
593 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
594
595 ---------------------------------------------------
596 methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
597 methodNamesLStmt = methodNamesStmt . unLoc
598
599 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
600 methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd
601 methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
602 methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd
603 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
604 methodNamesStmts stmts `addOneFV` loopAName
605 methodNamesStmt (LetStmt {}) = emptyFVs
606 methodNamesStmt (ParStmt {}) = emptyFVs
607 methodNamesStmt (TransStmt {}) = emptyFVs
608 methodNamesStmt ApplicativeStmt{} = emptyFVs
609 -- ParStmt and TransStmt can't occur in commands, but it's not
610 -- convenient to error here so we just do what's convenient
611
612 {-
613 ************************************************************************
614 * *
615 Arithmetic sequences
616 * *
617 ************************************************************************
618 -}
619
620 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
621 rnArithSeq (From expr)
622 = do { (expr', fvExpr) <- rnLExpr expr
623 ; return (From expr', fvExpr) }
624
625 rnArithSeq (FromThen expr1 expr2)
626 = do { (expr1', fvExpr1) <- rnLExpr expr1
627 ; (expr2', fvExpr2) <- rnLExpr expr2
628 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
629
630 rnArithSeq (FromTo expr1 expr2)
631 = do { (expr1', fvExpr1) <- rnLExpr expr1
632 ; (expr2', fvExpr2) <- rnLExpr expr2
633 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
634
635 rnArithSeq (FromThenTo expr1 expr2 expr3)
636 = do { (expr1', fvExpr1) <- rnLExpr expr1
637 ; (expr2', fvExpr2) <- rnLExpr expr2
638 ; (expr3', fvExpr3) <- rnLExpr expr3
639 ; return (FromThenTo expr1' expr2' expr3',
640 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
641
642 {-
643 ************************************************************************
644 * *
645 \subsubsection{@Stmt@s: in @do@ expressions}
646 * *
647 ************************************************************************
648 -}
649
650 {-
651 Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
652 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
653 Both ApplicativeDo and RecursiveDo need to create tuples not
654 present in the source text.
655
656 For ApplicativeDo we create:
657
658 (a,b,c) <- (\c b a -> (a,b,c)) <$>
659
660 For RecursiveDo we create:
661
662 mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
663
664 The order of the components in those tuples needs to be stable
665 across recompilations, otherwise they can get optimized differently
666 and we end up with incompatible binaries.
667 To get a stable order we use nameSetElemsStable.
668 See Note [Deterministic UniqFM] to learn more about nondeterminism.
669 -}
670
671 -- | Rename some Stmts
672 rnStmts :: Outputable (body RdrName)
673 => HsStmtContext Name
674 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
675 -- ^ How to rename the body of each statement (e.g. rnLExpr)
676 -> [LStmt RdrName (Located (body RdrName))]
677 -- ^ Statements
678 -> ([Name] -> RnM (thing, FreeVars))
679 -- ^ if these statements scope over something, this renames it
680 -- and returns the result.
681 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
682 rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
683
684 -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
685 rnStmtsWithPostProcessing
686 :: Outputable (body RdrName)
687 => HsStmtContext Name
688 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
689 -- ^ How to rename the body of each statement (e.g. rnLExpr)
690 -> (HsStmtContext Name
691 -> [(LStmt Name (Located (body Name)), FreeVars)]
692 -> RnM ([LStmt Name (Located (body Name))], FreeVars))
693 -- ^ postprocess the statements
694 -> [LStmt RdrName (Located (body RdrName))]
695 -- ^ Statements
696 -> ([Name] -> RnM (thing, FreeVars))
697 -- ^ if these statements scope over something, this renames it
698 -- and returns the result.
699 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
700 rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
701 = do { ((stmts', thing), fvs) <-
702 rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
703 ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
704 ; return ((pp_stmts, thing), fvs `plusFV` fvs')
705 }
706
707 -- | maybe rearrange statements according to the ApplicativeDo transformation
708 postProcessStmtsForApplicativeDo
709 :: HsStmtContext Name
710 -> [(ExprLStmt Name, FreeVars)]
711 -> RnM ([ExprLStmt Name], FreeVars)
712 postProcessStmtsForApplicativeDo ctxt stmts
713 = do {
714 -- rearrange the statements using ApplicativeStmt if
715 -- -XApplicativeDo is on. Also strip out the FreeVars attached
716 -- to each Stmt body.
717 ado_is_on <- xoptM LangExt.ApplicativeDo
718 ; let is_do_expr | DoExpr <- ctxt = True
719 | otherwise = False
720 ; if ado_is_on && is_do_expr
721 then rearrangeForApplicativeDo ctxt stmts
722 else noPostProcessStmts ctxt stmts }
723
724 -- | strip the FreeVars annotations from statements
725 noPostProcessStmts
726 :: HsStmtContext Name
727 -> [(LStmt Name (Located (body Name)), FreeVars)]
728 -> RnM ([LStmt Name (Located (body Name))], FreeVars)
729 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
730
731
732 rnStmtsWithFreeVars :: Outputable (body RdrName)
733 => HsStmtContext Name
734 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
735 -> [LStmt RdrName (Located (body RdrName))]
736 -> ([Name] -> RnM (thing, FreeVars))
737 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
738 , FreeVars)
739 -- Each Stmt body is annotated with its FreeVars, so that
740 -- we can rearrange statements for ApplicativeDo.
741 --
742 -- Variables bound by the Stmts, and mentioned in thing_inside,
743 -- do not appear in the result FreeVars
744
745 rnStmtsWithFreeVars ctxt _ [] thing_inside
746 = do { checkEmptyStmts ctxt
747 ; (thing, fvs) <- thing_inside []
748 ; return (([], thing), fvs) }
749
750 rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo
751 = -- Behave like do { rec { ...all but last... }; last }
752 do { ((stmts1, (stmts2, thing)), fvs)
753 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
754 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
755 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
756 ; return (((stmts1 ++ stmts2), thing), fvs) }
757 where
758 Just (all_but_last, last_stmt) = snocView stmts
759
760 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
761 | null lstmts
762 = setSrcSpan loc $
763 do { lstmt' <- checkLastStmt ctxt lstmt
764 ; rnStmt ctxt rnBody lstmt' thing_inside }
765
766 | otherwise
767 = do { ((stmts1, (stmts2, thing)), fvs)
768 <- setSrcSpan loc $
769 do { checkStmt ctxt lstmt
770 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
771 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
772 thing_inside (bndrs1 ++ bndrs2) }
773 ; return (((stmts1 ++ stmts2), thing), fvs) }
774
775 ----------------------
776
777 {-
778 Note [Failing pattern matches in Stmts]
779 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
780
781 Many things desugar to HsStmts including monadic things like `do` and `mdo`
782 statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
783 exhaustive list). How we deal with pattern match failure is context-dependent.
784
785 * In the case of list comprehensions and pattern guards we don't need any 'fail'
786 function; the desugarer ignores the fail function field of 'BindStmt' entirely.
787 * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
788 expressions) we want pattern match failure to be desugared to the appropriate
789 'fail' function (either that of Monad or MonadFail, depending on whether
790 -XMonadFailDesugaring is enabled.)
791
792 At one point we failed to make this distinction, leading to #11216.
793 -}
794
795 rnStmt :: Outputable (body RdrName)
796 => HsStmtContext Name
797 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
798 -- ^ How to rename the body of the statement
799 -> LStmt RdrName (Located (body RdrName))
800 -- ^ The statement
801 -> ([Name] -> RnM (thing, FreeVars))
802 -- ^ Rename the stuff that this statement scopes over
803 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
804 , FreeVars)
805 -- Variables bound by the Stmt, and mentioned in thing_inside,
806 -- do not appear in the result FreeVars
807
808 rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
809 = do { (body', fv_expr) <- rnBody body
810 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
811 ; (thing, fvs3) <- thing_inside []
812 ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
813 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
814
815 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
816 = do { (body', fv_expr) <- rnBody body
817 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
818 ; (guard_op, fvs2) <- if isListCompExpr ctxt
819 then lookupStmtName ctxt guardMName
820 else return (noSyntaxExpr, emptyFVs)
821 -- Only list/parr/monad comprehensions use 'guard'
822 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
823 -- Here "gd" is a guard
824 ; (thing, fvs3) <- thing_inside []
825 ; return (([(L loc (BodyStmt body'
826 then_op guard_op placeHolderType), fv_expr)], thing),
827 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
828
829 rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
830 = do { (body', fv_expr) <- rnBody body
831 -- The binders do not scope over the expression
832 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
833
834 ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
835 ; let getFailFunction
836 -- If the pattern is irrefutible (e.g.: wildcard, tuple,
837 -- ~pat, etc.) we should not need to fail.
838 | isIrrefutableHsPat pat
839 = return (noSyntaxExpr, emptyFVs)
840 -- For non-monadic contexts (e.g. guard patterns, list
841 -- comprehensions, etc.) we should not need to fail.
842 -- See Note [Failing pattern matches in Stmts]
843 | not (isMonadFailStmtContext ctxt)
844 = return (noSyntaxExpr, emptyFVs)
845 | xMonadFailEnabled = lookupSyntaxName failMName
846 | otherwise = lookupSyntaxName failMName_preMFP
847 ; (fail_op, fvs2) <- getFailFunction
848
849 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
850 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
851 ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
852 , fv_expr )]
853 , thing),
854 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
855 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
856 -- but it does not matter because the names are unique
857
858 rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
859 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
860 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
861 ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
862
863 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
864 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
865 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
866 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
867 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
868 , recS_mfix_fn = mfix_op
869 , recS_bind_fn = bind_op }
870
871 -- Step1: Bring all the binders of the mdo into scope
872 -- (Remember that this also removes the binders from the
873 -- finally-returned free-vars.)
874 -- And rename each individual stmt, making a
875 -- singleton segment. At this stage the FwdRefs field
876 -- isn't finished: it's empty for all except a BindStmt
877 -- for which it's the fwd refs within the bind itself
878 -- (This set may not be empty, because we're in a recursive
879 -- context.)
880 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
881 { let bndrs = nameSetElemsStable $
882 foldr (unionNameSet . (\(ds,_,_,_) -> ds))
883 emptyNameSet
884 segs
885 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
886 ; (thing, fvs_later) <- thing_inside bndrs
887 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
888 -- We aren't going to try to group RecStmts with
889 -- ApplicativeDo, so attaching empty FVs is fine.
890 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
891 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
892
893 rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
894 = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
895 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
896 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
897 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
898 ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
899 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
900
901 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
902 , trS_using = using })) thing_inside
903 = do { -- Rename the 'using' expression in the context before the transform is begun
904 (using', fvs1) <- rnLExpr using
905
906 -- Rename the stmts and the 'by' expression
907 -- Keep track of the variables mentioned in the 'by' expression
908 ; ((stmts', (by', used_bndrs, thing)), fvs2)
909 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
910 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
911 ; (thing, fvs_thing) <- thing_inside bndrs
912 ; let fvs = fvs_by `plusFV` fvs_thing
913 used_bndrs = filter (`elemNameSet` fvs) bndrs
914 -- The paper (Fig 5) has a bug here; we must treat any free variable
915 -- of the "thing inside", **or of the by-expression**, as used
916 ; return ((by', used_bndrs, thing), fvs) }
917
918 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
919 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
920 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
921 ; (fmap_op, fvs5) <- case form of
922 ThenForm -> return (noExpr, emptyFVs)
923 _ -> lookupStmtNamePoly ctxt fmapName
924
925 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
926 `plusFV` fvs4 `plusFV` fvs5
927 bndr_map = used_bndrs `zip` used_bndrs
928 -- See Note [TransStmt binder map] in HsExpr
929
930 ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
931 ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
932 , trS_by = by', trS_using = using', trS_form = form
933 , trS_ret = return_op, trS_bind = bind_op
934 , trS_bind_arg_ty = PlaceHolder
935 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
936
937 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
938 panic "rnStmt: ApplicativeStmt"
939
940 rnParallelStmts :: forall thing. HsStmtContext Name
941 -> SyntaxExpr Name
942 -> [ParStmtBlock RdrName RdrName]
943 -> ([Name] -> RnM (thing, FreeVars))
944 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
945 -- Note [Renaming parallel Stmts]
946 rnParallelStmts ctxt return_op segs thing_inside
947 = do { orig_lcl_env <- getLocalRdrEnv
948 ; rn_segs orig_lcl_env [] segs }
949 where
950 rn_segs :: LocalRdrEnv
951 -> [Name] -> [ParStmtBlock RdrName RdrName]
952 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
953 rn_segs _ bndrs_so_far []
954 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
955 ; mapM_ dupErr dups
956 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
957 ; return (([], thing), fvs) }
958
959 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
960 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
961 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
962 setLocalRdrEnv env $ do
963 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
964 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
965 ; return ((used_bndrs, segs', thing), fvs) }
966
967 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
968 ; return ((seg':segs', thing), fvs) }
969
970 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
971 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
972 <+> quotes (ppr (head vs)))
973
974 lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)
975 -- Like lookupSyntaxName, but respects contexts
976 lookupStmtName ctxt n
977 | rebindableContext ctxt
978 = lookupSyntaxName n
979 | otherwise
980 = return (mkRnSyntaxExpr n, emptyFVs)
981
982 lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
983 lookupStmtNamePoly ctxt name
984 | rebindableContext ctxt
985 = do { rebindable_on <- xoptM LangExt.RebindableSyntax
986 ; if rebindable_on
987 then do { fm <- lookupOccRn (nameRdrName name)
988 ; return (HsVar (noLoc fm), unitFV fm) }
989 else not_rebindable }
990 | otherwise
991 = not_rebindable
992 where
993 not_rebindable = return (HsVar (noLoc name), emptyFVs)
994
995 -- | Is this a context where we respect RebindableSyntax?
996 -- but ListComp/PArrComp are never rebindable
997 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
998 rebindableContext :: HsStmtContext Name -> Bool
999 rebindableContext ctxt = case ctxt of
1000 ListComp -> False
1001 PArrComp -> False
1002 ArrowExpr -> False
1003 PatGuard {} -> False
1004
1005 DoExpr -> True
1006 MDoExpr -> True
1007 MonadComp -> True
1008 GhciStmtCtxt -> True -- I suppose?
1009
1010 ParStmtCtxt c -> rebindableContext c -- Look inside to
1011 TransStmtCtxt c -> rebindableContext c -- the parent context
1012
1013 {-
1014 Note [Renaming parallel Stmts]
1015 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1016 Renaming parallel statements is painful. Given, say
1017 [ a+c | a <- as, bs <- bss
1018 | c <- bs, a <- ds ]
1019 Note that
1020 (a) In order to report "Defined but not used" about 'bs', we must
1021 rename each group of Stmts with a thing_inside whose FreeVars
1022 include at least {a,c}
1023
1024 (b) We want to report that 'a' is illegally bound in both branches
1025
1026 (c) The 'bs' in the second group must obviously not be captured by
1027 the binding in the first group
1028
1029 To satisfy (a) we nest the segements.
1030 To satisfy (b) we check for duplicates just before thing_inside.
1031 To satisfy (c) we reset the LocalRdrEnv each time.
1032
1033 ************************************************************************
1034 * *
1035 \subsubsection{mdo expressions}
1036 * *
1037 ************************************************************************
1038 -}
1039
1040 type FwdRefs = NameSet
1041 type Segment stmts = (Defs,
1042 Uses, -- May include defs
1043 FwdRefs, -- A subset of uses that are
1044 -- (a) used before they are bound in this segment, or
1045 -- (b) used here, and bound in subsequent segments
1046 stmts) -- Either Stmt or [Stmt]
1047
1048
1049 -- wrapper that does both the left- and right-hand sides
1050 rnRecStmtsAndThen :: Outputable (body RdrName) =>
1051 (Located (body RdrName)
1052 -> RnM (Located (body Name), FreeVars))
1053 -> [LStmt RdrName (Located (body RdrName))]
1054 -- assumes that the FreeVars returned includes
1055 -- the FreeVars of the Segments
1056 -> ([Segment (LStmt Name (Located (body Name)))]
1057 -> RnM (a, FreeVars))
1058 -> RnM (a, FreeVars)
1059 rnRecStmtsAndThen rnBody s cont
1060 = do { -- (A) Make the mini fixity env for all of the stmts
1061 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
1062
1063 -- (B) Do the LHSes
1064 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
1065
1066 -- ...bring them and their fixities into scope
1067 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
1068 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
1069 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
1070 ; bindLocalNamesFV bound_names $
1071 addLocalFixities fix_env bound_names $ do
1072
1073 -- (C) do the right-hand-sides and thing-inside
1074 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
1075 ; (res, fvs) <- cont segs
1076 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
1077 ; return (res, fvs) }}
1078
1079 -- get all the fixity decls in any Let stmt
1080 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
1081 collectRecStmtsFixities l =
1082 foldr (\ s -> \acc -> case s of
1083 (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
1084 foldr (\ sig -> \ acc -> case sig of
1085 (L loc (FixSig s)) -> (L loc s) : acc
1086 _ -> acc) acc sigs
1087 _ -> acc) [] l
1088
1089 -- left-hand sides
1090
1091 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
1092 -> LStmt RdrName body
1093 -- rename LHS, and return its FVs
1094 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1095 -- so we don't bother to compute it accurately in the other cases
1096 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1097
1098 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
1099 = return [(L loc (BodyStmt body a b c), emptyFVs)]
1100
1101 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
1102 = return [(L loc (LastStmt body noret a), emptyFVs)]
1103
1104 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
1105 = do
1106 -- should the ctxt be MDo instead?
1107 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1108 return [(L loc (BindStmt pat' body a b t),
1109 fv_pat)]
1110
1111 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
1112 = failWith (badIpBinds (text "an mdo expression") binds)
1113
1114 rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
1115 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1116 return [(L loc (LetStmt (L l (HsValBinds binds'))),
1117 -- Warning: this is bogus; see function invariant
1118 emptyFVs
1119 )]
1120
1121 -- XXX Do we need to do something with the return and mfix names?
1122 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1123 = rn_rec_stmts_lhs fix_env stmts
1124
1125 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1126 = pprPanic "rn_rec_stmt" (ppr stmt)
1127
1128 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1129 = pprPanic "rn_rec_stmt" (ppr stmt)
1130
1131 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1132 = pprPanic "rn_rec_stmt" (ppr stmt)
1133
1134 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
1135 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1136
1137 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
1138 -> [LStmt RdrName body]
1139 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1140 rn_rec_stmts_lhs fix_env stmts
1141 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1142 ; let boundNames = collectLStmtsBinders (map fst ls)
1143 -- First do error checking: we need to check for dups here because we
1144 -- don't bind all of the variables from the Stmt at once
1145 -- with bindLocatedLocals.
1146 ; checkDupNames boundNames
1147 ; return ls }
1148
1149
1150 -- right-hand-sides
1151
1152 rn_rec_stmt :: (Outputable (body RdrName)) =>
1153 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1154 -> [Name]
1155 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
1156 -> RnM [Segment (LStmt Name (Located (body Name)))]
1157 -- Rename a Stmt that is inside a RecStmt (or mdo)
1158 -- Assumes all binders are already in scope
1159 -- Turns each stmt into a singleton Stmt
1160 rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
1161 = do { (body', fv_expr) <- rnBody body
1162 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1163 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1164 L loc (LastStmt body' noret ret_op))] }
1165
1166 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
1167 = do { (body', fvs) <- rnBody body
1168 ; (then_op, fvs1) <- lookupSyntaxName thenMName
1169 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1170 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
1171
1172 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
1173 = do { (body', fv_expr) <- rnBody body
1174 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
1175
1176 ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
1177 ; let failFunction | xMonadFailEnabled = failMName
1178 | otherwise = failMName_preMFP
1179 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
1180
1181 ; let bndrs = mkNameSet (collectPatBinders pat')
1182 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1183 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1184 L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
1185
1186 rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
1187 = failWith (badIpBinds (text "an mdo expression") binds)
1188
1189 rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
1190 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1191 -- fixities and unused are handled above in rnRecStmtsAndThen
1192 ; let fvs = allUses du_binds
1193 ; return [(duDefs du_binds, fvs, emptyNameSet,
1194 L loc (LetStmt (L l (HsValBinds binds'))))] }
1195
1196 -- no RecStmt case because they get flattened above when doing the LHSes
1197 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
1198 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1199
1200 rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
1201 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1202
1203 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
1204 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1205
1206 rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
1207 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1208
1209 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
1210 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
1211
1212 rn_rec_stmts :: Outputable (body RdrName) =>
1213 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1214 -> [Name]
1215 -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
1216 -> RnM [Segment (LStmt Name (Located (body Name)))]
1217 rn_rec_stmts rnBody bndrs stmts
1218 = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
1219 ; return (concat segs_s) }
1220
1221 ---------------------------------------------
1222 segmentRecStmts :: SrcSpan -> HsStmtContext Name
1223 -> Stmt Name body
1224 -> [Segment (LStmt Name body)] -> FreeVars
1225 -> ([LStmt Name body], FreeVars)
1226
1227 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
1228 | null segs
1229 = ([], fvs_later)
1230
1231 | MDoExpr <- ctxt
1232 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1233 -- Step 4: Turn the segments into Stmts
1234 -- Use RecStmt when and only when there are fwd refs
1235 -- Also gather up the uses from the end towards the
1236 -- start, so we can tell the RecStmt which things are
1237 -- used 'after' the RecStmt
1238
1239 | otherwise
1240 = ([ L loc $
1241 empty_rec_stmt { recS_stmts = ss
1242 , recS_later_ids = nameSetElemsStable
1243 (defs `intersectNameSet` fvs_later)
1244 , recS_rec_ids = nameSetElemsStable
1245 (defs `intersectNameSet` uses) }]
1246 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1247 , uses `plusFV` fvs_later)
1248
1249 where
1250 (defs_s, uses_s, _, ss) = unzip4 segs
1251 defs = plusFVs defs_s
1252 uses = plusFVs uses_s
1253
1254 -- Step 2: Fill in the fwd refs.
1255 -- The segments are all singletons, but their fwd-ref
1256 -- field mentions all the things used by the segment
1257 -- that are bound after their use
1258 segs_w_fwd_refs = addFwdRefs segs
1259
1260 -- Step 3: Group together the segments to make bigger segments
1261 -- Invariant: in the result, no segment uses a variable
1262 -- bound in a later segment
1263 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1264
1265 ----------------------------
1266 addFwdRefs :: [Segment a] -> [Segment a]
1267 -- So far the segments only have forward refs *within* the Stmt
1268 -- (which happens for bind: x <- ...x...)
1269 -- This function adds the cross-seg fwd ref info
1270
1271 addFwdRefs segs
1272 = fst (foldr mk_seg ([], emptyNameSet) segs)
1273 where
1274 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1275 = (new_seg : segs, all_defs)
1276 where
1277 new_seg = (defs, uses, new_fwds, stmts)
1278 all_defs = later_defs `unionNameSet` defs
1279 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1280 -- Add the downstream fwd refs here
1281
1282 {-
1283 Note [Segmenting mdo]
1284 ~~~~~~~~~~~~~~~~~~~~~
1285 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1286 and leave those found in "do rec"'s intact. See
1287 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1288 leading to this design choice. Hence the test in segmentRecStmts.
1289
1290 Note [Glomming segments]
1291 ~~~~~~~~~~~~~~~~~~~~~~~~
1292 Glomming the singleton segments of an mdo into minimal recursive groups.
1293
1294 At first I thought this was just strongly connected components, but
1295 there's an important constraint: the order of the stmts must not change.
1296
1297 Consider
1298 mdo { x <- ...y...
1299 p <- z
1300 y <- ...x...
1301 q <- x
1302 z <- y
1303 r <- x }
1304
1305 Here, the first stmt mention 'y', which is bound in the third.
1306 But that means that the innocent second stmt (p <- z) gets caught
1307 up in the recursion. And that in turn means that the binding for
1308 'z' has to be included... and so on.
1309
1310 Start at the tail { r <- x }
1311 Now add the next one { z <- y ; r <- x }
1312 Now add one more { q <- x ; z <- y ; r <- x }
1313 Now one more... but this time we have to group a bunch into rec
1314 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1315 Now one more, which we can add on without a rec
1316 { p <- z ;
1317 rec { y <- ...x... ; q <- x ; z <- y } ;
1318 r <- x }
1319 Finally we add the last one; since it mentions y we have to
1320 glom it together with the first two groups
1321 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1322 q <- x ; z <- y } ;
1323 r <- x }
1324 -}
1325
1326 glomSegments :: HsStmtContext Name
1327 -> [Segment (LStmt Name body)]
1328 -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts
1329 -- See Note [Glomming segments]
1330
1331 glomSegments _ [] = []
1332 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1333 -- Actually stmts will always be a singleton
1334 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1335 where
1336 segs' = glomSegments ctxt segs
1337 (extras, others) = grab uses segs'
1338 (ds, us, fs, ss) = unzip4 extras
1339
1340 seg_defs = plusFVs ds `plusFV` defs
1341 seg_uses = plusFVs us `plusFV` uses
1342 seg_fwds = plusFVs fs `plusFV` fwds
1343 seg_stmts = stmt : concat ss
1344
1345 grab :: NameSet -- The client
1346 -> [Segment a]
1347 -> ([Segment a], -- Needed by the 'client'
1348 [Segment a]) -- Not needed by the client
1349 -- The result is simply a split of the input
1350 grab uses dus
1351 = (reverse yeses, reverse noes)
1352 where
1353 (noes, yeses) = span not_needed (reverse dus)
1354 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1355
1356 ----------------------------------------------------
1357 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1358 -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts
1359 -> FreeVars -- Free vars used 'later'
1360 -> ([LStmt Name body], FreeVars)
1361
1362 segsToStmts _ [] fvs_later = ([], fvs_later)
1363 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1364 = ASSERT( not (null ss) )
1365 (new_stmt : later_stmts, later_uses `plusFV` uses)
1366 where
1367 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1368 new_stmt | non_rec = head ss
1369 | otherwise = L (getLoc (head ss)) rec_stmt
1370 rec_stmt = empty_rec_stmt { recS_stmts = ss
1371 , recS_later_ids = nameSetElemsStable used_later
1372 , recS_rec_ids = nameSetElemsStable fwds }
1373 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1374 non_rec = isSingleton ss && isEmptyNameSet fwds
1375 used_later = defs `intersectNameSet` later_uses
1376 -- The ones needed after the RecStmt
1377
1378 {-
1379 ************************************************************************
1380 * *
1381 ApplicativeDo
1382 * *
1383 ************************************************************************
1384
1385 Note [ApplicativeDo]
1386
1387 = Example =
1388
1389 For a sequence of statements
1390
1391 do
1392 x <- A
1393 y <- B x
1394 z <- C
1395 return (f x y z)
1396
1397 We want to transform this to
1398
1399 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
1400
1401 It would be easy to notice that "y <- B x" and "z <- C" are
1402 independent and do something like this:
1403
1404 do
1405 x <- A
1406 (y,z) <- (,) <$> B x <*> C
1407 return (f x y z)
1408
1409 But this isn't enough! A and C were also independent, and this
1410 transformation loses the ability to do A and C in parallel.
1411
1412 The algorithm works by first splitting the sequence of statements into
1413 independent "segments", and a separate "tail" (the final statement). In
1414 our example above, the segements would be
1415
1416 [ x <- A
1417 , y <- B x ]
1418
1419 [ z <- C ]
1420
1421 and the tail is:
1422
1423 return (f x y z)
1424
1425 Then we take these segments and make an Applicative expression from them:
1426
1427 (\(x,y) z -> return (f x y z))
1428 <$> do { x <- A; y <- B x; return (x,y) }
1429 <*> C
1430
1431 Finally, we recursively apply the transformation to each segment, to
1432 discover any nested parallelism.
1433
1434 = Syntax & spec =
1435
1436 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
1437
1438 stmt ::= pat <- expr
1439 | (arg_1 | ... | arg_n) -- applicative composition, n>=1
1440 | ... -- other kinds of statement (e.g. let)
1441
1442 arg ::= pat <- expr
1443 | {stmt_1; ..; stmt_n} {var_1..var_n}
1444
1445 (note that in the actual implementation,the expr in a do statement is
1446 represented by a LastStmt as the final stmt, this is just a
1447 representational issue and may change later.)
1448
1449 == Transformation to introduce applicative stmts ==
1450
1451 ado {} tail = tail
1452 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
1453 ado {one} tail = one : tail
1454 ado stmts tail
1455 | n == 1 = ado before (ado after tail)
1456 where (before,after) = split(stmts_1)
1457 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
1458 where
1459 {stmts_1 .. stmts_n} = segments(stmts)
1460
1461 segments(stmts) =
1462 -- divide stmts into segments with no interdependencies
1463
1464 mkArg({pat <- expr}) = (pat <- expr)
1465 mkArg({stmt_1; ...; stmt_n}) =
1466 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
1467
1468 split({stmt_1; ..; stmt_n) =
1469 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
1470 -- 1 <= i <= n
1471 -- i is a good place to insert a bind
1472
1473 == Desugaring for do ==
1474
1475 dsDo {} expr = expr
1476
1477 dsDo {pat <- rhs; stmts} expr =
1478 rhs >>= \pat -> dsDo stmts expr
1479
1480 dsDo {(arg_1 | ... | arg_n)} (return expr) =
1481 (\argpat (arg_1) .. argpat(arg_n) -> expr)
1482 <$> argexpr(arg_1)
1483 <*> ...
1484 <*> argexpr(arg_n)
1485
1486 dsDo {(arg_1 | ... | arg_n); stmts} expr =
1487 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
1488 <$> argexpr(arg_1)
1489 <*> ...
1490 <*> argexpr(arg_n)
1491
1492 -}
1493
1494 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
1495 -- 'pureName' due to @RebindableSyntax@.
1496 data MonadNames = MonadNames { return_name, pure_name :: Name }
1497
1498 -- | rearrange a list of statements using ApplicativeDoStmt. See
1499 -- Note [ApplicativeDo].
1500 rearrangeForApplicativeDo
1501 :: HsStmtContext Name
1502 -> [(ExprLStmt Name, FreeVars)]
1503 -> RnM ([ExprLStmt Name], FreeVars)
1504
1505 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
1506 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
1507 rearrangeForApplicativeDo ctxt stmts0 = do
1508 optimal_ado <- goptM Opt_OptimalApplicativeDo
1509 let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
1510 | otherwise = mkStmtTreeHeuristic stmts
1511 return_name <- lookupSyntaxName' returnMName
1512 pure_name <- lookupSyntaxName' pureAName
1513 let monad_names = MonadNames { return_name = return_name
1514 , pure_name = pure_name }
1515 stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
1516 where
1517 (stmts,(last,last_fvs)) = findLast stmts0
1518 findLast [] = error "findLast"
1519 findLast [last] = ([],last)
1520 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
1521
1522 -- | A tree of statements using a mixture of applicative and bind constructs.
1523 data StmtTree a
1524 = StmtTreeOne a
1525 | StmtTreeBind (StmtTree a) (StmtTree a)
1526 | StmtTreeApplicative [StmtTree a]
1527
1528 flattenStmtTree :: StmtTree a -> [a]
1529 flattenStmtTree t = go t []
1530 where
1531 go (StmtTreeOne a) as = a : as
1532 go (StmtTreeBind l r) as = go l (go r as)
1533 go (StmtTreeApplicative ts) as = foldr go as ts
1534
1535 type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars)
1536 type Cost = Int
1537
1538 -- | Turn a sequence of statements into an ExprStmtTree using a
1539 -- heuristic algorithm. /O(n^2)/
1540 mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1541 mkStmtTreeHeuristic [one] = StmtTreeOne one
1542 mkStmtTreeHeuristic stmts =
1543 case segments stmts of
1544 [one] -> split one
1545 segs -> StmtTreeApplicative (map split segs)
1546 where
1547 split [one] = StmtTreeOne one
1548 split stmts =
1549 StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
1550 where (before, after) = splitSegment stmts
1551
1552 -- | Turn a sequence of statements into an ExprStmtTree optimally,
1553 -- using dynamic programming. /O(n^3)/
1554 mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1555 mkStmtTreeOptimal stmts =
1556 ASSERT(not (null stmts)) -- the empty case is handled by the caller;
1557 -- we don't support empty StmtTrees.
1558 fst (arr ! (0,n))
1559 where
1560 n = length stmts - 1
1561 stmt_arr = listArray (0,n) stmts
1562
1563 -- lazy cache of optimal trees for subsequences of the input
1564 arr :: Array (Int,Int) (ExprStmtTree, Cost)
1565 arr = array ((0,0),(n,n))
1566 [ ((lo,hi), tree lo hi)
1567 | lo <- [0..n]
1568 , hi <- [lo..n] ]
1569
1570 -- compute the optimal tree for the sequence [lo..hi]
1571 tree lo hi
1572 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1573 | otherwise =
1574 case segments [ stmt_arr ! i | i <- [lo..hi] ] of
1575 [] -> panic "mkStmtTree"
1576 [_one] -> split lo hi
1577 segs -> (StmtTreeApplicative trees, maximum costs)
1578 where
1579 bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
1580 (trees,costs) = unzip (map (uncurry split) (tail bounds))
1581
1582 -- find the best place to split the segment [lo..hi]
1583 split :: Int -> Int -> (ExprStmtTree, Cost)
1584 split lo hi
1585 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1586 | otherwise = (StmtTreeBind before after, c1+c2)
1587 where
1588 -- As per the paper, for a sequence s1...sn, we want to find
1589 -- the split with the minimum cost, where the cost is the
1590 -- sum of the cost of the left and right subsequences.
1591 --
1592 -- As an optimisation (also in the paper) if the cost of
1593 -- s1..s(n-1) is different from the cost of s2..sn, we know
1594 -- that the optimal solution is the lower of the two. Only
1595 -- in the case that these two have the same cost do we need
1596 -- to do the exhaustive search.
1597 --
1598 ((before,c1),(after,c2))
1599 | hi - lo == 1
1600 = ((StmtTreeOne (stmt_arr ! lo), 1),
1601 (StmtTreeOne (stmt_arr ! hi), 1))
1602 | left_cost < right_cost
1603 = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
1604 | otherwise -- left_cost > right_cost
1605 = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
1606 | otherwise = minimumBy (comparing cost) alternatives
1607 where
1608 (left, left_cost) = arr ! (lo,hi-1)
1609 (right, right_cost) = arr ! (lo+1,hi)
1610 cost ((_,c1),(_,c2)) = c1 + c2
1611 alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
1612 | k <- [lo .. hi-1] ]
1613
1614
1615 -- | Turn the ExprStmtTree back into a sequence of statements, using
1616 -- ApplicativeStmt where necessary.
1617 stmtTreeToStmts
1618 :: MonadNames
1619 -> HsStmtContext Name
1620 -> ExprStmtTree
1621 -> [ExprLStmt Name] -- ^ the "tail"
1622 -> FreeVars -- ^ free variables of the tail
1623 -> RnM ( [ExprLStmt Name] -- ( output statements,
1624 , FreeVars ) -- , things we needed
1625
1626 -- If we have a single bind, and we can do it without a join, transform
1627 -- to an ApplicativeStmt. This corresponds to the rule
1628 -- dsBlock [pat <- rhs] (return expr) = expr <$> rhs
1629 -- In the spec, but we do it here rather than in the desugarer,
1630 -- because we need the typechecker to typecheck the <$> form rather than
1631 -- the bind form, which would give rise to a Monad constraint.
1632 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
1633 tail _tail_fvs
1634 | isIrrefutableHsPat pat, (False,tail') <- needJoin monad_names tail
1635 -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
1636 -- to know which types have only one constructor. So only
1637 -- tuples come out as irrefutable; other single-constructor
1638 -- types, and newtypes, will not. See the code for
1639 -- isIrrefuatableHsPat
1640 = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
1641
1642 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
1643 return (s : tail, emptyNameSet)
1644
1645 stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
1646 (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
1647 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
1648 (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
1649 return (stmts2, fvs1 `plusFV` fvs2)
1650
1651 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
1652 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
1653 let (stmts', fvss) = unzip pairs
1654 let (need_join, tail') = needJoin monad_names tail
1655 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
1656 return (stmts, unionNameSets (fvs:fvss))
1657 where
1658 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
1659 return (ApplicativeArgOne pat exp, emptyFVs)
1660 stmtTreeArg ctxt tail_fvs tree = do
1661 let stmts = flattenStmtTree tree
1662 pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1663 `intersectNameSet` tail_fvs
1664 pvars = nameSetElemsStable pvarset
1665 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1666 pat = mkBigLHsVarPatTup pvars
1667 tup = mkBigLHsVarTup pvars
1668 (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
1669 (mb_ret, fvs1) <-
1670 if | L _ ApplicativeStmt{} <- last stmts' ->
1671 return (unLoc tup, emptyNameSet)
1672 | otherwise -> do
1673 (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
1674 return (HsApp (noLoc ret) tup, fvs)
1675 return ( ApplicativeArgMany stmts' mb_ret pat
1676 , fvs1 `plusFV` fvs2)
1677
1678
1679 -- | Divide a sequence of statements into segments, where no segment
1680 -- depends on any variables defined by a statement in another segment.
1681 segments
1682 :: [(ExprLStmt Name, FreeVars)]
1683 -> [[(ExprLStmt Name, FreeVars)]]
1684 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
1685 where
1686 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1687
1688 -- We would rather not have a segment that just has LetStmts in
1689 -- it, so combine those with an adjacent segment where possible.
1690 merge [] = []
1691 merge (seg : segs)
1692 = case rest of
1693 [] -> [(seg,all_lets)]
1694 ((s,s_lets):ss) | all_lets || s_lets
1695 -> (seg ++ s, all_lets && s_lets) : ss
1696 _otherwise -> (seg,all_lets) : rest
1697 where
1698 rest = merge segs
1699 all_lets = all (isLetStmt . fst) seg
1700
1701 -- walk splits the statement sequence into segments, traversing
1702 -- the sequence from the back to the front, and keeping track of
1703 -- the set of free variables of the current segment. Whenever
1704 -- this set of free variables is empty, we have a complete segment.
1705 walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]
1706 walk [] = []
1707 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
1708 where (seg,rest) = chunter fvs' stmts
1709 (_, fvs') = stmtRefs stmt fvs
1710
1711 chunter _ [] = ([], [])
1712 chunter vars ((stmt,fvs) : rest)
1713 | not (isEmptyNameSet vars)
1714 = ((stmt,fvs) : chunk, rest')
1715 where (chunk,rest') = chunter vars' rest
1716 (pvars, evars) = stmtRefs stmt fvs
1717 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
1718 chunter _ rest = ([], rest)
1719
1720 stmtRefs stmt fvs
1721 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
1722 | otherwise = (pvars, fvs')
1723 where fvs' = fvs `intersectNameSet` allvars
1724 pvars = mkNameSet (collectStmtBinders (unLoc stmt))
1725
1726 isLetStmt :: LStmt a b -> Bool
1727 isLetStmt (L _ LetStmt{}) = True
1728 isLetStmt _ = False
1729
1730 -- | Find a "good" place to insert a bind in an indivisible segment.
1731 -- This is the only place where we use heuristics. The current
1732 -- heuristic is to peel off the first group of independent statements
1733 -- and put the bind after those.
1734 splitSegment
1735 :: [(ExprLStmt Name, FreeVars)]
1736 -> ( [(ExprLStmt Name, FreeVars)]
1737 , [(ExprLStmt Name, FreeVars)] )
1738 splitSegment [one,two] = ([one],[two])
1739 -- there is no choice when there are only two statements; this just saves
1740 -- some work in a common case.
1741 splitSegment stmts
1742 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
1743 = if not (null lets)
1744 then (lets, binds++rest)
1745 else (lets++binds, rest)
1746 | otherwise
1747 = case stmts of
1748 (x:xs) -> ([x],xs)
1749 _other -> (stmts,[])
1750
1751 slurpIndependentStmts
1752 :: [(LStmt Name (Located (body Name)), FreeVars)]
1753 -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts
1754 , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts
1755 , [(LStmt Name (Located (body Name)), FreeVars)] )
1756 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
1757 where
1758 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
1759 -- in this group, then add it to the group.
1760 go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
1761 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1762 = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
1763 bndrs' rest
1764 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
1765 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
1766 -- group, then move it to the beginning, so that it doesn't interfere with
1767 -- grouping more BindStmts.
1768 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
1769 -- because we might be moving evaluation earlier.
1770 go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
1771 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1772 = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
1773 go _ [] _ _ = Nothing
1774 go _ [_] _ _ = Nothing
1775 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
1776
1777 -- | Build an ApplicativeStmt, and strip the "return" from the tail
1778 -- if necessary.
1779 --
1780 -- For example, if we start with
1781 -- do x <- E1; y <- E2; return (f x y)
1782 -- then we get
1783 -- do (E1[x] | E2[y]); f x y
1784 --
1785 -- the LastStmt in this case has the return removed, but we set the
1786 -- flag on the LastStmt to indicate this, so that we can print out the
1787 -- original statement correctly in error messages. It is easier to do
1788 -- it this way rather than try to ignore the return later in both the
1789 -- typechecker and the desugarer (I tried it that way first!).
1790 mkApplicativeStmt
1791 :: HsStmtContext Name
1792 -> [ApplicativeArg Name Name] -- ^ The args
1793 -> Bool -- ^ True <=> need a join
1794 -> [ExprLStmt Name] -- ^ The body statements
1795 -> RnM ([ExprLStmt Name], FreeVars)
1796 mkApplicativeStmt ctxt args need_join body_stmts
1797 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
1798 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
1799 ; (mb_join, fvs3) <-
1800 if need_join then
1801 do { (join_op, fvs) <- lookupStmtName ctxt joinMName
1802 ; return (Just join_op, fvs) }
1803 else
1804 return (Nothing, emptyNameSet)
1805 ; let applicative_stmt = noLoc $ ApplicativeStmt
1806 (zip (fmap_op : repeat ap_op) args)
1807 mb_join
1808 placeHolderType
1809 ; return ( applicative_stmt : body_stmts
1810 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1811
1812 -- | Given the statements following an ApplicativeStmt, determine whether
1813 -- we need a @join@ or not, and remove the @return@ if necessary.
1814 needJoin :: MonadNames
1815 -> [ExprLStmt Name]
1816 -> (Bool, [ExprLStmt Name])
1817 needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
1818 needJoin monad_names [L loc (LastStmt e _ t)]
1819 | Just arg <- isReturnApp monad_names e =
1820 (False, [L loc (LastStmt arg True t)])
1821 needJoin _monad_names stmts = (True, stmts)
1822
1823 -- | @Just e@, if the expression is @return e@ or @return $ e@,
1824 -- otherwise @Nothing@
1825 isReturnApp :: MonadNames
1826 -> LHsExpr Name
1827 -> Maybe (LHsExpr Name)
1828 isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
1829 isReturnApp monad_names (L _ e) = case e of
1830 OpApp l op _ r | is_return l, is_dollar op -> Just r
1831 HsApp f arg | is_return f -> Just arg
1832 _otherwise -> Nothing
1833 where
1834 is_var f (L _ (HsPar e)) = is_var f e
1835 is_var f (L _ (HsAppType e _)) = is_var f e
1836 is_var f (L _ (HsVar (L _ r))) = f r
1837 -- TODO: I don't know how to get this right for rebindable syntax
1838 is_var _ _ = False
1839
1840 is_return = is_var (\n -> n == return_name monad_names
1841 || n == pure_name monad_names)
1842 is_dollar = is_var (`hasKey` dollarIdKey)
1843
1844 {-
1845 ************************************************************************
1846 * *
1847 \subsubsection{Errors}
1848 * *
1849 ************************************************************************
1850 -}
1851
1852 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1853 -- We've seen an empty sequence of Stmts... is that ok?
1854 checkEmptyStmts ctxt
1855 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1856
1857 okEmpty :: HsStmtContext a -> Bool
1858 okEmpty (PatGuard {}) = True
1859 okEmpty _ = False
1860
1861 emptyErr :: HsStmtContext Name -> SDoc
1862 emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
1863 emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
1864 emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
1865
1866 ----------------------
1867 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1868 -> LStmt RdrName (Located (body RdrName))
1869 -> RnM (LStmt RdrName (Located (body RdrName)))
1870 checkLastStmt ctxt lstmt@(L loc stmt)
1871 = case ctxt of
1872 ListComp -> check_comp
1873 MonadComp -> check_comp
1874 PArrComp -> check_comp
1875 ArrowExpr -> check_do
1876 DoExpr -> check_do
1877 MDoExpr -> check_do
1878 _ -> check_other
1879 where
1880 check_do -- Expect BodyStmt, and change it to LastStmt
1881 = case stmt of
1882 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1883 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1884 -- LastStmt directly (unlike the parser)
1885 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1886 last_error = (text "The last statement in" <+> pprAStmtContext ctxt
1887 <+> text "must be an expression")
1888
1889 check_comp -- Expect LastStmt; this should be enforced by the parser!
1890 = case stmt of
1891 LastStmt {} -> return lstmt
1892 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1893
1894 check_other -- Behave just as if this wasn't the last stmt
1895 = do { checkStmt ctxt lstmt; return lstmt }
1896
1897 -- Checking when a particular Stmt is ok
1898 checkStmt :: HsStmtContext Name
1899 -> LStmt RdrName (Located (body RdrName))
1900 -> RnM ()
1901 checkStmt ctxt (L _ stmt)
1902 = do { dflags <- getDynFlags
1903 ; case okStmt dflags ctxt stmt of
1904 IsValid -> return ()
1905 NotValid extra -> addErr (msg $$ extra) }
1906 where
1907 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
1908 , text "in" <+> pprAStmtContext ctxt ]
1909
1910 pprStmtCat :: Stmt a body -> SDoc
1911 pprStmtCat (TransStmt {}) = text "transform"
1912 pprStmtCat (LastStmt {}) = text "return expression"
1913 pprStmtCat (BodyStmt {}) = text "body"
1914 pprStmtCat (BindStmt {}) = text "binding"
1915 pprStmtCat (LetStmt {}) = text "let"
1916 pprStmtCat (RecStmt {}) = text "rec"
1917 pprStmtCat (ParStmt {}) = text "parallel"
1918 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
1919
1920 ------------
1921 emptyInvalid :: Validity -- Payload is the empty document
1922 emptyInvalid = NotValid Outputable.empty
1923
1924 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1925 :: DynFlags -> HsStmtContext Name
1926 -> Stmt RdrName (Located (body RdrName)) -> Validity
1927 -- Return Nothing if OK, (Just extra) if not ok
1928 -- The "extra" is an SDoc that is appended to an generic error message
1929
1930 okStmt dflags ctxt stmt
1931 = case ctxt of
1932 PatGuard {} -> okPatGuardStmt stmt
1933 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1934 DoExpr -> okDoStmt dflags ctxt stmt
1935 MDoExpr -> okDoStmt dflags ctxt stmt
1936 ArrowExpr -> okDoStmt dflags ctxt stmt
1937 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1938 ListComp -> okCompStmt dflags ctxt stmt
1939 MonadComp -> okCompStmt dflags ctxt stmt
1940 PArrComp -> okPArrStmt dflags ctxt stmt
1941 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1942
1943 -------------
1944 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1945 okPatGuardStmt stmt
1946 = case stmt of
1947 BodyStmt {} -> IsValid
1948 BindStmt {} -> IsValid
1949 LetStmt {} -> IsValid
1950 _ -> emptyInvalid
1951
1952 -------------
1953 okParStmt dflags ctxt stmt
1954 = case stmt of
1955 LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
1956 _ -> okStmt dflags ctxt stmt
1957
1958 ----------------
1959 okDoStmt dflags ctxt stmt
1960 = case stmt of
1961 RecStmt {}
1962 | LangExt.RecursiveDo `xopt` dflags -> IsValid
1963 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1964 | otherwise -> NotValid (text "Use RecursiveDo")
1965 BindStmt {} -> IsValid
1966 LetStmt {} -> IsValid
1967 BodyStmt {} -> IsValid
1968 _ -> emptyInvalid
1969
1970 ----------------
1971 okCompStmt dflags _ stmt
1972 = case stmt of
1973 BindStmt {} -> IsValid
1974 LetStmt {} -> IsValid
1975 BodyStmt {} -> IsValid
1976 ParStmt {}
1977 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1978 | otherwise -> NotValid (text "Use ParallelListComp")
1979 TransStmt {}
1980 | LangExt.TransformListComp `xopt` dflags -> IsValid
1981 | otherwise -> NotValid (text "Use TransformListComp")
1982 RecStmt {} -> emptyInvalid
1983 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1984 ApplicativeStmt {} -> emptyInvalid
1985
1986 ----------------
1987 okPArrStmt dflags _ stmt
1988 = case stmt of
1989 BindStmt {} -> IsValid
1990 LetStmt {} -> IsValid
1991 BodyStmt {} -> IsValid
1992 ParStmt {}
1993 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1994 | otherwise -> NotValid (text "Use ParallelListComp")
1995 TransStmt {} -> emptyInvalid
1996 RecStmt {} -> emptyInvalid
1997 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1998 ApplicativeStmt {} -> emptyInvalid
1999
2000 ---------
2001 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
2002 checkTupleSection args
2003 = do { tuple_section <- xoptM LangExt.TupleSections
2004 ; checkErr (all tupArgPresent args || tuple_section) msg }
2005 where
2006 msg = text "Illegal tuple section: use TupleSections"
2007
2008 ---------
2009 sectionErr :: HsExpr RdrName -> SDoc
2010 sectionErr expr
2011 = hang (text "A section must be enclosed in parentheses")
2012 2 (text "thus:" <+> (parens (ppr expr)))
2013
2014 patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars)
2015 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
2016 nest 4 (ppr e)] $$
2017 explanation)
2018 ; return (EWildPat, emptyFVs) }
2019
2020 badIpBinds :: Outputable a => SDoc -> a -> SDoc
2021 badIpBinds what binds
2022 = hang (text "Implicit-parameter bindings illegal in" <+> what)
2023 2 (ppr binds)