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 )
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 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
175 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
176 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
177 return (expr'', fvs_qq `plusFV` fvs_expr)
180 ---------------------------------------------
182 -- See Note [Parsing sections] in Parser.y.pp
183 rnExpr (HsPar (L loc (section@(SectionL {}))))
184 = do { (section', fvs) <- rnSection section
185 ; return (HsPar (L loc section'), fvs) }
187 rnExpr (HsPar (L loc (section@(SectionR {}))))
188 = do { (section', fvs) <- rnSection section
189 ; return (HsPar (L loc section'), fvs) }
192 = do { (e', fvs_e) <- rnLExpr e
193 ; return (HsPar e', fvs_e) }
195 rnExpr expr@(SectionL {})
196 = do { addErr (sectionErr expr); rnSection expr }
197 rnExpr expr@(SectionR {})
198 = do { addErr (sectionErr expr); rnSection expr }
200 ---------------------------------------------
201 rnExpr (HsCoreAnn ann expr)
202 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
203 return (HsCoreAnn ann expr', fvs_expr)
205 rnExpr (HsSCC lbl expr)
206 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
207 return (HsSCC lbl expr', fvs_expr)
208 rnExpr (HsTickPragma info expr)
209 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
210 return (HsTickPragma info expr', fvs_expr)
212 rnExpr (HsLam matches)
213 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
214 return (HsLam matches', fvMatch)
216 rnExpr (HsCase expr matches)
217 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
218 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
219 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
221 rnExpr (HsLet binds expr)
222 = rnLocalBindsAndThen binds $ \ binds' ->
223 rnLExpr expr `thenM` \ (expr',fvExpr) ->
224 return (HsLet binds' expr', fvExpr)
226 rnExpr (HsDo do_or_lc stmts body _)
227 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
229 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
231 rnExpr (ExplicitList _ exps)
232 = rnExprs exps `thenM` \ (exps', fvs) ->
233 return (ExplicitList placeHolderType exps', fvs)
235 rnExpr (ExplicitPArr _ exps)
236 = rnExprs exps `thenM` \ (exps', fvs) ->
237 return (ExplicitPArr placeHolderType exps', fvs)
239 rnExpr (ExplicitTuple tup_args boxity)
240 = do { checkTupleSection tup_args
241 ; checkTupSize (length tup_args)
242 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
243 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
245 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
246 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
248 rnExpr (RecordCon con_id _ rbinds)
249 = do { conname <- lookupLocatedOccRn con_id
250 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
251 ; return (RecordCon conname noPostTcExpr rbinds',
252 fvRbinds `addOneFV` unLoc conname) }
254 rnExpr (RecordUpd expr rbinds _ _ _)
255 = do { (expr', fvExpr) <- rnLExpr expr
256 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
257 ; return (RecordUpd expr' rbinds' [] [] [],
258 fvExpr `plusFV` fvRbinds) }
260 rnExpr (ExprWithTySig expr pty)
261 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
262 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
264 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
266 doc = text "In an expression type signature"
268 rnExpr (HsIf p b1 b2)
269 = rnLExpr p `thenM` \ (p', fvP) ->
270 rnLExpr b1 `thenM` \ (b1', fvB1) ->
271 rnLExpr b2 `thenM` \ (b2', fvB2) ->
272 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
275 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
276 return (HsType t, fvT)
278 doc = text "In a type argument"
280 rnExpr (ArithSeq _ seq)
281 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
282 return (ArithSeq noPostTcExpr new_seq, fvs)
284 rnExpr (PArrSeq _ seq)
285 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
286 return (PArrSeq noPostTcExpr new_seq, fvs)
289 These three are pattern syntax appearing in expressions.
290 Since all the symbols are reservedops we can simply reject them.
291 We return a (bogus) EWildPat in each case.
294 rnExpr e@EWildPat = patSynErr e
295 rnExpr e@(EAsPat {}) = patSynErr e
296 rnExpr e@(EViewPat {}) = patSynErr e
297 rnExpr e@(ELazyPat {}) = patSynErr e
300 %************************************************************************
304 %************************************************************************
307 rnExpr (HsProc pat body)
309 rnPats ProcExpr [pat] $ \ [pat'] ->
310 rnCmdTop body `thenM` \ (body',fvBody) ->
311 return (HsProc pat' body', fvBody)
313 rnExpr (HsArrApp arrow arg _ ho rtl)
314 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
315 rnLExpr arg `thenM` \ (arg',fvArg) ->
316 return (HsArrApp arrow' arg' placeHolderType ho rtl,
317 fvArrow `plusFV` fvArg)
319 select_arrow_scope tc = case ho of
320 HsHigherOrderApp -> tc
321 HsFirstOrderApp -> escapeArrowScope tc
324 rnExpr (HsArrForm op (Just _) [arg1, arg2])
325 = escapeArrowScope (rnLExpr op)
326 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
327 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
328 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
332 lookupFixityRn op_name `thenM` \ fixity ->
333 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
336 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
338 rnExpr (HsArrForm op fixity cmds)
339 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
340 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
341 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
343 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
346 ----------------------
347 -- See Note [Parsing sections] in Parser.y.pp
348 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
349 rnSection section@(SectionR op expr)
350 = do { (op', fvs_op) <- rnLExpr op
351 ; (expr', fvs_expr) <- rnLExpr expr
352 ; checkSectionPrec InfixR section op' expr'
353 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
355 rnSection section@(SectionL expr op)
356 = do { (expr', fvs_expr) <- rnLExpr expr
357 ; (op', fvs_op) <- rnLExpr op
358 ; checkSectionPrec InfixL section op' expr'
359 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
361 rnSection other = pprPanic "rnSection" (ppr other)
364 %************************************************************************
368 %************************************************************************
371 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
372 -> RnM (HsRecordBinds Name, FreeVars)
373 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
374 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
375 ; (flds', fvss) <- mapAndUnzipM rn_field flds
376 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
377 fvs `plusFV` plusFVs fvss) }
379 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
380 ; return (fld { hsRecFieldArg = arg' }, fvs) }
384 %************************************************************************
388 %************************************************************************
391 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
392 rnCmdArgs [] = return ([], emptyFVs)
394 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
395 rnCmdArgs args `thenM` \ (args',fvArgs) ->
396 return (arg':args', fvArg `plusFV` fvArgs)
398 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
399 rnCmdTop = wrapLocFstM rnCmdTop'
401 rnCmdTop' (HsCmdTop cmd _ _ _)
402 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
404 cmd_names = [arrAName, composeAName, firstAName] ++
405 nameSetToList (methodNamesCmd (unLoc cmd'))
407 -- Generate the rebindable syntax for the monad
408 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
410 return (HsCmdTop cmd' [] placeHolderType cmd_names',
411 fvCmd `plusFV` cmd_fvs)
413 ---------------------------------------------------
414 -- convert OpApp's in a command context to HsArrForm's
416 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
417 convertOpFormsLCmd = fmap convertOpFormsCmd
419 convertOpFormsCmd :: HsCmd id -> HsCmd id
421 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
422 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
423 convertOpFormsCmd (OpApp c1 op fixity c2)
425 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
426 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
428 HsArrForm op (Just fixity) [arg1, arg2]
430 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
432 convertOpFormsCmd (HsCase exp matches)
433 = HsCase exp (convertOpFormsMatch matches)
435 convertOpFormsCmd (HsIf exp c1 c2)
436 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
438 convertOpFormsCmd (HsLet binds cmd)
439 = HsLet binds (convertOpFormsLCmd cmd)
441 convertOpFormsCmd (HsDo ctxt stmts body ty)
442 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
443 (convertOpFormsLCmd body) ty
445 -- Anything else is unchanged. This includes HsArrForm (already done),
446 -- things with no sub-commands, and illegal commands (which will be
447 -- caught by the type checker)
448 convertOpFormsCmd c = c
450 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
451 convertOpFormsStmt (BindStmt pat cmd _ _)
452 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
453 convertOpFormsStmt (ExprStmt cmd _ _)
454 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
455 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
456 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
457 convertOpFormsStmt stmt = stmt
459 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
460 convertOpFormsMatch (MatchGroup ms ty)
461 = MatchGroup (map (fmap convert) ms) ty
462 where convert (Match pat mty grhss)
463 = Match pat mty (convertOpFormsGRHSs grhss)
465 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
466 convertOpFormsGRHSs (GRHSs grhss binds)
467 = GRHSs (map convertOpFormsGRHS grhss) binds
469 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
470 convertOpFormsGRHS = fmap convert
472 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
474 ---------------------------------------------------
475 type CmdNeeds = FreeVars -- Only inhabitants are
476 -- appAName, choiceAName, loopAName
478 -- find what methods the Cmd needs (loop, choice, apply)
479 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
480 methodNamesLCmd = methodNamesCmd . unLoc
482 methodNamesCmd :: HsCmd Name -> CmdNeeds
484 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
486 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
488 methodNamesCmd (HsArrForm {}) = emptyFVs
490 methodNamesCmd (HsPar c) = methodNamesLCmd c
492 methodNamesCmd (HsIf _ c1 c2)
493 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
495 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
497 methodNamesCmd (HsDo _ stmts body _)
498 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
500 methodNamesCmd (HsApp c _) = methodNamesLCmd c
502 methodNamesCmd (HsLam match) = methodNamesMatch match
504 methodNamesCmd (HsCase _ matches)
505 = methodNamesMatch matches `addOneFV` choiceAName
507 methodNamesCmd _ = emptyFVs
508 -- Other forms can't occur in commands, but it's not convenient
509 -- to error here so we just do what's convenient.
510 -- The type checker will complain later
512 ---------------------------------------------------
513 methodNamesMatch :: MatchGroup Name -> FreeVars
514 methodNamesMatch (MatchGroup ms _)
515 = plusFVs (map do_one ms)
517 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
519 -------------------------------------------------
521 methodNamesGRHSs :: GRHSs Name -> FreeVars
522 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
524 -------------------------------------------------
526 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
527 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
529 ---------------------------------------------------
530 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
531 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
533 ---------------------------------------------------
534 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
535 methodNamesLStmt = methodNamesStmt . unLoc
537 methodNamesStmt :: StmtLR Name Name -> FreeVars
538 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
539 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
540 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
541 methodNamesStmt (LetStmt _) = emptyFVs
542 methodNamesStmt (ParStmt _) = emptyFVs
543 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
544 methodNamesStmt (GroupStmt _ _) = emptyFVs
545 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
546 -- here so we just do what's convenient
550 %************************************************************************
554 %************************************************************************
557 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
558 rnArithSeq (From expr)
559 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
560 return (From expr', fvExpr)
562 rnArithSeq (FromThen expr1 expr2)
563 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
564 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
565 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
567 rnArithSeq (FromTo expr1 expr2)
568 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
569 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
570 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
572 rnArithSeq (FromThenTo expr1 expr2 expr3)
573 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
574 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
575 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
576 return (FromThenTo expr1' expr2' expr3',
577 plusFVs [fvExpr1, fvExpr2, fvExpr3])
580 %************************************************************************
582 Template Haskell brackets
584 %************************************************************************
587 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
588 rnBracket (VarBr n) = do { name <- lookupOccRn n
589 ; this_mod <- getModule
590 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
591 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
592 ; return () } -- only way that is going to happen
593 ; return (VarBr name, unitFV name) }
595 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
597 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
598 ; return (ExpBr e', fvs) }
600 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
601 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
602 ; return (TypBr t', fvs) }
604 doc = ptext (sLit "In a Template-Haskell quoted type")
605 rnBracket (DecBr group)
606 = do { gbl_env <- getGblEnv
608 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
609 -- The emptyDUs is so that we just collect uses for this
610 -- group alone in the call to rnSrcDecls below
611 ; (tcg_env, group') <- setGblEnv new_gbl_env $
615 -- Discard the tcg_env; it contains only extra info about fixity
616 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
619 %************************************************************************
621 \subsubsection{@Stmt@s: in @do@ expressions}
623 %************************************************************************
626 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
627 -> RnM (thing, FreeVars)
628 -> RnM (([LStmt Name], thing), FreeVars)
630 rnStmts (MDoExpr _) = rnMDoStmts
631 rnStmts ctxt = rnNormalStmts ctxt
633 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
634 -> RnM (thing, FreeVars)
635 -> RnM (([LStmt Name], thing), FreeVars)
636 rnNormalStmts _ [] thing_inside
637 = do { (thing, fvs) <- thing_inside
638 ; return (([],thing), fvs) }
640 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
641 = do { ((stmts1, (stmts2, thing)), fvs)
644 rnNormalStmts ctxt stmts thing_inside
645 ; return (((stmts1 ++ stmts2), thing), fvs) }
648 rnStmt :: HsStmtContext Name -> LStmt RdrName
649 -> RnM (thing, FreeVars)
650 -> RnM (([LStmt Name], thing), FreeVars)
652 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
653 = do { (expr', fv_expr) <- rnLExpr expr
654 ; (then_op, fvs1) <- lookupSyntaxName thenMName
655 ; (thing, fvs2) <- thing_inside
656 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
657 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
659 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
660 = do { (expr', fv_expr) <- rnLExpr expr
661 -- The binders do not scope over the expression
662 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
663 ; (fail_op, fvs2) <- lookupSyntaxName failMName
664 ; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
665 { (thing, fvs3) <- thing_inside
666 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
667 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
668 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
669 -- but it does not matter because the names are unique
671 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
672 = do { checkLetStmt ctxt binds
673 ; rnLocalBindsAndThen binds $ \binds' -> do
674 { (thing, fvs) <- thing_inside
675 ; return (([L loc (LetStmt binds')], thing), fvs) } }
677 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
678 = do { checkRecStmt ctxt
680 -- Step1: Bring all the binders of the mdo into scope
681 -- (Remember that this also removes the binders from the
682 -- finally-returned free-vars.)
683 -- And rename each individual stmt, making a
684 -- singleton segment. At this stage the FwdRefs field
685 -- isn't finished: it's empty for all except a BindStmt
686 -- for which it's the fwd refs within the bind itself
687 -- (This set may not be empty, because we're in a recursive
689 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
691 { (thing, fvs_later) <- thing_inside
692 ; (return_op, fvs1) <- lookupSyntaxName returnMName
693 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
694 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
696 -- Step 2: Fill in the fwd refs.
697 -- The segments are all singletons, but their fwd-ref
698 -- field mentions all the things used by the segment
699 -- that are bound after their use
700 segs_w_fwd_refs = addFwdRefs segs
702 -- Step 3: Group together the segments to make bigger segments
703 -- Invariant: in the result, no segment uses a variable
704 -- bound in a later segment
705 grouped_segs = glomSegments segs_w_fwd_refs
707 -- Step 4: Turn the segments into Stmts
708 -- Use RecStmt when and only when there are fwd refs
709 -- Also gather up the uses from the end towards the
710 -- start, so we can tell the RecStmt which things are
711 -- used 'after' the RecStmt
712 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
713 , recS_mfix_fn = mfix_op
714 , recS_bind_fn = bind_op }
715 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
717 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
719 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
720 = do { checkParStmt ctxt
721 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
722 ; return (([L loc (ParStmt segs')], thing), fvs) }
724 rnStmt ctxt (L loc (TransformStmt (stmts, _) usingExpr maybeByExpr)) thing_inside = do
725 checkTransformStmt ctxt
727 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
728 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
729 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
730 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
731 (thing, fv_thing) <- thing_inside
733 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
735 return (([L loc (TransformStmt (stmts', binders) usingExpr' maybeByExpr')], thing),
736 fv_usingExpr `plusFV` fvs)
738 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
739 rnMaybeLExpr (Just expr) = do
740 (expr', fv_expr) <- rnLExpr expr
741 return (Just expr', fv_expr)
743 rnStmt ctxt (L loc (GroupStmt (stmts, _) groupByClause)) thing_inside = do
744 checkTransformStmt ctxt
746 -- We must rename the using expression in the context before the transform is begun
747 groupByClauseAction <-
748 case groupByClause of
749 GroupByNothing usingExpr -> do
750 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
751 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
752 GroupBySomething eitherUsingExpr byExpr -> do
753 (eitherUsingExpr', fv_eitherUsingExpr) <-
754 case eitherUsingExpr of
755 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
757 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
758 return (Left usingExpr', fv_usingExpr)
761 (byExpr', fv_byExpr) <- rnLExpr byExpr
762 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
764 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
765 -- perhaps we could refactor this to use rnNormalStmts directly?
766 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
767 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
768 (groupByClause', fv_groupByClause) <- groupByClauseAction
770 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
771 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
773 -- Bind the "thing" inside a context where we have REBOUND everything
774 -- bound by the statements before the group. This is necessary since after
775 -- the grouping the same identifiers actually have different meanings
776 -- i.e. they refer to lists not singletons!
777 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
779 -- We remove entries from the binder map that are not used in the thing_inside.
780 -- We can then use that usage information to ensure that the free variables do
781 -- not contain the things we just bound, but do contain the things we need to
782 -- make those bindings (i.e. the corresponding non-listy variables)
784 -- Note that we also retain those entries which have an old binder in our
785 -- own free variables (the using or by expression). This is because this map
786 -- is reused in the desugarer to create the type to bind from the statements
787 -- that occur before this one. If the binders we need are not in the map, they
788 -- will never get bound into our desugared expression and hence the simplifier
789 -- crashes as we refer to variables that don't exist!
790 let usedBinderMap = filter
791 (\(old_binder, new_binder) ->
792 (new_binder `elemNameSet` fv_thing) ||
793 (old_binder `elemNameSet` fv_groupByClause)) binderMap
794 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
795 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
797 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
799 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
800 return (([L loc (GroupStmt (stmts', usedBinderMap) groupByClause')], thing), fvs)
802 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
804 -> ([Name] -> RnM (thing, FreeVars))
805 -> RnM (([LStmt Name], [Name], thing), FreeVars)
806 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
807 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
808 -- Find the Names that are bound by stmts that
809 -- by assumption we have just renamed
810 local_env <- getLocalRdrEnv
812 stmts_binders = collectLStmtsBinders stmts
813 bndrs = map (expectJust "rnStmt"
814 . lookupLocalRdrEnv local_env
815 . unLoc) stmts_binders
817 -- If shadow, we'll look up (Unqual x) twice, getting
818 -- the second binding both times, which is the
820 unshadowed_bndrs = nub bndrs
822 -- Typecheck the thing inside, passing on all
823 -- the Names bound before it for its information
824 (thing, fvs) <- thing_inside unshadowed_bndrs
826 -- Figure out which of the bound names are used
827 -- after the statements we renamed
828 let used_bndrs = filter (`elemNameSet` fvs) bndrs
829 return ((used_bndrs, thing), fvs)
831 -- Flatten the tuple returned by the above call a bit!
832 return ((stmts', used_bndrs, inner_thing), fvs)
834 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
835 -> RnM (thing, FreeVars)
836 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
837 rnParallelStmts ctxt segs thing_inside = do
838 orig_lcl_env <- getLocalRdrEnv
839 go orig_lcl_env [] segs
841 go orig_lcl_env bndrs [] = do
842 let (bndrs', dups) = removeDups cmpByOcc bndrs
843 inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
846 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
847 return (([], thing), fvs)
849 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
850 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
851 -- Typecheck the thing inside, passing on all
852 -- the Names bound, but separately; revert the envt
853 setLocalRdrEnv orig_lcl_env $ do
854 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
856 let seg' = (stmts', bndrs)
857 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
859 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
860 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
861 <+> quotes (ppr (head vs)))
865 %************************************************************************
867 \subsubsection{mdo expressions}
869 %************************************************************************
872 type FwdRefs = NameSet
873 type Segment stmts = (Defs,
874 Uses, -- May include defs
875 FwdRefs, -- A subset of uses that are
876 -- (a) used before they are bound in this segment, or
877 -- (b) used here, and bound in subsequent segments
878 stmts) -- Either Stmt or [Stmt]
881 ----------------------------------------------------
883 rnMDoStmts :: [LStmt RdrName]
884 -> RnM (thing, FreeVars)
885 -> RnM (([LStmt Name], thing), FreeVars)
886 rnMDoStmts stmts thing_inside
887 = rn_rec_stmts_and_then stmts $ \ segs -> do
888 { (thing, fvs_later) <- thing_inside
889 ; let segs_w_fwd_refs = addFwdRefs segs
890 grouped_segs = glomSegments segs_w_fwd_refs
891 (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
892 ; return ((stmts', thing), fvs) }
894 ---------------------------------------------
896 -- wrapper that does both the left- and right-hand sides
897 rn_rec_stmts_and_then :: [LStmt RdrName]
898 -- assumes that the FreeVars returned includes
899 -- the FreeVars of the Segments
900 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
902 rn_rec_stmts_and_then s cont
903 = do { -- (A) Make the mini fixity env for all of the stmts
904 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
907 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
909 -- ...bring them and their fixities into scope
910 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
911 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
913 -- (C) do the right-hand-sides and thing-inside
914 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
915 ; (res, fvs) <- cont segs
916 ; warnUnusedLocalBinds bound_names fvs
917 ; return (res, fvs) }}
919 -- get all the fixity decls in any Let stmt
920 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
921 collectRecStmtsFixities l =
922 foldr (\ s -> \acc -> case s of
923 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
924 foldr (\ sig -> \ acc -> case sig of
925 (L loc (FixSig s)) -> (L loc s) : acc
931 rn_rec_stmt_lhs :: MiniFixityEnv
933 -- rename LHS, and return its FVs
934 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
935 -- so we don't bother to compute it accurately in the other cases
936 -> RnM [(LStmtLR Name RdrName, FreeVars)]
938 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
939 -- this is actually correct
942 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
944 -- should the ctxt be MDo instead?
945 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
946 return [(L loc (BindStmt pat' expr a b),
949 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
950 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
952 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
953 = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
954 return [(L loc (LetStmt (HsValBinds binds')),
955 -- Warning: this is bogus; see function invariant
959 -- XXX Do we need to do something with the return and mfix names?
960 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
961 = rn_rec_stmts_lhs fix_env stmts
963 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
964 = pprPanic "rn_rec_stmt" (ppr stmt)
966 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
967 = pprPanic "rn_rec_stmt" (ppr stmt)
969 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
970 = pprPanic "rn_rec_stmt" (ppr stmt)
972 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
973 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
975 rn_rec_stmts_lhs :: MiniFixityEnv
977 -> RnM [(LStmtLR Name RdrName, FreeVars)]
978 rn_rec_stmts_lhs fix_env stmts
979 = do { let boundNames = collectLStmtsBinders stmts
980 -- First do error checking: we need to check for dups here because we
981 -- don't bind all of the variables from the Stmt at once
982 -- with bindLocatedLocals.
983 ; checkDupRdrNames boundNames
984 ; ls <- mapM (rn_rec_stmt_lhs fix_env) stmts
985 ; return (concat ls) }
990 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
991 -- Rename a Stmt that is inside a RecStmt (or mdo)
992 -- Assumes all binders are already in scope
993 -- Turns each stmt into a singleton Stmt
994 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
995 = rnLExpr expr `thenM` \ (expr', fvs) ->
996 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
997 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
998 L loc (ExprStmt expr' then_op placeHolderType))]
1000 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1001 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1002 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1003 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1005 bndrs = mkNameSet (collectPatBinders pat')
1006 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1008 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1009 L loc (BindStmt pat' expr' bind_op fail_op))]
1011 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1012 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1014 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1015 (binds', du_binds) <-
1016 -- fixities and unused are handled above in rn_rec_stmts_and_then
1017 rnValBindsRHS (mkNameSet all_bndrs) binds'
1018 return [(duDefs du_binds, duUses du_binds,
1019 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1021 -- no RecStmt case becuase they get flattened above when doing the LHSes
1022 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1023 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1025 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1026 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1028 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1029 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1031 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1032 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1034 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1035 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1037 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1038 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1039 return (concat segs_s)
1041 ---------------------------------------------
1042 addFwdRefs :: [Segment a] -> [Segment a]
1043 -- So far the segments only have forward refs *within* the Stmt
1044 -- (which happens for bind: x <- ...x...)
1045 -- This function adds the cross-seg fwd ref info
1048 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1050 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1051 = (new_seg : segs, all_defs)
1053 new_seg = (defs, uses, new_fwds, stmts)
1054 all_defs = later_defs `unionNameSets` defs
1055 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1056 -- Add the downstream fwd refs here
1058 ----------------------------------------------------
1059 -- Glomming the singleton segments of an mdo into
1060 -- minimal recursive groups.
1062 -- At first I thought this was just strongly connected components, but
1063 -- there's an important constraint: the order of the stmts must not change.
1066 -- mdo { x <- ...y...
1073 -- Here, the first stmt mention 'y', which is bound in the third.
1074 -- But that means that the innocent second stmt (p <- z) gets caught
1075 -- up in the recursion. And that in turn means that the binding for
1076 -- 'z' has to be included... and so on.
1078 -- Start at the tail { r <- x }
1079 -- Now add the next one { z <- y ; r <- x }
1080 -- Now add one more { q <- x ; z <- y ; r <- x }
1081 -- Now one more... but this time we have to group a bunch into rec
1082 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1083 -- Now one more, which we can add on without a rec
1085 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1087 -- Finally we add the last one; since it mentions y we have to
1088 -- glom it togeher with the first two groups
1089 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1090 -- q <- x ; z <- y } ;
1093 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1095 glomSegments [] = []
1096 glomSegments ((defs,uses,fwds,stmt) : segs)
1097 -- Actually stmts will always be a singleton
1098 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1100 segs' = glomSegments segs
1101 (extras, others) = grab uses segs'
1102 (ds, us, fs, ss) = unzip4 extras
1104 seg_defs = plusFVs ds `plusFV` defs
1105 seg_uses = plusFVs us `plusFV` uses
1106 seg_fwds = plusFVs fs `plusFV` fwds
1107 seg_stmts = stmt : concat ss
1109 grab :: NameSet -- The client
1111 -> ([Segment a], -- Needed by the 'client'
1112 [Segment a]) -- Not needed by the client
1113 -- The result is simply a split of the input
1115 = (reverse yeses, reverse noes)
1117 (noes, yeses) = span not_needed (reverse dus)
1118 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1121 ----------------------------------------------------
1122 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1123 -> [Segment [LStmt Name]]
1124 -> FreeVars -- Free vars used 'later'
1125 -> ([LStmt Name], FreeVars)
1127 segsToStmts _ [] fvs_later = ([], fvs_later)
1128 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1129 = ASSERT( not (null ss) )
1130 (new_stmt : later_stmts, later_uses `plusFV` uses)
1132 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1133 new_stmt | non_rec = head ss
1134 | otherwise = L (getLoc (head ss)) rec_stmt
1135 rec_stmt = empty_rec_stmt { recS_stmts = ss
1136 , recS_later_ids = nameSetToList used_later
1137 , recS_rec_ids = nameSetToList fwds }
1138 non_rec = isSingleton ss && isEmptyNameSet fwds
1139 used_later = defs `intersectNameSet` later_uses
1140 -- The ones needed after the RecStmt
1143 %************************************************************************
1145 \subsubsection{Assertion utils}
1147 %************************************************************************
1150 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1151 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1153 mkAssertErrorExpr :: RnM (HsExpr Name)
1154 -- Return an expression for (assertError "Foo.hs:27")
1156 = getSrcSpanM `thenM` \ sloc ->
1157 return (HsApp (L sloc (HsVar assertErrorName))
1158 (L sloc (srcSpanPrimLit sloc)))
1161 Note [Adding the implicit parameter to 'assert']
1162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1163 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1164 By doing this in the renamer we allow the typechecker to just see the
1165 expanded application and do the right thing. But it's not really
1166 the Right Thing because there's no way to "undo" if you want to see
1167 the original source code. We'll have fix this in due course, when
1168 we care more about being able to reconstruct the exact original
1171 %************************************************************************
1173 \subsubsection{Errors}
1175 %************************************************************************
1179 ----------------------
1180 -- Checking when a particular Stmt is ok
1181 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1182 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1183 checkLetStmt _ctxt _binds = return ()
1184 -- We do not allow implicit-parameter bindings in a parallel
1185 -- list comprehension. I'm not sure what it might mean.
1188 checkRecStmt :: HsStmtContext Name -> RnM ()
1189 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1190 checkRecStmt (DoExpr {}) = return () -- and in 'do'
1191 checkRecStmt ctxt = addErr msg
1193 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1196 checkParStmt :: HsStmtContext Name -> RnM ()
1198 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1199 ; checkErr parallel_list_comp msg }
1201 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1204 checkTransformStmt :: HsStmtContext Name -> RnM ()
1205 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1206 -- desugarer will break when we come to operate on a parallel array
1207 = do { transform_list_comp <- doptM Opt_TransformListComp
1208 ; checkErr transform_list_comp msg }
1210 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1211 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1212 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1213 checkTransformStmt ctxt = addErr msg
1215 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1218 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1219 checkTupleSection args
1220 = do { tuple_section <- doptM Opt_TupleSections
1221 ; checkErr (all tupArgPresent args || tuple_section) msg }
1223 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1226 sectionErr :: HsExpr RdrName -> SDoc
1228 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1229 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1231 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1232 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1234 ; return (EWildPat, emptyFVs) }
1236 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1237 badIpBinds what binds
1238 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)