2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnLExpr, rnExpr, rnStmts
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
23 import RnSource ( rnSrcDecls, findSplice )
24 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack, getHetMetLevel )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
34 import BasicTypes ( FixityDirection(..) )
37 import Var ( TyVar, varName )
41 import LoadIface ( loadInterfaceForName )
44 import Util ( isSingleton, snocView )
45 import ListSetOps ( removeDups )
55 thenM :: Monad a => a b -> (b -> a c) -> a c
58 thenM_ :: Monad a => a b -> a c -> a c
62 %************************************************************************
64 \subsubsection{Expressions}
66 %************************************************************************
69 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
70 rnExprs ls = rnExprs' ls emptyUniqSet
72 rnExprs' [] acc = return ([], acc)
73 rnExprs' (expr:exprs) acc
74 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
76 -- Now we do a "seq" on the free vars because typically it's small
77 -- or empty, especially in very long lists of constants
79 acc' = acc `plusFV` fvExpr
81 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
82 return (expr':exprs', fvExprs)
85 Variables. We look up the variable and return the resulting name.
89 -- during the renamer phase we only care about the length of the
90 -- current HetMet level; the actual tyvars don't
91 -- matter, so we use bottoms for them
93 dummyTyVar = error "tried to force RnExpr.dummyTyVar"
95 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
96 rnLExpr = wrapLocFstM rnExpr
98 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
100 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
101 -- Separated from rnExpr because it's also used
102 -- when renaming infix expressions
103 -- See Note [Adding the implicit parameter to 'assert']
105 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
106 ; if ignore_asserts || not (name `hasKey` assertIdKey)
107 then return (HsVar name, unitFV name)
108 else do { e <- mkAssertErrorExpr
109 ; return (e, unitFV name) } }
112 = do name <- lookupOccRn v
116 = newIPNameRn v `thenM` \ name ->
117 return (HsIPVar name, emptyFVs)
119 rnExpr (HsLit lit@(HsString s))
121 opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
122 ; if opt_OverloadedStrings then
123 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
124 else -- Same as below
126 return (HsLit lit, emptyFVs)
131 return (HsLit lit, emptyFVs)
133 rnExpr (HsOverLit lit)
134 = rnOverLit lit `thenM` \ (lit', fvs) ->
135 return (HsOverLit lit', fvs)
137 rnExpr (HsApp fun arg)
138 = rnLExpr fun `thenM` \ (fun',fvFun) ->
139 rnLExpr arg `thenM` \ (arg',fvArg) ->
140 return (HsApp fun' arg', fvFun `plusFV` fvArg)
142 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
143 = do { (e1', fv_e1) <- rnLExpr e1
144 ; (e2', fv_e2) <- rnLExpr e2
145 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
146 ; (op', fv_op) <- finishHsVar op_name
147 -- NB: op' is usually just a variable, but might be
148 -- an applicatoin (assert "Foo.hs:47")
150 -- When renaming code synthesised from "deriving" declarations
151 -- we used to avoid fixity stuff, but we can't easily tell any
152 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
153 -- should prevent bad things happening.
154 ; fixity <- lookupFixityRn op_name
155 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
156 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
157 rnExpr (OpApp _ other_op _ _)
158 = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
160 , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
163 = rnLExpr e `thenM` \ (e', fv_e) ->
164 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
165 mkNegAppRn e' neg_name `thenM` \ final_e ->
166 return (final_e, fv_e `plusFV` fv_neg)
168 rnExpr (HsHetMetBrak c e)
169 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e
170 ; return (HsHetMetBrak c e', fv_e)
172 rnExpr (HsHetMetEsc c t e)
173 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
174 ; return (HsHetMetEsc c t e', fv_e)
176 rnExpr (HsHetMetCSP c e)
177 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
178 ; return (HsHetMetCSP c e', fv_e)
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)
188 = checkTH e "bracket" `thenM_`
189 rnBracket br_body `thenM` \ (body', fvs_e) ->
190 return (HsBracket body', fvs_e)
192 rnExpr (HsSpliceE splice)
193 = rnSplice splice `thenM` \ (splice', fvs) ->
194 return (HsSpliceE splice', fvs)
197 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
199 rnExpr (HsQuasiQuoteE qq)
200 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
204 ---------------------------------------------
206 -- See Note [Parsing sections] in Parser.y.pp
207 rnExpr (HsPar (L loc (section@(SectionL {}))))
208 = do { (section', fvs) <- rnSection section
209 ; return (HsPar (L loc section'), fvs) }
211 rnExpr (HsPar (L loc (section@(SectionR {}))))
212 = do { (section', fvs) <- rnSection section
213 ; return (HsPar (L loc section'), fvs) }
216 = do { (e', fvs_e) <- rnLExpr e
217 ; return (HsPar e', fvs_e) }
219 rnExpr expr@(SectionL {})
220 = do { addErr (sectionErr expr); rnSection expr }
221 rnExpr expr@(SectionR {})
222 = do { addErr (sectionErr expr); rnSection expr }
224 ---------------------------------------------
225 rnExpr (HsCoreAnn ann expr)
226 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
227 return (HsCoreAnn ann expr', fvs_expr)
229 rnExpr (HsSCC lbl expr)
230 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
231 return (HsSCC lbl expr', fvs_expr)
232 rnExpr (HsTickPragma info expr)
233 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
234 return (HsTickPragma info expr', fvs_expr)
236 rnExpr (HsLam matches)
237 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
238 return (HsLam matches', fvMatch)
240 rnExpr (HsCase expr matches)
241 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
242 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
243 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
245 rnExpr (HsLet binds expr)
246 = rnLocalBindsAndThen binds $ \ binds' ->
247 rnLExpr expr `thenM` \ (expr',fvExpr) ->
248 return (HsLet binds' expr', fvExpr)
250 rnExpr (HsDo do_or_lc stmts _)
251 = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
252 ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
254 rnExpr (ExplicitList _ exps)
255 = rnExprs exps `thenM` \ (exps', fvs) ->
256 return (ExplicitList placeHolderType exps', fvs)
258 rnExpr (ExplicitPArr _ exps)
259 = rnExprs exps `thenM` \ (exps', fvs) ->
260 return (ExplicitPArr placeHolderType exps', fvs)
262 rnExpr (ExplicitTuple tup_args boxity)
263 = do { checkTupleSection tup_args
264 ; checkTupSize (length tup_args)
265 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
266 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
268 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
269 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
271 rnExpr (RecordCon con_id _ rbinds)
272 = do { conname <- lookupLocatedOccRn con_id
273 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
274 ; return (RecordCon conname noPostTcExpr rbinds',
275 fvRbinds `addOneFV` unLoc conname) }
277 rnExpr (RecordUpd expr rbinds _ _ _)
278 = do { (expr', fvExpr) <- rnLExpr expr
279 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
280 ; return (RecordUpd expr' rbinds' [] [] [],
281 fvExpr `plusFV` fvRbinds) }
283 rnExpr (ExprWithTySig expr pty)
284 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
285 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
287 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
289 doc = text "In an expression type signature"
291 rnExpr (HsIf _ p b1 b2)
292 = do { (p', fvP) <- rnLExpr p
293 ; (b1', fvB1) <- rnLExpr b1
294 ; (b2', fvB2) <- rnLExpr b2
295 ; (mb_ite, fvITE) <- lookupIfThenElse
296 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
299 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
300 return (HsType t, fvT)
302 doc = text "In a type argument"
304 rnExpr (ArithSeq _ seq)
305 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
306 return (ArithSeq noPostTcExpr new_seq, fvs)
308 rnExpr (PArrSeq _ seq)
309 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
310 return (PArrSeq noPostTcExpr new_seq, fvs)
313 These three are pattern syntax appearing in expressions.
314 Since all the symbols are reservedops we can simply reject them.
315 We return a (bogus) EWildPat in each case.
318 rnExpr e@EWildPat = patSynErr e
319 rnExpr e@(EAsPat {}) = patSynErr e
320 rnExpr e@(EViewPat {}) = patSynErr e
321 rnExpr e@(ELazyPat {}) = patSynErr e
324 %************************************************************************
328 %************************************************************************
331 rnExpr (HsProc pat body)
333 rnPat ProcExpr pat $ \ pat' ->
334 rnCmdTop body `thenM` \ (body',fvBody) ->
335 return (HsProc pat' body', fvBody)
337 rnExpr (HsArrApp arrow arg _ ho rtl)
338 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
339 rnLExpr arg `thenM` \ (arg',fvArg) ->
340 return (HsArrApp arrow' arg' placeHolderType ho rtl,
341 fvArrow `plusFV` fvArg)
343 select_arrow_scope tc = case ho of
344 HsHigherOrderApp -> tc
345 HsFirstOrderApp -> escapeArrowScope tc
348 rnExpr (HsArrForm op (Just _) [arg1, arg2])
349 = escapeArrowScope (rnLExpr op)
350 `thenM` \ (op',fv_op) ->
351 let L _ (HsVar op_name) = op' in
352 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
353 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
357 lookupFixityRn op_name `thenM` \ fixity ->
358 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
361 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
363 rnExpr (HsArrForm op fixity cmds)
364 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
365 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
366 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
368 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
371 ----------------------
372 -- See Note [Parsing sections] in Parser.y.pp
373 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
374 rnSection section@(SectionR op expr)
375 = do { (op', fvs_op) <- rnLExpr op
376 ; (expr', fvs_expr) <- rnLExpr expr
377 ; checkSectionPrec InfixR section op' expr'
378 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
380 rnSection section@(SectionL expr op)
381 = do { (expr', fvs_expr) <- rnLExpr expr
382 ; (op', fvs_op) <- rnLExpr op
383 ; checkSectionPrec InfixL section op' expr'
384 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
386 rnSection other = pprPanic "rnSection" (ppr other)
389 %************************************************************************
393 %************************************************************************
396 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
397 -> RnM (HsRecordBinds Name, FreeVars)
398 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
399 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
400 ; (flds', fvss) <- mapAndUnzipM rn_field flds
401 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
402 fvs `plusFV` plusFVs fvss) }
404 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
405 ; return (fld { hsRecFieldArg = arg' }, fvs) }
409 %************************************************************************
413 %************************************************************************
416 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
417 rnCmdArgs [] = return ([], emptyFVs)
419 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
420 rnCmdArgs args `thenM` \ (args',fvArgs) ->
421 return (arg':args', fvArg `plusFV` fvArgs)
423 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
424 rnCmdTop = wrapLocFstM rnCmdTop'
426 rnCmdTop' (HsCmdTop cmd _ _ _)
427 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
429 cmd_names = [arrAName, composeAName, firstAName] ++
430 nameSetToList (methodNamesCmd (unLoc cmd'))
432 -- Generate the rebindable syntax for the monad
433 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
435 return (HsCmdTop cmd' [] placeHolderType cmd_names',
436 fvCmd `plusFV` cmd_fvs)
438 ---------------------------------------------------
439 -- convert OpApp's in a command context to HsArrForm's
441 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
442 convertOpFormsLCmd = fmap convertOpFormsCmd
444 convertOpFormsCmd :: HsCmd id -> HsCmd id
446 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
447 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
448 convertOpFormsCmd (OpApp c1 op fixity c2)
450 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
451 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
453 HsArrForm op (Just fixity) [arg1, arg2]
455 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
457 convertOpFormsCmd (HsCase exp matches)
458 = HsCase exp (convertOpFormsMatch matches)
460 convertOpFormsCmd (HsIf f exp c1 c2)
461 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
463 convertOpFormsCmd (HsLet binds cmd)
464 = HsLet binds (convertOpFormsLCmd cmd)
466 convertOpFormsCmd (HsDo DoExpr stmts ty)
467 = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
468 -- Mark the HsDo as begin the body of an arrow command
470 -- Anything else is unchanged. This includes HsArrForm (already done),
471 -- things with no sub-commands, and illegal commands (which will be
472 -- caught by the type checker)
473 convertOpFormsCmd c = c
475 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
476 convertOpFormsStmt (BindStmt pat cmd _ _)
477 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
478 convertOpFormsStmt (ExprStmt cmd _ _ _)
479 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
480 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
481 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
482 convertOpFormsStmt stmt = stmt
484 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
485 convertOpFormsMatch (MatchGroup ms ty)
486 = MatchGroup (map (fmap convert) ms) ty
487 where convert (Match pat mty grhss)
488 = Match pat mty (convertOpFormsGRHSs grhss)
490 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
491 convertOpFormsGRHSs (GRHSs grhss binds)
492 = GRHSs (map convertOpFormsGRHS grhss) binds
494 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
495 convertOpFormsGRHS = fmap convert
497 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
499 ---------------------------------------------------
500 type CmdNeeds = FreeVars -- Only inhabitants are
501 -- appAName, choiceAName, loopAName
503 -- find what methods the Cmd needs (loop, choice, apply)
504 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
505 methodNamesLCmd = methodNamesCmd . unLoc
507 methodNamesCmd :: HsCmd Name -> CmdNeeds
509 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
511 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
513 methodNamesCmd (HsArrForm {}) = emptyFVs
515 methodNamesCmd (HsPar c) = methodNamesLCmd c
517 methodNamesCmd (HsIf _ _ c1 c2)
518 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
520 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
521 methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
522 methodNamesCmd (HsApp c _) = methodNamesLCmd c
523 methodNamesCmd (HsLam match) = methodNamesMatch match
525 methodNamesCmd (HsCase _ matches)
526 = methodNamesMatch matches `addOneFV` choiceAName
528 methodNamesCmd _ = emptyFVs
529 -- Other forms can't occur in commands, but it's not convenient
530 -- to error here so we just do what's convenient.
531 -- The type checker will complain later
533 ---------------------------------------------------
534 methodNamesMatch :: MatchGroup Name -> FreeVars
535 methodNamesMatch (MatchGroup ms _)
536 = plusFVs (map do_one ms)
538 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
540 -------------------------------------------------
542 methodNamesGRHSs :: GRHSs Name -> FreeVars
543 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
545 -------------------------------------------------
547 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
548 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
550 ---------------------------------------------------
551 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
552 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
554 ---------------------------------------------------
555 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
556 methodNamesLStmt = methodNamesStmt . unLoc
558 methodNamesStmt :: StmtLR Name Name -> FreeVars
559 methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
560 methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
561 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
562 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
563 methodNamesStmt (LetStmt _) = emptyFVs
564 methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
565 methodNamesStmt (TransStmt {}) = emptyFVs
566 -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
567 -- here so we just do what's convenient
571 %************************************************************************
575 %************************************************************************
578 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
579 rnArithSeq (From expr)
580 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
581 return (From expr', fvExpr)
583 rnArithSeq (FromThen expr1 expr2)
584 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
585 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
586 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
588 rnArithSeq (FromTo expr1 expr2)
589 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
590 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
591 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
593 rnArithSeq (FromThenTo expr1 expr2 expr3)
594 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
595 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
596 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
597 return (FromThenTo expr1' expr2' expr3',
598 plusFVs [fvExpr1, fvExpr2, fvExpr3])
601 %************************************************************************
603 Template Haskell brackets
605 %************************************************************************
608 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
610 = do { name <- lookupOccRn n
611 ; this_mod <- getModule
612 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes
613 do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and
614 ; return () } -- this is the only way that is going
616 ; return (VarBr name, unitFV name) }
618 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
620 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
621 ; return (ExpBr e', fvs) }
623 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
625 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
626 ; return (TypBr t', fvs) }
628 doc = ptext (sLit "In a Template-Haskell quoted type")
630 rnBracket (DecBrL decls)
631 = do { (group, mb_splice) <- findSplice decls
634 Just (SpliceDecl (L loc _) _, _)
636 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
637 -- Why not? See Section 7.3 of the TH paper.
639 ; gbl_env <- getGblEnv
640 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
641 -- The emptyDUs is so that we just collect uses for this
642 -- group alone in the call to rnSrcDecls below
643 ; (tcg_env, group') <- setGblEnv new_gbl_env $
647 -- Discard the tcg_env; it contains only extra info about fixity
648 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
649 ppr (duUses (tcg_dus tcg_env))))
650 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
652 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
655 %************************************************************************
657 \subsubsection{@Stmt@s: in @do@ expressions}
659 %************************************************************************
662 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
663 -> ([Name] -> RnM (thing, FreeVars))
664 -> RnM (([LStmt Name], thing), FreeVars)
665 -- Variables bound by the Stmts, and mentioned in thing_inside,
666 -- do not appear in the result FreeVars
668 rnStmts ctxt [] thing_inside
669 = do { checkEmptyStmts ctxt
670 ; (thing, fvs) <- thing_inside []
671 ; return (([], thing), fvs) }
673 rnStmts MDoExpr stmts thing_inside -- Deal with mdo
674 = -- Behave like do { rec { ...all but last... }; last }
675 do { ((stmts1, (stmts2, thing)), fvs)
676 <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
677 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
678 ; rnStmt MDoExpr last_stmt' thing_inside }
679 ; return (((stmts1 ++ stmts2), thing), fvs) }
681 Just (all_but_last, last_stmt) = snocView stmts
683 rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
686 do { lstmt' <- checkLastStmt ctxt lstmt
687 ; rnStmt ctxt lstmt' thing_inside }
690 = do { ((stmts1, (stmts2, thing)), fvs)
692 do { checkStmt ctxt lstmt
693 ; rnStmt ctxt lstmt $ \ bndrs1 ->
694 rnStmts ctxt lstmts $ \ bndrs2 ->
695 thing_inside (bndrs1 ++ bndrs2) }
696 ; return (((stmts1 ++ stmts2), thing), fvs) }
698 ----------------------
699 rnStmt :: HsStmtContext Name
701 -> ([Name] -> RnM (thing, FreeVars))
702 -> RnM (([LStmt Name], thing), FreeVars)
703 -- Variables bound by the Stmt, and mentioned in thing_inside,
704 -- do not appear in the result FreeVars
706 rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
707 = do { (expr', fv_expr) <- rnLExpr expr
708 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
709 ; (thing, fvs3) <- thing_inside []
710 ; return (([L loc (LastStmt expr' ret_op)], thing),
711 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
713 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
714 = do { (expr', fv_expr) <- rnLExpr expr
715 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
716 ; (guard_op, fvs2) <- if isListCompExpr ctxt
717 then lookupStmtName ctxt guardMName
718 else return (noSyntaxExpr, emptyFVs)
719 -- Only list/parr/monad comprehensions use 'guard'
720 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
721 -- Here "gd" is a guard
722 ; (thing, fvs3) <- thing_inside []
723 ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
724 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
726 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
727 = do { (expr', fv_expr) <- rnLExpr expr
728 -- The binders do not scope over the expression
729 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
730 ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
731 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
732 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
733 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
734 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
735 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
736 -- but it does not matter because the names are unique
738 rnStmt _ (L loc (LetStmt binds)) thing_inside
739 = do { rnLocalBindsAndThen binds $ \binds' -> do
740 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
741 ; return (([L loc (LetStmt binds')], thing), fvs) } }
743 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
745 -- Step1: Bring all the binders of the mdo into scope
746 -- (Remember that this also removes the binders from the
747 -- finally-returned free-vars.)
748 -- And rename each individual stmt, making a
749 -- singleton segment. At this stage the FwdRefs field
750 -- isn't finished: it's empty for all except a BindStmt
751 -- for which it's the fwd refs within the bind itself
752 -- (This set may not be empty, because we're in a recursive
754 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
756 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
758 ; (thing, fvs_later) <- thing_inside bndrs
759 ; (return_op, fvs1) <- lookupStmtName ctxt returnMName
760 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
761 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
763 -- Step 2: Fill in the fwd refs.
764 -- The segments are all singletons, but their fwd-ref
765 -- field mentions all the things used by the segment
766 -- that are bound after their use
767 segs_w_fwd_refs = addFwdRefs segs
769 -- Step 3: Group together the segments to make bigger segments
770 -- Invariant: in the result, no segment uses a variable
771 -- bound in a later segment
772 grouped_segs = glomSegments segs_w_fwd_refs
774 -- Step 4: Turn the segments into Stmts
775 -- Use RecStmt when and only when there are fwd refs
776 -- Also gather up the uses from the end towards the
777 -- start, so we can tell the RecStmt which things are
778 -- used 'after' the RecStmt
779 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
780 , recS_mfix_fn = mfix_op
781 , recS_bind_fn = bind_op }
782 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
784 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
786 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
787 = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
788 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
789 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
790 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
791 ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
792 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
794 rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
795 , trS_using = using })) thing_inside
796 = do { -- Rename the 'using' expression in the context before the transform is begun
797 (using', fvs1) <- case form of
798 GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
799 ; return (noLoc e, fvs) }
802 -- Rename the stmts and the 'by' expression
803 -- Keep track of the variables mentioned in the 'by' expression
804 ; ((stmts', (by', used_bndrs, thing)), fvs2)
805 <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
806 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
807 ; (thing, fvs_thing) <- thing_inside bndrs
808 ; let fvs = fvs_by `plusFV` fvs_thing
809 used_bndrs = filter (`elemNameSet` fvs) bndrs
810 -- The paper (Fig 5) has a bug here; we must treat any free varaible
811 -- of the "thing inside", **or of the by-expression**, as used
812 ; return ((by', used_bndrs, thing), fvs) }
814 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
815 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
816 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
817 ; (fmap_op, fvs5) <- case form of
818 ThenForm -> return (noSyntaxExpr, emptyFVs)
819 _ -> lookupStmtName ctxt fmapName
821 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
822 `plusFV` fvs4 `plusFV` fvs5
823 bndr_map = used_bndrs `zip` used_bndrs
824 -- See Note [TransStmt binder map] in HsExpr
826 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
827 ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
828 , trS_by = by', trS_using = using', trS_form = form
829 , trS_ret = return_op, trS_bind = bind_op
830 , trS_fmap = fmap_op })], thing), all_fvs) }
832 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
834 rnParallelStmts :: forall thing. HsStmtContext Name
836 -> ([Name] -> RnM (thing, FreeVars))
837 -> RnM (([ParSeg Name], thing), FreeVars)
838 -- Note [Renaming parallel Stmts]
839 rnParallelStmts ctxt segs thing_inside
840 = do { orig_lcl_env <- getLocalRdrEnv
841 ; rn_segs orig_lcl_env [] segs }
843 rn_segs :: LocalRdrEnv
844 -> [Name] -> [ParSeg RdrName]
845 -> RnM (([ParSeg Name], thing), FreeVars)
846 rn_segs _ bndrs_so_far []
847 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
849 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
850 ; return (([], thing), fvs) }
852 rn_segs env bndrs_so_far ((stmts,_) : segs)
853 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
854 <- rnStmts ctxt stmts $ \ bndrs ->
855 setLocalRdrEnv env $ do
856 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
857 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
858 ; return ((used_bndrs, segs', thing), fvs) }
860 ; let seg' = (stmts', used_bndrs)
861 ; return ((seg':segs', thing), fvs) }
863 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
864 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
865 <+> quotes (ppr (head vs)))
867 lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
868 -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
869 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
870 lookupStmtName ctxt n
872 ListComp -> not_rebindable
873 PArrComp -> not_rebindable
874 ArrowExpr -> not_rebindable
875 PatGuard {} -> not_rebindable
878 MDoExpr -> rebindable
879 MonadComp -> rebindable
880 GhciStmt -> rebindable -- I suppose?
882 ParStmtCtxt c -> lookupStmtName c n -- Look inside to
883 TransStmtCtxt c -> lookupStmtName c n -- the parent context
885 rebindable = lookupSyntaxName n
886 not_rebindable = return (HsVar n, emptyFVs)
889 Note [Renaming parallel Stmts]
890 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
891 Renaming parallel statements is painful. Given, say
892 [ a+c | a <- as, bs <- bss
895 (a) In order to report "Defined by not used" about 'bs', we must rename
896 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
898 (b) We want to report that 'a' is illegally bound in both branches
900 (c) The 'bs' in the second group must obviously not be captured by
901 the binding in the first group
903 To satisfy (a) we nest the segements.
904 To satisfy (b) we check for duplicates just before thing_inside.
905 To satisfy (c) we reset the LocalRdrEnv each time.
907 %************************************************************************
909 \subsubsection{mdo expressions}
911 %************************************************************************
914 type FwdRefs = NameSet
915 type Segment stmts = (Defs,
916 Uses, -- May include defs
917 FwdRefs, -- A subset of uses that are
918 -- (a) used before they are bound in this segment, or
919 -- (b) used here, and bound in subsequent segments
920 stmts) -- Either Stmt or [Stmt]
923 -- wrapper that does both the left- and right-hand sides
924 rnRecStmtsAndThen :: [LStmt RdrName]
925 -- assumes that the FreeVars returned includes
926 -- the FreeVars of the Segments
927 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
929 rnRecStmtsAndThen s cont
930 = do { -- (A) Make the mini fixity env for all of the stmts
931 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
934 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
936 -- ...bring them and their fixities into scope
937 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
938 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
939 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
940 ; bindLocalNamesFV bound_names $
941 addLocalFixities fix_env bound_names $ do
943 -- (C) do the right-hand-sides and thing-inside
944 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
945 ; (res, fvs) <- cont segs
946 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
947 ; return (res, fvs) }}
949 -- get all the fixity decls in any Let stmt
950 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
951 collectRecStmtsFixities l =
952 foldr (\ s -> \acc -> case s of
953 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
954 foldr (\ sig -> \ acc -> case sig of
955 (L loc (FixSig s)) -> (L loc s) : acc
961 rn_rec_stmt_lhs :: MiniFixityEnv
963 -- rename LHS, and return its FVs
964 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
965 -- so we don't bother to compute it accurately in the other cases
966 -> RnM [(LStmtLR Name RdrName, FreeVars)]
968 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
969 = return [(L loc (ExprStmt expr a b c), emptyFVs)]
971 rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
972 = return [(L loc (LastStmt expr a), emptyFVs)]
974 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
976 -- should the ctxt be MDo instead?
977 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
978 return [(L loc (BindStmt pat' expr a b),
981 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
982 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
984 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
985 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
986 return [(L loc (LetStmt (HsValBinds binds')),
987 -- Warning: this is bogus; see function invariant
991 -- XXX Do we need to do something with the return and mfix names?
992 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
993 = rn_rec_stmts_lhs fix_env stmts
995 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
996 = pprPanic "rn_rec_stmt" (ppr stmt)
998 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
999 = pprPanic "rn_rec_stmt" (ppr stmt)
1001 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
1002 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1004 rn_rec_stmts_lhs :: MiniFixityEnv
1006 -> RnM [(LStmtLR Name RdrName, FreeVars)]
1007 rn_rec_stmts_lhs fix_env stmts
1008 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1009 ; let boundNames = collectLStmtsBinders (map fst ls)
1010 -- First do error checking: we need to check for dups here because we
1011 -- don't bind all of the variables from the Stmt at once
1012 -- with bindLocatedLocals.
1013 ; checkDupNames boundNames
1019 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
1020 -- Rename a Stmt that is inside a RecStmt (or mdo)
1021 -- Assumes all binders are already in scope
1022 -- Turns each stmt into a singleton Stmt
1023 rn_rec_stmt _ (L loc (LastStmt expr _)) _
1024 = do { (expr', fv_expr) <- rnLExpr expr
1025 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1026 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1027 L loc (LastStmt expr' ret_op))] }
1029 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
1030 = rnLExpr expr `thenM` \ (expr', fvs) ->
1031 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1032 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1033 L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
1035 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1036 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1037 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1038 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1040 bndrs = mkNameSet (collectPatBinders pat')
1041 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1043 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1044 L loc (BindStmt pat' expr' bind_op fail_op))]
1046 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1047 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1049 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1050 (binds', du_binds) <-
1051 -- fixities and unused are handled above in rnRecStmtsAndThen
1052 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1053 return [(duDefs du_binds, allUses du_binds,
1054 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1056 -- no RecStmt case becuase they get flattened above when doing the LHSes
1057 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1058 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1060 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1061 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1063 rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
1064 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1066 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1067 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1069 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1070 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1071 return (concat segs_s)
1073 ---------------------------------------------
1074 addFwdRefs :: [Segment a] -> [Segment a]
1075 -- So far the segments only have forward refs *within* the Stmt
1076 -- (which happens for bind: x <- ...x...)
1077 -- This function adds the cross-seg fwd ref info
1080 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1082 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1083 = (new_seg : segs, all_defs)
1085 new_seg = (defs, uses, new_fwds, stmts)
1086 all_defs = later_defs `unionNameSets` defs
1087 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1088 -- Add the downstream fwd refs here
1090 ----------------------------------------------------
1091 -- Glomming the singleton segments of an mdo into
1092 -- minimal recursive groups.
1094 -- At first I thought this was just strongly connected components, but
1095 -- there's an important constraint: the order of the stmts must not change.
1098 -- mdo { x <- ...y...
1105 -- Here, the first stmt mention 'y', which is bound in the third.
1106 -- But that means that the innocent second stmt (p <- z) gets caught
1107 -- up in the recursion. And that in turn means that the binding for
1108 -- 'z' has to be included... and so on.
1110 -- Start at the tail { r <- x }
1111 -- Now add the next one { z <- y ; r <- x }
1112 -- Now add one more { q <- x ; z <- y ; r <- x }
1113 -- Now one more... but this time we have to group a bunch into rec
1114 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1115 -- Now one more, which we can add on without a rec
1117 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1119 -- Finally we add the last one; since it mentions y we have to
1120 -- glom it togeher with the first two groups
1121 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1122 -- q <- x ; z <- y } ;
1125 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1127 glomSegments [] = []
1128 glomSegments ((defs,uses,fwds,stmt) : segs)
1129 -- Actually stmts will always be a singleton
1130 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1132 segs' = glomSegments segs
1133 (extras, others) = grab uses segs'
1134 (ds, us, fs, ss) = unzip4 extras
1136 seg_defs = plusFVs ds `plusFV` defs
1137 seg_uses = plusFVs us `plusFV` uses
1138 seg_fwds = plusFVs fs `plusFV` fwds
1139 seg_stmts = stmt : concat ss
1141 grab :: NameSet -- The client
1143 -> ([Segment a], -- Needed by the 'client'
1144 [Segment a]) -- Not needed by the client
1145 -- The result is simply a split of the input
1147 = (reverse yeses, reverse noes)
1149 (noes, yeses) = span not_needed (reverse dus)
1150 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1153 ----------------------------------------------------
1154 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1155 -> [Segment [LStmt Name]]
1156 -> FreeVars -- Free vars used 'later'
1157 -> ([LStmt Name], FreeVars)
1159 segsToStmts _ [] fvs_later = ([], fvs_later)
1160 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1161 = ASSERT( not (null ss) )
1162 (new_stmt : later_stmts, later_uses `plusFV` uses)
1164 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1165 new_stmt | non_rec = head ss
1166 | otherwise = L (getLoc (head ss)) rec_stmt
1167 rec_stmt = empty_rec_stmt { recS_stmts = ss
1168 , recS_later_ids = nameSetToList used_later
1169 , recS_rec_ids = nameSetToList fwds }
1170 non_rec = isSingleton ss && isEmptyNameSet fwds
1171 used_later = defs `intersectNameSet` later_uses
1172 -- The ones needed after the RecStmt
1175 %************************************************************************
1177 \subsubsection{Assertion utils}
1179 %************************************************************************
1182 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1183 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1185 mkAssertErrorExpr :: RnM (HsExpr Name)
1186 -- Return an expression for (assertError "Foo.hs:27")
1188 = getSrcSpanM `thenM` \ sloc ->
1189 return (HsApp (L sloc (HsVar assertErrorName))
1190 (L sloc (srcSpanPrimLit sloc)))
1193 Note [Adding the implicit parameter to 'assert']
1194 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1195 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1196 By doing this in the renamer we allow the typechecker to just see the
1197 expanded application and do the right thing. But it's not really
1198 the Right Thing because there's no way to "undo" if you want to see
1199 the original source code. We'll have fix this in due course, when
1200 we care more about being able to reconstruct the exact original
1203 %************************************************************************
1205 \subsubsection{Errors}
1207 %************************************************************************
1210 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1211 -- We've seen an empty sequence of Stmts... is that ok?
1212 checkEmptyStmts ctxt
1213 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1215 okEmpty :: HsStmtContext a -> Bool
1216 okEmpty (PatGuard {}) = True
1219 emptyErr :: HsStmtContext Name -> SDoc
1220 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1221 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1222 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1224 ----------------------
1225 checkLastStmt :: HsStmtContext Name
1227 -> RnM (LStmt RdrName)
1228 checkLastStmt ctxt lstmt@(L loc stmt)
1230 ListComp -> check_comp
1231 MonadComp -> check_comp
1232 PArrComp -> check_comp
1233 ArrowExpr -> check_do
1238 check_do -- Expect ExprStmt, and change it to LastStmt
1240 ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
1241 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1242 -- LastStmt directly (unlike the parser)
1243 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1244 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1245 <+> ptext (sLit "must be an expression"))
1247 check_comp -- Expect LastStmt; this should be enforced by the parser!
1249 LastStmt {} -> return lstmt
1250 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1252 check_other -- Behave just as if this wasn't the last stmt
1253 = do { checkStmt ctxt lstmt; return lstmt }
1255 -- Checking when a particular Stmt is ok
1256 checkStmt :: HsStmtContext Name
1259 checkStmt ctxt (L _ stmt)
1260 = do { dflags <- getDOpts
1261 ; case okStmt dflags ctxt stmt of
1262 Nothing -> return ()
1263 Just extra -> addErr (msg $$ extra) }
1265 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1266 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1268 pprStmtCat :: Stmt a -> SDoc
1269 pprStmtCat (TransStmt {}) = ptext (sLit "transform")
1270 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1271 pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
1272 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1273 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1274 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1275 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1278 isOK, notOK :: Maybe SDoc
1282 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1283 :: DynFlags -> HsStmtContext Name
1284 -> Stmt RdrName -> Maybe SDoc
1285 -- Return Nothing if OK, (Just extra) if not ok
1286 -- The "extra" is an SDoc that is appended to an generic error message
1288 okStmt dflags ctxt stmt
1290 PatGuard {} -> okPatGuardStmt stmt
1291 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1292 DoExpr -> okDoStmt dflags ctxt stmt
1293 MDoExpr -> okDoStmt dflags ctxt stmt
1294 ArrowExpr -> okDoStmt dflags ctxt stmt
1295 GhciStmt -> okDoStmt dflags ctxt stmt
1296 ListComp -> okCompStmt dflags ctxt stmt
1297 MonadComp -> okCompStmt dflags ctxt stmt
1298 PArrComp -> okPArrStmt dflags ctxt stmt
1299 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1302 okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
1311 okParStmt dflags ctxt stmt
1313 LetStmt (HsIPBinds {}) -> notOK
1314 _ -> okStmt dflags ctxt stmt
1317 okDoStmt dflags ctxt stmt
1320 | Opt_DoRec `xopt` dflags -> isOK
1321 | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec'
1322 | otherwise -> Just (ptext (sLit "Use -XDoRec"))
1329 okCompStmt dflags _ stmt
1335 | Opt_ParallelListComp `xopt` dflags -> isOK
1336 | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1338 | Opt_TransformListComp `xopt` dflags -> isOK
1339 | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1341 LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
1344 okPArrStmt dflags _ stmt
1350 | Opt_ParallelListComp `xopt` dflags -> isOK
1351 | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1352 TransStmt {} -> notOK
1354 LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
1357 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1358 checkTupleSection args
1359 = do { tuple_section <- xoptM Opt_TupleSections
1360 ; checkErr (all tupArgPresent args || tuple_section) msg }
1362 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1365 sectionErr :: HsExpr RdrName -> SDoc
1367 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1368 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1370 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1371 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1373 ; return (EWildPat, emptyFVs) }
1375 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1376 badIpBinds what binds
1377 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)