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(..) )
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 )
58 thenM :: Monad a => a b -> (b -> a c) -> a c
61 thenM_ :: Monad a => a b -> a c -> a c
65 %************************************************************************
67 \subsubsection{Expressions}
69 %************************************************************************
72 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
73 rnExprs ls = rnExprs' ls emptyUniqSet
75 rnExprs' [] acc = return ([], acc)
76 rnExprs' (expr:exprs) acc
77 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
79 -- Now we do a "seq" on the free vars because typically it's small
80 -- or empty, especially in very long lists of constants
82 acc' = acc `plusFV` fvExpr
84 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
85 return (expr':exprs', fvExprs)
88 Variables. We look up the variable and return the resulting name.
91 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
92 rnLExpr = wrapLocFstM rnExpr
94 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
96 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
97 -- Separated from rnExpr because it's also used
98 -- when renaming infix expressions
99 -- See Note [Adding the implicit parameter to 'assert']
101 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
102 ; if ignore_asserts || not (name `hasKey` assertIdKey)
103 then return (HsVar name, unitFV name)
104 else do { e <- mkAssertErrorExpr
105 ; return (e, unitFV name) } }
108 = do name <- lookupOccRn v
112 = newIPNameRn v `thenM` \ name ->
113 return (HsIPVar name, emptyFVs)
115 rnExpr (HsLit lit@(HsString s))
117 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
118 ; if opt_OverloadedStrings then
119 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
120 else -- Same as below
122 return (HsLit lit, emptyFVs)
127 return (HsLit lit, emptyFVs)
129 rnExpr (HsOverLit lit)
130 = rnOverLit lit `thenM` \ (lit', fvs) ->
131 return (HsOverLit lit', fvs)
133 rnExpr (HsApp fun arg)
134 = rnLExpr fun `thenM` \ (fun',fvFun) ->
135 rnLExpr arg `thenM` \ (arg',fvArg) ->
136 return (HsApp fun' arg', fvFun `plusFV` fvArg)
138 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
139 = do { (e1', fv_e1) <- rnLExpr e1
140 ; (e2', fv_e2) <- rnLExpr e2
141 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
142 ; (op', fv_op) <- finishHsVar op_name
143 -- NB: op' is usually just a variable, but might be
144 -- an applicatoin (assert "Foo.hs:47")
146 -- When renaming code synthesised from "deriving" declarations
147 -- we used to avoid fixity stuff, but we can't easily tell any
148 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
149 -- should prevent bad things happening.
150 ; fixity <- lookupFixityRn op_name
151 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
152 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
155 = rnLExpr e `thenM` \ (e', fv_e) ->
156 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
157 mkNegAppRn e' neg_name `thenM` \ final_e ->
158 return (final_e, fv_e `plusFV` fv_neg)
160 ------------------------------------------
161 -- Template Haskell extensions
162 -- Don't ifdef-GHCI them because we want to fail gracefully
163 -- (not with an rnExpr crash) in a stage-1 compiler.
164 rnExpr e@(HsBracket br_body)
165 = checkTH e "bracket" `thenM_`
166 rnBracket br_body `thenM` \ (body', fvs_e) ->
167 return (HsBracket body', fvs_e)
169 rnExpr (HsSpliceE splice)
170 = rnSplice splice `thenM` \ (splice', fvs) ->
171 return (HsSpliceE splice', fvs)
174 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
176 rnExpr (HsQuasiQuoteE qq)
177 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
178 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
179 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
180 return (expr'', fvs_qq `plusFV` fvs_expr)
183 ---------------------------------------------
185 -- See Note [Parsing sections] in Parser.y.pp
186 rnExpr (HsPar (L loc (section@(SectionL {}))))
187 = do { (section', fvs) <- rnSection section
188 ; return (HsPar (L loc section'), fvs) }
190 rnExpr (HsPar (L loc (section@(SectionR {}))))
191 = do { (section', fvs) <- rnSection section
192 ; return (HsPar (L loc section'), fvs) }
195 = do { (e', fvs_e) <- rnLExpr e
196 ; return (HsPar e', fvs_e) }
198 rnExpr expr@(SectionL {})
199 = do { addErr (sectionErr expr); rnSection expr }
200 rnExpr expr@(SectionR {})
201 = do { addErr (sectionErr expr); rnSection expr }
203 ---------------------------------------------
204 rnExpr (HsCoreAnn ann expr)
205 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
206 return (HsCoreAnn ann expr', fvs_expr)
208 rnExpr (HsSCC lbl expr)
209 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
210 return (HsSCC lbl expr', fvs_expr)
211 rnExpr (HsTickPragma info expr)
212 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
213 return (HsTickPragma info expr', fvs_expr)
215 rnExpr (HsLam matches)
216 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
217 return (HsLam matches', fvMatch)
219 rnExpr (HsCase expr matches)
220 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
221 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
222 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
224 rnExpr (HsLet binds expr)
225 = rnLocalBindsAndThen binds $ \ binds' ->
226 rnLExpr expr `thenM` \ (expr',fvExpr) ->
227 return (HsLet binds' expr', fvExpr)
229 rnExpr (HsDo do_or_lc stmts body _)
230 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
232 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
234 rnExpr (ExplicitList _ exps)
235 = rnExprs exps `thenM` \ (exps', fvs) ->
236 return (ExplicitList placeHolderType exps', fvs)
238 rnExpr (ExplicitPArr _ exps)
239 = rnExprs exps `thenM` \ (exps', fvs) ->
240 return (ExplicitPArr placeHolderType exps', fvs)
242 rnExpr (ExplicitTuple exps boxity)
243 = checkTupSize (length exps) `thenM_`
244 rnExprs exps `thenM` \ (exps', fvs) ->
245 return (ExplicitTuple exps' boxity, fvs)
247 rnExpr (RecordCon con_id _ rbinds)
248 = do { conname <- lookupLocatedOccRn con_id
249 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
250 ; return (RecordCon conname noPostTcExpr rbinds',
251 fvRbinds `addOneFV` unLoc conname) }
253 rnExpr (RecordUpd expr rbinds _ _ _)
254 = do { (expr', fvExpr) <- rnLExpr expr
255 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
256 ; return (RecordUpd expr' rbinds' [] [] [],
257 fvExpr `plusFV` fvRbinds) }
259 rnExpr (ExprWithTySig expr pty)
260 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
261 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
263 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
265 doc = text "In an expression type signature"
267 rnExpr (HsIf p b1 b2)
268 = rnLExpr p `thenM` \ (p', fvP) ->
269 rnLExpr b1 `thenM` \ (b1', fvB1) ->
270 rnLExpr b2 `thenM` \ (b2', fvB2) ->
271 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
274 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
275 return (HsType t, fvT)
277 doc = text "In a type argument"
279 rnExpr (ArithSeq _ seq)
280 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
281 return (ArithSeq noPostTcExpr new_seq, fvs)
283 rnExpr (PArrSeq _ seq)
284 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
285 return (PArrSeq noPostTcExpr new_seq, fvs)
288 These three are pattern syntax appearing in expressions.
289 Since all the symbols are reservedops we can simply reject them.
290 We return a (bogus) EWildPat in each case.
293 rnExpr e@EWildPat = patSynErr e
294 rnExpr e@(EAsPat {}) = patSynErr e
295 rnExpr e@(EViewPat {}) = patSynErr e
296 rnExpr e@(ELazyPat {}) = patSynErr e
299 %************************************************************************
303 %************************************************************************
306 rnExpr (HsProc pat body)
308 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
309 rnCmdTop body `thenM` \ (body',fvBody) ->
310 return (HsProc pat' body', fvBody)
312 rnExpr (HsArrApp arrow arg _ ho rtl)
313 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
314 rnLExpr arg `thenM` \ (arg',fvArg) ->
315 return (HsArrApp arrow' arg' placeHolderType ho rtl,
316 fvArrow `plusFV` fvArg)
318 select_arrow_scope tc = case ho of
319 HsHigherOrderApp -> tc
320 HsFirstOrderApp -> escapeArrowScope tc
323 rnExpr (HsArrForm op (Just _) [arg1, arg2])
324 = escapeArrowScope (rnLExpr op)
325 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
326 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
327 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
331 lookupFixityRn op_name `thenM` \ fixity ->
332 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
335 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
337 rnExpr (HsArrForm op fixity cmds)
338 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
339 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
340 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
342 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
345 ----------------------
346 -- See Note [Parsing sections] in Parser.y.pp
347 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
348 rnSection section@(SectionR op expr)
349 = do { (op', fvs_op) <- rnLExpr op
350 ; (expr', fvs_expr) <- rnLExpr expr
351 ; checkSectionPrec InfixR section op' expr'
352 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
354 rnSection section@(SectionL expr op)
355 = do { (expr', fvs_expr) <- rnLExpr expr
356 ; (op', fvs_op) <- rnLExpr op
357 ; checkSectionPrec InfixL section op' expr'
358 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
360 rnSection other = pprPanic "rnSection" (ppr other)
363 %************************************************************************
367 %************************************************************************
370 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
371 rnCmdArgs [] = return ([], emptyFVs)
373 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
374 rnCmdArgs args `thenM` \ (args',fvArgs) ->
375 return (arg':args', fvArg `plusFV` fvArgs)
377 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
378 rnCmdTop = wrapLocFstM rnCmdTop'
380 rnCmdTop' (HsCmdTop cmd _ _ _)
381 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
383 cmd_names = [arrAName, composeAName, firstAName] ++
384 nameSetToList (methodNamesCmd (unLoc cmd'))
386 -- Generate the rebindable syntax for the monad
387 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
389 return (HsCmdTop cmd' [] placeHolderType cmd_names',
390 fvCmd `plusFV` cmd_fvs)
392 ---------------------------------------------------
393 -- convert OpApp's in a command context to HsArrForm's
395 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
396 convertOpFormsLCmd = fmap convertOpFormsCmd
398 convertOpFormsCmd :: HsCmd id -> HsCmd id
400 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
401 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
402 convertOpFormsCmd (OpApp c1 op fixity c2)
404 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
405 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
407 HsArrForm op (Just fixity) [arg1, arg2]
409 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
411 convertOpFormsCmd (HsCase exp matches)
412 = HsCase exp (convertOpFormsMatch matches)
414 convertOpFormsCmd (HsIf exp c1 c2)
415 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
417 convertOpFormsCmd (HsLet binds cmd)
418 = HsLet binds (convertOpFormsLCmd cmd)
420 convertOpFormsCmd (HsDo ctxt stmts body ty)
421 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
422 (convertOpFormsLCmd body) ty
424 -- Anything else is unchanged. This includes HsArrForm (already done),
425 -- things with no sub-commands, and illegal commands (which will be
426 -- caught by the type checker)
427 convertOpFormsCmd c = c
429 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
430 convertOpFormsStmt (BindStmt pat cmd _ _)
431 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
432 convertOpFormsStmt (ExprStmt cmd _ _)
433 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
434 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
435 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
436 convertOpFormsStmt stmt = stmt
438 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
439 convertOpFormsMatch (MatchGroup ms ty)
440 = MatchGroup (map (fmap convert) ms) ty
441 where convert (Match pat mty grhss)
442 = Match pat mty (convertOpFormsGRHSs grhss)
444 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
445 convertOpFormsGRHSs (GRHSs grhss binds)
446 = GRHSs (map convertOpFormsGRHS grhss) binds
448 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
449 convertOpFormsGRHS = fmap convert
451 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
453 ---------------------------------------------------
454 type CmdNeeds = FreeVars -- Only inhabitants are
455 -- appAName, choiceAName, loopAName
457 -- find what methods the Cmd needs (loop, choice, apply)
458 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
459 methodNamesLCmd = methodNamesCmd . unLoc
461 methodNamesCmd :: HsCmd Name -> CmdNeeds
463 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
465 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
467 methodNamesCmd (HsArrForm {}) = emptyFVs
469 methodNamesCmd (HsPar c) = methodNamesLCmd c
471 methodNamesCmd (HsIf _ c1 c2)
472 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
474 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
476 methodNamesCmd (HsDo _ stmts body _)
477 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
479 methodNamesCmd (HsApp c _) = methodNamesLCmd c
481 methodNamesCmd (HsLam match) = methodNamesMatch match
483 methodNamesCmd (HsCase _ matches)
484 = methodNamesMatch matches `addOneFV` choiceAName
486 methodNamesCmd _ = emptyFVs
487 -- Other forms can't occur in commands, but it's not convenient
488 -- to error here so we just do what's convenient.
489 -- The type checker will complain later
491 ---------------------------------------------------
492 methodNamesMatch :: MatchGroup Name -> FreeVars
493 methodNamesMatch (MatchGroup ms _)
494 = plusFVs (map do_one ms)
496 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
498 -------------------------------------------------
500 methodNamesGRHSs :: GRHSs Name -> FreeVars
501 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
503 -------------------------------------------------
505 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
506 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
508 ---------------------------------------------------
509 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
510 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
512 ---------------------------------------------------
513 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
514 methodNamesLStmt = methodNamesStmt . unLoc
516 methodNamesStmt :: StmtLR Name Name -> FreeVars
517 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
518 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
519 methodNamesStmt (RecStmt stmts _ _ _ _)
520 = methodNamesStmts stmts `addOneFV` loopAName
521 methodNamesStmt (LetStmt _) = emptyFVs
522 methodNamesStmt (ParStmt _) = emptyFVs
523 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
524 methodNamesStmt (GroupStmt _ _) = emptyFVs
525 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
526 -- here so we just do what's convenient
530 %************************************************************************
534 %************************************************************************
537 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
538 rnArithSeq (From expr)
539 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
540 return (From expr', fvExpr)
542 rnArithSeq (FromThen expr1 expr2)
543 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
544 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
545 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
547 rnArithSeq (FromTo expr1 expr2)
548 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
549 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
550 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
552 rnArithSeq (FromThenTo expr1 expr2 expr3)
553 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
554 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
555 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
556 return (FromThenTo expr1' expr2' expr3',
557 plusFVs [fvExpr1, fvExpr2, fvExpr3])
560 %************************************************************************
562 Template Haskell brackets
564 %************************************************************************
567 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
568 rnBracket (VarBr n) = do { name <- lookupOccRn n
569 ; this_mod <- getModule
570 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
571 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
572 ; return () } -- only way that is going to happen
573 ; return (VarBr name, unitFV name) }
575 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
577 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
578 ; return (ExpBr e', fvs) }
580 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
581 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
582 ; return (TypBr t', fvs) }
584 doc = ptext (sLit "In a Template-Haskell quoted type")
585 rnBracket (DecBr group)
586 = do { gbl_env <- getGblEnv
588 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
589 -- The emptyDUs is so that we just collect uses for this
590 -- group alone in the call to rnSrcDecls below
591 ; (tcg_env, group') <- setGblEnv new_gbl_env $
595 -- Discard the tcg_env; it contains only extra info about fixity
596 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
599 %************************************************************************
601 \subsubsection{@Stmt@s: in @do@ expressions}
603 %************************************************************************
606 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
607 -> RnM (thing, FreeVars)
608 -> RnM (([LStmt Name], thing), FreeVars)
610 rnStmts (MDoExpr _) = rnMDoStmts
611 rnStmts ctxt = rnNormalStmts ctxt
613 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
614 -> RnM (thing, FreeVars)
615 -> RnM (([LStmt Name], thing), FreeVars)
616 -- Used for cases *other* than recursive mdo
617 -- Implements nested scopes
619 rnNormalStmts _ [] thing_inside
620 = do { (thing, fvs) <- thing_inside
621 ; return (([],thing), fvs) }
623 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
624 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
625 rnNormalStmts ctxt stmts thing_inside
626 ; return (((L loc stmt' : stmts'), thing), fvs) }
629 rnStmt :: HsStmtContext Name -> Stmt RdrName
630 -> RnM (thing, FreeVars)
631 -> RnM ((Stmt Name, thing), FreeVars)
633 rnStmt _ (ExprStmt expr _ _) thing_inside
634 = do { (expr', fv_expr) <- rnLExpr expr
635 ; (then_op, fvs1) <- lookupSyntaxName thenMName
636 ; (thing, fvs2) <- thing_inside
637 ; return ((ExprStmt expr' then_op placeHolderType, thing),
638 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
640 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
641 = do { (expr', fv_expr) <- rnLExpr expr
642 -- The binders do not scope over the expression
643 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
644 ; (fail_op, fvs2) <- lookupSyntaxName failMName
645 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
646 { (thing, fvs3) <- thing_inside
647 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
648 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
649 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
650 -- but it does not matter because the names are unique
652 rnStmt ctxt (LetStmt binds) thing_inside
653 = do { checkLetStmt ctxt binds
654 ; rnLocalBindsAndThen binds $ \binds' -> do
655 { (thing, fvs) <- thing_inside
656 ; return ((LetStmt binds', thing), fvs) } }
658 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
659 = do { checkRecStmt ctxt
660 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
661 { (thing, fvs) <- thing_inside
663 segs_w_fwd_refs = addFwdRefs segs
664 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
665 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
666 fwd_vars = nameSetToList (plusFVs fs)
668 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
669 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
671 rnStmt ctxt (ParStmt segs) thing_inside
672 = do { checkParStmt ctxt
673 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
674 ; return ((ParStmt segs', thing), fvs) }
676 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
677 checkTransformStmt ctxt
679 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
680 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
681 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
682 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
683 (thing, fv_thing) <- thing_inside
685 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
687 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
689 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
690 rnMaybeLExpr (Just expr) = do
691 (expr', fv_expr) <- rnLExpr expr
692 return (Just expr', fv_expr)
694 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
695 checkTransformStmt ctxt
697 -- We must rename the using expression in the context before the transform is begun
698 groupByClauseAction <-
699 case groupByClause of
700 GroupByNothing usingExpr -> do
701 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
702 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
703 GroupBySomething eitherUsingExpr byExpr -> do
704 (eitherUsingExpr', fv_eitherUsingExpr) <-
705 case eitherUsingExpr of
706 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
708 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
709 return (Left usingExpr', fv_usingExpr)
712 (byExpr', fv_byExpr) <- rnLExpr byExpr
713 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
715 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
716 -- perhaps we could refactor this to use rnNormalStmts directly?
717 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
718 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
719 (groupByClause', fv_groupByClause) <- groupByClauseAction
721 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
722 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
724 -- Bind the "thing" inside a context where we have REBOUND everything
725 -- bound by the statements before the group. This is necessary since after
726 -- the grouping the same identifiers actually have different meanings
727 -- i.e. they refer to lists not singletons!
728 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
730 -- We remove entries from the binder map that are not used in the thing_inside.
731 -- We can then use that usage information to ensure that the free variables do
732 -- not contain the things we just bound, but do contain the things we need to
733 -- make those bindings (i.e. the corresponding non-listy variables)
735 -- Note that we also retain those entries which have an old binder in our
736 -- own free variables (the using or by expression). This is because this map
737 -- is reused in the desugarer to create the type to bind from the statements
738 -- that occur before this one. If the binders we need are not in the map, they
739 -- will never get bound into our desugared expression and hence the simplifier
740 -- crashes as we refer to variables that don't exist!
741 let usedBinderMap = filter
742 (\(old_binder, new_binder) ->
743 (new_binder `elemNameSet` fv_thing) ||
744 (old_binder `elemNameSet` fv_groupByClause)) binderMap
745 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
746 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
748 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
750 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
751 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
753 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
755 -> ([Name] -> RnM (thing, FreeVars))
756 -> RnM (([LStmt Name], [Name], thing), FreeVars)
757 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
758 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
759 -- Find the Names that are bound by stmts that
760 -- by assumption we have just renamed
761 local_env <- getLocalRdrEnv
763 stmts_binders = collectLStmtsBinders stmts
764 bndrs = map (expectJust "rnStmt"
765 . lookupLocalRdrEnv local_env
766 . unLoc) stmts_binders
768 -- If shadow, we'll look up (Unqual x) twice, getting
769 -- the second binding both times, which is the
771 unshadowed_bndrs = nub bndrs
773 -- Typecheck the thing inside, passing on all
774 -- the Names bound before it for its information
775 (thing, fvs) <- thing_inside unshadowed_bndrs
777 -- Figure out which of the bound names are used
778 -- after the statements we renamed
779 let used_bndrs = filter (`elemNameSet` fvs) bndrs
780 return ((used_bndrs, thing), fvs)
782 -- Flatten the tuple returned by the above call a bit!
783 return ((stmts', used_bndrs, inner_thing), fvs)
785 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
786 -> RnM (thing, FreeVars)
787 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
788 rnParallelStmts ctxt segs thing_inside = do
789 orig_lcl_env <- getLocalRdrEnv
790 go orig_lcl_env [] segs
792 go orig_lcl_env bndrs [] = do
793 let (bndrs', dups) = removeDups cmpByOcc bndrs
794 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
797 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
798 return (([], thing), fvs)
800 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
801 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
802 -- Typecheck the thing inside, passing on all
803 -- the Names bound, but separately; revert the envt
804 setLocalRdrEnv orig_lcl_env $ do
805 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
807 let seg' = (stmts', bndrs)
808 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
810 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
811 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
812 <+> quotes (ppr (head vs)))
816 %************************************************************************
818 \subsubsection{mdo expressions}
820 %************************************************************************
823 type FwdRefs = NameSet
824 type Segment stmts = (Defs,
825 Uses, -- May include defs
826 FwdRefs, -- A subset of uses that are
827 -- (a) used before they are bound in this segment, or
828 -- (b) used here, and bound in subsequent segments
829 stmts) -- Either Stmt or [Stmt]
832 ----------------------------------------------------
834 rnMDoStmts :: [LStmt RdrName]
835 -> RnM (thing, FreeVars)
836 -> RnM (([LStmt Name], thing), FreeVars)
837 rnMDoStmts stmts thing_inside
838 = -- Step1: Bring all the binders of the mdo into scope
839 -- (Remember that this also removes the binders from the
840 -- finally-returned free-vars.)
841 -- And rename each individual stmt, making a
842 -- singleton segment. At this stage the FwdRefs field
843 -- isn't finished: it's empty for all except a BindStmt
844 -- for which it's the fwd refs within the bind itself
845 -- (This set may not be empty, because we're in a recursive
847 rn_rec_stmts_and_then stmts $ \ segs -> do {
849 ; (thing, fvs_later) <- thing_inside
852 -- Step 2: Fill in the fwd refs.
853 -- The segments are all singletons, but their fwd-ref
854 -- field mentions all the things used by the segment
855 -- that are bound after their use
856 segs_w_fwd_refs = addFwdRefs segs
858 -- Step 3: Group together the segments to make bigger segments
859 -- Invariant: in the result, no segment uses a variable
860 -- bound in a later segment
861 grouped_segs = glomSegments segs_w_fwd_refs
863 -- Step 4: Turn the segments into Stmts
864 -- Use RecStmt when and only when there are fwd refs
865 -- Also gather up the uses from the end towards the
866 -- start, so we can tell the RecStmt which things are
867 -- used 'after' the RecStmt
868 (stmts', fvs) = segsToStmts grouped_segs fvs_later
870 ; return ((stmts', thing), fvs) }
872 ---------------------------------------------
874 -- wrapper that does both the left- and right-hand sides
875 rn_rec_stmts_and_then :: [LStmt RdrName]
876 -- assumes that the FreeVars returned includes
877 -- the FreeVars of the Segments
878 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
880 rn_rec_stmts_and_then s cont
881 = do { -- (A) Make the mini fixity env for all of the stmts
882 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
885 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
887 -- ...bring them and their fixities into scope
888 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
889 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
891 -- (C) do the right-hand-sides and thing-inside
892 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
893 ; (res, fvs) <- cont segs
894 ; warnUnusedLocalBinds bound_names fvs
895 ; return (res, fvs) }}
897 -- get all the fixity decls in any Let stmt
898 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
899 collectRecStmtsFixities l =
900 foldr (\ s -> \acc -> case s of
901 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
902 foldr (\ sig -> \ acc -> case sig of
903 (L loc (FixSig s)) -> (L loc s) : acc
909 rn_rec_stmt_lhs :: MiniFixityEnv
911 -- rename LHS, and return its FVs
912 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
913 -- so we don't bother to compute it accurately in the other cases
914 -> RnM [(LStmtLR Name RdrName, FreeVars)]
916 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
917 -- this is actually correct
920 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
922 -- should the ctxt be MDo instead?
923 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
924 return [(L loc (BindStmt pat' expr a b),
927 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
928 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
930 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
931 = do binds' <- rnValBindsLHS fix_env binds
932 return [(L loc (LetStmt (HsValBinds binds')),
933 -- Warning: this is bogus; see function invariant
937 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
938 = rn_rec_stmts_lhs fix_env stmts
940 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
941 = pprPanic "rn_rec_stmt" (ppr stmt)
943 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
944 = pprPanic "rn_rec_stmt" (ppr stmt)
946 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
947 = pprPanic "rn_rec_stmt" (ppr stmt)
949 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
950 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
952 rn_rec_stmts_lhs :: MiniFixityEnv
954 -> RnM [(LStmtLR Name RdrName, FreeVars)]
955 rn_rec_stmts_lhs fix_env stmts =
956 let boundNames = collectLStmtsBinders stmts
957 doc = text "In a recursive mdo-expression"
959 -- First do error checking: we need to check for dups here because we
960 -- don't bind all of the variables from the Stmt at once
961 -- with bindLocatedLocals.
962 checkDupRdrNames doc boundNames
963 mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
968 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
969 -- Rename a Stmt that is inside a RecStmt (or mdo)
970 -- Assumes all binders are already in scope
971 -- Turns each stmt into a singleton Stmt
972 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
973 = rnLExpr expr `thenM` \ (expr', fvs) ->
974 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
975 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
976 L loc (ExprStmt expr' then_op placeHolderType))]
978 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
979 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
980 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
981 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
983 bndrs = mkNameSet (collectPatBinders pat')
984 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
986 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
987 L loc (BindStmt pat' expr' bind_op fail_op))]
989 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
990 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
992 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
993 (binds', du_binds) <-
994 -- fixities and unused are handled above in rn_rec_stmts_and_then
995 rnValBindsRHS (mkNameSet all_bndrs) binds'
996 return [(duDefs du_binds, duUses du_binds,
997 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
999 -- no RecStmt case becuase they get flattened above when doing the LHSes
1000 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1001 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1003 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1004 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1006 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1007 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1009 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1010 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1012 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1013 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1015 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1016 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1017 return (concat segs_s)
1019 ---------------------------------------------
1020 addFwdRefs :: [Segment a] -> [Segment a]
1021 -- So far the segments only have forward refs *within* the Stmt
1022 -- (which happens for bind: x <- ...x...)
1023 -- This function adds the cross-seg fwd ref info
1026 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1028 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1029 = (new_seg : segs, all_defs)
1031 new_seg = (defs, uses, new_fwds, stmts)
1032 all_defs = later_defs `unionNameSets` defs
1033 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1034 -- Add the downstream fwd refs here
1036 ----------------------------------------------------
1037 -- Glomming the singleton segments of an mdo into
1038 -- minimal recursive groups.
1040 -- At first I thought this was just strongly connected components, but
1041 -- there's an important constraint: the order of the stmts must not change.
1044 -- mdo { x <- ...y...
1051 -- Here, the first stmt mention 'y', which is bound in the third.
1052 -- But that means that the innocent second stmt (p <- z) gets caught
1053 -- up in the recursion. And that in turn means that the binding for
1054 -- 'z' has to be included... and so on.
1056 -- Start at the tail { r <- x }
1057 -- Now add the next one { z <- y ; r <- x }
1058 -- Now add one more { q <- x ; z <- y ; r <- x }
1059 -- Now one more... but this time we have to group a bunch into rec
1060 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1061 -- Now one more, which we can add on without a rec
1063 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1065 -- Finally we add the last one; since it mentions y we have to
1066 -- glom it togeher with the first two groups
1067 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1068 -- q <- x ; z <- y } ;
1071 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1073 glomSegments [] = []
1074 glomSegments ((defs,uses,fwds,stmt) : segs)
1075 -- Actually stmts will always be a singleton
1076 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1078 segs' = glomSegments segs
1079 (extras, others) = grab uses segs'
1080 (ds, us, fs, ss) = unzip4 extras
1082 seg_defs = plusFVs ds `plusFV` defs
1083 seg_uses = plusFVs us `plusFV` uses
1084 seg_fwds = plusFVs fs `plusFV` fwds
1085 seg_stmts = stmt : concat ss
1087 grab :: NameSet -- The client
1089 -> ([Segment a], -- Needed by the 'client'
1090 [Segment a]) -- Not needed by the client
1091 -- The result is simply a split of the input
1093 = (reverse yeses, reverse noes)
1095 (noes, yeses) = span not_needed (reverse dus)
1096 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1099 ----------------------------------------------------
1100 segsToStmts :: [Segment [LStmt Name]]
1101 -> FreeVars -- Free vars used 'later'
1102 -> ([LStmt Name], FreeVars)
1104 segsToStmts [] fvs_later = ([], fvs_later)
1105 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1106 = ASSERT( not (null ss) )
1107 (new_stmt : later_stmts, later_uses `plusFV` uses)
1109 (later_stmts, later_uses) = segsToStmts segs fvs_later
1110 new_stmt | non_rec = head ss
1111 | otherwise = L (getLoc (head ss)) $
1112 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1115 non_rec = isSingleton ss && isEmptyNameSet fwds
1116 used_later = defs `intersectNameSet` later_uses
1117 -- The ones needed after the RecStmt
1120 %************************************************************************
1122 \subsubsection{Assertion utils}
1124 %************************************************************************
1127 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1128 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1130 mkAssertErrorExpr :: RnM (HsExpr Name)
1131 -- Return an expression for (assertError "Foo.hs:27")
1133 = getSrcSpanM `thenM` \ sloc ->
1134 return (HsApp (L sloc (HsVar assertErrorName))
1135 (L sloc (srcSpanPrimLit sloc)))
1138 Note [Adding the implicit parameter to 'assert']
1139 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1140 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1141 By doing this in the renamer we allow the typechecker to just see the
1142 expanded application and do the right thing. But it's not really
1143 the Right Thing because there's no way to "undo" if you want to see
1144 the original source code. We'll have fix this in due course, when
1145 we care more about being able to reconstruct the exact original
1148 %************************************************************************
1150 \subsubsection{Errors}
1152 %************************************************************************
1156 ----------------------
1157 -- Checking when a particular Stmt is ok
1158 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1159 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1160 checkLetStmt _ctxt _binds = return ()
1161 -- We do not allow implicit-parameter bindings in a parallel
1162 -- list comprehension. I'm not sure what it might mean.
1165 checkRecStmt :: HsStmtContext Name -> RnM ()
1166 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1167 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1168 -- proc x -> do { ...rec... }
1169 -- We don't have enough context to distinguish this situation here
1170 -- so we leave it to the type checker
1171 checkRecStmt ctxt = addErr msg
1173 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1176 checkParStmt :: HsStmtContext Name -> RnM ()
1178 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1179 ; checkErr parallel_list_comp msg }
1181 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1184 checkTransformStmt :: HsStmtContext Name -> RnM ()
1185 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1186 -- desugarer will break when we come to operate on a parallel array
1187 = do { transform_list_comp <- doptM Opt_TransformListComp
1188 ; checkErr transform_list_comp msg }
1190 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1191 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1192 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1193 checkTransformStmt ctxt = addErr msg
1195 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1198 sectionErr :: HsExpr RdrName -> SDoc
1200 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1201 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1203 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1204 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1206 ; return (EWildPat, emptyFVs) }
1208 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1209 badIpBinds what binds
1210 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)