2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnLExpr, rnExpr, rnStmts
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
23 import RnSource ( rnSrcDecls, findSplice )
24 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
34 import BasicTypes ( FixityDirection(..) )
40 import LoadIface ( loadInterfaceForName )
43 import Util ( isSingleton )
44 import ListSetOps ( removeDups )
54 thenM :: Monad a => a b -> (b -> a c) -> a c
57 thenM_ :: Monad a => a b -> a c -> a c
61 %************************************************************************
63 \subsubsection{Expressions}
65 %************************************************************************
68 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
69 rnExprs ls = rnExprs' ls emptyUniqSet
71 rnExprs' [] acc = return ([], acc)
72 rnExprs' (expr:exprs) acc
73 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
75 -- Now we do a "seq" on the free vars because typically it's small
76 -- or empty, especially in very long lists of constants
78 acc' = acc `plusFV` fvExpr
80 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
81 return (expr':exprs', fvExprs)
84 Variables. We look up the variable and return the resulting name.
87 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
88 rnLExpr = wrapLocFstM rnExpr
90 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
92 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
93 -- Separated from rnExpr because it's also used
94 -- when renaming infix expressions
95 -- See Note [Adding the implicit parameter to 'assert']
97 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
98 ; if ignore_asserts || not (name `hasKey` assertIdKey)
99 then return (HsVar name, unitFV name)
100 else do { e <- mkAssertErrorExpr
101 ; return (e, unitFV name) } }
104 = do name <- lookupOccRn v
108 = newIPNameRn v `thenM` \ name ->
109 return (HsIPVar name, emptyFVs)
111 rnExpr (HsLit lit@(HsString s))
113 opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
114 ; if opt_OverloadedStrings then
115 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
116 else -- Same as below
118 return (HsLit lit, emptyFVs)
123 return (HsLit lit, emptyFVs)
125 rnExpr (HsOverLit lit)
126 = rnOverLit lit `thenM` \ (lit', fvs) ->
127 return (HsOverLit lit', fvs)
129 rnExpr (HsApp fun arg)
130 = rnLExpr fun `thenM` \ (fun',fvFun) ->
131 rnLExpr arg `thenM` \ (arg',fvArg) ->
132 return (HsApp fun' arg', fvFun `plusFV` fvArg)
134 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
135 = do { (e1', fv_e1) <- rnLExpr e1
136 ; (e2', fv_e2) <- rnLExpr e2
137 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
138 ; (op', fv_op) <- finishHsVar op_name
139 -- NB: op' is usually just a variable, but might be
140 -- an applicatoin (assert "Foo.hs:47")
142 -- When renaming code synthesised from "deriving" declarations
143 -- we used to avoid fixity stuff, but we can't easily tell any
144 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
145 -- should prevent bad things happening.
146 ; fixity <- lookupFixityRn op_name
147 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
148 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
149 rnExpr (OpApp _ other_op _ _)
150 = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
152 , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
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 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
181 ---------------------------------------------
183 -- See Note [Parsing sections] in Parser.y.pp
184 rnExpr (HsPar (L loc (section@(SectionL {}))))
185 = do { (section', fvs) <- rnSection section
186 ; return (HsPar (L loc section'), fvs) }
188 rnExpr (HsPar (L loc (section@(SectionR {}))))
189 = do { (section', fvs) <- rnSection section
190 ; return (HsPar (L loc section'), fvs) }
193 = do { (e', fvs_e) <- rnLExpr e
194 ; return (HsPar e', fvs_e) }
196 rnExpr expr@(SectionL {})
197 = do { addErr (sectionErr expr); rnSection expr }
198 rnExpr expr@(SectionR {})
199 = do { addErr (sectionErr expr); rnSection expr }
201 ---------------------------------------------
202 rnExpr (HsCoreAnn ann expr)
203 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
204 return (HsCoreAnn ann expr', fvs_expr)
206 rnExpr (HsSCC lbl expr)
207 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
208 return (HsSCC lbl expr', fvs_expr)
209 rnExpr (HsTickPragma info expr)
210 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
211 return (HsTickPragma info expr', fvs_expr)
213 rnExpr (HsLam matches)
214 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
215 return (HsLam matches', fvMatch)
217 rnExpr (HsCase expr matches)
218 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
219 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
220 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
222 rnExpr (HsLet binds expr)
223 = rnLocalBindsAndThen binds $ \ binds' ->
224 rnLExpr expr `thenM` \ (expr',fvExpr) ->
225 return (HsLet binds' expr', fvExpr)
227 rnExpr (HsDo do_or_lc stmts body _)
228 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
230 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
232 rnExpr (ExplicitList _ exps)
233 = rnExprs exps `thenM` \ (exps', fvs) ->
234 return (ExplicitList placeHolderType exps', fvs)
236 rnExpr (ExplicitPArr _ exps)
237 = rnExprs exps `thenM` \ (exps', fvs) ->
238 return (ExplicitPArr placeHolderType exps', fvs)
240 rnExpr (ExplicitTuple tup_args boxity)
241 = do { checkTupleSection tup_args
242 ; checkTupSize (length tup_args)
243 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
244 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
246 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
247 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
249 rnExpr (RecordCon con_id _ rbinds)
250 = do { conname <- lookupLocatedOccRn con_id
251 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
252 ; return (RecordCon conname noPostTcExpr rbinds',
253 fvRbinds `addOneFV` unLoc conname) }
255 rnExpr (RecordUpd expr rbinds _ _ _)
256 = do { (expr', fvExpr) <- rnLExpr expr
257 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
258 ; return (RecordUpd expr' rbinds' [] [] [],
259 fvExpr `plusFV` fvRbinds) }
261 rnExpr (ExprWithTySig expr pty)
262 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
263 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
265 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
267 doc = text "In an expression type signature"
269 rnExpr (HsIf _ p b1 b2)
270 = do { (p', fvP) <- rnLExpr p
271 ; (b1', fvB1) <- rnLExpr b1
272 ; (b2', fvB2) <- rnLExpr b2
273 ; (mb_ite, fvITE) <- lookupIfThenElse
274 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
277 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
278 return (HsType t, fvT)
280 doc = text "In a type argument"
282 rnExpr (ArithSeq _ seq)
283 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
284 return (ArithSeq noPostTcExpr new_seq, fvs)
286 rnExpr (PArrSeq _ seq)
287 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
288 return (PArrSeq noPostTcExpr new_seq, fvs)
291 These three are pattern syntax appearing in expressions.
292 Since all the symbols are reservedops we can simply reject them.
293 We return a (bogus) EWildPat in each case.
296 rnExpr e@EWildPat = patSynErr e
297 rnExpr e@(EAsPat {}) = patSynErr e
298 rnExpr e@(EViewPat {}) = patSynErr e
299 rnExpr e@(ELazyPat {}) = patSynErr e
302 %************************************************************************
306 %************************************************************************
309 rnExpr (HsProc pat body)
311 rnPat ProcExpr pat $ \ pat' ->
312 rnCmdTop body `thenM` \ (body',fvBody) ->
313 return (HsProc pat' body', fvBody)
315 rnExpr (HsArrApp arrow arg _ ho rtl)
316 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
317 rnLExpr arg `thenM` \ (arg',fvArg) ->
318 return (HsArrApp arrow' arg' placeHolderType ho rtl,
319 fvArrow `plusFV` fvArg)
321 select_arrow_scope tc = case ho of
322 HsHigherOrderApp -> tc
323 HsFirstOrderApp -> escapeArrowScope tc
326 rnExpr (HsArrForm op (Just _) [arg1, arg2])
327 = escapeArrowScope (rnLExpr op)
328 `thenM` \ (op',fv_op) ->
329 let L _ (HsVar op_name) = op' in
330 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
331 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
335 lookupFixityRn op_name `thenM` \ fixity ->
336 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
339 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
341 rnExpr (HsArrForm op fixity cmds)
342 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
343 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
344 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
346 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
349 ----------------------
350 -- See Note [Parsing sections] in Parser.y.pp
351 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
352 rnSection section@(SectionR op expr)
353 = do { (op', fvs_op) <- rnLExpr op
354 ; (expr', fvs_expr) <- rnLExpr expr
355 ; checkSectionPrec InfixR section op' expr'
356 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
358 rnSection section@(SectionL expr op)
359 = do { (expr', fvs_expr) <- rnLExpr expr
360 ; (op', fvs_op) <- rnLExpr op
361 ; checkSectionPrec InfixL section op' expr'
362 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
364 rnSection other = pprPanic "rnSection" (ppr other)
367 %************************************************************************
371 %************************************************************************
374 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
375 -> RnM (HsRecordBinds Name, FreeVars)
376 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
377 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
378 ; (flds', fvss) <- mapAndUnzipM rn_field flds
379 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
380 fvs `plusFV` plusFVs fvss) }
382 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
383 ; return (fld { hsRecFieldArg = arg' }, fvs) }
387 %************************************************************************
391 %************************************************************************
394 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
395 rnCmdArgs [] = return ([], emptyFVs)
397 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
398 rnCmdArgs args `thenM` \ (args',fvArgs) ->
399 return (arg':args', fvArg `plusFV` fvArgs)
401 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
402 rnCmdTop = wrapLocFstM rnCmdTop'
404 rnCmdTop' (HsCmdTop cmd _ _ _)
405 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
407 cmd_names = [arrAName, composeAName, firstAName] ++
408 nameSetToList (methodNamesCmd (unLoc cmd'))
410 -- Generate the rebindable syntax for the monad
411 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
413 return (HsCmdTop cmd' [] placeHolderType cmd_names',
414 fvCmd `plusFV` cmd_fvs)
416 ---------------------------------------------------
417 -- convert OpApp's in a command context to HsArrForm's
419 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
420 convertOpFormsLCmd = fmap convertOpFormsCmd
422 convertOpFormsCmd :: HsCmd id -> HsCmd id
424 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
425 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
426 convertOpFormsCmd (OpApp c1 op fixity c2)
428 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
429 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
431 HsArrForm op (Just fixity) [arg1, arg2]
433 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
435 convertOpFormsCmd (HsCase exp matches)
436 = HsCase exp (convertOpFormsMatch matches)
438 convertOpFormsCmd (HsIf f exp c1 c2)
439 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
441 convertOpFormsCmd (HsLet binds cmd)
442 = HsLet binds (convertOpFormsLCmd cmd)
444 convertOpFormsCmd (HsDo ctxt stmts body ty)
445 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
446 (convertOpFormsLCmd body) ty
448 -- Anything else is unchanged. This includes HsArrForm (already done),
449 -- things with no sub-commands, and illegal commands (which will be
450 -- caught by the type checker)
451 convertOpFormsCmd c = c
453 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
454 convertOpFormsStmt (BindStmt pat cmd _ _)
455 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
456 convertOpFormsStmt (ExprStmt cmd _ _)
457 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
458 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
459 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
460 convertOpFormsStmt stmt = stmt
462 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
463 convertOpFormsMatch (MatchGroup ms ty)
464 = MatchGroup (map (fmap convert) ms) ty
465 where convert (Match pat mty grhss)
466 = Match pat mty (convertOpFormsGRHSs grhss)
468 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
469 convertOpFormsGRHSs (GRHSs grhss binds)
470 = GRHSs (map convertOpFormsGRHS grhss) binds
472 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
473 convertOpFormsGRHS = fmap convert
475 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
477 ---------------------------------------------------
478 type CmdNeeds = FreeVars -- Only inhabitants are
479 -- appAName, choiceAName, loopAName
481 -- find what methods the Cmd needs (loop, choice, apply)
482 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
483 methodNamesLCmd = methodNamesCmd . unLoc
485 methodNamesCmd :: HsCmd Name -> CmdNeeds
487 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
489 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
491 methodNamesCmd (HsArrForm {}) = emptyFVs
493 methodNamesCmd (HsPar c) = methodNamesLCmd c
495 methodNamesCmd (HsIf _ _ c1 c2)
496 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
498 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
500 methodNamesCmd (HsDo _ stmts body _)
501 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
503 methodNamesCmd (HsApp c _) = methodNamesLCmd c
505 methodNamesCmd (HsLam match) = methodNamesMatch match
507 methodNamesCmd (HsCase _ matches)
508 = methodNamesMatch matches `addOneFV` choiceAName
510 methodNamesCmd _ = emptyFVs
511 -- Other forms can't occur in commands, but it's not convenient
512 -- to error here so we just do what's convenient.
513 -- The type checker will complain later
515 ---------------------------------------------------
516 methodNamesMatch :: MatchGroup Name -> FreeVars
517 methodNamesMatch (MatchGroup ms _)
518 = plusFVs (map do_one ms)
520 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
522 -------------------------------------------------
524 methodNamesGRHSs :: GRHSs Name -> FreeVars
525 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
527 -------------------------------------------------
529 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
530 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
532 ---------------------------------------------------
533 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
534 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
536 ---------------------------------------------------
537 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
538 methodNamesLStmt = methodNamesStmt . unLoc
540 methodNamesStmt :: StmtLR Name Name -> FreeVars
541 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
542 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
543 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
544 methodNamesStmt (LetStmt _) = emptyFVs
545 methodNamesStmt (ParStmt _) = emptyFVs
546 methodNamesStmt (TransformStmt {}) = emptyFVs
547 methodNamesStmt (GroupStmt {}) = emptyFVs
548 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
549 -- here so we just do what's convenient
553 %************************************************************************
557 %************************************************************************
560 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
561 rnArithSeq (From expr)
562 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
563 return (From expr', fvExpr)
565 rnArithSeq (FromThen expr1 expr2)
566 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
567 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
568 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
570 rnArithSeq (FromTo expr1 expr2)
571 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
572 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
573 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
575 rnArithSeq (FromThenTo expr1 expr2 expr3)
576 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
577 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
578 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
579 return (FromThenTo expr1' expr2' expr3',
580 plusFVs [fvExpr1, fvExpr2, fvExpr3])
583 %************************************************************************
585 Template Haskell brackets
587 %************************************************************************
590 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
591 rnBracket (VarBr n) = do { name <- lookupOccRn n
592 ; this_mod <- getModule
593 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
594 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
595 ; return () } -- only way that is going to happen
596 ; return (VarBr name, unitFV name) }
598 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
600 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
601 ; return (ExpBr e', fvs) }
603 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
605 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
606 ; return (TypBr t', fvs) }
608 doc = ptext (sLit "In a Template-Haskell quoted type")
610 rnBracket (DecBrL decls)
611 = do { (group, mb_splice) <- findSplice decls
614 Just (SpliceDecl (L loc _) _, _)
616 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
617 -- Why not? See Section 7.3 of the TH paper.
619 ; gbl_env <- getGblEnv
620 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
621 -- The emptyDUs is so that we just collect uses for this
622 -- group alone in the call to rnSrcDecls below
623 ; (tcg_env, group') <- setGblEnv new_gbl_env $
627 -- Discard the tcg_env; it contains only extra info about fixity
628 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
629 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
631 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
634 %************************************************************************
636 \subsubsection{@Stmt@s: in @do@ expressions}
638 %************************************************************************
641 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
642 -> ([Name] -> RnM (thing, FreeVars))
643 -> RnM (([LStmt Name], thing), FreeVars)
644 -- Variables bound by the Stmts, and mentioned in thing_inside,
645 -- do not appear in the result FreeVars
647 -- Renaming a single RecStmt can give a sequence of smaller Stmts
649 rnStmts _ [] thing_inside
650 = do { (res, fvs) <- thing_inside []
651 ; return (([], res), fvs) }
653 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
654 = do { ((stmts1, (stmts2, thing)), fvs)
656 rnStmt ctxt stmt $ \ bndrs1 ->
657 rnStmts ctxt stmts $ \ bndrs2 ->
658 thing_inside (bndrs1 ++ bndrs2)
659 ; return (((stmts1 ++ stmts2), thing), fvs) }
662 rnStmt :: HsStmtContext Name -> LStmt RdrName
663 -> ([Name] -> RnM (thing, FreeVars))
664 -> RnM (([LStmt Name], thing), FreeVars)
665 -- Variables bound by the Stmt, and mentioned in thing_inside,
666 -- do not appear in the result FreeVars
668 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
669 = do { (expr', fv_expr) <- rnLExpr expr
670 ; (then_op, fvs1) <- lookupSyntaxName thenMName
671 ; (thing, fvs2) <- thing_inside []
672 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
673 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
675 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
676 = do { (expr', fv_expr) <- rnLExpr expr
677 -- The binders do not scope over the expression
678 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
679 ; (fail_op, fvs2) <- lookupSyntaxName failMName
680 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
681 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
682 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
683 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
684 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
685 -- but it does not matter because the names are unique
687 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
688 = do { checkLetStmt ctxt binds
689 ; rnLocalBindsAndThen binds $ \binds' -> do
690 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
691 ; return (([L loc (LetStmt binds')], thing), fvs) } }
693 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
694 = do { checkRecStmt ctxt
696 -- Step1: Bring all the binders of the mdo into scope
697 -- (Remember that this also removes the binders from the
698 -- finally-returned free-vars.)
699 -- And rename each individual stmt, making a
700 -- singleton segment. At this stage the FwdRefs field
701 -- isn't finished: it's empty for all except a BindStmt
702 -- for which it's the fwd refs within the bind itself
703 -- (This set may not be empty, because we're in a recursive
705 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
707 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
709 ; (thing, fvs_later) <- thing_inside bndrs
710 ; (return_op, fvs1) <- lookupSyntaxName returnMName
711 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
712 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
714 -- Step 2: Fill in the fwd refs.
715 -- The segments are all singletons, but their fwd-ref
716 -- field mentions all the things used by the segment
717 -- that are bound after their use
718 segs_w_fwd_refs = addFwdRefs segs
720 -- Step 3: Group together the segments to make bigger segments
721 -- Invariant: in the result, no segment uses a variable
722 -- bound in a later segment
723 grouped_segs = glomSegments segs_w_fwd_refs
725 -- Step 4: Turn the segments into Stmts
726 -- Use RecStmt when and only when there are fwd refs
727 -- Also gather up the uses from the end towards the
728 -- start, so we can tell the RecStmt which things are
729 -- used 'after' the RecStmt
730 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
731 , recS_mfix_fn = mfix_op
732 , recS_bind_fn = bind_op }
733 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
735 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
737 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
738 = do { checkParStmt ctxt
739 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
740 ; return (([L loc (ParStmt segs')], thing), fvs) }
742 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
743 = do { checkTransformStmt ctxt
745 ; (using', fvs1) <- rnLExpr using
747 ; ((stmts', (by', used_bndrs, thing)), fvs2)
748 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
749 do { (by', fvs_by) <- case by of
750 Nothing -> return (Nothing, emptyFVs)
751 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
752 ; (thing, fvs_thing) <- thing_inside bndrs
753 ; let fvs = fvs_by `plusFV` fvs_thing
754 used_bndrs = filter (`elemNameSet` fvs) bndrs
755 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
756 -- the "thing inside", **or of the by-expression**, as used
757 ; return ((by', used_bndrs, thing), fvs) }
759 ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
760 fvs1 `plusFV` fvs2) }
762 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
763 = do { checkTransformStmt ctxt
765 -- Rename the 'using' expression in the context before the transform is begun
766 ; (using', fvs1) <- case using of
767 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
768 Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
769 ; return (Right e', fvs) }
771 -- Rename the stmts and the 'by' expression
772 -- Keep track of the variables mentioned in the 'by' expression
773 ; ((stmts', (by', used_bndrs, thing)), fvs2)
774 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
775 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
776 ; (thing, fvs_thing) <- thing_inside bndrs
777 ; let fvs = fvs_by `plusFV` fvs_thing
778 used_bndrs = filter (`elemNameSet` fvs) bndrs
779 ; return ((by', used_bndrs, thing), fvs) }
781 ; let all_fvs = fvs1 `plusFV` fvs2
782 bndr_map = used_bndrs `zip` used_bndrs
783 -- See Note [GroupStmt binder map] in HsExpr
785 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
786 ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
789 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
791 rnParallelStmts :: forall thing. HsStmtContext Name
793 -> ([Name] -> RnM (thing, FreeVars))
794 -> RnM (([ParSeg Name], thing), FreeVars)
795 -- Note [Renaming parallel Stmts]
796 rnParallelStmts ctxt segs thing_inside
797 = do { orig_lcl_env <- getLocalRdrEnv
798 ; rn_segs orig_lcl_env [] segs }
800 rn_segs :: LocalRdrEnv
801 -> [Name] -> [ParSeg RdrName]
802 -> RnM (([ParSeg Name], thing), FreeVars)
803 rn_segs _ bndrs_so_far []
804 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
806 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
807 ; return (([], thing), fvs) }
809 rn_segs env bndrs_so_far ((stmts,_) : segs)
810 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
811 <- rnStmts ctxt stmts $ \ bndrs ->
812 setLocalRdrEnv env $ do
813 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
814 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
815 ; return ((used_bndrs, segs', thing), fvs) }
817 ; let seg' = (stmts', used_bndrs)
818 ; return ((seg':segs', thing), fvs) }
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)))
825 Note [Renaming parallel Stmts]
826 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
827 Renaming parallel statements is painful. Given, say
828 [ a+c | a <- as, bs <- bss
831 (a) In order to report "Defined by not used" about 'bs', we must rename
832 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
834 (b) We want to report that 'a' is illegally bound in both branches
836 (c) The 'bs' in the second group must obviously not be captured by
837 the binding in the first group
839 To satisfy (a) we nest the segements.
840 To satisfy (b) we check for duplicates just before thing_inside.
841 To satisfy (c) we reset the LocalRdrEnv each time.
843 %************************************************************************
845 \subsubsection{mdo expressions}
847 %************************************************************************
850 type FwdRefs = NameSet
851 type Segment stmts = (Defs,
852 Uses, -- May include defs
853 FwdRefs, -- A subset of uses that are
854 -- (a) used before they are bound in this segment, or
855 -- (b) used here, and bound in subsequent segments
856 stmts) -- Either Stmt or [Stmt]
859 -- wrapper that does both the left- and right-hand sides
860 rnRecStmtsAndThen :: [LStmt RdrName]
861 -- assumes that the FreeVars returned includes
862 -- the FreeVars of the Segments
863 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
865 rnRecStmtsAndThen s cont
866 = do { -- (A) Make the mini fixity env for all of the stmts
867 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
870 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
872 -- ...bring them and their fixities into scope
873 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
874 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
875 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
876 ; bindLocalNamesFV bound_names $
877 addLocalFixities fix_env bound_names $ do
879 -- (C) do the right-hand-sides and thing-inside
880 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
881 ; (res, fvs) <- cont segs
882 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
883 ; return (res, fvs) }}
885 -- get all the fixity decls in any Let stmt
886 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
887 collectRecStmtsFixities l =
888 foldr (\ s -> \acc -> case s of
889 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
890 foldr (\ sig -> \ acc -> case sig of
891 (L loc (FixSig s)) -> (L loc s) : acc
897 rn_rec_stmt_lhs :: MiniFixityEnv
899 -- rename LHS, and return its FVs
900 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
901 -- so we don't bother to compute it accurately in the other cases
902 -> RnM [(LStmtLR Name RdrName, FreeVars)]
904 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
905 -- this is actually correct
908 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
910 -- should the ctxt be MDo instead?
911 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
912 return [(L loc (BindStmt pat' expr a b),
915 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
916 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
918 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
919 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
920 return [(L loc (LetStmt (HsValBinds binds')),
921 -- Warning: this is bogus; see function invariant
925 -- XXX Do we need to do something with the return and mfix names?
926 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
927 = rn_rec_stmts_lhs fix_env stmts
929 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
930 = pprPanic "rn_rec_stmt" (ppr stmt)
932 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
933 = pprPanic "rn_rec_stmt" (ppr stmt)
935 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
936 = pprPanic "rn_rec_stmt" (ppr stmt)
938 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
939 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
941 rn_rec_stmts_lhs :: MiniFixityEnv
943 -> RnM [(LStmtLR Name RdrName, FreeVars)]
944 rn_rec_stmts_lhs fix_env stmts
945 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
946 ; let boundNames = collectLStmtsBinders (map fst ls)
947 -- First do error checking: we need to check for dups here because we
948 -- don't bind all of the variables from the Stmt at once
949 -- with bindLocatedLocals.
950 ; checkDupNames boundNames
956 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
957 -- Rename a Stmt that is inside a RecStmt (or mdo)
958 -- Assumes all binders are already in scope
959 -- Turns each stmt into a singleton Stmt
960 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
961 = rnLExpr expr `thenM` \ (expr', fvs) ->
962 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
963 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
964 L loc (ExprStmt expr' then_op placeHolderType))]
966 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
967 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
968 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
969 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
971 bndrs = mkNameSet (collectPatBinders pat')
972 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
974 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
975 L loc (BindStmt pat' expr' bind_op fail_op))]
977 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
978 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
980 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
981 (binds', du_binds) <-
982 -- fixities and unused are handled above in rnRecStmtsAndThen
983 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
984 return [(duDefs du_binds, allUses du_binds,
985 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
987 -- no RecStmt case becuase they get flattened above when doing the LHSes
988 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
989 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
991 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
992 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
994 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
995 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
997 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
998 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1000 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1001 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1003 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1004 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1005 return (concat segs_s)
1007 ---------------------------------------------
1008 addFwdRefs :: [Segment a] -> [Segment a]
1009 -- So far the segments only have forward refs *within* the Stmt
1010 -- (which happens for bind: x <- ...x...)
1011 -- This function adds the cross-seg fwd ref info
1014 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1016 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1017 = (new_seg : segs, all_defs)
1019 new_seg = (defs, uses, new_fwds, stmts)
1020 all_defs = later_defs `unionNameSets` defs
1021 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1022 -- Add the downstream fwd refs here
1024 ----------------------------------------------------
1025 -- Glomming the singleton segments of an mdo into
1026 -- minimal recursive groups.
1028 -- At first I thought this was just strongly connected components, but
1029 -- there's an important constraint: the order of the stmts must not change.
1032 -- mdo { x <- ...y...
1039 -- Here, the first stmt mention 'y', which is bound in the third.
1040 -- But that means that the innocent second stmt (p <- z) gets caught
1041 -- up in the recursion. And that in turn means that the binding for
1042 -- 'z' has to be included... and so on.
1044 -- Start at the tail { r <- x }
1045 -- Now add the next one { z <- y ; r <- x }
1046 -- Now add one more { q <- x ; z <- y ; r <- x }
1047 -- Now one more... but this time we have to group a bunch into rec
1048 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1049 -- Now one more, which we can add on without a rec
1051 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1053 -- Finally we add the last one; since it mentions y we have to
1054 -- glom it togeher with the first two groups
1055 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1056 -- q <- x ; z <- y } ;
1059 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1061 glomSegments [] = []
1062 glomSegments ((defs,uses,fwds,stmt) : segs)
1063 -- Actually stmts will always be a singleton
1064 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1066 segs' = glomSegments segs
1067 (extras, others) = grab uses segs'
1068 (ds, us, fs, ss) = unzip4 extras
1070 seg_defs = plusFVs ds `plusFV` defs
1071 seg_uses = plusFVs us `plusFV` uses
1072 seg_fwds = plusFVs fs `plusFV` fwds
1073 seg_stmts = stmt : concat ss
1075 grab :: NameSet -- The client
1077 -> ([Segment a], -- Needed by the 'client'
1078 [Segment a]) -- Not needed by the client
1079 -- The result is simply a split of the input
1081 = (reverse yeses, reverse noes)
1083 (noes, yeses) = span not_needed (reverse dus)
1084 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1087 ----------------------------------------------------
1088 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1089 -> [Segment [LStmt Name]]
1090 -> FreeVars -- Free vars used 'later'
1091 -> ([LStmt Name], FreeVars)
1093 segsToStmts _ [] fvs_later = ([], fvs_later)
1094 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1095 = ASSERT( not (null ss) )
1096 (new_stmt : later_stmts, later_uses `plusFV` uses)
1098 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1099 new_stmt | non_rec = head ss
1100 | otherwise = L (getLoc (head ss)) rec_stmt
1101 rec_stmt = empty_rec_stmt { recS_stmts = ss
1102 , recS_later_ids = nameSetToList used_later
1103 , recS_rec_ids = nameSetToList fwds }
1104 non_rec = isSingleton ss && isEmptyNameSet fwds
1105 used_later = defs `intersectNameSet` later_uses
1106 -- The ones needed after the RecStmt
1109 %************************************************************************
1111 \subsubsection{Assertion utils}
1113 %************************************************************************
1116 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1117 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1119 mkAssertErrorExpr :: RnM (HsExpr Name)
1120 -- Return an expression for (assertError "Foo.hs:27")
1122 = getSrcSpanM `thenM` \ sloc ->
1123 return (HsApp (L sloc (HsVar assertErrorName))
1124 (L sloc (srcSpanPrimLit sloc)))
1127 Note [Adding the implicit parameter to 'assert']
1128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1129 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1130 By doing this in the renamer we allow the typechecker to just see the
1131 expanded application and do the right thing. But it's not really
1132 the Right Thing because there's no way to "undo" if you want to see
1133 the original source code. We'll have fix this in due course, when
1134 we care more about being able to reconstruct the exact original
1137 %************************************************************************
1139 \subsubsection{Errors}
1141 %************************************************************************
1145 ----------------------
1146 -- Checking when a particular Stmt is ok
1147 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1148 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1149 checkLetStmt _ctxt _binds = return ()
1150 -- We do not allow implicit-parameter bindings in a parallel
1151 -- list comprehension. I'm not sure what it might mean.
1154 checkRecStmt :: HsStmtContext Name -> RnM ()
1155 checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
1156 checkRecStmt DoExpr = return () -- and in 'do'
1157 checkRecStmt ctxt = addErr msg
1159 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1162 checkParStmt :: HsStmtContext Name -> RnM ()
1164 = do { parallel_list_comp <- xoptM Opt_ParallelListComp
1165 ; checkErr parallel_list_comp msg }
1167 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1170 checkTransformStmt :: HsStmtContext Name -> RnM ()
1171 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1172 -- desugarer will break when we come to operate on a parallel array
1173 = do { transform_list_comp <- xoptM Opt_TransformListComp
1174 ; checkErr transform_list_comp msg }
1176 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1177 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1178 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1179 checkTransformStmt ctxt = addErr msg
1181 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1184 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1185 checkTupleSection args
1186 = do { tuple_section <- xoptM Opt_TupleSections
1187 ; checkErr (all tupArgPresent args || tuple_section) msg }
1189 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1192 sectionErr :: HsExpr RdrName -> SDoc
1194 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1195 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1197 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1198 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1200 ; return (EWildPat, emptyFVs) }
1202 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1203 badIpBinds what binds
1204 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)