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, rnValBindsLHS, rnValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
33 import DynFlags ( DynFlag(..) )
34 import BasicTypes ( FixityDirection(..) )
40 import LoadIface ( loadInterfaceForName )
43 import Util ( isSingleton )
44 import ListSetOps ( removeDups )
45 import Maybes ( expectJust )
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.
88 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
89 rnLExpr = wrapLocFstM rnExpr
91 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
93 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
94 -- Separated from rnExpr because it's also used
95 -- when renaming infix expressions
96 -- See Note [Adding the implicit parameter to 'assert']
98 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
99 ; if ignore_asserts || not (name `hasKey` assertIdKey)
100 then return (HsVar name, unitFV name)
101 else do { e <- mkAssertErrorExpr
102 ; return (e, unitFV name) } }
105 = do name <- lookupOccRn v
109 = newIPNameRn v `thenM` \ name ->
110 return (HsIPVar name, emptyFVs)
112 rnExpr (HsLit lit@(HsString s))
114 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
115 ; if opt_OverloadedStrings then
116 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
117 else -- Same as below
119 return (HsLit lit, emptyFVs)
124 return (HsLit lit, emptyFVs)
126 rnExpr (HsOverLit lit)
127 = rnOverLit lit `thenM` \ (lit', fvs) ->
128 return (HsOverLit lit', fvs)
130 rnExpr (HsApp fun arg)
131 = rnLExpr fun `thenM` \ (fun',fvFun) ->
132 rnLExpr arg `thenM` \ (arg',fvArg) ->
133 return (HsApp fun' arg', fvFun `plusFV` fvArg)
135 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
136 = do { (e1', fv_e1) <- rnLExpr e1
137 ; (e2', fv_e2) <- rnLExpr e2
138 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
139 ; (op', fv_op) <- finishHsVar op_name
140 -- NB: op' is usually just a variable, but might be
141 -- an applicatoin (assert "Foo.hs:47")
143 -- When renaming code synthesised from "deriving" declarations
144 -- we used to avoid fixity stuff, but we can't easily tell any
145 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
146 -- should prevent bad things happening.
147 ; fixity <- lookupFixityRn op_name
148 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
149 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
152 = rnLExpr e `thenM` \ (e', fv_e) ->
153 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
154 mkNegAppRn e' neg_name `thenM` \ final_e ->
155 return (final_e, fv_e `plusFV` fv_neg)
157 ------------------------------------------
158 -- Template Haskell extensions
159 -- Don't ifdef-GHCI them because we want to fail gracefully
160 -- (not with an rnExpr crash) in a stage-1 compiler.
161 rnExpr e@(HsBracket br_body)
162 = checkTH e "bracket" `thenM_`
163 rnBracket br_body `thenM` \ (body', fvs_e) ->
164 return (HsBracket body', fvs_e)
166 rnExpr (HsSpliceE splice)
167 = rnSplice splice `thenM` \ (splice', fvs) ->
168 return (HsSpliceE splice', fvs)
171 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
173 rnExpr (HsQuasiQuoteE qq)
174 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
178 ---------------------------------------------
180 -- See Note [Parsing sections] in Parser.y.pp
181 rnExpr (HsPar (L loc (section@(SectionL {}))))
182 = do { (section', fvs) <- rnSection section
183 ; return (HsPar (L loc section'), fvs) }
185 rnExpr (HsPar (L loc (section@(SectionR {}))))
186 = do { (section', fvs) <- rnSection section
187 ; return (HsPar (L loc section'), fvs) }
190 = do { (e', fvs_e) <- rnLExpr e
191 ; return (HsPar e', fvs_e) }
193 rnExpr expr@(SectionL {})
194 = do { addErr (sectionErr expr); rnSection expr }
195 rnExpr expr@(SectionR {})
196 = do { addErr (sectionErr expr); rnSection expr }
198 ---------------------------------------------
199 rnExpr (HsCoreAnn ann expr)
200 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
201 return (HsCoreAnn ann expr', fvs_expr)
203 rnExpr (HsSCC lbl expr)
204 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
205 return (HsSCC lbl expr', fvs_expr)
206 rnExpr (HsTickPragma info expr)
207 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
208 return (HsTickPragma info expr', fvs_expr)
210 rnExpr (HsLam matches)
211 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
212 return (HsLam matches', fvMatch)
214 rnExpr (HsCase expr matches)
215 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
216 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
217 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
219 rnExpr (HsLet binds expr)
220 = rnLocalBindsAndThen binds $ \ binds' ->
221 rnLExpr expr `thenM` \ (expr',fvExpr) ->
222 return (HsLet binds' expr', fvExpr)
224 rnExpr (HsDo do_or_lc stmts body _)
225 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
227 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
229 rnExpr (ExplicitList _ exps)
230 = rnExprs exps `thenM` \ (exps', fvs) ->
231 return (ExplicitList placeHolderType exps', fvs)
233 rnExpr (ExplicitPArr _ exps)
234 = rnExprs exps `thenM` \ (exps', fvs) ->
235 return (ExplicitPArr placeHolderType exps', fvs)
237 rnExpr (ExplicitTuple tup_args boxity)
238 = do { checkTupleSection tup_args
239 ; checkTupSize (length tup_args)
240 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
241 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
243 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
244 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
246 rnExpr (RecordCon con_id _ rbinds)
247 = do { conname <- lookupLocatedOccRn con_id
248 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
249 ; return (RecordCon conname noPostTcExpr rbinds',
250 fvRbinds `addOneFV` unLoc conname) }
252 rnExpr (RecordUpd expr rbinds _ _ _)
253 = do { (expr', fvExpr) <- rnLExpr expr
254 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
255 ; return (RecordUpd expr' rbinds' [] [] [],
256 fvExpr `plusFV` fvRbinds) }
258 rnExpr (ExprWithTySig expr pty)
259 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
260 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
262 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
264 doc = text "In an expression type signature"
266 rnExpr (HsIf p b1 b2)
267 = rnLExpr p `thenM` \ (p', fvP) ->
268 rnLExpr b1 `thenM` \ (b1', fvB1) ->
269 rnLExpr b2 `thenM` \ (b2', fvB2) ->
270 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
273 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
274 return (HsType t, fvT)
276 doc = text "In a type argument"
278 rnExpr (ArithSeq _ seq)
279 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
280 return (ArithSeq noPostTcExpr new_seq, fvs)
282 rnExpr (PArrSeq _ seq)
283 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
284 return (PArrSeq noPostTcExpr new_seq, fvs)
287 These three are pattern syntax appearing in expressions.
288 Since all the symbols are reservedops we can simply reject them.
289 We return a (bogus) EWildPat in each case.
292 rnExpr e@EWildPat = patSynErr e
293 rnExpr e@(EAsPat {}) = patSynErr e
294 rnExpr e@(EViewPat {}) = patSynErr e
295 rnExpr e@(ELazyPat {}) = patSynErr e
298 %************************************************************************
302 %************************************************************************
305 rnExpr (HsProc pat body)
307 rnPat ProcExpr pat $ \ pat' ->
308 rnCmdTop body `thenM` \ (body',fvBody) ->
309 return (HsProc pat' body', fvBody)
311 rnExpr (HsArrApp arrow arg _ ho rtl)
312 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
313 rnLExpr arg `thenM` \ (arg',fvArg) ->
314 return (HsArrApp arrow' arg' placeHolderType ho rtl,
315 fvArrow `plusFV` fvArg)
317 select_arrow_scope tc = case ho of
318 HsHigherOrderApp -> tc
319 HsFirstOrderApp -> escapeArrowScope tc
322 rnExpr (HsArrForm op (Just _) [arg1, arg2])
323 = escapeArrowScope (rnLExpr op)
324 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
325 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
326 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
330 lookupFixityRn op_name `thenM` \ fixity ->
331 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
334 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
336 rnExpr (HsArrForm op fixity cmds)
337 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
338 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
339 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
341 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
344 ----------------------
345 -- See Note [Parsing sections] in Parser.y.pp
346 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
347 rnSection section@(SectionR op expr)
348 = do { (op', fvs_op) <- rnLExpr op
349 ; (expr', fvs_expr) <- rnLExpr expr
350 ; checkSectionPrec InfixR section op' expr'
351 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
353 rnSection section@(SectionL expr op)
354 = do { (expr', fvs_expr) <- rnLExpr expr
355 ; (op', fvs_op) <- rnLExpr op
356 ; checkSectionPrec InfixL section op' expr'
357 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
359 rnSection other = pprPanic "rnSection" (ppr other)
362 %************************************************************************
366 %************************************************************************
369 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
370 -> RnM (HsRecordBinds Name, FreeVars)
371 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
372 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
373 ; (flds', fvss) <- mapAndUnzipM rn_field flds
374 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
375 fvs `plusFV` plusFVs fvss) }
377 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
378 ; return (fld { hsRecFieldArg = arg' }, fvs) }
382 %************************************************************************
386 %************************************************************************
389 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
390 rnCmdArgs [] = return ([], emptyFVs)
392 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
393 rnCmdArgs args `thenM` \ (args',fvArgs) ->
394 return (arg':args', fvArg `plusFV` fvArgs)
396 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
397 rnCmdTop = wrapLocFstM rnCmdTop'
399 rnCmdTop' (HsCmdTop cmd _ _ _)
400 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
402 cmd_names = [arrAName, composeAName, firstAName] ++
403 nameSetToList (methodNamesCmd (unLoc cmd'))
405 -- Generate the rebindable syntax for the monad
406 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
408 return (HsCmdTop cmd' [] placeHolderType cmd_names',
409 fvCmd `plusFV` cmd_fvs)
411 ---------------------------------------------------
412 -- convert OpApp's in a command context to HsArrForm's
414 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
415 convertOpFormsLCmd = fmap convertOpFormsCmd
417 convertOpFormsCmd :: HsCmd id -> HsCmd id
419 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
420 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
421 convertOpFormsCmd (OpApp c1 op fixity c2)
423 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
424 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
426 HsArrForm op (Just fixity) [arg1, arg2]
428 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
430 convertOpFormsCmd (HsCase exp matches)
431 = HsCase exp (convertOpFormsMatch matches)
433 convertOpFormsCmd (HsIf exp c1 c2)
434 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
436 convertOpFormsCmd (HsLet binds cmd)
437 = HsLet binds (convertOpFormsLCmd cmd)
439 convertOpFormsCmd (HsDo ctxt stmts body ty)
440 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
441 (convertOpFormsLCmd body) ty
443 -- Anything else is unchanged. This includes HsArrForm (already done),
444 -- things with no sub-commands, and illegal commands (which will be
445 -- caught by the type checker)
446 convertOpFormsCmd c = c
448 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
449 convertOpFormsStmt (BindStmt pat cmd _ _)
450 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
451 convertOpFormsStmt (ExprStmt cmd _ _)
452 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
453 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
454 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
455 convertOpFormsStmt stmt = stmt
457 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
458 convertOpFormsMatch (MatchGroup ms ty)
459 = MatchGroup (map (fmap convert) ms) ty
460 where convert (Match pat mty grhss)
461 = Match pat mty (convertOpFormsGRHSs grhss)
463 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
464 convertOpFormsGRHSs (GRHSs grhss binds)
465 = GRHSs (map convertOpFormsGRHS grhss) binds
467 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
468 convertOpFormsGRHS = fmap convert
470 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
472 ---------------------------------------------------
473 type CmdNeeds = FreeVars -- Only inhabitants are
474 -- appAName, choiceAName, loopAName
476 -- find what methods the Cmd needs (loop, choice, apply)
477 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
478 methodNamesLCmd = methodNamesCmd . unLoc
480 methodNamesCmd :: HsCmd Name -> CmdNeeds
482 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
484 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
486 methodNamesCmd (HsArrForm {}) = emptyFVs
488 methodNamesCmd (HsPar c) = methodNamesLCmd c
490 methodNamesCmd (HsIf _ c1 c2)
491 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
493 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
495 methodNamesCmd (HsDo _ stmts body _)
496 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
498 methodNamesCmd (HsApp c _) = methodNamesLCmd c
500 methodNamesCmd (HsLam match) = methodNamesMatch match
502 methodNamesCmd (HsCase _ matches)
503 = methodNamesMatch matches `addOneFV` choiceAName
505 methodNamesCmd _ = emptyFVs
506 -- Other forms can't occur in commands, but it's not convenient
507 -- to error here so we just do what's convenient.
508 -- The type checker will complain later
510 ---------------------------------------------------
511 methodNamesMatch :: MatchGroup Name -> FreeVars
512 methodNamesMatch (MatchGroup ms _)
513 = plusFVs (map do_one ms)
515 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
517 -------------------------------------------------
519 methodNamesGRHSs :: GRHSs Name -> FreeVars
520 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
522 -------------------------------------------------
524 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
525 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
527 ---------------------------------------------------
528 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
529 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
531 ---------------------------------------------------
532 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
533 methodNamesLStmt = methodNamesStmt . unLoc
535 methodNamesStmt :: StmtLR Name Name -> FreeVars
536 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
537 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
538 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
539 methodNamesStmt (LetStmt _) = emptyFVs
540 methodNamesStmt (ParStmt _) = emptyFVs
541 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
542 methodNamesStmt (GroupStmt _ _) = emptyFVs
543 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
544 -- here so we just do what's convenient
548 %************************************************************************
552 %************************************************************************
555 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
556 rnArithSeq (From expr)
557 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
558 return (From expr', fvExpr)
560 rnArithSeq (FromThen expr1 expr2)
561 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
562 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
563 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
565 rnArithSeq (FromTo expr1 expr2)
566 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
567 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
568 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
570 rnArithSeq (FromThenTo expr1 expr2 expr3)
571 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
572 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
573 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
574 return (FromThenTo expr1' expr2' expr3',
575 plusFVs [fvExpr1, fvExpr2, fvExpr3])
578 %************************************************************************
580 Template Haskell brackets
582 %************************************************************************
585 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
586 rnBracket (VarBr n) = do { name <- lookupOccRn n
587 ; this_mod <- getModule
588 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
589 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
590 ; return () } -- only way that is going to happen
591 ; return (VarBr name, unitFV name) }
593 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
595 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
596 ; return (ExpBr e', fvs) }
598 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
600 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
601 ; return (TypBr t', fvs) }
603 doc = ptext (sLit "In a Template-Haskell quoted type")
605 rnBracket (DecBrL decls)
606 = do { (group, mb_splice) <- findSplice decls
609 Just (SpliceDecl (L loc _), _)
611 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
612 -- Why not? See Section 7.3 of the TH paper.
614 ; gbl_env <- getGblEnv
615 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
616 -- The emptyDUs is so that we just collect uses for this
617 -- group alone in the call to rnSrcDecls below
618 ; (tcg_env, group') <- setGblEnv new_gbl_env $
622 -- Discard the tcg_env; it contains only extra info about fixity
623 ; return (DecBrG group', allUses (tcg_dus tcg_env)) }
625 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
628 %************************************************************************
630 \subsubsection{@Stmt@s: in @do@ expressions}
632 %************************************************************************
635 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
636 -> RnM (thing, FreeVars)
637 -> RnM (([LStmt Name], thing), FreeVars)
639 rnStmts (MDoExpr _) = rnMDoStmts
640 rnStmts ctxt = rnNormalStmts ctxt
642 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
643 -> RnM (thing, FreeVars)
644 -> RnM (([LStmt Name], thing), FreeVars)
645 rnNormalStmts _ [] thing_inside
646 = do { (thing, fvs) <- thing_inside
647 ; return (([],thing), fvs) }
649 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
650 = do { ((stmts1, (stmts2, thing)), fvs)
653 rnNormalStmts ctxt stmts thing_inside
654 ; return (((stmts1 ++ stmts2), thing), fvs) }
657 rnStmt :: HsStmtContext Name -> LStmt RdrName
658 -> RnM (thing, FreeVars)
659 -> RnM (([LStmt Name], thing), FreeVars)
661 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
662 = do { (expr', fv_expr) <- rnLExpr expr
663 ; (then_op, fvs1) <- lookupSyntaxName thenMName
664 ; (thing, fvs2) <- thing_inside
665 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
666 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
668 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
669 = do { (expr', fv_expr) <- rnLExpr expr
670 -- The binders do not scope over the expression
671 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
672 ; (fail_op, fvs2) <- lookupSyntaxName failMName
673 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
674 { (thing, fvs3) <- thing_inside
675 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
676 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
677 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
678 -- but it does not matter because the names are unique
680 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
681 = do { checkLetStmt ctxt binds
682 ; rnLocalBindsAndThen binds $ \binds' -> do
683 { (thing, fvs) <- thing_inside
684 ; return (([L loc (LetStmt binds')], thing), fvs) } }
686 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
687 = do { checkRecStmt ctxt
689 -- Step1: Bring all the binders of the mdo into scope
690 -- (Remember that this also removes the binders from the
691 -- finally-returned free-vars.)
692 -- And rename each individual stmt, making a
693 -- singleton segment. At this stage the FwdRefs field
694 -- isn't finished: it's empty for all except a BindStmt
695 -- for which it's the fwd refs within the bind itself
696 -- (This set may not be empty, because we're in a recursive
698 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
700 { (thing, fvs_later) <- thing_inside
701 ; (return_op, fvs1) <- lookupSyntaxName returnMName
702 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
703 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
705 -- Step 2: Fill in the fwd refs.
706 -- The segments are all singletons, but their fwd-ref
707 -- field mentions all the things used by the segment
708 -- that are bound after their use
709 segs_w_fwd_refs = addFwdRefs segs
711 -- Step 3: Group together the segments to make bigger segments
712 -- Invariant: in the result, no segment uses a variable
713 -- bound in a later segment
714 grouped_segs = glomSegments segs_w_fwd_refs
716 -- Step 4: Turn the segments into Stmts
717 -- Use RecStmt when and only when there are fwd refs
718 -- Also gather up the uses from the end towards the
719 -- start, so we can tell the RecStmt which things are
720 -- used 'after' the RecStmt
721 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
722 , recS_mfix_fn = mfix_op
723 , recS_bind_fn = bind_op }
724 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
726 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
728 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
729 = do { checkParStmt ctxt
730 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
731 ; return (([L loc (ParStmt segs')], thing), fvs) }
733 rnStmt ctxt (L loc (TransformStmt (stmts, _) usingExpr maybeByExpr)) thing_inside = do
734 checkTransformStmt ctxt
736 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
737 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
738 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
739 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
740 (thing, fv_thing) <- thing_inside
742 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
744 return (([L loc (TransformStmt (stmts', binders) usingExpr' maybeByExpr')], thing),
745 fv_usingExpr `plusFV` fvs)
747 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
748 rnMaybeLExpr (Just expr) = do
749 (expr', fv_expr) <- rnLExpr expr
750 return (Just expr', fv_expr)
752 rnStmt ctxt (L loc (GroupStmt (stmts, _) groupByClause)) thing_inside = do
753 checkTransformStmt ctxt
755 -- We must rename the using expression in the context before the transform is begun
756 groupByClauseAction <-
757 case groupByClause of
758 GroupByNothing usingExpr -> do
759 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
760 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
761 GroupBySomething eitherUsingExpr byExpr -> do
762 (eitherUsingExpr', fv_eitherUsingExpr) <-
763 case eitherUsingExpr of
764 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
766 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
767 return (Left usingExpr', fv_usingExpr)
770 (byExpr', fv_byExpr) <- rnLExpr byExpr
771 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
773 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
774 -- perhaps we could refactor this to use rnNormalStmts directly?
775 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
776 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
777 (groupByClause', fv_groupByClause) <- groupByClauseAction
779 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
780 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
782 -- Bind the "thing" inside a context where we have REBOUND everything
783 -- bound by the statements before the group. This is necessary since after
784 -- the grouping the same identifiers actually have different meanings
785 -- i.e. they refer to lists not singletons!
786 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
788 -- We remove entries from the binder map that are not used in the thing_inside.
789 -- We can then use that usage information to ensure that the free variables do
790 -- not contain the things we just bound, but do contain the things we need to
791 -- make those bindings (i.e. the corresponding non-listy variables)
793 -- Note that we also retain those entries which have an old binder in our
794 -- own free variables (the using or by expression). This is because this map
795 -- is reused in the desugarer to create the type to bind from the statements
796 -- that occur before this one. If the binders we need are not in the map, they
797 -- will never get bound into our desugared expression and hence the simplifier
798 -- crashes as we refer to variables that don't exist!
799 let usedBinderMap = filter
800 (\(old_binder, new_binder) ->
801 (new_binder `elemNameSet` fv_thing) ||
802 (old_binder `elemNameSet` fv_groupByClause)) binderMap
803 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
804 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
806 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
808 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
809 return (([L loc (GroupStmt (stmts', usedBinderMap) groupByClause')], thing), fvs)
811 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
813 -> ([Name] -> RnM (thing, FreeVars))
814 -> RnM (([LStmt Name], [Name], thing), FreeVars)
815 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
816 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
817 -- Find the Names that are bound by stmts that
818 -- by assumption we have just renamed
819 local_env <- getLocalRdrEnv
821 stmts_binders = collectLStmtsBinders stmts
822 bndrs = map (expectJust "rnStmt"
823 . lookupLocalRdrEnv local_env
824 . unLoc) stmts_binders
826 -- If shadow, we'll look up (Unqual x) twice, getting
827 -- the second binding both times, which is the
829 unshadowed_bndrs = nub bndrs
831 -- Typecheck the thing inside, passing on all
832 -- the Names bound before it for its information
833 (thing, fvs) <- thing_inside unshadowed_bndrs
835 -- Figure out which of the bound names are used
836 -- after the statements we renamed
837 let used_bndrs = filter (`elemNameSet` fvs) bndrs
838 return ((used_bndrs, thing), fvs)
840 -- Flatten the tuple returned by the above call a bit!
841 return ((stmts', used_bndrs, inner_thing), fvs)
843 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
844 -> RnM (thing, FreeVars)
845 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
846 rnParallelStmts ctxt segs thing_inside = do
847 orig_lcl_env <- getLocalRdrEnv
848 go orig_lcl_env [] segs
850 go orig_lcl_env bndrs [] = do
851 let (bndrs', dups) = removeDups cmpByOcc bndrs
852 inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
855 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
856 return (([], thing), fvs)
858 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
859 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
860 -- Typecheck the thing inside, passing on all
861 -- the Names bound, but separately; revert the envt
862 setLocalRdrEnv orig_lcl_env $ do
863 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
865 let seg' = (stmts', bndrs)
866 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
868 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
869 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
870 <+> quotes (ppr (head vs)))
874 %************************************************************************
876 \subsubsection{mdo expressions}
878 %************************************************************************
881 type FwdRefs = NameSet
882 type Segment stmts = (Defs,
883 Uses, -- May include defs
884 FwdRefs, -- A subset of uses that are
885 -- (a) used before they are bound in this segment, or
886 -- (b) used here, and bound in subsequent segments
887 stmts) -- Either Stmt or [Stmt]
890 ----------------------------------------------------
892 rnMDoStmts :: [LStmt RdrName]
893 -> RnM (thing, FreeVars)
894 -> RnM (([LStmt Name], thing), FreeVars)
895 rnMDoStmts stmts thing_inside
896 = rn_rec_stmts_and_then stmts $ \ segs -> do
897 { (thing, fvs_later) <- thing_inside
898 ; let segs_w_fwd_refs = addFwdRefs segs
899 grouped_segs = glomSegments segs_w_fwd_refs
900 (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
901 ; return ((stmts', thing), fvs) }
903 ---------------------------------------------
905 -- wrapper that does both the left- and right-hand sides
906 rn_rec_stmts_and_then :: [LStmt RdrName]
907 -- assumes that the FreeVars returned includes
908 -- the FreeVars of the Segments
909 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
911 rn_rec_stmts_and_then s cont
912 = do { -- (A) Make the mini fixity env for all of the stmts
913 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
916 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
918 -- ...bring them and their fixities into scope
919 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
920 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
922 -- (C) do the right-hand-sides and thing-inside
923 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
924 ; (res, fvs) <- cont segs
925 ; warnUnusedLocalBinds bound_names fvs
926 ; return (res, fvs) }}
928 -- get all the fixity decls in any Let stmt
929 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
930 collectRecStmtsFixities l =
931 foldr (\ s -> \acc -> case s of
932 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
933 foldr (\ sig -> \ acc -> case sig of
934 (L loc (FixSig s)) -> (L loc s) : acc
940 rn_rec_stmt_lhs :: MiniFixityEnv
942 -- rename LHS, and return its FVs
943 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
944 -- so we don't bother to compute it accurately in the other cases
945 -> RnM [(LStmtLR Name RdrName, FreeVars)]
947 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
948 -- this is actually correct
951 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
953 -- should the ctxt be MDo instead?
954 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
955 return [(L loc (BindStmt pat' expr a b),
958 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
959 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
961 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
962 = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
963 return [(L loc (LetStmt (HsValBinds binds')),
964 -- Warning: this is bogus; see function invariant
968 -- XXX Do we need to do something with the return and mfix names?
969 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
970 = rn_rec_stmts_lhs fix_env stmts
972 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
973 = pprPanic "rn_rec_stmt" (ppr stmt)
975 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
976 = pprPanic "rn_rec_stmt" (ppr stmt)
978 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
979 = pprPanic "rn_rec_stmt" (ppr stmt)
981 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
982 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
984 rn_rec_stmts_lhs :: MiniFixityEnv
986 -> RnM [(LStmtLR Name RdrName, FreeVars)]
987 rn_rec_stmts_lhs fix_env stmts
988 = do { let boundNames = collectLStmtsBinders stmts
989 -- First do error checking: we need to check for dups here because we
990 -- don't bind all of the variables from the Stmt at once
991 -- with bindLocatedLocals.
992 ; checkDupRdrNames boundNames
993 ; ls <- mapM (rn_rec_stmt_lhs fix_env) stmts
994 ; return (concat ls) }
999 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
1000 -- Rename a Stmt that is inside a RecStmt (or mdo)
1001 -- Assumes all binders are already in scope
1002 -- Turns each stmt into a singleton Stmt
1003 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
1004 = rnLExpr expr `thenM` \ (expr', fvs) ->
1005 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1006 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1007 L loc (ExprStmt expr' then_op placeHolderType))]
1009 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1010 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1011 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1012 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1014 bndrs = mkNameSet (collectPatBinders pat')
1015 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1017 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1018 L loc (BindStmt pat' expr' bind_op fail_op))]
1020 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1021 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1023 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1024 (binds', du_binds) <-
1025 -- fixities and unused are handled above in rn_rec_stmts_and_then
1026 rnValBindsRHS (mkNameSet all_bndrs) binds'
1027 return [(duDefs du_binds, duUses du_binds,
1028 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1030 -- no RecStmt case becuase they get flattened above when doing the LHSes
1031 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1032 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1034 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1035 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1037 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1038 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1040 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1041 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1043 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1044 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1046 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1047 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1048 return (concat segs_s)
1050 ---------------------------------------------
1051 addFwdRefs :: [Segment a] -> [Segment a]
1052 -- So far the segments only have forward refs *within* the Stmt
1053 -- (which happens for bind: x <- ...x...)
1054 -- This function adds the cross-seg fwd ref info
1057 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1059 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1060 = (new_seg : segs, all_defs)
1062 new_seg = (defs, uses, new_fwds, stmts)
1063 all_defs = later_defs `unionNameSets` defs
1064 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1065 -- Add the downstream fwd refs here
1067 ----------------------------------------------------
1068 -- Glomming the singleton segments of an mdo into
1069 -- minimal recursive groups.
1071 -- At first I thought this was just strongly connected components, but
1072 -- there's an important constraint: the order of the stmts must not change.
1075 -- mdo { x <- ...y...
1082 -- Here, the first stmt mention 'y', which is bound in the third.
1083 -- But that means that the innocent second stmt (p <- z) gets caught
1084 -- up in the recursion. And that in turn means that the binding for
1085 -- 'z' has to be included... and so on.
1087 -- Start at the tail { r <- x }
1088 -- Now add the next one { z <- y ; r <- x }
1089 -- Now add one more { q <- x ; z <- y ; r <- x }
1090 -- Now one more... but this time we have to group a bunch into rec
1091 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1092 -- Now one more, which we can add on without a rec
1094 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1096 -- Finally we add the last one; since it mentions y we have to
1097 -- glom it togeher with the first two groups
1098 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1099 -- q <- x ; z <- y } ;
1102 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1104 glomSegments [] = []
1105 glomSegments ((defs,uses,fwds,stmt) : segs)
1106 -- Actually stmts will always be a singleton
1107 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1109 segs' = glomSegments segs
1110 (extras, others) = grab uses segs'
1111 (ds, us, fs, ss) = unzip4 extras
1113 seg_defs = plusFVs ds `plusFV` defs
1114 seg_uses = plusFVs us `plusFV` uses
1115 seg_fwds = plusFVs fs `plusFV` fwds
1116 seg_stmts = stmt : concat ss
1118 grab :: NameSet -- The client
1120 -> ([Segment a], -- Needed by the 'client'
1121 [Segment a]) -- Not needed by the client
1122 -- The result is simply a split of the input
1124 = (reverse yeses, reverse noes)
1126 (noes, yeses) = span not_needed (reverse dus)
1127 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1130 ----------------------------------------------------
1131 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1132 -> [Segment [LStmt Name]]
1133 -> FreeVars -- Free vars used 'later'
1134 -> ([LStmt Name], FreeVars)
1136 segsToStmts _ [] fvs_later = ([], fvs_later)
1137 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1138 = ASSERT( not (null ss) )
1139 (new_stmt : later_stmts, later_uses `plusFV` uses)
1141 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1142 new_stmt | non_rec = head ss
1143 | otherwise = L (getLoc (head ss)) rec_stmt
1144 rec_stmt = empty_rec_stmt { recS_stmts = ss
1145 , recS_later_ids = nameSetToList used_later
1146 , recS_rec_ids = nameSetToList fwds }
1147 non_rec = isSingleton ss && isEmptyNameSet fwds
1148 used_later = defs `intersectNameSet` later_uses
1149 -- The ones needed after the RecStmt
1152 %************************************************************************
1154 \subsubsection{Assertion utils}
1156 %************************************************************************
1159 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1160 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1162 mkAssertErrorExpr :: RnM (HsExpr Name)
1163 -- Return an expression for (assertError "Foo.hs:27")
1165 = getSrcSpanM `thenM` \ sloc ->
1166 return (HsApp (L sloc (HsVar assertErrorName))
1167 (L sloc (srcSpanPrimLit sloc)))
1170 Note [Adding the implicit parameter to 'assert']
1171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1172 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1173 By doing this in the renamer we allow the typechecker to just see the
1174 expanded application and do the right thing. But it's not really
1175 the Right Thing because there's no way to "undo" if you want to see
1176 the original source code. We'll have fix this in due course, when
1177 we care more about being able to reconstruct the exact original
1180 %************************************************************************
1182 \subsubsection{Errors}
1184 %************************************************************************
1188 ----------------------
1189 -- Checking when a particular Stmt is ok
1190 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1191 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1192 checkLetStmt _ctxt _binds = return ()
1193 -- We do not allow implicit-parameter bindings in a parallel
1194 -- list comprehension. I'm not sure what it might mean.
1197 checkRecStmt :: HsStmtContext Name -> RnM ()
1198 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1199 checkRecStmt (DoExpr {}) = return () -- and in 'do'
1200 checkRecStmt ctxt = addErr msg
1202 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1205 checkParStmt :: HsStmtContext Name -> RnM ()
1207 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1208 ; checkErr parallel_list_comp msg }
1210 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1213 checkTransformStmt :: HsStmtContext Name -> RnM ()
1214 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1215 -- desugarer will break when we come to operate on a parallel array
1216 = do { transform_list_comp <- doptM Opt_TransformListComp
1217 ; checkErr transform_list_comp msg }
1219 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1220 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1221 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1222 checkTransformStmt ctxt = addErr msg
1224 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1227 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1228 checkTupleSection args
1229 = do { tuple_section <- doptM Opt_TupleSections
1230 ; checkErr (all tupArgPresent args || tuple_section) msg }
1232 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1235 sectionErr :: HsExpr RdrName -> SDoc
1237 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1238 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1240 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1241 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1243 ; return (EWildPat, emptyFVs) }
1245 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1246 badIpBinds what binds
1247 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)