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 )
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 body _)
251 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
253 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
255 rnExpr (ExplicitList _ exps)
256 = rnExprs exps `thenM` \ (exps', fvs) ->
257 return (ExplicitList placeHolderType exps', fvs)
259 rnExpr (ExplicitPArr _ exps)
260 = rnExprs exps `thenM` \ (exps', fvs) ->
261 return (ExplicitPArr placeHolderType exps', fvs)
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) }
269 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
270 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
272 rnExpr (RecordCon con_id _ rbinds)
273 = do { conname <- lookupLocatedOccRn con_id
274 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
275 ; return (RecordCon conname noPostTcExpr rbinds',
276 fvRbinds `addOneFV` unLoc conname) }
278 rnExpr (RecordUpd expr rbinds _ _ _)
279 = do { (expr', fvExpr) <- rnLExpr expr
280 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
281 ; return (RecordUpd expr' rbinds' [] [] [],
282 fvExpr `plusFV` fvRbinds) }
284 rnExpr (ExprWithTySig expr pty)
285 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
286 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
288 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
290 doc = text "In an expression type signature"
292 rnExpr (HsIf _ p b1 b2)
293 = do { (p', fvP) <- rnLExpr p
294 ; (b1', fvB1) <- rnLExpr b1
295 ; (b2', fvB2) <- rnLExpr b2
296 ; (mb_ite, fvITE) <- lookupIfThenElse
297 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
300 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
301 return (HsType t, fvT)
303 doc = text "In a type argument"
305 rnExpr (ArithSeq _ seq)
306 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
307 return (ArithSeq noPostTcExpr new_seq, fvs)
309 rnExpr (PArrSeq _ seq)
310 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
311 return (PArrSeq noPostTcExpr new_seq, fvs)
314 These three are pattern syntax appearing in expressions.
315 Since all the symbols are reservedops we can simply reject them.
316 We return a (bogus) EWildPat in each case.
319 rnExpr e@EWildPat = patSynErr e
320 rnExpr e@(EAsPat {}) = patSynErr e
321 rnExpr e@(EViewPat {}) = patSynErr e
322 rnExpr e@(ELazyPat {}) = patSynErr e
325 %************************************************************************
329 %************************************************************************
332 rnExpr (HsProc pat body)
334 rnPat ProcExpr pat $ \ pat' ->
335 rnCmdTop body `thenM` \ (body',fvBody) ->
336 return (HsProc pat' body', fvBody)
338 rnExpr (HsArrApp arrow arg _ ho rtl)
339 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
340 rnLExpr arg `thenM` \ (arg',fvArg) ->
341 return (HsArrApp arrow' arg' placeHolderType ho rtl,
342 fvArrow `plusFV` fvArg)
344 select_arrow_scope tc = case ho of
345 HsHigherOrderApp -> tc
346 HsFirstOrderApp -> escapeArrowScope tc
349 rnExpr (HsArrForm op (Just _) [arg1, arg2])
350 = escapeArrowScope (rnLExpr op)
351 `thenM` \ (op',fv_op) ->
352 let L _ (HsVar op_name) = op' in
353 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
354 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
358 lookupFixityRn op_name `thenM` \ fixity ->
359 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
362 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
364 rnExpr (HsArrForm op fixity cmds)
365 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
366 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
367 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
369 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
372 ----------------------
373 -- See Note [Parsing sections] in Parser.y.pp
374 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
375 rnSection section@(SectionR op expr)
376 = do { (op', fvs_op) <- rnLExpr op
377 ; (expr', fvs_expr) <- rnLExpr expr
378 ; checkSectionPrec InfixR section op' expr'
379 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
381 rnSection section@(SectionL expr op)
382 = do { (expr', fvs_expr) <- rnLExpr expr
383 ; (op', fvs_op) <- rnLExpr op
384 ; checkSectionPrec InfixL section op' expr'
385 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
387 rnSection other = pprPanic "rnSection" (ppr other)
390 %************************************************************************
394 %************************************************************************
397 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
398 -> RnM (HsRecordBinds Name, FreeVars)
399 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
400 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
401 ; (flds', fvss) <- mapAndUnzipM rn_field flds
402 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
403 fvs `plusFV` plusFVs fvss) }
405 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
406 ; return (fld { hsRecFieldArg = arg' }, fvs) }
410 %************************************************************************
414 %************************************************************************
417 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
418 rnCmdArgs [] = return ([], emptyFVs)
420 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
421 rnCmdArgs args `thenM` \ (args',fvArgs) ->
422 return (arg':args', fvArg `plusFV` fvArgs)
424 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
425 rnCmdTop = wrapLocFstM rnCmdTop'
427 rnCmdTop' (HsCmdTop cmd _ _ _)
428 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
430 cmd_names = [arrAName, composeAName, firstAName] ++
431 nameSetToList (methodNamesCmd (unLoc cmd'))
433 -- Generate the rebindable syntax for the monad
434 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
436 return (HsCmdTop cmd' [] placeHolderType cmd_names',
437 fvCmd `plusFV` cmd_fvs)
439 ---------------------------------------------------
440 -- convert OpApp's in a command context to HsArrForm's
442 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
443 convertOpFormsLCmd = fmap convertOpFormsCmd
445 convertOpFormsCmd :: HsCmd id -> HsCmd id
447 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
448 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
449 convertOpFormsCmd (OpApp c1 op fixity c2)
451 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
452 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
454 HsArrForm op (Just fixity) [arg1, arg2]
456 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
458 convertOpFormsCmd (HsCase exp matches)
459 = HsCase exp (convertOpFormsMatch matches)
461 convertOpFormsCmd (HsIf f exp c1 c2)
462 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
464 convertOpFormsCmd (HsLet binds cmd)
465 = HsLet binds (convertOpFormsLCmd cmd)
467 convertOpFormsCmd (HsDo ctxt stmts body ty)
468 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
469 (convertOpFormsLCmd body) ty
471 -- Anything else is unchanged. This includes HsArrForm (already done),
472 -- things with no sub-commands, and illegal commands (which will be
473 -- caught by the type checker)
474 convertOpFormsCmd c = c
476 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
477 convertOpFormsStmt (BindStmt pat cmd _ _)
478 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
479 convertOpFormsStmt (ExprStmt cmd _ _)
480 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
481 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
482 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
483 convertOpFormsStmt stmt = stmt
485 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
486 convertOpFormsMatch (MatchGroup ms ty)
487 = MatchGroup (map (fmap convert) ms) ty
488 where convert (Match pat mty grhss)
489 = Match pat mty (convertOpFormsGRHSs grhss)
491 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
492 convertOpFormsGRHSs (GRHSs grhss binds)
493 = GRHSs (map convertOpFormsGRHS grhss) binds
495 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
496 convertOpFormsGRHS = fmap convert
498 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
500 ---------------------------------------------------
501 type CmdNeeds = FreeVars -- Only inhabitants are
502 -- appAName, choiceAName, loopAName
504 -- find what methods the Cmd needs (loop, choice, apply)
505 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
506 methodNamesLCmd = methodNamesCmd . unLoc
508 methodNamesCmd :: HsCmd Name -> CmdNeeds
510 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
512 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
514 methodNamesCmd (HsArrForm {}) = emptyFVs
516 methodNamesCmd (HsPar c) = methodNamesLCmd c
518 methodNamesCmd (HsIf _ _ c1 c2)
519 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
521 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
523 methodNamesCmd (HsDo _ stmts body _)
524 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
526 methodNamesCmd (HsApp c _) = methodNamesLCmd c
528 methodNamesCmd (HsLam match) = methodNamesMatch match
530 methodNamesCmd (HsCase _ matches)
531 = methodNamesMatch matches `addOneFV` choiceAName
533 methodNamesCmd _ = emptyFVs
534 -- Other forms can't occur in commands, but it's not convenient
535 -- to error here so we just do what's convenient.
536 -- The type checker will complain later
538 ---------------------------------------------------
539 methodNamesMatch :: MatchGroup Name -> FreeVars
540 methodNamesMatch (MatchGroup ms _)
541 = plusFVs (map do_one ms)
543 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
545 -------------------------------------------------
547 methodNamesGRHSs :: GRHSs Name -> FreeVars
548 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
550 -------------------------------------------------
552 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
553 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
555 ---------------------------------------------------
556 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
557 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
559 ---------------------------------------------------
560 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
561 methodNamesLStmt = methodNamesStmt . unLoc
563 methodNamesStmt :: StmtLR Name Name -> FreeVars
564 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
565 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
566 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
567 methodNamesStmt (LetStmt _) = emptyFVs
568 methodNamesStmt (ParStmt _) = emptyFVs
569 methodNamesStmt (TransformStmt {}) = emptyFVs
570 methodNamesStmt (GroupStmt {}) = emptyFVs
571 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
572 -- here so we just do what's convenient
576 %************************************************************************
580 %************************************************************************
583 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
584 rnArithSeq (From expr)
585 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
586 return (From expr', fvExpr)
588 rnArithSeq (FromThen expr1 expr2)
589 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
590 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
591 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
593 rnArithSeq (FromTo expr1 expr2)
594 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
595 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
596 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
598 rnArithSeq (FromThenTo expr1 expr2 expr3)
599 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
600 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
601 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
602 return (FromThenTo expr1' expr2' expr3',
603 plusFVs [fvExpr1, fvExpr2, fvExpr3])
606 %************************************************************************
608 Template Haskell brackets
610 %************************************************************************
613 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
614 rnBracket (VarBr n) = do { name <- lookupOccRn n
615 ; this_mod <- getModule
616 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
617 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
618 ; return () } -- only way that is going to happen
619 ; return (VarBr name, unitFV name) }
621 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
623 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
624 ; return (ExpBr e', fvs) }
626 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
628 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
629 ; return (TypBr t', fvs) }
631 doc = ptext (sLit "In a Template-Haskell quoted type")
633 rnBracket (DecBrL decls)
634 = do { (group, mb_splice) <- findSplice decls
637 Just (SpliceDecl (L loc _) _, _)
639 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
640 -- Why not? See Section 7.3 of the TH paper.
642 ; gbl_env <- getGblEnv
643 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
644 -- The emptyDUs is so that we just collect uses for this
645 -- group alone in the call to rnSrcDecls below
646 ; (tcg_env, group') <- setGblEnv new_gbl_env $
650 -- Discard the tcg_env; it contains only extra info about fixity
651 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
652 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
654 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
657 %************************************************************************
659 \subsubsection{@Stmt@s: in @do@ expressions}
661 %************************************************************************
664 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
665 -> ([Name] -> RnM (thing, FreeVars))
666 -> RnM (([LStmt Name], thing), FreeVars)
667 -- Variables bound by the Stmts, and mentioned in thing_inside,
668 -- do not appear in the result FreeVars
670 -- Renaming a single RecStmt can give a sequence of smaller Stmts
672 rnStmts _ [] thing_inside
673 = do { (res, fvs) <- thing_inside []
674 ; return (([], res), fvs) }
676 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
677 = do { ((stmts1, (stmts2, thing)), fvs)
679 rnStmt ctxt stmt $ \ bndrs1 ->
680 rnStmts ctxt stmts $ \ bndrs2 ->
681 thing_inside (bndrs1 ++ bndrs2)
682 ; return (((stmts1 ++ stmts2), thing), fvs) }
685 rnStmt :: HsStmtContext Name -> LStmt RdrName
686 -> ([Name] -> RnM (thing, FreeVars))
687 -> RnM (([LStmt Name], thing), FreeVars)
688 -- Variables bound by the Stmt, and mentioned in thing_inside,
689 -- do not appear in the result FreeVars
691 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
692 = do { (expr', fv_expr) <- rnLExpr expr
693 ; (then_op, fvs1) <- lookupSyntaxName thenMName
694 ; (thing, fvs2) <- thing_inside []
695 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
696 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
698 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
699 = do { (expr', fv_expr) <- rnLExpr expr
700 -- The binders do not scope over the expression
701 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
702 ; (fail_op, fvs2) <- lookupSyntaxName failMName
703 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
704 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
705 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
706 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
707 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
708 -- but it does not matter because the names are unique
710 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
711 = do { checkLetStmt ctxt binds
712 ; rnLocalBindsAndThen binds $ \binds' -> do
713 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
714 ; return (([L loc (LetStmt binds')], thing), fvs) } }
716 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
717 = do { checkRecStmt ctxt
719 -- Step1: Bring all the binders of the mdo into scope
720 -- (Remember that this also removes the binders from the
721 -- finally-returned free-vars.)
722 -- And rename each individual stmt, making a
723 -- singleton segment. At this stage the FwdRefs field
724 -- isn't finished: it's empty for all except a BindStmt
725 -- for which it's the fwd refs within the bind itself
726 -- (This set may not be empty, because we're in a recursive
728 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
730 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
732 ; (thing, fvs_later) <- thing_inside bndrs
733 ; (return_op, fvs1) <- lookupSyntaxName returnMName
734 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
735 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
737 -- Step 2: Fill in the fwd refs.
738 -- The segments are all singletons, but their fwd-ref
739 -- field mentions all the things used by the segment
740 -- that are bound after their use
741 segs_w_fwd_refs = addFwdRefs segs
743 -- Step 3: Group together the segments to make bigger segments
744 -- Invariant: in the result, no segment uses a variable
745 -- bound in a later segment
746 grouped_segs = glomSegments segs_w_fwd_refs
748 -- Step 4: Turn the segments into Stmts
749 -- Use RecStmt when and only when there are fwd refs
750 -- Also gather up the uses from the end towards the
751 -- start, so we can tell the RecStmt which things are
752 -- used 'after' the RecStmt
753 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
754 , recS_mfix_fn = mfix_op
755 , recS_bind_fn = bind_op }
756 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
758 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
760 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
761 = do { checkParStmt ctxt
762 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
763 ; return (([L loc (ParStmt segs')], thing), fvs) }
765 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
766 = do { checkTransformStmt ctxt
768 ; (using', fvs1) <- rnLExpr using
770 ; ((stmts', (by', used_bndrs, thing)), fvs2)
771 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
772 do { (by', fvs_by) <- case by of
773 Nothing -> return (Nothing, emptyFVs)
774 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
775 ; (thing, fvs_thing) <- thing_inside bndrs
776 ; let fvs = fvs_by `plusFV` fvs_thing
777 used_bndrs = filter (`elemNameSet` fvs) bndrs
778 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
779 -- the "thing inside", **or of the by-expression**, as used
780 ; return ((by', used_bndrs, thing), fvs) }
782 ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
783 fvs1 `plusFV` fvs2) }
785 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
786 = do { checkTransformStmt ctxt
788 -- Rename the 'using' expression in the context before the transform is begun
789 ; (using', fvs1) <- case using of
790 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
791 Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
792 ; return (Right e', fvs) }
794 -- Rename the stmts and the 'by' expression
795 -- Keep track of the variables mentioned in the 'by' expression
796 ; ((stmts', (by', used_bndrs, thing)), fvs2)
797 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
798 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
799 ; (thing, fvs_thing) <- thing_inside bndrs
800 ; let fvs = fvs_by `plusFV` fvs_thing
801 used_bndrs = filter (`elemNameSet` fvs) bndrs
802 ; return ((by', used_bndrs, thing), fvs) }
804 ; let all_fvs = fvs1 `plusFV` fvs2
805 bndr_map = used_bndrs `zip` used_bndrs
806 -- See Note [GroupStmt binder map] in HsExpr
808 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
809 ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
812 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
814 rnParallelStmts :: forall thing. HsStmtContext Name
816 -> ([Name] -> RnM (thing, FreeVars))
817 -> RnM (([ParSeg Name], thing), FreeVars)
818 -- Note [Renaming parallel Stmts]
819 rnParallelStmts ctxt segs thing_inside
820 = do { orig_lcl_env <- getLocalRdrEnv
821 ; rn_segs orig_lcl_env [] segs }
823 rn_segs :: LocalRdrEnv
824 -> [Name] -> [ParSeg RdrName]
825 -> RnM (([ParSeg Name], thing), FreeVars)
826 rn_segs _ bndrs_so_far []
827 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
829 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
830 ; return (([], thing), fvs) }
832 rn_segs env bndrs_so_far ((stmts,_) : segs)
833 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
834 <- rnStmts ctxt stmts $ \ bndrs ->
835 setLocalRdrEnv env $ do
836 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
837 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
838 ; return ((used_bndrs, segs', thing), fvs) }
840 ; let seg' = (stmts', used_bndrs)
841 ; return ((seg':segs', thing), fvs) }
843 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
844 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
845 <+> quotes (ppr (head vs)))
848 Note [Renaming parallel Stmts]
849 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
850 Renaming parallel statements is painful. Given, say
851 [ a+c | a <- as, bs <- bss
854 (a) In order to report "Defined by not used" about 'bs', we must rename
855 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
857 (b) We want to report that 'a' is illegally bound in both branches
859 (c) The 'bs' in the second group must obviously not be captured by
860 the binding in the first group
862 To satisfy (a) we nest the segements.
863 To satisfy (b) we check for duplicates just before thing_inside.
864 To satisfy (c) we reset the LocalRdrEnv each time.
866 %************************************************************************
868 \subsubsection{mdo expressions}
870 %************************************************************************
873 type FwdRefs = NameSet
874 type Segment stmts = (Defs,
875 Uses, -- May include defs
876 FwdRefs, -- A subset of uses that are
877 -- (a) used before they are bound in this segment, or
878 -- (b) used here, and bound in subsequent segments
879 stmts) -- Either Stmt or [Stmt]
882 -- wrapper that does both the left- and right-hand sides
883 rnRecStmtsAndThen :: [LStmt RdrName]
884 -- assumes that the FreeVars returned includes
885 -- the FreeVars of the Segments
886 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
888 rnRecStmtsAndThen s cont
889 = do { -- (A) Make the mini fixity env for all of the stmts
890 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
893 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
895 -- ...bring them and their fixities into scope
896 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
897 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
898 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
899 ; bindLocalNamesFV bound_names $
900 addLocalFixities fix_env bound_names $ do
902 -- (C) do the right-hand-sides and thing-inside
903 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
904 ; (res, fvs) <- cont segs
905 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
906 ; return (res, fvs) }}
908 -- get all the fixity decls in any Let stmt
909 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
910 collectRecStmtsFixities l =
911 foldr (\ s -> \acc -> case s of
912 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
913 foldr (\ sig -> \ acc -> case sig of
914 (L loc (FixSig s)) -> (L loc s) : acc
920 rn_rec_stmt_lhs :: MiniFixityEnv
922 -- rename LHS, and return its FVs
923 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
924 -- so we don't bother to compute it accurately in the other cases
925 -> RnM [(LStmtLR Name RdrName, FreeVars)]
927 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
928 -- this is actually correct
931 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
933 -- should the ctxt be MDo instead?
934 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
935 return [(L loc (BindStmt pat' expr a b),
938 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
939 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
941 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
942 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
943 return [(L loc (LetStmt (HsValBinds binds')),
944 -- Warning: this is bogus; see function invariant
948 -- XXX Do we need to do something with the return and mfix names?
949 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
950 = rn_rec_stmts_lhs fix_env stmts
952 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
953 = pprPanic "rn_rec_stmt" (ppr stmt)
955 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
956 = pprPanic "rn_rec_stmt" (ppr stmt)
958 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
959 = pprPanic "rn_rec_stmt" (ppr stmt)
961 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
962 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
964 rn_rec_stmts_lhs :: MiniFixityEnv
966 -> RnM [(LStmtLR Name RdrName, FreeVars)]
967 rn_rec_stmts_lhs fix_env stmts
968 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
969 ; let boundNames = collectLStmtsBinders (map fst ls)
970 -- First do error checking: we need to check for dups here because we
971 -- don't bind all of the variables from the Stmt at once
972 -- with bindLocatedLocals.
973 ; checkDupNames boundNames
979 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
980 -- Rename a Stmt that is inside a RecStmt (or mdo)
981 -- Assumes all binders are already in scope
982 -- Turns each stmt into a singleton Stmt
983 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
984 = rnLExpr expr `thenM` \ (expr', fvs) ->
985 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
986 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
987 L loc (ExprStmt expr' then_op placeHolderType))]
989 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
990 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
991 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
992 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
994 bndrs = mkNameSet (collectPatBinders pat')
995 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
997 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
998 L loc (BindStmt pat' expr' bind_op fail_op))]
1000 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1001 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1003 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1004 (binds', du_binds) <-
1005 -- fixities and unused are handled above in rnRecStmtsAndThen
1006 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1007 return [(duDefs du_binds, allUses du_binds,
1008 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1010 -- no RecStmt case becuase they get flattened above when doing the LHSes
1011 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1012 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1014 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1015 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1017 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1018 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1020 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1021 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1023 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1024 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1026 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1027 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1028 return (concat segs_s)
1030 ---------------------------------------------
1031 addFwdRefs :: [Segment a] -> [Segment a]
1032 -- So far the segments only have forward refs *within* the Stmt
1033 -- (which happens for bind: x <- ...x...)
1034 -- This function adds the cross-seg fwd ref info
1037 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1039 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1040 = (new_seg : segs, all_defs)
1042 new_seg = (defs, uses, new_fwds, stmts)
1043 all_defs = later_defs `unionNameSets` defs
1044 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1045 -- Add the downstream fwd refs here
1047 ----------------------------------------------------
1048 -- Glomming the singleton segments of an mdo into
1049 -- minimal recursive groups.
1051 -- At first I thought this was just strongly connected components, but
1052 -- there's an important constraint: the order of the stmts must not change.
1055 -- mdo { x <- ...y...
1062 -- Here, the first stmt mention 'y', which is bound in the third.
1063 -- But that means that the innocent second stmt (p <- z) gets caught
1064 -- up in the recursion. And that in turn means that the binding for
1065 -- 'z' has to be included... and so on.
1067 -- Start at the tail { r <- x }
1068 -- Now add the next one { z <- y ; r <- x }
1069 -- Now add one more { q <- x ; z <- y ; r <- x }
1070 -- Now one more... but this time we have to group a bunch into rec
1071 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1072 -- Now one more, which we can add on without a rec
1074 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1076 -- Finally we add the last one; since it mentions y we have to
1077 -- glom it togeher with the first two groups
1078 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1079 -- q <- x ; z <- y } ;
1082 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1084 glomSegments [] = []
1085 glomSegments ((defs,uses,fwds,stmt) : segs)
1086 -- Actually stmts will always be a singleton
1087 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1089 segs' = glomSegments segs
1090 (extras, others) = grab uses segs'
1091 (ds, us, fs, ss) = unzip4 extras
1093 seg_defs = plusFVs ds `plusFV` defs
1094 seg_uses = plusFVs us `plusFV` uses
1095 seg_fwds = plusFVs fs `plusFV` fwds
1096 seg_stmts = stmt : concat ss
1098 grab :: NameSet -- The client
1100 -> ([Segment a], -- Needed by the 'client'
1101 [Segment a]) -- Not needed by the client
1102 -- The result is simply a split of the input
1104 = (reverse yeses, reverse noes)
1106 (noes, yeses) = span not_needed (reverse dus)
1107 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1110 ----------------------------------------------------
1111 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1112 -> [Segment [LStmt Name]]
1113 -> FreeVars -- Free vars used 'later'
1114 -> ([LStmt Name], FreeVars)
1116 segsToStmts _ [] fvs_later = ([], fvs_later)
1117 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1118 = ASSERT( not (null ss) )
1119 (new_stmt : later_stmts, later_uses `plusFV` uses)
1121 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1122 new_stmt | non_rec = head ss
1123 | otherwise = L (getLoc (head ss)) rec_stmt
1124 rec_stmt = empty_rec_stmt { recS_stmts = ss
1125 , recS_later_ids = nameSetToList used_later
1126 , recS_rec_ids = nameSetToList fwds }
1127 non_rec = isSingleton ss && isEmptyNameSet fwds
1128 used_later = defs `intersectNameSet` later_uses
1129 -- The ones needed after the RecStmt
1132 %************************************************************************
1134 \subsubsection{Assertion utils}
1136 %************************************************************************
1139 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1140 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1142 mkAssertErrorExpr :: RnM (HsExpr Name)
1143 -- Return an expression for (assertError "Foo.hs:27")
1145 = getSrcSpanM `thenM` \ sloc ->
1146 return (HsApp (L sloc (HsVar assertErrorName))
1147 (L sloc (srcSpanPrimLit sloc)))
1150 Note [Adding the implicit parameter to 'assert']
1151 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1152 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1153 By doing this in the renamer we allow the typechecker to just see the
1154 expanded application and do the right thing. But it's not really
1155 the Right Thing because there's no way to "undo" if you want to see
1156 the original source code. We'll have fix this in due course, when
1157 we care more about being able to reconstruct the exact original
1160 %************************************************************************
1162 \subsubsection{Errors}
1164 %************************************************************************
1168 ----------------------
1169 -- Checking when a particular Stmt is ok
1170 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1171 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1172 checkLetStmt _ctxt _binds = return ()
1173 -- We do not allow implicit-parameter bindings in a parallel
1174 -- list comprehension. I'm not sure what it might mean.
1177 checkRecStmt :: HsStmtContext Name -> RnM ()
1178 checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
1179 checkRecStmt DoExpr = return () -- and in 'do'
1180 checkRecStmt ctxt = addErr msg
1182 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1185 checkParStmt :: HsStmtContext Name -> RnM ()
1187 = do { parallel_list_comp <- xoptM Opt_ParallelListComp
1188 ; checkErr parallel_list_comp msg }
1190 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1193 checkTransformStmt :: HsStmtContext Name -> RnM ()
1194 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1195 -- desugarer will break when we come to operate on a parallel array
1196 = do { transform_list_comp <- xoptM Opt_TransformListComp
1197 ; checkErr transform_list_comp msg }
1199 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1200 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1201 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1202 checkTransformStmt ctxt = addErr msg
1204 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1207 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1208 checkTupleSection args
1209 = do { tuple_section <- xoptM Opt_TupleSections
1210 ; checkErr (all tupArgPresent args || tuple_section) msg }
1212 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1215 sectionErr :: HsExpr RdrName -> SDoc
1217 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1218 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1220 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1221 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1223 ; return (EWildPat, emptyFVs) }
1225 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1226 badIpBinds what binds
1227 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)