Make XNegativeLiterals treat -0.0 as negative 0
[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 [f@(FieldOcc (L _ fn) s)]) ->
125 return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s))
126 , unitFV (selectorFieldOcc f)) ;
127 Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
128 PlaceHolder)
129 , mkFVs (map selectorFieldOcc 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 -- For non-monadic contexts (e.g. guard patterns, list
837 -- comprehensions, etc.) we should not need to fail.
838 -- See Note [Failing pattern matches in Stmts]
839 | not (isMonadFailStmtContext ctxt)
840 = return (noSyntaxExpr, emptyFVs)
841 | xMonadFailEnabled = lookupSyntaxName failMName
842 | otherwise = lookupSyntaxName failMName_preMFP
843 ; (fail_op, fvs2) <- getFailFunction
844
845 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
846 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
847 ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
848 , fv_expr )]
849 , thing),
850 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
851 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
852 -- but it does not matter because the names are unique
853
854 rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
855 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
856 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
857 ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
858
859 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
860 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
861 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
862 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
863 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
864 , recS_mfix_fn = mfix_op
865 , recS_bind_fn = bind_op }
866
867 -- Step1: Bring all the binders of the mdo into scope
868 -- (Remember that this also removes the binders from the
869 -- finally-returned free-vars.)
870 -- And rename each individual stmt, making a
871 -- singleton segment. At this stage the FwdRefs field
872 -- isn't finished: it's empty for all except a BindStmt
873 -- for which it's the fwd refs within the bind itself
874 -- (This set may not be empty, because we're in a recursive
875 -- context.)
876 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
877 { let bndrs = nameSetElemsStable $
878 foldr (unionNameSet . (\(ds,_,_,_) -> ds))
879 emptyNameSet
880 segs
881 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
882 ; (thing, fvs_later) <- thing_inside bndrs
883 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
884 -- We aren't going to try to group RecStmts with
885 -- ApplicativeDo, so attaching empty FVs is fine.
886 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
887 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
888
889 rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
890 = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
891 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
892 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
893 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
894 ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
895 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
896
897 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
898 , trS_using = using })) thing_inside
899 = do { -- Rename the 'using' expression in the context before the transform is begun
900 (using', fvs1) <- rnLExpr using
901
902 -- Rename the stmts and the 'by' expression
903 -- Keep track of the variables mentioned in the 'by' expression
904 ; ((stmts', (by', used_bndrs, thing)), fvs2)
905 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
906 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
907 ; (thing, fvs_thing) <- thing_inside bndrs
908 ; let fvs = fvs_by `plusFV` fvs_thing
909 used_bndrs = filter (`elemNameSet` fvs) bndrs
910 -- The paper (Fig 5) has a bug here; we must treat any free variable
911 -- of the "thing inside", **or of the by-expression**, as used
912 ; return ((by', used_bndrs, thing), fvs) }
913
914 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
915 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
916 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
917 ; (fmap_op, fvs5) <- case form of
918 ThenForm -> return (noExpr, emptyFVs)
919 _ -> lookupStmtNamePoly ctxt fmapName
920
921 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
922 `plusFV` fvs4 `plusFV` fvs5
923 bndr_map = used_bndrs `zip` used_bndrs
924 -- See Note [TransStmt binder map] in HsExpr
925
926 ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
927 ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
928 , trS_by = by', trS_using = using', trS_form = form
929 , trS_ret = return_op, trS_bind = bind_op
930 , trS_bind_arg_ty = PlaceHolder
931 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
932
933 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
934 panic "rnStmt: ApplicativeStmt"
935
936 rnParallelStmts :: forall thing. HsStmtContext Name
937 -> SyntaxExpr Name
938 -> [ParStmtBlock RdrName RdrName]
939 -> ([Name] -> RnM (thing, FreeVars))
940 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
941 -- Note [Renaming parallel Stmts]
942 rnParallelStmts ctxt return_op segs thing_inside
943 = do { orig_lcl_env <- getLocalRdrEnv
944 ; rn_segs orig_lcl_env [] segs }
945 where
946 rn_segs :: LocalRdrEnv
947 -> [Name] -> [ParStmtBlock RdrName RdrName]
948 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
949 rn_segs _ bndrs_so_far []
950 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
951 ; mapM_ dupErr dups
952 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
953 ; return (([], thing), fvs) }
954
955 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
956 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
957 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
958 setLocalRdrEnv env $ do
959 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
960 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
961 ; return ((used_bndrs, segs', thing), fvs) }
962
963 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
964 ; return ((seg':segs', thing), fvs) }
965
966 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
967 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
968 <+> quotes (ppr (head vs)))
969
970 lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)
971 -- Like lookupSyntaxName, but respects contexts
972 lookupStmtName ctxt n
973 | rebindableContext ctxt
974 = lookupSyntaxName n
975 | otherwise
976 = return (mkRnSyntaxExpr n, emptyFVs)
977
978 lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
979 lookupStmtNamePoly ctxt name
980 | rebindableContext ctxt
981 = do { rebindable_on <- xoptM LangExt.RebindableSyntax
982 ; if rebindable_on
983 then do { fm <- lookupOccRn (nameRdrName name)
984 ; return (HsVar (noLoc fm), unitFV fm) }
985 else not_rebindable }
986 | otherwise
987 = not_rebindable
988 where
989 not_rebindable = return (HsVar (noLoc name), emptyFVs)
990
991 -- | Is this a context where we respect RebindableSyntax?
992 -- but ListComp/PArrComp are never rebindable
993 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
994 rebindableContext :: HsStmtContext Name -> Bool
995 rebindableContext ctxt = case ctxt of
996 ListComp -> False
997 PArrComp -> False
998 ArrowExpr -> False
999 PatGuard {} -> False
1000
1001 DoExpr -> True
1002 MDoExpr -> True
1003 MonadComp -> True
1004 GhciStmtCtxt -> True -- I suppose?
1005
1006 ParStmtCtxt c -> rebindableContext c -- Look inside to
1007 TransStmtCtxt c -> rebindableContext c -- the parent context
1008
1009 {-
1010 Note [Renaming parallel Stmts]
1011 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1012 Renaming parallel statements is painful. Given, say
1013 [ a+c | a <- as, bs <- bss
1014 | c <- bs, a <- ds ]
1015 Note that
1016 (a) In order to report "Defined but not used" about 'bs', we must
1017 rename each group of Stmts with a thing_inside whose FreeVars
1018 include at least {a,c}
1019
1020 (b) We want to report that 'a' is illegally bound in both branches
1021
1022 (c) The 'bs' in the second group must obviously not be captured by
1023 the binding in the first group
1024
1025 To satisfy (a) we nest the segements.
1026 To satisfy (b) we check for duplicates just before thing_inside.
1027 To satisfy (c) we reset the LocalRdrEnv each time.
1028
1029 ************************************************************************
1030 * *
1031 \subsubsection{mdo expressions}
1032 * *
1033 ************************************************************************
1034 -}
1035
1036 type FwdRefs = NameSet
1037 type Segment stmts = (Defs,
1038 Uses, -- May include defs
1039 FwdRefs, -- A subset of uses that are
1040 -- (a) used before they are bound in this segment, or
1041 -- (b) used here, and bound in subsequent segments
1042 stmts) -- Either Stmt or [Stmt]
1043
1044
1045 -- wrapper that does both the left- and right-hand sides
1046 rnRecStmtsAndThen :: Outputable (body RdrName) =>
1047 (Located (body RdrName)
1048 -> RnM (Located (body Name), FreeVars))
1049 -> [LStmt RdrName (Located (body RdrName))]
1050 -- assumes that the FreeVars returned includes
1051 -- the FreeVars of the Segments
1052 -> ([Segment (LStmt Name (Located (body Name)))]
1053 -> RnM (a, FreeVars))
1054 -> RnM (a, FreeVars)
1055 rnRecStmtsAndThen rnBody s cont
1056 = do { -- (A) Make the mini fixity env for all of the stmts
1057 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
1058
1059 -- (B) Do the LHSes
1060 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
1061
1062 -- ...bring them and their fixities into scope
1063 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
1064 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
1065 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
1066 ; bindLocalNamesFV bound_names $
1067 addLocalFixities fix_env bound_names $ do
1068
1069 -- (C) do the right-hand-sides and thing-inside
1070 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
1071 ; (res, fvs) <- cont segs
1072 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
1073 ; return (res, fvs) }}
1074
1075 -- get all the fixity decls in any Let stmt
1076 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
1077 collectRecStmtsFixities l =
1078 foldr (\ s -> \acc -> case s of
1079 (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
1080 foldr (\ sig -> \ acc -> case sig of
1081 (L loc (FixSig s)) -> (L loc s) : acc
1082 _ -> acc) acc sigs
1083 _ -> acc) [] l
1084
1085 -- left-hand sides
1086
1087 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
1088 -> LStmt RdrName body
1089 -- rename LHS, and return its FVs
1090 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1091 -- so we don't bother to compute it accurately in the other cases
1092 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1093
1094 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
1095 = return [(L loc (BodyStmt body a b c), emptyFVs)]
1096
1097 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
1098 = return [(L loc (LastStmt body noret a), emptyFVs)]
1099
1100 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
1101 = do
1102 -- should the ctxt be MDo instead?
1103 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1104 return [(L loc (BindStmt pat' body a b t),
1105 fv_pat)]
1106
1107 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
1108 = failWith (badIpBinds (text "an mdo expression") binds)
1109
1110 rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
1111 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1112 return [(L loc (LetStmt (L l (HsValBinds binds'))),
1113 -- Warning: this is bogus; see function invariant
1114 emptyFVs
1115 )]
1116
1117 -- XXX Do we need to do something with the return and mfix names?
1118 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1119 = rn_rec_stmts_lhs fix_env stmts
1120
1121 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1122 = pprPanic "rn_rec_stmt" (ppr stmt)
1123
1124 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1125 = pprPanic "rn_rec_stmt" (ppr stmt)
1126
1127 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1128 = pprPanic "rn_rec_stmt" (ppr stmt)
1129
1130 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
1131 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1132
1133 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
1134 -> [LStmt RdrName body]
1135 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1136 rn_rec_stmts_lhs fix_env stmts
1137 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1138 ; let boundNames = collectLStmtsBinders (map fst ls)
1139 -- First do error checking: we need to check for dups here because we
1140 -- don't bind all of the variables from the Stmt at once
1141 -- with bindLocatedLocals.
1142 ; checkDupNames boundNames
1143 ; return ls }
1144
1145
1146 -- right-hand-sides
1147
1148 rn_rec_stmt :: (Outputable (body RdrName)) =>
1149 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1150 -> [Name]
1151 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
1152 -> RnM [Segment (LStmt Name (Located (body Name)))]
1153 -- Rename a Stmt that is inside a RecStmt (or mdo)
1154 -- Assumes all binders are already in scope
1155 -- Turns each stmt into a singleton Stmt
1156 rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
1157 = do { (body', fv_expr) <- rnBody body
1158 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1159 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1160 L loc (LastStmt body' noret ret_op))] }
1161
1162 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
1163 = do { (body', fvs) <- rnBody body
1164 ; (then_op, fvs1) <- lookupSyntaxName thenMName
1165 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1166 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
1167
1168 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
1169 = do { (body', fv_expr) <- rnBody body
1170 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
1171
1172 ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
1173 ; let failFunction | xMonadFailEnabled = failMName
1174 | otherwise = failMName_preMFP
1175 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
1176
1177 ; let bndrs = mkNameSet (collectPatBinders pat')
1178 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1179 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1180 L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
1181
1182 rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
1183 = failWith (badIpBinds (text "an mdo expression") binds)
1184
1185 rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
1186 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1187 -- fixities and unused are handled above in rnRecStmtsAndThen
1188 ; let fvs = allUses du_binds
1189 ; return [(duDefs du_binds, fvs, emptyNameSet,
1190 L loc (LetStmt (L l (HsValBinds binds'))))] }
1191
1192 -- no RecStmt case because they get flattened above when doing the LHSes
1193 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
1194 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1195
1196 rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
1197 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1198
1199 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
1200 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1201
1202 rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
1203 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1204
1205 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
1206 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
1207
1208 rn_rec_stmts :: Outputable (body RdrName) =>
1209 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1210 -> [Name]
1211 -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
1212 -> RnM [Segment (LStmt Name (Located (body Name)))]
1213 rn_rec_stmts rnBody bndrs stmts
1214 = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
1215 ; return (concat segs_s) }
1216
1217 ---------------------------------------------
1218 segmentRecStmts :: SrcSpan -> HsStmtContext Name
1219 -> Stmt Name body
1220 -> [Segment (LStmt Name body)] -> FreeVars
1221 -> ([LStmt Name body], FreeVars)
1222
1223 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
1224 | null segs
1225 = ([], fvs_later)
1226
1227 | MDoExpr <- ctxt
1228 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1229 -- Step 4: Turn the segments into Stmts
1230 -- Use RecStmt when and only when there are fwd refs
1231 -- Also gather up the uses from the end towards the
1232 -- start, so we can tell the RecStmt which things are
1233 -- used 'after' the RecStmt
1234
1235 | otherwise
1236 = ([ L loc $
1237 empty_rec_stmt { recS_stmts = ss
1238 , recS_later_ids = nameSetElemsStable
1239 (defs `intersectNameSet` fvs_later)
1240 , recS_rec_ids = nameSetElemsStable
1241 (defs `intersectNameSet` uses) }]
1242 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1243 , uses `plusFV` fvs_later)
1244
1245 where
1246 (defs_s, uses_s, _, ss) = unzip4 segs
1247 defs = plusFVs defs_s
1248 uses = plusFVs uses_s
1249
1250 -- Step 2: Fill in the fwd refs.
1251 -- The segments are all singletons, but their fwd-ref
1252 -- field mentions all the things used by the segment
1253 -- that are bound after their use
1254 segs_w_fwd_refs = addFwdRefs segs
1255
1256 -- Step 3: Group together the segments to make bigger segments
1257 -- Invariant: in the result, no segment uses a variable
1258 -- bound in a later segment
1259 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1260
1261 ----------------------------
1262 addFwdRefs :: [Segment a] -> [Segment a]
1263 -- So far the segments only have forward refs *within* the Stmt
1264 -- (which happens for bind: x <- ...x...)
1265 -- This function adds the cross-seg fwd ref info
1266
1267 addFwdRefs segs
1268 = fst (foldr mk_seg ([], emptyNameSet) segs)
1269 where
1270 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1271 = (new_seg : segs, all_defs)
1272 where
1273 new_seg = (defs, uses, new_fwds, stmts)
1274 all_defs = later_defs `unionNameSet` defs
1275 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1276 -- Add the downstream fwd refs here
1277
1278 {-
1279 Note [Segmenting mdo]
1280 ~~~~~~~~~~~~~~~~~~~~~
1281 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1282 and leave those found in "do rec"'s intact. See
1283 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1284 leading to this design choice. Hence the test in segmentRecStmts.
1285
1286 Note [Glomming segments]
1287 ~~~~~~~~~~~~~~~~~~~~~~~~
1288 Glomming the singleton segments of an mdo into minimal recursive groups.
1289
1290 At first I thought this was just strongly connected components, but
1291 there's an important constraint: the order of the stmts must not change.
1292
1293 Consider
1294 mdo { x <- ...y...
1295 p <- z
1296 y <- ...x...
1297 q <- x
1298 z <- y
1299 r <- x }
1300
1301 Here, the first stmt mention 'y', which is bound in the third.
1302 But that means that the innocent second stmt (p <- z) gets caught
1303 up in the recursion. And that in turn means that the binding for
1304 'z' has to be included... and so on.
1305
1306 Start at the tail { r <- x }
1307 Now add the next one { z <- y ; r <- x }
1308 Now add one more { q <- x ; z <- y ; r <- x }
1309 Now one more... but this time we have to group a bunch into rec
1310 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1311 Now one more, which we can add on without a rec
1312 { p <- z ;
1313 rec { y <- ...x... ; q <- x ; z <- y } ;
1314 r <- x }
1315 Finally we add the last one; since it mentions y we have to
1316 glom it together with the first two groups
1317 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1318 q <- x ; z <- y } ;
1319 r <- x }
1320 -}
1321
1322 glomSegments :: HsStmtContext Name
1323 -> [Segment (LStmt Name body)]
1324 -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts
1325 -- See Note [Glomming segments]
1326
1327 glomSegments _ [] = []
1328 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1329 -- Actually stmts will always be a singleton
1330 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1331 where
1332 segs' = glomSegments ctxt segs
1333 (extras, others) = grab uses segs'
1334 (ds, us, fs, ss) = unzip4 extras
1335
1336 seg_defs = plusFVs ds `plusFV` defs
1337 seg_uses = plusFVs us `plusFV` uses
1338 seg_fwds = plusFVs fs `plusFV` fwds
1339 seg_stmts = stmt : concat ss
1340
1341 grab :: NameSet -- The client
1342 -> [Segment a]
1343 -> ([Segment a], -- Needed by the 'client'
1344 [Segment a]) -- Not needed by the client
1345 -- The result is simply a split of the input
1346 grab uses dus
1347 = (reverse yeses, reverse noes)
1348 where
1349 (noes, yeses) = span not_needed (reverse dus)
1350 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1351
1352 ----------------------------------------------------
1353 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1354 -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts
1355 -> FreeVars -- Free vars used 'later'
1356 -> ([LStmt Name body], FreeVars)
1357
1358 segsToStmts _ [] fvs_later = ([], fvs_later)
1359 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1360 = ASSERT( not (null ss) )
1361 (new_stmt : later_stmts, later_uses `plusFV` uses)
1362 where
1363 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1364 new_stmt | non_rec = head ss
1365 | otherwise = L (getLoc (head ss)) rec_stmt
1366 rec_stmt = empty_rec_stmt { recS_stmts = ss
1367 , recS_later_ids = nameSetElemsStable used_later
1368 , recS_rec_ids = nameSetElemsStable fwds }
1369 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1370 non_rec = isSingleton ss && isEmptyNameSet fwds
1371 used_later = defs `intersectNameSet` later_uses
1372 -- The ones needed after the RecStmt
1373
1374 {-
1375 ************************************************************************
1376 * *
1377 ApplicativeDo
1378 * *
1379 ************************************************************************
1380
1381 Note [ApplicativeDo]
1382
1383 = Example =
1384
1385 For a sequence of statements
1386
1387 do
1388 x <- A
1389 y <- B x
1390 z <- C
1391 return (f x y z)
1392
1393 We want to transform this to
1394
1395 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
1396
1397 It would be easy to notice that "y <- B x" and "z <- C" are
1398 independent and do something like this:
1399
1400 do
1401 x <- A
1402 (y,z) <- (,) <$> B x <*> C
1403 return (f x y z)
1404
1405 But this isn't enough! A and C were also independent, and this
1406 transformation loses the ability to do A and C in parallel.
1407
1408 The algorithm works by first splitting the sequence of statements into
1409 independent "segments", and a separate "tail" (the final statement). In
1410 our example above, the segements would be
1411
1412 [ x <- A
1413 , y <- B x ]
1414
1415 [ z <- C ]
1416
1417 and the tail is:
1418
1419 return (f x y z)
1420
1421 Then we take these segments and make an Applicative expression from them:
1422
1423 (\(x,y) z -> return (f x y z))
1424 <$> do { x <- A; y <- B x; return (x,y) }
1425 <*> C
1426
1427 Finally, we recursively apply the transformation to each segment, to
1428 discover any nested parallelism.
1429
1430 = Syntax & spec =
1431
1432 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
1433
1434 stmt ::= pat <- expr
1435 | (arg_1 | ... | arg_n) -- applicative composition, n>=1
1436 | ... -- other kinds of statement (e.g. let)
1437
1438 arg ::= pat <- expr
1439 | {stmt_1; ..; stmt_n} {var_1..var_n}
1440
1441 (note that in the actual implementation,the expr in a do statement is
1442 represented by a LastStmt as the final stmt, this is just a
1443 representational issue and may change later.)
1444
1445 == Transformation to introduce applicative stmts ==
1446
1447 ado {} tail = tail
1448 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
1449 ado {one} tail = one : tail
1450 ado stmts tail
1451 | n == 1 = ado before (ado after tail)
1452 where (before,after) = split(stmts_1)
1453 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
1454 where
1455 {stmts_1 .. stmts_n} = segments(stmts)
1456
1457 segments(stmts) =
1458 -- divide stmts into segments with no interdependencies
1459
1460 mkArg({pat <- expr}) = (pat <- expr)
1461 mkArg({stmt_1; ...; stmt_n}) =
1462 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
1463
1464 split({stmt_1; ..; stmt_n) =
1465 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
1466 -- 1 <= i <= n
1467 -- i is a good place to insert a bind
1468
1469 == Desugaring for do ==
1470
1471 dsDo {} expr = expr
1472
1473 dsDo {pat <- rhs; stmts} expr =
1474 rhs >>= \pat -> dsDo stmts expr
1475
1476 dsDo {(arg_1 | ... | arg_n)} (return expr) =
1477 (\argpat (arg_1) .. argpat(arg_n) -> expr)
1478 <$> argexpr(arg_1)
1479 <*> ...
1480 <*> argexpr(arg_n)
1481
1482 dsDo {(arg_1 | ... | arg_n); stmts} expr =
1483 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
1484 <$> argexpr(arg_1)
1485 <*> ...
1486 <*> argexpr(arg_n)
1487
1488 -}
1489
1490 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
1491 -- 'pureName' due to @RebindableSyntax@.
1492 data MonadNames = MonadNames { return_name, pure_name :: Name }
1493
1494 -- | rearrange a list of statements using ApplicativeDoStmt. See
1495 -- Note [ApplicativeDo].
1496 rearrangeForApplicativeDo
1497 :: HsStmtContext Name
1498 -> [(ExprLStmt Name, FreeVars)]
1499 -> RnM ([ExprLStmt Name], FreeVars)
1500
1501 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
1502 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
1503 rearrangeForApplicativeDo ctxt stmts0 = do
1504 optimal_ado <- goptM Opt_OptimalApplicativeDo
1505 let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
1506 | otherwise = mkStmtTreeHeuristic stmts
1507 return_name <- lookupSyntaxName' returnMName
1508 pure_name <- lookupSyntaxName' pureAName
1509 let monad_names = MonadNames { return_name = return_name
1510 , pure_name = pure_name }
1511 stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
1512 where
1513 (stmts,(last,last_fvs)) = findLast stmts0
1514 findLast [] = error "findLast"
1515 findLast [last] = ([],last)
1516 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
1517
1518 -- | A tree of statements using a mixture of applicative and bind constructs.
1519 data StmtTree a
1520 = StmtTreeOne a
1521 | StmtTreeBind (StmtTree a) (StmtTree a)
1522 | StmtTreeApplicative [StmtTree a]
1523
1524 flattenStmtTree :: StmtTree a -> [a]
1525 flattenStmtTree t = go t []
1526 where
1527 go (StmtTreeOne a) as = a : as
1528 go (StmtTreeBind l r) as = go l (go r as)
1529 go (StmtTreeApplicative ts) as = foldr go as ts
1530
1531 type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars)
1532 type Cost = Int
1533
1534 -- | Turn a sequence of statements into an ExprStmtTree using a
1535 -- heuristic algorithm. /O(n^2)/
1536 mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1537 mkStmtTreeHeuristic [one] = StmtTreeOne one
1538 mkStmtTreeHeuristic stmts =
1539 case segments stmts of
1540 [one] -> split one
1541 segs -> StmtTreeApplicative (map split segs)
1542 where
1543 split [one] = StmtTreeOne one
1544 split stmts =
1545 StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
1546 where (before, after) = splitSegment stmts
1547
1548 -- | Turn a sequence of statements into an ExprStmtTree optimally,
1549 -- using dynamic programming. /O(n^3)/
1550 mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1551 mkStmtTreeOptimal stmts =
1552 ASSERT(not (null stmts)) -- the empty case is handled by the caller;
1553 -- we don't support empty StmtTrees.
1554 fst (arr ! (0,n))
1555 where
1556 n = length stmts - 1
1557 stmt_arr = listArray (0,n) stmts
1558
1559 -- lazy cache of optimal trees for subsequences of the input
1560 arr :: Array (Int,Int) (ExprStmtTree, Cost)
1561 arr = array ((0,0),(n,n))
1562 [ ((lo,hi), tree lo hi)
1563 | lo <- [0..n]
1564 , hi <- [lo..n] ]
1565
1566 -- compute the optimal tree for the sequence [lo..hi]
1567 tree lo hi
1568 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1569 | otherwise =
1570 case segments [ stmt_arr ! i | i <- [lo..hi] ] of
1571 [] -> panic "mkStmtTree"
1572 [_one] -> split lo hi
1573 segs -> (StmtTreeApplicative trees, maximum costs)
1574 where
1575 bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
1576 (trees,costs) = unzip (map (uncurry split) (tail bounds))
1577
1578 -- find the best place to split the segment [lo..hi]
1579 split :: Int -> Int -> (ExprStmtTree, Cost)
1580 split lo hi
1581 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1582 | otherwise = (StmtTreeBind before after, c1+c2)
1583 where
1584 -- As per the paper, for a sequence s1...sn, we want to find
1585 -- the split with the minimum cost, where the cost is the
1586 -- sum of the cost of the left and right subsequences.
1587 --
1588 -- As an optimisation (also in the paper) if the cost of
1589 -- s1..s(n-1) is different from the cost of s2..sn, we know
1590 -- that the optimal solution is the lower of the two. Only
1591 -- in the case that these two have the same cost do we need
1592 -- to do the exhaustive search.
1593 --
1594 ((before,c1),(after,c2))
1595 | hi - lo == 1
1596 = ((StmtTreeOne (stmt_arr ! lo), 1),
1597 (StmtTreeOne (stmt_arr ! hi), 1))
1598 | left_cost < right_cost
1599 = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
1600 | otherwise -- left_cost > right_cost
1601 = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
1602 | otherwise = minimumBy (comparing cost) alternatives
1603 where
1604 (left, left_cost) = arr ! (lo,hi-1)
1605 (right, right_cost) = arr ! (lo+1,hi)
1606 cost ((_,c1),(_,c2)) = c1 + c2
1607 alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
1608 | k <- [lo .. hi-1] ]
1609
1610
1611 -- | Turn the ExprStmtTree back into a sequence of statements, using
1612 -- ApplicativeStmt where necessary.
1613 stmtTreeToStmts
1614 :: MonadNames
1615 -> HsStmtContext Name
1616 -> ExprStmtTree
1617 -> [ExprLStmt Name] -- ^ the "tail"
1618 -> FreeVars -- ^ free variables of the tail
1619 -> RnM ( [ExprLStmt Name] -- ( output statements,
1620 , FreeVars ) -- , things we needed
1621
1622 -- If we have a single bind, and we can do it without a join, transform
1623 -- to an ApplicativeStmt. This corresponds to the rule
1624 -- dsBlock [pat <- rhs] (return expr) = expr <$> rhs
1625 -- In the spec, but we do it here rather than in the desugarer,
1626 -- because we need the typechecker to typecheck the <$> form rather than
1627 -- the bind form, which would give rise to a Monad constraint.
1628 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
1629 tail _tail_fvs
1630 | isIrrefutableHsPat pat, (False,tail') <- needJoin monad_names tail
1631 -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
1632 -- to know which types have only one constructor. So only
1633 -- tuples come out as irrefutable; other single-constructor
1634 -- types, and newtypes, will not. See the code for
1635 -- isIrrefuatableHsPat
1636 = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
1637
1638 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
1639 return (s : tail, emptyNameSet)
1640
1641 stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
1642 (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
1643 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
1644 (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
1645 return (stmts2, fvs1 `plusFV` fvs2)
1646
1647 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
1648 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
1649 let (stmts', fvss) = unzip pairs
1650 let (need_join, tail') = needJoin monad_names tail
1651 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
1652 return (stmts, unionNameSets (fvs:fvss))
1653 where
1654 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
1655 return (ApplicativeArgOne pat exp, emptyFVs)
1656 stmtTreeArg ctxt tail_fvs tree = do
1657 let stmts = flattenStmtTree tree
1658 pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1659 `intersectNameSet` tail_fvs
1660 pvars = nameSetElemsStable pvarset
1661 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1662 pat = mkBigLHsVarPatTup pvars
1663 tup = mkBigLHsVarTup pvars
1664 (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
1665 (mb_ret, fvs1) <-
1666 if | L _ ApplicativeStmt{} <- last stmts' ->
1667 return (unLoc tup, emptyNameSet)
1668 | otherwise -> do
1669 (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
1670 return (HsApp (noLoc ret) tup, fvs)
1671 return ( ApplicativeArgMany stmts' mb_ret pat
1672 , fvs1 `plusFV` fvs2)
1673
1674
1675 -- | Divide a sequence of statements into segments, where no segment
1676 -- depends on any variables defined by a statement in another segment.
1677 segments
1678 :: [(ExprLStmt Name, FreeVars)]
1679 -> [[(ExprLStmt Name, FreeVars)]]
1680 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
1681 where
1682 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1683
1684 -- We would rather not have a segment that just has LetStmts in
1685 -- it, so combine those with an adjacent segment where possible.
1686 merge [] = []
1687 merge (seg : segs)
1688 = case rest of
1689 [] -> [(seg,all_lets)]
1690 ((s,s_lets):ss) | all_lets || s_lets
1691 -> (seg ++ s, all_lets && s_lets) : ss
1692 _otherwise -> (seg,all_lets) : rest
1693 where
1694 rest = merge segs
1695 all_lets = all (isLetStmt . fst) seg
1696
1697 -- walk splits the statement sequence into segments, traversing
1698 -- the sequence from the back to the front, and keeping track of
1699 -- the set of free variables of the current segment. Whenever
1700 -- this set of free variables is empty, we have a complete segment.
1701 walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]
1702 walk [] = []
1703 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
1704 where (seg,rest) = chunter fvs' stmts
1705 (_, fvs') = stmtRefs stmt fvs
1706
1707 chunter _ [] = ([], [])
1708 chunter vars ((stmt,fvs) : rest)
1709 | not (isEmptyNameSet vars)
1710 = ((stmt,fvs) : chunk, rest')
1711 where (chunk,rest') = chunter vars' rest
1712 (pvars, evars) = stmtRefs stmt fvs
1713 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
1714 chunter _ rest = ([], rest)
1715
1716 stmtRefs stmt fvs
1717 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
1718 | otherwise = (pvars, fvs')
1719 where fvs' = fvs `intersectNameSet` allvars
1720 pvars = mkNameSet (collectStmtBinders (unLoc stmt))
1721
1722 isLetStmt :: LStmt a b -> Bool
1723 isLetStmt (L _ LetStmt{}) = True
1724 isLetStmt _ = False
1725
1726 -- | Find a "good" place to insert a bind in an indivisible segment.
1727 -- This is the only place where we use heuristics. The current
1728 -- heuristic is to peel off the first group of independent statements
1729 -- and put the bind after those.
1730 splitSegment
1731 :: [(ExprLStmt Name, FreeVars)]
1732 -> ( [(ExprLStmt Name, FreeVars)]
1733 , [(ExprLStmt Name, FreeVars)] )
1734 splitSegment [one,two] = ([one],[two])
1735 -- there is no choice when there are only two statements; this just saves
1736 -- some work in a common case.
1737 splitSegment stmts
1738 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
1739 = if not (null lets)
1740 then (lets, binds++rest)
1741 else (lets++binds, rest)
1742 | otherwise
1743 = case stmts of
1744 (x:xs) -> ([x],xs)
1745 _other -> (stmts,[])
1746
1747 slurpIndependentStmts
1748 :: [(LStmt Name (Located (body Name)), FreeVars)]
1749 -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts
1750 , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts
1751 , [(LStmt Name (Located (body Name)), FreeVars)] )
1752 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
1753 where
1754 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
1755 -- in this group, then add it to the group.
1756 go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
1757 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1758 = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
1759 bndrs' rest
1760 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
1761 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
1762 -- group, then move it to the beginning, so that it doesn't interfere with
1763 -- grouping more BindStmts.
1764 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
1765 -- because we might be moving evaluation earlier.
1766 go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
1767 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1768 = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
1769 go _ [] _ _ = Nothing
1770 go _ [_] _ _ = Nothing
1771 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
1772
1773 -- | Build an ApplicativeStmt, and strip the "return" from the tail
1774 -- if necessary.
1775 --
1776 -- For example, if we start with
1777 -- do x <- E1; y <- E2; return (f x y)
1778 -- then we get
1779 -- do (E1[x] | E2[y]); f x y
1780 --
1781 -- the LastStmt in this case has the return removed, but we set the
1782 -- flag on the LastStmt to indicate this, so that we can print out the
1783 -- original statement correctly in error messages. It is easier to do
1784 -- it this way rather than try to ignore the return later in both the
1785 -- typechecker and the desugarer (I tried it that way first!).
1786 mkApplicativeStmt
1787 :: HsStmtContext Name
1788 -> [ApplicativeArg Name Name] -- ^ The args
1789 -> Bool -- ^ True <=> need a join
1790 -> [ExprLStmt Name] -- ^ The body statements
1791 -> RnM ([ExprLStmt Name], FreeVars)
1792 mkApplicativeStmt ctxt args need_join body_stmts
1793 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
1794 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
1795 ; (mb_join, fvs3) <-
1796 if need_join then
1797 do { (join_op, fvs) <- lookupStmtName ctxt joinMName
1798 ; return (Just join_op, fvs) }
1799 else
1800 return (Nothing, emptyNameSet)
1801 ; let applicative_stmt = noLoc $ ApplicativeStmt
1802 (zip (fmap_op : repeat ap_op) args)
1803 mb_join
1804 placeHolderType
1805 ; return ( applicative_stmt : body_stmts
1806 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1807
1808 -- | Given the statements following an ApplicativeStmt, determine whether
1809 -- we need a @join@ or not, and remove the @return@ if necessary.
1810 needJoin :: MonadNames
1811 -> [ExprLStmt Name]
1812 -> (Bool, [ExprLStmt Name])
1813 needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
1814 needJoin monad_names [L loc (LastStmt e _ t)]
1815 | Just arg <- isReturnApp monad_names e =
1816 (False, [L loc (LastStmt arg True t)])
1817 needJoin _monad_names stmts = (True, stmts)
1818
1819 -- | @Just e@, if the expression is @return e@ or @return $ e@,
1820 -- otherwise @Nothing@
1821 isReturnApp :: MonadNames
1822 -> LHsExpr Name
1823 -> Maybe (LHsExpr Name)
1824 isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
1825 isReturnApp monad_names (L _ e) = case e of
1826 OpApp l op _ r | is_return l, is_dollar op -> Just r
1827 HsApp f arg | is_return f -> Just arg
1828 _otherwise -> Nothing
1829 where
1830 is_var f (L _ (HsPar e)) = is_var f e
1831 is_var f (L _ (HsAppType e _)) = is_var f e
1832 is_var f (L _ (HsVar (L _ r))) = f r
1833 -- TODO: I don't know how to get this right for rebindable syntax
1834 is_var _ _ = False
1835
1836 is_return = is_var (\n -> n == return_name monad_names
1837 || n == pure_name monad_names)
1838 is_dollar = is_var (`hasKey` dollarIdKey)
1839
1840 {-
1841 ************************************************************************
1842 * *
1843 \subsubsection{Errors}
1844 * *
1845 ************************************************************************
1846 -}
1847
1848 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1849 -- We've seen an empty sequence of Stmts... is that ok?
1850 checkEmptyStmts ctxt
1851 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1852
1853 okEmpty :: HsStmtContext a -> Bool
1854 okEmpty (PatGuard {}) = True
1855 okEmpty _ = False
1856
1857 emptyErr :: HsStmtContext Name -> SDoc
1858 emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
1859 emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
1860 emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
1861
1862 ----------------------
1863 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1864 -> LStmt RdrName (Located (body RdrName))
1865 -> RnM (LStmt RdrName (Located (body RdrName)))
1866 checkLastStmt ctxt lstmt@(L loc stmt)
1867 = case ctxt of
1868 ListComp -> check_comp
1869 MonadComp -> check_comp
1870 PArrComp -> check_comp
1871 ArrowExpr -> check_do
1872 DoExpr -> check_do
1873 MDoExpr -> check_do
1874 _ -> check_other
1875 where
1876 check_do -- Expect BodyStmt, and change it to LastStmt
1877 = case stmt of
1878 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1879 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1880 -- LastStmt directly (unlike the parser)
1881 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1882 last_error = (text "The last statement in" <+> pprAStmtContext ctxt
1883 <+> text "must be an expression")
1884
1885 check_comp -- Expect LastStmt; this should be enforced by the parser!
1886 = case stmt of
1887 LastStmt {} -> return lstmt
1888 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1889
1890 check_other -- Behave just as if this wasn't the last stmt
1891 = do { checkStmt ctxt lstmt; return lstmt }
1892
1893 -- Checking when a particular Stmt is ok
1894 checkStmt :: HsStmtContext Name
1895 -> LStmt RdrName (Located (body RdrName))
1896 -> RnM ()
1897 checkStmt ctxt (L _ stmt)
1898 = do { dflags <- getDynFlags
1899 ; case okStmt dflags ctxt stmt of
1900 IsValid -> return ()
1901 NotValid extra -> addErr (msg $$ extra) }
1902 where
1903 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
1904 , text "in" <+> pprAStmtContext ctxt ]
1905
1906 pprStmtCat :: Stmt a body -> SDoc
1907 pprStmtCat (TransStmt {}) = text "transform"
1908 pprStmtCat (LastStmt {}) = text "return expression"
1909 pprStmtCat (BodyStmt {}) = text "body"
1910 pprStmtCat (BindStmt {}) = text "binding"
1911 pprStmtCat (LetStmt {}) = text "let"
1912 pprStmtCat (RecStmt {}) = text "rec"
1913 pprStmtCat (ParStmt {}) = text "parallel"
1914 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
1915
1916 ------------
1917 emptyInvalid :: Validity -- Payload is the empty document
1918 emptyInvalid = NotValid Outputable.empty
1919
1920 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1921 :: DynFlags -> HsStmtContext Name
1922 -> Stmt RdrName (Located (body RdrName)) -> Validity
1923 -- Return Nothing if OK, (Just extra) if not ok
1924 -- The "extra" is an SDoc that is appended to an generic error message
1925
1926 okStmt dflags ctxt stmt
1927 = case ctxt of
1928 PatGuard {} -> okPatGuardStmt stmt
1929 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1930 DoExpr -> okDoStmt dflags ctxt stmt
1931 MDoExpr -> okDoStmt dflags ctxt stmt
1932 ArrowExpr -> okDoStmt dflags ctxt stmt
1933 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1934 ListComp -> okCompStmt dflags ctxt stmt
1935 MonadComp -> okCompStmt dflags ctxt stmt
1936 PArrComp -> okPArrStmt dflags ctxt stmt
1937 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1938
1939 -------------
1940 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1941 okPatGuardStmt stmt
1942 = case stmt of
1943 BodyStmt {} -> IsValid
1944 BindStmt {} -> IsValid
1945 LetStmt {} -> IsValid
1946 _ -> emptyInvalid
1947
1948 -------------
1949 okParStmt dflags ctxt stmt
1950 = case stmt of
1951 LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
1952 _ -> okStmt dflags ctxt stmt
1953
1954 ----------------
1955 okDoStmt dflags ctxt stmt
1956 = case stmt of
1957 RecStmt {}
1958 | LangExt.RecursiveDo `xopt` dflags -> IsValid
1959 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1960 | otherwise -> NotValid (text "Use RecursiveDo")
1961 BindStmt {} -> IsValid
1962 LetStmt {} -> IsValid
1963 BodyStmt {} -> IsValid
1964 _ -> emptyInvalid
1965
1966 ----------------
1967 okCompStmt dflags _ stmt
1968 = case stmt of
1969 BindStmt {} -> IsValid
1970 LetStmt {} -> IsValid
1971 BodyStmt {} -> IsValid
1972 ParStmt {}
1973 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1974 | otherwise -> NotValid (text "Use ParallelListComp")
1975 TransStmt {}
1976 | LangExt.TransformListComp `xopt` dflags -> IsValid
1977 | otherwise -> NotValid (text "Use TransformListComp")
1978 RecStmt {} -> emptyInvalid
1979 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1980 ApplicativeStmt {} -> emptyInvalid
1981
1982 ----------------
1983 okPArrStmt dflags _ stmt
1984 = case stmt of
1985 BindStmt {} -> IsValid
1986 LetStmt {} -> IsValid
1987 BodyStmt {} -> IsValid
1988 ParStmt {}
1989 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1990 | otherwise -> NotValid (text "Use ParallelListComp")
1991 TransStmt {} -> emptyInvalid
1992 RecStmt {} -> emptyInvalid
1993 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1994 ApplicativeStmt {} -> emptyInvalid
1995
1996 ---------
1997 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
1998 checkTupleSection args
1999 = do { tuple_section <- xoptM LangExt.TupleSections
2000 ; checkErr (all tupArgPresent args || tuple_section) msg }
2001 where
2002 msg = text "Illegal tuple section: use TupleSections"
2003
2004 ---------
2005 sectionErr :: HsExpr RdrName -> SDoc
2006 sectionErr expr
2007 = hang (text "A section must be enclosed in parentheses")
2008 2 (text "thus:" <+> (parens (ppr expr)))
2009
2010 patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars)
2011 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
2012 nest 4 (ppr e)] $$
2013 explanation)
2014 ; return (EWildPat, emptyFVs) }
2015
2016 badIpBinds :: Outputable a => SDoc -> a -> SDoc
2017 badIpBinds what binds
2018 = hang (text "Implicit-parameter bindings illegal in" <+> what)
2019 2 (ppr binds)