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 ; rebind <- xoptM Opt_RebindableSyntax
298 then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
299 else do { hetMetLevel <- getHetMetLevel
300 ; n <- lookupOccRn $ mkRdrUnqual $ setOccNameDepth (length hetMetLevel) (mkVarOccFS (fsLit "ifThenElse"))
301 ; c <- return $ HsVar n
302 ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
305 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
306 return (HsType t, fvT)
308 doc = text "In a type argument"
310 rnExpr (ArithSeq _ seq)
311 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
312 return (ArithSeq noPostTcExpr new_seq, fvs)
314 rnExpr (PArrSeq _ seq)
315 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
316 return (PArrSeq noPostTcExpr new_seq, fvs)
319 These three are pattern syntax appearing in expressions.
320 Since all the symbols are reservedops we can simply reject them.
321 We return a (bogus) EWildPat in each case.
324 rnExpr e@EWildPat = patSynErr e
325 rnExpr e@(EAsPat {}) = patSynErr e
326 rnExpr e@(EViewPat {}) = patSynErr e
327 rnExpr e@(ELazyPat {}) = patSynErr e
330 %************************************************************************
334 %************************************************************************
337 rnExpr (HsProc pat body)
339 rnPat ProcExpr pat $ \ pat' ->
340 rnCmdTop body `thenM` \ (body',fvBody) ->
341 return (HsProc pat' body', fvBody)
343 rnExpr (HsArrApp arrow arg _ ho rtl)
344 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
345 rnLExpr arg `thenM` \ (arg',fvArg) ->
346 return (HsArrApp arrow' arg' placeHolderType ho rtl,
347 fvArrow `plusFV` fvArg)
349 select_arrow_scope tc = case ho of
350 HsHigherOrderApp -> tc
351 HsFirstOrderApp -> escapeArrowScope tc
354 rnExpr (HsArrForm op (Just _) [arg1, arg2])
355 = escapeArrowScope (rnLExpr op)
356 `thenM` \ (op',fv_op) ->
357 let L _ (HsVar op_name) = op' in
358 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
359 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
363 lookupFixityRn op_name `thenM` \ fixity ->
364 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
367 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
369 rnExpr (HsArrForm op fixity cmds)
370 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
371 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
372 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
374 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
377 ----------------------
378 -- See Note [Parsing sections] in Parser.y.pp
379 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
380 rnSection section@(SectionR op expr)
381 = do { (op', fvs_op) <- rnLExpr op
382 ; (expr', fvs_expr) <- rnLExpr expr
383 ; checkSectionPrec InfixR section op' expr'
384 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
386 rnSection section@(SectionL expr op)
387 = do { (expr', fvs_expr) <- rnLExpr expr
388 ; (op', fvs_op) <- rnLExpr op
389 ; checkSectionPrec InfixL section op' expr'
390 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
392 rnSection other = pprPanic "rnSection" (ppr other)
395 %************************************************************************
399 %************************************************************************
402 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
403 -> RnM (HsRecordBinds Name, FreeVars)
404 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
405 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
406 ; (flds', fvss) <- mapAndUnzipM rn_field flds
407 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
408 fvs `plusFV` plusFVs fvss) }
410 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
411 ; return (fld { hsRecFieldArg = arg' }, fvs) }
415 %************************************************************************
419 %************************************************************************
422 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
423 rnCmdArgs [] = return ([], emptyFVs)
425 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
426 rnCmdArgs args `thenM` \ (args',fvArgs) ->
427 return (arg':args', fvArg `plusFV` fvArgs)
429 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
430 rnCmdTop = wrapLocFstM rnCmdTop'
432 rnCmdTop' (HsCmdTop cmd _ _ _)
433 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
435 cmd_names = [arrAName, composeAName, firstAName] ++
436 nameSetToList (methodNamesCmd (unLoc cmd'))
438 -- Generate the rebindable syntax for the monad
439 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
441 return (HsCmdTop cmd' [] placeHolderType cmd_names',
442 fvCmd `plusFV` cmd_fvs)
444 ---------------------------------------------------
445 -- convert OpApp's in a command context to HsArrForm's
447 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
448 convertOpFormsLCmd = fmap convertOpFormsCmd
450 convertOpFormsCmd :: HsCmd id -> HsCmd id
452 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
453 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
454 convertOpFormsCmd (OpApp c1 op fixity c2)
456 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
457 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
459 HsArrForm op (Just fixity) [arg1, arg2]
461 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
463 convertOpFormsCmd (HsCase exp matches)
464 = HsCase exp (convertOpFormsMatch matches)
466 convertOpFormsCmd (HsIf f exp c1 c2)
467 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
469 convertOpFormsCmd (HsLet binds cmd)
470 = HsLet binds (convertOpFormsLCmd cmd)
472 convertOpFormsCmd (HsDo ctxt stmts body ty)
473 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
474 (convertOpFormsLCmd body) ty
476 -- Anything else is unchanged. This includes HsArrForm (already done),
477 -- things with no sub-commands, and illegal commands (which will be
478 -- caught by the type checker)
479 convertOpFormsCmd c = c
481 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
482 convertOpFormsStmt (BindStmt pat cmd _ _)
483 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
484 convertOpFormsStmt (ExprStmt cmd _ _)
485 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
486 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
487 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
488 convertOpFormsStmt stmt = stmt
490 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
491 convertOpFormsMatch (MatchGroup ms ty)
492 = MatchGroup (map (fmap convert) ms) ty
493 where convert (Match pat mty grhss)
494 = Match pat mty (convertOpFormsGRHSs grhss)
496 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
497 convertOpFormsGRHSs (GRHSs grhss binds)
498 = GRHSs (map convertOpFormsGRHS grhss) binds
500 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
501 convertOpFormsGRHS = fmap convert
503 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
505 ---------------------------------------------------
506 type CmdNeeds = FreeVars -- Only inhabitants are
507 -- appAName, choiceAName, loopAName
509 -- find what methods the Cmd needs (loop, choice, apply)
510 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
511 methodNamesLCmd = methodNamesCmd . unLoc
513 methodNamesCmd :: HsCmd Name -> CmdNeeds
515 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
517 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
519 methodNamesCmd (HsArrForm {}) = emptyFVs
521 methodNamesCmd (HsPar c) = methodNamesLCmd c
523 methodNamesCmd (HsIf _ _ c1 c2)
524 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
526 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
528 methodNamesCmd (HsDo _ stmts body _)
529 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
531 methodNamesCmd (HsApp c _) = methodNamesLCmd c
533 methodNamesCmd (HsLam match) = methodNamesMatch match
535 methodNamesCmd (HsCase _ matches)
536 = methodNamesMatch matches `addOneFV` choiceAName
538 methodNamesCmd _ = emptyFVs
539 -- Other forms can't occur in commands, but it's not convenient
540 -- to error here so we just do what's convenient.
541 -- The type checker will complain later
543 ---------------------------------------------------
544 methodNamesMatch :: MatchGroup Name -> FreeVars
545 methodNamesMatch (MatchGroup ms _)
546 = plusFVs (map do_one ms)
548 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
550 -------------------------------------------------
552 methodNamesGRHSs :: GRHSs Name -> FreeVars
553 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
555 -------------------------------------------------
557 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
558 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
560 ---------------------------------------------------
561 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
562 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
564 ---------------------------------------------------
565 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
566 methodNamesLStmt = methodNamesStmt . unLoc
568 methodNamesStmt :: StmtLR Name Name -> FreeVars
569 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
570 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
571 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
572 methodNamesStmt (LetStmt _) = emptyFVs
573 methodNamesStmt (ParStmt _) = emptyFVs
574 methodNamesStmt (TransformStmt {}) = emptyFVs
575 methodNamesStmt (GroupStmt {}) = emptyFVs
576 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
577 -- here so we just do what's convenient
581 %************************************************************************
585 %************************************************************************
588 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
589 rnArithSeq (From expr)
590 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
591 return (From expr', fvExpr)
593 rnArithSeq (FromThen expr1 expr2)
594 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
595 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
596 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
598 rnArithSeq (FromTo expr1 expr2)
599 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
600 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
601 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
603 rnArithSeq (FromThenTo expr1 expr2 expr3)
604 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
605 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
606 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
607 return (FromThenTo expr1' expr2' expr3',
608 plusFVs [fvExpr1, fvExpr2, fvExpr3])
611 %************************************************************************
613 Template Haskell brackets
615 %************************************************************************
618 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
619 rnBracket (VarBr n) = do { name <- lookupOccRn n
620 ; this_mod <- getModule
621 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
622 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
623 ; return () } -- only way that is going to happen
624 ; return (VarBr name, unitFV name) }
626 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
628 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
629 ; return (ExpBr e', fvs) }
631 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
633 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
634 ; return (TypBr t', fvs) }
636 doc = ptext (sLit "In a Template-Haskell quoted type")
638 rnBracket (DecBrL decls)
639 = do { (group, mb_splice) <- findSplice decls
642 Just (SpliceDecl (L loc _) _, _)
644 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
645 -- Why not? See Section 7.3 of the TH paper.
647 ; gbl_env <- getGblEnv
648 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
649 -- The emptyDUs is so that we just collect uses for this
650 -- group alone in the call to rnSrcDecls below
651 ; (tcg_env, group') <- setGblEnv new_gbl_env $
655 -- Discard the tcg_env; it contains only extra info about fixity
656 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
657 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
659 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
662 %************************************************************************
664 \subsubsection{@Stmt@s: in @do@ expressions}
666 %************************************************************************
669 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
670 -> ([Name] -> RnM (thing, FreeVars))
671 -> RnM (([LStmt Name], thing), FreeVars)
672 -- Variables bound by the Stmts, and mentioned in thing_inside,
673 -- do not appear in the result FreeVars
675 -- Renaming a single RecStmt can give a sequence of smaller Stmts
677 rnStmts _ [] thing_inside
678 = do { (res, fvs) <- thing_inside []
679 ; return (([], res), fvs) }
681 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
682 = do { ((stmts1, (stmts2, thing)), fvs)
684 rnStmt ctxt stmt $ \ bndrs1 ->
685 rnStmts ctxt stmts $ \ bndrs2 ->
686 thing_inside (bndrs1 ++ bndrs2)
687 ; return (((stmts1 ++ stmts2), thing), fvs) }
690 rnStmt :: HsStmtContext Name -> LStmt RdrName
691 -> ([Name] -> RnM (thing, FreeVars))
692 -> RnM (([LStmt Name], thing), FreeVars)
693 -- Variables bound by the Stmt, and mentioned in thing_inside,
694 -- do not appear in the result FreeVars
696 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
697 = do { (expr', fv_expr) <- rnLExpr expr
698 ; (then_op, fvs1) <- lookupSyntaxName thenMName
699 ; (thing, fvs2) <- thing_inside []
700 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
701 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
703 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
704 = do { (expr', fv_expr) <- rnLExpr expr
705 -- The binders do not scope over the expression
706 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
707 ; (fail_op, fvs2) <- lookupSyntaxName failMName
708 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
709 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
710 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
711 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
712 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
713 -- but it does not matter because the names are unique
715 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
716 = do { checkLetStmt ctxt binds
717 ; rnLocalBindsAndThen binds $ \binds' -> do
718 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
719 ; return (([L loc (LetStmt binds')], thing), fvs) } }
721 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
722 = do { checkRecStmt ctxt
724 -- Step1: Bring all the binders of the mdo into scope
725 -- (Remember that this also removes the binders from the
726 -- finally-returned free-vars.)
727 -- And rename each individual stmt, making a
728 -- singleton segment. At this stage the FwdRefs field
729 -- isn't finished: it's empty for all except a BindStmt
730 -- for which it's the fwd refs within the bind itself
731 -- (This set may not be empty, because we're in a recursive
733 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
735 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
737 ; (thing, fvs_later) <- thing_inside bndrs
738 ; (return_op, fvs1) <- lookupSyntaxName returnMName
739 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
740 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
742 -- Step 2: Fill in the fwd refs.
743 -- The segments are all singletons, but their fwd-ref
744 -- field mentions all the things used by the segment
745 -- that are bound after their use
746 segs_w_fwd_refs = addFwdRefs segs
748 -- Step 3: Group together the segments to make bigger segments
749 -- Invariant: in the result, no segment uses a variable
750 -- bound in a later segment
751 grouped_segs = glomSegments segs_w_fwd_refs
753 -- Step 4: Turn the segments into Stmts
754 -- Use RecStmt when and only when there are fwd refs
755 -- Also gather up the uses from the end towards the
756 -- start, so we can tell the RecStmt which things are
757 -- used 'after' the RecStmt
758 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
759 , recS_mfix_fn = mfix_op
760 , recS_bind_fn = bind_op }
761 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
763 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
765 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
766 = do { checkParStmt ctxt
767 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
768 ; return (([L loc (ParStmt segs')], thing), fvs) }
770 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
771 = do { checkTransformStmt ctxt
773 ; (using', fvs1) <- rnLExpr using
775 ; ((stmts', (by', used_bndrs, thing)), fvs2)
776 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
777 do { (by', fvs_by) <- case by of
778 Nothing -> return (Nothing, emptyFVs)
779 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
780 ; (thing, fvs_thing) <- thing_inside bndrs
781 ; let fvs = fvs_by `plusFV` fvs_thing
782 used_bndrs = filter (`elemNameSet` fvs) bndrs
783 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
784 -- the "thing inside", **or of the by-expression**, as used
785 ; return ((by', used_bndrs, thing), fvs) }
787 ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
788 fvs1 `plusFV` fvs2) }
790 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
791 = do { checkTransformStmt ctxt
793 -- Rename the 'using' expression in the context before the transform is begun
794 ; (using', fvs1) <- case using of
795 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
796 Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
797 ; return (Right e', fvs) }
799 -- Rename the stmts and the 'by' expression
800 -- Keep track of the variables mentioned in the 'by' expression
801 ; ((stmts', (by', used_bndrs, thing)), fvs2)
802 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
803 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
804 ; (thing, fvs_thing) <- thing_inside bndrs
805 ; let fvs = fvs_by `plusFV` fvs_thing
806 used_bndrs = filter (`elemNameSet` fvs) bndrs
807 ; return ((by', used_bndrs, thing), fvs) }
809 ; let all_fvs = fvs1 `plusFV` fvs2
810 bndr_map = used_bndrs `zip` used_bndrs
811 -- See Note [GroupStmt binder map] in HsExpr
813 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
814 ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
817 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
819 rnParallelStmts :: forall thing. HsStmtContext Name
821 -> ([Name] -> RnM (thing, FreeVars))
822 -> RnM (([ParSeg Name], thing), FreeVars)
823 -- Note [Renaming parallel Stmts]
824 rnParallelStmts ctxt segs thing_inside
825 = do { orig_lcl_env <- getLocalRdrEnv
826 ; rn_segs orig_lcl_env [] segs }
828 rn_segs :: LocalRdrEnv
829 -> [Name] -> [ParSeg RdrName]
830 -> RnM (([ParSeg Name], thing), FreeVars)
831 rn_segs _ bndrs_so_far []
832 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
834 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
835 ; return (([], thing), fvs) }
837 rn_segs env bndrs_so_far ((stmts,_) : segs)
838 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
839 <- rnStmts ctxt stmts $ \ bndrs ->
840 setLocalRdrEnv env $ do
841 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
842 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
843 ; return ((used_bndrs, segs', thing), fvs) }
845 ; let seg' = (stmts', used_bndrs)
846 ; return ((seg':segs', thing), fvs) }
848 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
849 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
850 <+> quotes (ppr (head vs)))
853 Note [Renaming parallel Stmts]
854 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
855 Renaming parallel statements is painful. Given, say
856 [ a+c | a <- as, bs <- bss
859 (a) In order to report "Defined by not used" about 'bs', we must rename
860 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
862 (b) We want to report that 'a' is illegally bound in both branches
864 (c) The 'bs' in the second group must obviously not be captured by
865 the binding in the first group
867 To satisfy (a) we nest the segements.
868 To satisfy (b) we check for duplicates just before thing_inside.
869 To satisfy (c) we reset the LocalRdrEnv each time.
871 %************************************************************************
873 \subsubsection{mdo expressions}
875 %************************************************************************
878 type FwdRefs = NameSet
879 type Segment stmts = (Defs,
880 Uses, -- May include defs
881 FwdRefs, -- A subset of uses that are
882 -- (a) used before they are bound in this segment, or
883 -- (b) used here, and bound in subsequent segments
884 stmts) -- Either Stmt or [Stmt]
887 -- wrapper that does both the left- and right-hand sides
888 rnRecStmtsAndThen :: [LStmt RdrName]
889 -- assumes that the FreeVars returned includes
890 -- the FreeVars of the Segments
891 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
893 rnRecStmtsAndThen s cont
894 = do { -- (A) Make the mini fixity env for all of the stmts
895 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
898 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
900 -- ...bring them and their fixities into scope
901 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
902 ; bindLocalNamesFV bound_names $
903 addLocalFixities fix_env bound_names $ do
905 -- (C) do the right-hand-sides and thing-inside
906 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
907 ; (res, fvs) <- cont segs
908 ; warnUnusedLocalBinds bound_names fvs
909 ; return (res, fvs) }}
911 -- get all the fixity decls in any Let stmt
912 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
913 collectRecStmtsFixities l =
914 foldr (\ s -> \acc -> case s of
915 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
916 foldr (\ sig -> \ acc -> case sig of
917 (L loc (FixSig s)) -> (L loc s) : acc
923 rn_rec_stmt_lhs :: MiniFixityEnv
925 -- rename LHS, and return its FVs
926 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
927 -- so we don't bother to compute it accurately in the other cases
928 -> RnM [(LStmtLR Name RdrName, FreeVars)]
930 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
931 -- this is actually correct
934 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
936 -- should the ctxt be MDo instead?
937 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
938 return [(L loc (BindStmt pat' expr a b),
941 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
942 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
944 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
945 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
946 return [(L loc (LetStmt (HsValBinds binds')),
947 -- Warning: this is bogus; see function invariant
951 -- XXX Do we need to do something with the return and mfix names?
952 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
953 = rn_rec_stmts_lhs fix_env stmts
955 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
956 = pprPanic "rn_rec_stmt" (ppr stmt)
958 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
959 = pprPanic "rn_rec_stmt" (ppr stmt)
961 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
962 = pprPanic "rn_rec_stmt" (ppr stmt)
964 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
965 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
967 rn_rec_stmts_lhs :: MiniFixityEnv
969 -> RnM [(LStmtLR Name RdrName, FreeVars)]
970 rn_rec_stmts_lhs fix_env stmts
971 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
972 ; let boundNames = collectLStmtsBinders (map fst ls)
973 -- First do error checking: we need to check for dups here because we
974 -- don't bind all of the variables from the Stmt at once
975 -- with bindLocatedLocals.
976 ; checkDupNames boundNames
982 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
983 -- Rename a Stmt that is inside a RecStmt (or mdo)
984 -- Assumes all binders are already in scope
985 -- Turns each stmt into a singleton Stmt
986 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
987 = rnLExpr expr `thenM` \ (expr', fvs) ->
988 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
989 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
990 L loc (ExprStmt expr' then_op placeHolderType))]
992 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
993 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
994 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
995 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
997 bndrs = mkNameSet (collectPatBinders pat')
998 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1000 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1001 L loc (BindStmt pat' expr' bind_op fail_op))]
1003 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1004 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1006 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1007 (binds', du_binds) <-
1008 -- fixities and unused are handled above in rnRecStmtsAndThen
1009 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1010 return [(duDefs du_binds, allUses du_binds,
1011 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1013 -- no RecStmt case becuase they get flattened above when doing the LHSes
1014 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1015 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1017 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1018 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1020 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1021 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1023 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1024 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1026 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1027 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1029 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1030 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1031 return (concat segs_s)
1033 ---------------------------------------------
1034 addFwdRefs :: [Segment a] -> [Segment a]
1035 -- So far the segments only have forward refs *within* the Stmt
1036 -- (which happens for bind: x <- ...x...)
1037 -- This function adds the cross-seg fwd ref info
1040 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1042 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1043 = (new_seg : segs, all_defs)
1045 new_seg = (defs, uses, new_fwds, stmts)
1046 all_defs = later_defs `unionNameSets` defs
1047 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1048 -- Add the downstream fwd refs here
1050 ----------------------------------------------------
1051 -- Glomming the singleton segments of an mdo into
1052 -- minimal recursive groups.
1054 -- At first I thought this was just strongly connected components, but
1055 -- there's an important constraint: the order of the stmts must not change.
1058 -- mdo { x <- ...y...
1065 -- Here, the first stmt mention 'y', which is bound in the third.
1066 -- But that means that the innocent second stmt (p <- z) gets caught
1067 -- up in the recursion. And that in turn means that the binding for
1068 -- 'z' has to be included... and so on.
1070 -- Start at the tail { r <- x }
1071 -- Now add the next one { z <- y ; r <- x }
1072 -- Now add one more { q <- x ; z <- y ; r <- x }
1073 -- Now one more... but this time we have to group a bunch into rec
1074 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1075 -- Now one more, which we can add on without a rec
1077 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1079 -- Finally we add the last one; since it mentions y we have to
1080 -- glom it togeher with the first two groups
1081 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1082 -- q <- x ; z <- y } ;
1085 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1087 glomSegments [] = []
1088 glomSegments ((defs,uses,fwds,stmt) : segs)
1089 -- Actually stmts will always be a singleton
1090 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1092 segs' = glomSegments segs
1093 (extras, others) = grab uses segs'
1094 (ds, us, fs, ss) = unzip4 extras
1096 seg_defs = plusFVs ds `plusFV` defs
1097 seg_uses = plusFVs us `plusFV` uses
1098 seg_fwds = plusFVs fs `plusFV` fwds
1099 seg_stmts = stmt : concat ss
1101 grab :: NameSet -- The client
1103 -> ([Segment a], -- Needed by the 'client'
1104 [Segment a]) -- Not needed by the client
1105 -- The result is simply a split of the input
1107 = (reverse yeses, reverse noes)
1109 (noes, yeses) = span not_needed (reverse dus)
1110 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1113 ----------------------------------------------------
1114 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1115 -> [Segment [LStmt Name]]
1116 -> FreeVars -- Free vars used 'later'
1117 -> ([LStmt Name], FreeVars)
1119 segsToStmts _ [] fvs_later = ([], fvs_later)
1120 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1121 = ASSERT( not (null ss) )
1122 (new_stmt : later_stmts, later_uses `plusFV` uses)
1124 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1125 new_stmt | non_rec = head ss
1126 | otherwise = L (getLoc (head ss)) rec_stmt
1127 rec_stmt = empty_rec_stmt { recS_stmts = ss
1128 , recS_later_ids = nameSetToList used_later
1129 , recS_rec_ids = nameSetToList fwds }
1130 non_rec = isSingleton ss && isEmptyNameSet fwds
1131 used_later = defs `intersectNameSet` later_uses
1132 -- The ones needed after the RecStmt
1135 %************************************************************************
1137 \subsubsection{Assertion utils}
1139 %************************************************************************
1142 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1143 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1145 mkAssertErrorExpr :: RnM (HsExpr Name)
1146 -- Return an expression for (assertError "Foo.hs:27")
1148 = getSrcSpanM `thenM` \ sloc ->
1149 return (HsApp (L sloc (HsVar assertErrorName))
1150 (L sloc (srcSpanPrimLit sloc)))
1153 Note [Adding the implicit parameter to 'assert']
1154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1155 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1156 By doing this in the renamer we allow the typechecker to just see the
1157 expanded application and do the right thing. But it's not really
1158 the Right Thing because there's no way to "undo" if you want to see
1159 the original source code. We'll have fix this in due course, when
1160 we care more about being able to reconstruct the exact original
1163 %************************************************************************
1165 \subsubsection{Errors}
1167 %************************************************************************
1171 ----------------------
1172 -- Checking when a particular Stmt is ok
1173 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1174 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1175 checkLetStmt _ctxt _binds = return ()
1176 -- We do not allow implicit-parameter bindings in a parallel
1177 -- list comprehension. I'm not sure what it might mean.
1180 checkRecStmt :: HsStmtContext Name -> RnM ()
1181 checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
1182 checkRecStmt DoExpr = return () -- and in 'do'
1183 checkRecStmt ctxt = addErr msg
1185 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1188 checkParStmt :: HsStmtContext Name -> RnM ()
1190 = do { parallel_list_comp <- xoptM Opt_ParallelListComp
1191 ; checkErr parallel_list_comp msg }
1193 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1196 checkTransformStmt :: HsStmtContext Name -> RnM ()
1197 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1198 -- desugarer will break when we come to operate on a parallel array
1199 = do { transform_list_comp <- xoptM Opt_TransformListComp
1200 ; checkErr transform_list_comp msg }
1202 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1203 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1204 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1205 checkTransformStmt ctxt = addErr msg
1207 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1210 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1211 checkTupleSection args
1212 = do { tuple_section <- xoptM Opt_TupleSections
1213 ; checkErr (all tupArgPresent args || tuple_section) msg }
1215 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1218 sectionErr :: HsExpr RdrName -> SDoc
1220 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1221 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1223 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1224 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1226 ; return (EWildPat, emptyFVs) }
1228 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1229 badIpBinds what binds
1230 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)