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, rnSplice, checkTH )
24 import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
33 import DynFlags ( DynFlag(..) )
34 import BasicTypes ( FixityDirection(..) )
35 import PrelNames ( hasKey, assertIdKey, assertErrorName,
36 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
37 negateName, thenMName, bindMName, failMName, groupWithName )
42 import LoadIface ( loadInterfaceForName )
45 import Util ( isSingleton )
46 import ListSetOps ( removeDups )
47 import Maybes ( expectJust )
52 import List ( unzip4 )
59 thenM :: Monad a => a b -> (b -> a c) -> a c
62 thenM_ :: Monad a => a b -> a c -> a c
65 returnM :: Monad m => a -> m a
68 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
71 checkM :: Monad m => Bool -> m () -> m ()
75 %************************************************************************
77 \subsubsection{Expressions}
79 %************************************************************************
82 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
83 rnExprs ls = rnExprs' ls emptyUniqSet
85 rnExprs' [] acc = returnM ([], acc)
86 rnExprs' (expr:exprs) acc
87 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
89 -- Now we do a "seq" on the free vars because typically it's small
90 -- or empty, especially in very long lists of constants
92 acc' = acc `plusFV` fvExpr
94 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
95 returnM (expr':exprs', fvExprs)
98 Variables. We look up the variable and return the resulting name.
101 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
102 rnLExpr = wrapLocFstM rnExpr
104 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
106 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
107 -- Separated from rnExpr because it's also used
108 -- when renaming infix expressions
109 -- See Note [Adding the implicit parameter to 'assert']
111 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
112 ; if ignore_asserts || not (name `hasKey` assertIdKey)
113 then return (HsVar name, unitFV name)
114 else do { e <- mkAssertErrorExpr
115 ; return (e, unitFV name) } }
118 = do name <- lookupOccRn v
122 = newIPNameRn v `thenM` \ name ->
123 returnM (HsIPVar name, emptyFVs)
125 rnExpr (HsLit lit@(HsString s))
127 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
128 ; if opt_OverloadedStrings then
129 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
130 else -- Same as below
132 returnM (HsLit lit, emptyFVs)
137 returnM (HsLit lit, emptyFVs)
139 rnExpr (HsOverLit lit)
140 = rnOverLit lit `thenM` \ (lit', fvs) ->
141 returnM (HsOverLit lit', fvs)
143 rnExpr (HsApp fun arg)
144 = rnLExpr fun `thenM` \ (fun',fvFun) ->
145 rnLExpr arg `thenM` \ (arg',fvArg) ->
146 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
148 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
149 = do { (e1', fv_e1) <- rnLExpr e1
150 ; (e2', fv_e2) <- rnLExpr e2
151 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
152 ; (op', fv_op) <- finishHsVar op_name
153 -- NB: op' is usually just a variable, but might be
154 -- an applicatoin (assert "Foo.hs:47")
156 -- When renaming code synthesised from "deriving" declarations
157 -- we used to avoid fixity stuff, but we can't easily tell any
158 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
159 -- should prevent bad things happening.
160 ; fixity <- lookupFixityRn op_name
161 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
162 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
165 = rnLExpr e `thenM` \ (e', fv_e) ->
166 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
167 mkNegAppRn e' neg_name `thenM` \ final_e ->
168 returnM (final_e, fv_e `plusFV` fv_neg)
170 ------------------------------------------
171 -- Template Haskell extensions
172 -- Don't ifdef-GHCI them because we want to fail gracefully
173 -- (not with an rnExpr crash) in a stage-1 compiler.
174 rnExpr e@(HsBracket br_body)
175 = checkTH e "bracket" `thenM_`
176 rnBracket br_body `thenM` \ (body', fvs_e) ->
177 returnM (HsBracket body', fvs_e)
179 rnExpr (HsSpliceE splice)
180 = rnSplice splice `thenM` \ (splice', fvs) ->
181 returnM (HsSpliceE splice', fvs)
184 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
186 rnExpr (HsQuasiQuoteE qq)
187 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
188 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
189 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
190 returnM (expr'', fvs_qq `plusFV` fvs_expr)
193 ---------------------------------------------
195 -- See Note [Parsing sections] in Parser.y.pp
196 rnExpr (HsPar (L loc (section@(SectionL {}))))
197 = do { (section', fvs) <- rnSection section
198 ; return (HsPar (L loc section'), fvs) }
200 rnExpr (HsPar (L loc (section@(SectionR {}))))
201 = do { (section', fvs) <- rnSection section
202 ; return (HsPar (L loc section'), fvs) }
205 = do { (e', fvs_e) <- rnLExpr e
206 ; return (HsPar e', fvs_e) }
208 rnExpr expr@(SectionL {})
209 = do { addErr (sectionErr expr); rnSection expr }
210 rnExpr expr@(SectionR {})
211 = do { addErr (sectionErr expr); rnSection expr }
213 ---------------------------------------------
214 rnExpr (HsCoreAnn ann expr)
215 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
216 returnM (HsCoreAnn ann expr', fvs_expr)
218 rnExpr (HsSCC lbl expr)
219 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
220 returnM (HsSCC lbl expr', fvs_expr)
221 rnExpr (HsTickPragma info expr)
222 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
223 returnM (HsTickPragma info expr', fvs_expr)
225 rnExpr (HsLam matches)
226 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
227 returnM (HsLam matches', fvMatch)
229 rnExpr (HsCase expr matches)
230 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
231 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
232 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
234 rnExpr (HsLet binds expr)
235 = rnLocalBindsAndThen binds $ \ binds' ->
236 rnLExpr expr `thenM` \ (expr',fvExpr) ->
237 returnM (HsLet binds' expr', fvExpr)
239 rnExpr (HsDo do_or_lc stmts body _)
240 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
242 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
244 rnExpr (ExplicitList _ exps)
245 = rnExprs exps `thenM` \ (exps', fvs) ->
246 returnM (ExplicitList placeHolderType exps', fvs)
248 rnExpr (ExplicitPArr _ exps)
249 = rnExprs exps `thenM` \ (exps', fvs) ->
250 returnM (ExplicitPArr placeHolderType exps', fvs)
252 rnExpr (ExplicitTuple exps boxity)
253 = checkTupSize (length exps) `thenM_`
254 rnExprs exps `thenM` \ (exps', fvs) ->
255 returnM (ExplicitTuple exps' boxity, fvs)
257 rnExpr (RecordCon con_id _ rbinds)
258 = do { conname <- lookupLocatedOccRn con_id
259 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
260 ; return (RecordCon conname noPostTcExpr rbinds',
261 fvRbinds `addOneFV` unLoc conname) }
263 rnExpr (RecordUpd expr rbinds _ _ _)
264 = do { (expr', fvExpr) <- rnLExpr expr
265 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
266 ; return (RecordUpd expr' rbinds' [] [] [],
267 fvExpr `plusFV` fvRbinds) }
269 rnExpr (ExprWithTySig expr pty)
270 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
271 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
273 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
275 doc = text "In an expression type signature"
277 rnExpr (HsIf p b1 b2)
278 = rnLExpr p `thenM` \ (p', fvP) ->
279 rnLExpr b1 `thenM` \ (b1', fvB1) ->
280 rnLExpr b2 `thenM` \ (b2', fvB2) ->
281 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
284 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
285 returnM (HsType t, fvT)
287 doc = text "In a type argument"
289 rnExpr (ArithSeq _ seq)
290 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
291 returnM (ArithSeq noPostTcExpr new_seq, fvs)
293 rnExpr (PArrSeq _ seq)
294 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
295 returnM (PArrSeq noPostTcExpr new_seq, fvs)
298 These three are pattern syntax appearing in expressions.
299 Since all the symbols are reservedops we can simply reject them.
300 We return a (bogus) EWildPat in each case.
303 rnExpr e@EWildPat = patSynErr e
304 rnExpr e@(EAsPat {}) = patSynErr e
305 rnExpr e@(EViewPat {}) = patSynErr e
306 rnExpr e@(ELazyPat {}) = patSynErr e
309 %************************************************************************
313 %************************************************************************
316 rnExpr (HsProc pat body)
318 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
319 rnCmdTop body `thenM` \ (body',fvBody) ->
320 returnM (HsProc pat' body', fvBody)
322 rnExpr (HsArrApp arrow arg _ ho rtl)
323 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
324 rnLExpr arg `thenM` \ (arg',fvArg) ->
325 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
326 fvArrow `plusFV` fvArg)
328 select_arrow_scope tc = case ho of
329 HsHigherOrderApp -> tc
330 HsFirstOrderApp -> escapeArrowScope tc
333 rnExpr (HsArrForm op (Just _) [arg1, arg2])
334 = escapeArrowScope (rnLExpr op)
335 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
336 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
337 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
341 lookupFixityRn op_name `thenM` \ fixity ->
342 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
345 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
347 rnExpr (HsArrForm op fixity cmds)
348 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
349 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
350 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
352 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
355 ----------------------
356 -- See Note [Parsing sections] in Parser.y.pp
357 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
358 rnSection section@(SectionR op expr)
359 = do { (op', fvs_op) <- rnLExpr op
360 ; (expr', fvs_expr) <- rnLExpr expr
361 ; checkSectionPrec InfixR section op' expr'
362 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
364 rnSection section@(SectionL expr op)
365 = do { (expr', fvs_expr) <- rnLExpr expr
366 ; (op', fvs_op) <- rnLExpr op
367 ; checkSectionPrec InfixL section op' expr'
368 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
370 rnSection other = pprPanic "rnSection" (ppr other)
373 %************************************************************************
377 %************************************************************************
380 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
381 rnCmdArgs [] = returnM ([], emptyFVs)
383 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
384 rnCmdArgs args `thenM` \ (args',fvArgs) ->
385 returnM (arg':args', fvArg `plusFV` fvArgs)
387 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
388 rnCmdTop = wrapLocFstM rnCmdTop'
390 rnCmdTop' (HsCmdTop cmd _ _ _)
391 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
393 cmd_names = [arrAName, composeAName, firstAName] ++
394 nameSetToList (methodNamesCmd (unLoc cmd'))
396 -- Generate the rebindable syntax for the monad
397 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
399 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
400 fvCmd `plusFV` cmd_fvs)
402 ---------------------------------------------------
403 -- convert OpApp's in a command context to HsArrForm's
405 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
406 convertOpFormsLCmd = fmap convertOpFormsCmd
408 convertOpFormsCmd :: HsCmd id -> HsCmd id
410 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
411 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
412 convertOpFormsCmd (OpApp c1 op fixity c2)
414 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
415 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
417 HsArrForm op (Just fixity) [arg1, arg2]
419 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
421 convertOpFormsCmd (HsCase exp matches)
422 = HsCase exp (convertOpFormsMatch matches)
424 convertOpFormsCmd (HsIf exp c1 c2)
425 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
427 convertOpFormsCmd (HsLet binds cmd)
428 = HsLet binds (convertOpFormsLCmd cmd)
430 convertOpFormsCmd (HsDo ctxt stmts body ty)
431 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
432 (convertOpFormsLCmd body) ty
434 -- Anything else is unchanged. This includes HsArrForm (already done),
435 -- things with no sub-commands, and illegal commands (which will be
436 -- caught by the type checker)
437 convertOpFormsCmd c = c
439 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
440 convertOpFormsStmt (BindStmt pat cmd _ _)
441 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
442 convertOpFormsStmt (ExprStmt cmd _ _)
443 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
444 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
445 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
446 convertOpFormsStmt stmt = stmt
448 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
449 convertOpFormsMatch (MatchGroup ms ty)
450 = MatchGroup (map (fmap convert) ms) ty
451 where convert (Match pat mty grhss)
452 = Match pat mty (convertOpFormsGRHSs grhss)
454 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
455 convertOpFormsGRHSs (GRHSs grhss binds)
456 = GRHSs (map convertOpFormsGRHS grhss) binds
458 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
459 convertOpFormsGRHS = fmap convert
461 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
463 ---------------------------------------------------
464 type CmdNeeds = FreeVars -- Only inhabitants are
465 -- appAName, choiceAName, loopAName
467 -- find what methods the Cmd needs (loop, choice, apply)
468 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
469 methodNamesLCmd = methodNamesCmd . unLoc
471 methodNamesCmd :: HsCmd Name -> CmdNeeds
473 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
475 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
477 methodNamesCmd (HsArrForm {}) = emptyFVs
479 methodNamesCmd (HsPar c) = methodNamesLCmd c
481 methodNamesCmd (HsIf _ c1 c2)
482 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
484 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
486 methodNamesCmd (HsDo _ stmts body _)
487 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
489 methodNamesCmd (HsApp c _) = methodNamesLCmd c
491 methodNamesCmd (HsLam match) = methodNamesMatch match
493 methodNamesCmd (HsCase _ matches)
494 = methodNamesMatch matches `addOneFV` choiceAName
496 methodNamesCmd _ = emptyFVs
497 -- Other forms can't occur in commands, but it's not convenient
498 -- to error here so we just do what's convenient.
499 -- The type checker will complain later
501 ---------------------------------------------------
502 methodNamesMatch :: MatchGroup Name -> FreeVars
503 methodNamesMatch (MatchGroup ms _)
504 = plusFVs (map do_one ms)
506 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
508 -------------------------------------------------
510 methodNamesGRHSs :: GRHSs Name -> FreeVars
511 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
513 -------------------------------------------------
515 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
516 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
518 ---------------------------------------------------
519 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
520 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
522 ---------------------------------------------------
523 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
524 methodNamesLStmt = methodNamesStmt . unLoc
526 methodNamesStmt :: StmtLR Name Name -> FreeVars
527 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
528 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
529 methodNamesStmt (RecStmt stmts _ _ _ _)
530 = methodNamesStmts stmts `addOneFV` loopAName
531 methodNamesStmt (LetStmt _) = emptyFVs
532 methodNamesStmt (ParStmt _) = emptyFVs
533 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
534 methodNamesStmt (GroupStmt _ _) = emptyFVs
535 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
536 -- here so we just do what's convenient
540 %************************************************************************
544 %************************************************************************
547 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
548 rnArithSeq (From expr)
549 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
550 returnM (From expr', fvExpr)
552 rnArithSeq (FromThen expr1 expr2)
553 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
554 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
555 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
557 rnArithSeq (FromTo expr1 expr2)
558 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
559 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
560 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
562 rnArithSeq (FromThenTo expr1 expr2 expr3)
563 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
564 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
565 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
566 returnM (FromThenTo expr1' expr2' expr3',
567 plusFVs [fvExpr1, fvExpr2, fvExpr3])
570 %************************************************************************
572 Template Haskell brackets
574 %************************************************************************
577 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
578 rnBracket (VarBr n) = do { name <- lookupOccRn n
579 ; this_mod <- getModule
580 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
581 do { loadInterfaceForName msg name -- home interface is loaded, and this is the
582 ; return () } -- only way that is going to happen
583 ; returnM (VarBr name, unitFV name) }
585 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
587 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
588 ; return (ExpBr e', fvs) }
590 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
591 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
592 ; return (TypBr t', fvs) }
594 doc = ptext (sLit "In a Template-Haskell quoted type")
595 rnBracket (DecBr group)
596 = do { gbl_env <- getGblEnv
598 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
599 -- The emptyDUs is so that we just collect uses for this
600 -- group alone in the call to rnSrcDecls below
601 ; (tcg_env, group') <- setGblEnv new_gbl_env $
605 -- Discard the tcg_env; it contains only extra info about fixity
606 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
609 %************************************************************************
611 \subsubsection{@Stmt@s: in @do@ expressions}
613 %************************************************************************
616 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
617 -> RnM (thing, FreeVars)
618 -> RnM (([LStmt Name], thing), FreeVars)
620 rnStmts (MDoExpr _) = rnMDoStmts
621 rnStmts ctxt = rnNormalStmts ctxt
623 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
624 -> RnM (thing, FreeVars)
625 -> RnM (([LStmt Name], thing), FreeVars)
626 -- Used for cases *other* than recursive mdo
627 -- Implements nested scopes
629 rnNormalStmts _ [] thing_inside
630 = do { (thing, fvs) <- thing_inside
631 ; return (([],thing), fvs) }
633 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
634 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
635 rnNormalStmts ctxt stmts thing_inside
636 ; return (((L loc stmt' : stmts'), thing), fvs) }
639 rnStmt :: HsStmtContext Name -> Stmt RdrName
640 -> RnM (thing, FreeVars)
641 -> RnM ((Stmt Name, thing), FreeVars)
643 rnStmt _ (ExprStmt expr _ _) thing_inside
644 = do { (expr', fv_expr) <- rnLExpr expr
645 ; (then_op, fvs1) <- lookupSyntaxName thenMName
646 ; (thing, fvs2) <- thing_inside
647 ; return ((ExprStmt expr' then_op placeHolderType, thing),
648 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
650 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
651 = do { (expr', fv_expr) <- rnLExpr expr
652 -- The binders do not scope over the expression
653 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
654 ; (fail_op, fvs2) <- lookupSyntaxName failMName
655 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
656 { (thing, fvs3) <- thing_inside
657 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
658 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
659 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
660 -- but it does not matter because the names are unique
662 rnStmt ctxt (LetStmt binds) thing_inside
663 = do { checkLetStmt ctxt binds
664 ; rnLocalBindsAndThen binds $ \binds' -> do
665 { (thing, fvs) <- thing_inside
666 ; return ((LetStmt binds', thing), fvs) } }
668 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
669 = do { checkRecStmt ctxt
670 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
671 { (thing, fvs) <- thing_inside
673 segs_w_fwd_refs = addFwdRefs segs
674 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
675 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
676 fwd_vars = nameSetToList (plusFVs fs)
678 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
679 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
681 rnStmt ctxt (ParStmt segs) thing_inside
682 = do { checkParStmt ctxt
683 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
684 ; return ((ParStmt segs', thing), fvs) }
686 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
687 checkTransformStmt ctxt
689 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
690 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
691 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
692 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
693 (thing, fv_thing) <- thing_inside
695 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
697 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
699 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
700 rnMaybeLExpr (Just expr) = do
701 (expr', fv_expr) <- rnLExpr expr
702 return (Just expr', fv_expr)
704 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
705 checkTransformStmt ctxt
707 -- We must rename the using expression in the context before the transform is begun
708 groupByClauseAction <-
709 case groupByClause of
710 GroupByNothing usingExpr -> do
711 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
712 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
713 GroupBySomething eitherUsingExpr byExpr -> do
714 (eitherUsingExpr', fv_eitherUsingExpr) <-
715 case eitherUsingExpr of
716 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
718 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
719 return (Left usingExpr', fv_usingExpr)
722 (byExpr', fv_byExpr) <- rnLExpr byExpr
723 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
725 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
726 -- perhaps we could refactor this to use rnNormalStmts directly?
727 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
728 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
729 (groupByClause', fv_groupByClause) <- groupByClauseAction
731 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
732 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
734 -- Bind the "thing" inside a context where we have REBOUND everything
735 -- bound by the statements before the group. This is necessary since after
736 -- the grouping the same identifiers actually have different meanings
737 -- i.e. they refer to lists not singletons!
738 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
740 -- We remove entries from the binder map that are not used in the thing_inside.
741 -- We can then use that usage information to ensure that the free variables do
742 -- not contain the things we just bound, but do contain the things we need to
743 -- make those bindings (i.e. the corresponding non-listy variables)
745 -- Note that we also retain those entries which have an old binder in our
746 -- own free variables (the using or by expression). This is because this map
747 -- is reused in the desugarer to create the type to bind from the statements
748 -- that occur before this one. If the binders we need are not in the map, they
749 -- will never get bound into our desugared expression and hence the simplifier
750 -- crashes as we refer to variables that don't exist!
751 let usedBinderMap = filter
752 (\(old_binder, new_binder) ->
753 (new_binder `elemNameSet` fv_thing) ||
754 (old_binder `elemNameSet` fv_groupByClause)) binderMap
755 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
756 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
758 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
760 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
761 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
763 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
765 -> ([Name] -> RnM (thing, FreeVars))
766 -> RnM (([LStmt Name], [Name], thing), FreeVars)
767 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
768 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
769 -- Find the Names that are bound by stmts that
770 -- by assumption we have just renamed
771 local_env <- getLocalRdrEnv
773 stmts_binders = collectLStmtsBinders stmts
774 bndrs = map (expectJust "rnStmt"
775 . lookupLocalRdrEnv local_env
776 . unLoc) stmts_binders
778 -- If shadow, we'll look up (Unqual x) twice, getting
779 -- the second binding both times, which is the
781 unshadowed_bndrs = nub bndrs
783 -- Typecheck the thing inside, passing on all
784 -- the Names bound before it for its information
785 (thing, fvs) <- thing_inside unshadowed_bndrs
787 -- Figure out which of the bound names are used
788 -- after the statements we renamed
789 let used_bndrs = filter (`elemNameSet` fvs) bndrs
790 return ((used_bndrs, thing), fvs)
792 -- Flatten the tuple returned by the above call a bit!
793 return ((stmts', used_bndrs, inner_thing), fvs)
795 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
796 -> RnM (thing, FreeVars)
797 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
798 rnParallelStmts ctxt segs thing_inside = do
799 orig_lcl_env <- getLocalRdrEnv
800 go orig_lcl_env [] segs
802 go orig_lcl_env bndrs [] = do
803 let (bndrs', dups) = removeDups cmpByOcc bndrs
804 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
807 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
808 return (([], thing), fvs)
810 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
811 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
812 -- Typecheck the thing inside, passing on all
813 -- the Names bound, but separately; revert the envt
814 setLocalRdrEnv orig_lcl_env $ do
815 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
817 let seg' = (stmts', bndrs)
818 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
820 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
821 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
822 <+> quotes (ppr (head vs)))
826 %************************************************************************
828 \subsubsection{mdo expressions}
830 %************************************************************************
833 type FwdRefs = NameSet
834 type Segment stmts = (Defs,
835 Uses, -- May include defs
836 FwdRefs, -- A subset of uses that are
837 -- (a) used before they are bound in this segment, or
838 -- (b) used here, and bound in subsequent segments
839 stmts) -- Either Stmt or [Stmt]
842 ----------------------------------------------------
844 rnMDoStmts :: [LStmt RdrName]
845 -> RnM (thing, FreeVars)
846 -> RnM (([LStmt Name], thing), FreeVars)
847 rnMDoStmts stmts thing_inside
848 = -- Step1: Bring all the binders of the mdo into scope
849 -- (Remember that this also removes the binders from the
850 -- finally-returned free-vars.)
851 -- And rename each individual stmt, making a
852 -- singleton segment. At this stage the FwdRefs field
853 -- isn't finished: it's empty for all except a BindStmt
854 -- for which it's the fwd refs within the bind itself
855 -- (This set may not be empty, because we're in a recursive
857 rn_rec_stmts_and_then stmts $ \ segs -> do {
859 ; (thing, fvs_later) <- thing_inside
862 -- Step 2: Fill in the fwd refs.
863 -- The segments are all singletons, but their fwd-ref
864 -- field mentions all the things used by the segment
865 -- that are bound after their use
866 segs_w_fwd_refs = addFwdRefs segs
868 -- Step 3: Group together the segments to make bigger segments
869 -- Invariant: in the result, no segment uses a variable
870 -- bound in a later segment
871 grouped_segs = glomSegments segs_w_fwd_refs
873 -- Step 4: Turn the segments into Stmts
874 -- Use RecStmt when and only when there are fwd refs
875 -- Also gather up the uses from the end towards the
876 -- start, so we can tell the RecStmt which things are
877 -- used 'after' the RecStmt
878 (stmts', fvs) = segsToStmts grouped_segs fvs_later
880 ; return ((stmts', thing), fvs) }
882 ---------------------------------------------
884 -- wrapper that does both the left- and right-hand sides
885 rn_rec_stmts_and_then :: [LStmt RdrName]
886 -- assumes that the FreeVars returned includes
887 -- the FreeVars of the Segments
888 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
890 rn_rec_stmts_and_then s cont
891 = do { -- (A) Make the mini fixity env for all of the stmts
892 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
895 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
897 -- ...bring them and their fixities into scope
898 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
899 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
901 -- (C) do the right-hand-sides and thing-inside
902 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
903 ; (res, fvs) <- cont segs
904 ; warnUnusedLocalBinds bound_names fvs
905 ; return (res, fvs) }}
907 -- get all the fixity decls in any Let stmt
908 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
909 collectRecStmtsFixities l =
910 foldr (\ s -> \acc -> case s of
911 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
912 foldr (\ sig -> \ acc -> case sig of
913 (L loc (FixSig s)) -> (L loc s) : acc
919 rn_rec_stmt_lhs :: MiniFixityEnv
921 -- rename LHS, and return its FVs
922 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
923 -- so we don't bother to compute it accurately in the other cases
924 -> RnM [(LStmtLR Name RdrName, FreeVars)]
926 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
927 -- this is actually correct
930 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
932 -- should the ctxt be MDo instead?
933 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
934 return [(L loc (BindStmt pat' expr a b),
937 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
938 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
940 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
941 = do binds' <- rnValBindsLHS fix_env binds
942 return [(L loc (LetStmt (HsValBinds binds')),
943 -- Warning: this is bogus; see function invariant
947 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
948 = rn_rec_stmts_lhs fix_env stmts
950 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
951 = pprPanic "rn_rec_stmt" (ppr stmt)
953 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
954 = pprPanic "rn_rec_stmt" (ppr stmt)
956 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
957 = pprPanic "rn_rec_stmt" (ppr stmt)
959 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
960 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
962 rn_rec_stmts_lhs :: MiniFixityEnv
964 -> RnM [(LStmtLR Name RdrName, FreeVars)]
965 rn_rec_stmts_lhs fix_env stmts =
966 let boundNames = collectLStmtsBinders stmts
967 doc = text "In a recursive mdo-expression"
969 -- First do error checking: we need to check for dups here because we
970 -- don't bind all of the variables from the Stmt at once
971 -- with bindLocatedLocals.
972 checkDupRdrNames doc boundNames
973 mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls)
978 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
979 -- Rename a Stmt that is inside a RecStmt (or mdo)
980 -- Assumes all binders are already in scope
981 -- Turns each stmt into a singleton Stmt
982 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
983 = rnLExpr expr `thenM` \ (expr', fvs) ->
984 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
985 returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
986 L loc (ExprStmt expr' then_op placeHolderType))]
988 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
989 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
990 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
991 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
993 bndrs = mkNameSet (collectPatBinders pat')
994 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
996 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
997 L loc (BindStmt pat' expr' bind_op fail_op))]
999 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1000 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1002 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1003 (binds', du_binds) <-
1004 -- fixities and unused are handled above in rn_rec_stmts_and_then
1005 rnValBindsRHS (mkNameSet all_bndrs) binds'
1006 returnM [(duDefs du_binds, duUses du_binds,
1007 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1009 -- no RecStmt case becuase they get flattened above when doing the LHSes
1010 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1011 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1013 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1014 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1016 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1017 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1019 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1020 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1022 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1023 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1025 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1026 rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1027 returnM (concat segs_s)
1029 ---------------------------------------------
1030 addFwdRefs :: [Segment a] -> [Segment a]
1031 -- So far the segments only have forward refs *within* the Stmt
1032 -- (which happens for bind: x <- ...x...)
1033 -- This function adds the cross-seg fwd ref info
1036 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1038 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1039 = (new_seg : segs, all_defs)
1041 new_seg = (defs, uses, new_fwds, stmts)
1042 all_defs = later_defs `unionNameSets` defs
1043 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1044 -- Add the downstream fwd refs here
1046 ----------------------------------------------------
1047 -- Glomming the singleton segments of an mdo into
1048 -- minimal recursive groups.
1050 -- At first I thought this was just strongly connected components, but
1051 -- there's an important constraint: the order of the stmts must not change.
1054 -- mdo { x <- ...y...
1061 -- Here, the first stmt mention 'y', which is bound in the third.
1062 -- But that means that the innocent second stmt (p <- z) gets caught
1063 -- up in the recursion. And that in turn means that the binding for
1064 -- 'z' has to be included... and so on.
1066 -- Start at the tail { r <- x }
1067 -- Now add the next one { z <- y ; r <- x }
1068 -- Now add one more { q <- x ; z <- y ; r <- x }
1069 -- Now one more... but this time we have to group a bunch into rec
1070 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1071 -- Now one more, which we can add on without a rec
1073 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1075 -- Finally we add the last one; since it mentions y we have to
1076 -- glom it togeher with the first two groups
1077 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1078 -- q <- x ; z <- y } ;
1081 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1083 glomSegments [] = []
1084 glomSegments ((defs,uses,fwds,stmt) : segs)
1085 -- Actually stmts will always be a singleton
1086 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1088 segs' = glomSegments segs
1089 (extras, others) = grab uses segs'
1090 (ds, us, fs, ss) = unzip4 extras
1092 seg_defs = plusFVs ds `plusFV` defs
1093 seg_uses = plusFVs us `plusFV` uses
1094 seg_fwds = plusFVs fs `plusFV` fwds
1095 seg_stmts = stmt : concat ss
1097 grab :: NameSet -- The client
1099 -> ([Segment a], -- Needed by the 'client'
1100 [Segment a]) -- Not needed by the client
1101 -- The result is simply a split of the input
1103 = (reverse yeses, reverse noes)
1105 (noes, yeses) = span not_needed (reverse dus)
1106 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1109 ----------------------------------------------------
1110 segsToStmts :: [Segment [LStmt Name]]
1111 -> FreeVars -- Free vars used 'later'
1112 -> ([LStmt Name], FreeVars)
1114 segsToStmts [] fvs_later = ([], fvs_later)
1115 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1116 = ASSERT( not (null ss) )
1117 (new_stmt : later_stmts, later_uses `plusFV` uses)
1119 (later_stmts, later_uses) = segsToStmts segs fvs_later
1120 new_stmt | non_rec = head ss
1121 | otherwise = L (getLoc (head ss)) $
1122 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1125 non_rec = isSingleton ss && isEmptyNameSet fwds
1126 used_later = defs `intersectNameSet` later_uses
1127 -- The ones needed after the RecStmt
1130 %************************************************************************
1132 \subsubsection{Assertion utils}
1134 %************************************************************************
1137 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1138 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
1140 mkAssertErrorExpr :: RnM (HsExpr Name)
1141 -- Return an expression for (assertError "Foo.hs:27")
1143 = getSrcSpanM `thenM` \ sloc ->
1144 return (HsApp (L sloc (HsVar assertErrorName))
1145 (L sloc (srcSpanPrimLit sloc)))
1148 Note [Adding the implicit parameter to 'assert']
1149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1151 By doing this in the renamer we allow the typechecker to just see the
1152 expanded application and do the right thing. But it's not really
1153 the Right Thing because there's no way to "undo" if you want to see
1154 the original source code. We'll have fix this in due course, when
1155 we care more about being able to reconstruct the exact original
1158 %************************************************************************
1160 \subsubsection{Errors}
1162 %************************************************************************
1166 ----------------------
1167 -- Checking when a particular Stmt is ok
1168 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1169 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1170 checkLetStmt _ctxt _binds = return ()
1171 -- We do not allow implicit-parameter bindings in a parallel
1172 -- list comprehension. I'm not sure what it might mean.
1175 checkRecStmt :: HsStmtContext Name -> RnM ()
1176 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1177 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1178 -- proc x -> do { ...rec... }
1179 -- We don't have enough context to distinguish this situation here
1180 -- so we leave it to the type checker
1181 checkRecStmt ctxt = addErr msg
1183 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1186 checkParStmt :: HsStmtContext Name -> RnM ()
1188 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1189 ; checkErr parallel_list_comp msg }
1191 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1194 checkTransformStmt :: HsStmtContext Name -> RnM ()
1195 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1196 -- desugarer will break when we come to operate on a parallel array
1197 = do { transform_list_comp <- doptM Opt_TransformListComp
1198 ; checkErr transform_list_comp msg }
1200 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1201 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1202 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1203 checkTransformStmt ctxt = addErr msg
1205 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1208 sectionErr :: HsExpr RdrName -> SDoc
1210 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1211 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1213 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1214 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1216 ; return (EWildPat, emptyFVs) }
1218 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1219 badIpBinds what binds
1220 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)