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