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