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 ; rebind <- xoptM Opt_RebindableSyntax
275 then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
276 else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
277 ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
280 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
281 return (HsType t, fvT)
283 doc = text "In a type argument"
285 rnExpr (ArithSeq _ seq)
286 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
287 return (ArithSeq noPostTcExpr new_seq, fvs)
289 rnExpr (PArrSeq _ seq)
290 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
291 return (PArrSeq noPostTcExpr new_seq, fvs)
294 These three are pattern syntax appearing in expressions.
295 Since all the symbols are reservedops we can simply reject them.
296 We return a (bogus) EWildPat in each case.
299 rnExpr e@EWildPat = patSynErr e
300 rnExpr e@(EAsPat {}) = patSynErr e
301 rnExpr e@(EViewPat {}) = patSynErr e
302 rnExpr e@(ELazyPat {}) = patSynErr e
305 %************************************************************************
309 %************************************************************************
312 rnExpr (HsProc pat body)
314 rnPat ProcExpr pat $ \ pat' ->
315 rnCmdTop body `thenM` \ (body',fvBody) ->
316 return (HsProc pat' body', fvBody)
318 rnExpr (HsArrApp arrow arg _ ho rtl)
319 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
320 rnLExpr arg `thenM` \ (arg',fvArg) ->
321 return (HsArrApp arrow' arg' placeHolderType ho rtl,
322 fvArrow `plusFV` fvArg)
324 select_arrow_scope tc = case ho of
325 HsHigherOrderApp -> tc
326 HsFirstOrderApp -> escapeArrowScope tc
329 rnExpr (HsArrForm op (Just _) [arg1, arg2])
330 = escapeArrowScope (rnLExpr op)
331 `thenM` \ (op',fv_op) ->
332 let L _ (HsVar op_name) = op' in
333 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
334 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
338 lookupFixityRn op_name `thenM` \ fixity ->
339 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
342 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
344 rnExpr (HsArrForm op fixity cmds)
345 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
346 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
347 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
349 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
352 ----------------------
353 -- See Note [Parsing sections] in Parser.y.pp
354 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
355 rnSection section@(SectionR op expr)
356 = do { (op', fvs_op) <- rnLExpr op
357 ; (expr', fvs_expr) <- rnLExpr expr
358 ; checkSectionPrec InfixR section op' expr'
359 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
361 rnSection section@(SectionL expr op)
362 = do { (expr', fvs_expr) <- rnLExpr expr
363 ; (op', fvs_op) <- rnLExpr op
364 ; checkSectionPrec InfixL section op' expr'
365 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
367 rnSection other = pprPanic "rnSection" (ppr other)
370 %************************************************************************
374 %************************************************************************
377 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
378 -> RnM (HsRecordBinds Name, FreeVars)
379 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
380 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
381 ; (flds', fvss) <- mapAndUnzipM rn_field flds
382 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
383 fvs `plusFV` plusFVs fvss) }
385 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
386 ; return (fld { hsRecFieldArg = arg' }, fvs) }
390 %************************************************************************
394 %************************************************************************
397 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
398 rnCmdArgs [] = return ([], emptyFVs)
400 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
401 rnCmdArgs args `thenM` \ (args',fvArgs) ->
402 return (arg':args', fvArg `plusFV` fvArgs)
404 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
405 rnCmdTop = wrapLocFstM rnCmdTop'
407 rnCmdTop' (HsCmdTop cmd _ _ _)
408 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
410 cmd_names = [arrAName, composeAName, firstAName] ++
411 nameSetToList (methodNamesCmd (unLoc cmd'))
413 -- Generate the rebindable syntax for the monad
414 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
416 return (HsCmdTop cmd' [] placeHolderType cmd_names',
417 fvCmd `plusFV` cmd_fvs)
419 ---------------------------------------------------
420 -- convert OpApp's in a command context to HsArrForm's
422 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
423 convertOpFormsLCmd = fmap convertOpFormsCmd
425 convertOpFormsCmd :: HsCmd id -> HsCmd id
427 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
428 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
429 convertOpFormsCmd (OpApp c1 op fixity c2)
431 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
432 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
434 HsArrForm op (Just fixity) [arg1, arg2]
436 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
438 convertOpFormsCmd (HsCase exp matches)
439 = HsCase exp (convertOpFormsMatch matches)
441 convertOpFormsCmd (HsIf f exp c1 c2)
442 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
444 convertOpFormsCmd (HsLet binds cmd)
445 = HsLet binds (convertOpFormsLCmd cmd)
447 convertOpFormsCmd (HsDo ctxt stmts body ty)
448 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
449 (convertOpFormsLCmd body) ty
451 -- Anything else is unchanged. This includes HsArrForm (already done),
452 -- things with no sub-commands, and illegal commands (which will be
453 -- caught by the type checker)
454 convertOpFormsCmd c = c
456 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
457 convertOpFormsStmt (BindStmt pat cmd _ _)
458 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
459 convertOpFormsStmt (ExprStmt cmd _ _)
460 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
461 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
462 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
463 convertOpFormsStmt stmt = stmt
465 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
466 convertOpFormsMatch (MatchGroup ms ty)
467 = MatchGroup (map (fmap convert) ms) ty
468 where convert (Match pat mty grhss)
469 = Match pat mty (convertOpFormsGRHSs grhss)
471 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
472 convertOpFormsGRHSs (GRHSs grhss binds)
473 = GRHSs (map convertOpFormsGRHS grhss) binds
475 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
476 convertOpFormsGRHS = fmap convert
478 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
480 ---------------------------------------------------
481 type CmdNeeds = FreeVars -- Only inhabitants are
482 -- appAName, choiceAName, loopAName
484 -- find what methods the Cmd needs (loop, choice, apply)
485 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
486 methodNamesLCmd = methodNamesCmd . unLoc
488 methodNamesCmd :: HsCmd Name -> CmdNeeds
490 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
492 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
494 methodNamesCmd (HsArrForm {}) = emptyFVs
496 methodNamesCmd (HsPar c) = methodNamesLCmd c
498 methodNamesCmd (HsIf _ _ c1 c2)
499 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
501 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
503 methodNamesCmd (HsDo _ stmts body _)
504 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
506 methodNamesCmd (HsApp c _) = methodNamesLCmd c
508 methodNamesCmd (HsLam match) = methodNamesMatch match
510 methodNamesCmd (HsCase _ matches)
511 = methodNamesMatch matches `addOneFV` choiceAName
513 methodNamesCmd _ = emptyFVs
514 -- Other forms can't occur in commands, but it's not convenient
515 -- to error here so we just do what's convenient.
516 -- The type checker will complain later
518 ---------------------------------------------------
519 methodNamesMatch :: MatchGroup Name -> FreeVars
520 methodNamesMatch (MatchGroup ms _)
521 = plusFVs (map do_one ms)
523 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
525 -------------------------------------------------
527 methodNamesGRHSs :: GRHSs Name -> FreeVars
528 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
530 -------------------------------------------------
532 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
533 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
535 ---------------------------------------------------
536 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
537 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
539 ---------------------------------------------------
540 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
541 methodNamesLStmt = methodNamesStmt . unLoc
543 methodNamesStmt :: StmtLR Name Name -> FreeVars
544 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
545 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
546 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
547 methodNamesStmt (LetStmt _) = emptyFVs
548 methodNamesStmt (ParStmt _) = emptyFVs
549 methodNamesStmt (TransformStmt {}) = emptyFVs
550 methodNamesStmt (GroupStmt {}) = emptyFVs
551 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
552 -- here so we just do what's convenient
556 %************************************************************************
560 %************************************************************************
563 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
564 rnArithSeq (From expr)
565 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
566 return (From expr', fvExpr)
568 rnArithSeq (FromThen expr1 expr2)
569 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
570 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
571 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
573 rnArithSeq (FromTo expr1 expr2)
574 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
575 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
576 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
578 rnArithSeq (FromThenTo expr1 expr2 expr3)
579 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
580 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
581 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
582 return (FromThenTo expr1' expr2' expr3',
583 plusFVs [fvExpr1, fvExpr2, fvExpr3])
586 %************************************************************************
588 Template Haskell brackets
590 %************************************************************************
593 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
594 rnBracket (VarBr n) = do { name <- lookupOccRn n
595 ; this_mod <- getModule
596 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
597 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
598 ; return () } -- only way that is going to happen
599 ; return (VarBr name, unitFV name) }
601 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
603 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
604 ; return (ExpBr e', fvs) }
606 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
608 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
609 ; return (TypBr t', fvs) }
611 doc = ptext (sLit "In a Template-Haskell quoted type")
613 rnBracket (DecBrL decls)
614 = do { (group, mb_splice) <- findSplice decls
617 Just (SpliceDecl (L loc _) _, _)
619 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
620 -- Why not? See Section 7.3 of the TH paper.
622 ; gbl_env <- getGblEnv
623 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
624 -- The emptyDUs is so that we just collect uses for this
625 -- group alone in the call to rnSrcDecls below
626 ; (tcg_env, group') <- setGblEnv new_gbl_env $
630 -- Discard the tcg_env; it contains only extra info about fixity
631 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
632 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
634 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
637 %************************************************************************
639 \subsubsection{@Stmt@s: in @do@ expressions}
641 %************************************************************************
644 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
645 -> ([Name] -> RnM (thing, FreeVars))
646 -> RnM (([LStmt Name], thing), FreeVars)
647 -- Variables bound by the Stmts, and mentioned in thing_inside,
648 -- do not appear in the result FreeVars
650 -- Renaming a single RecStmt can give a sequence of smaller Stmts
652 rnStmts _ [] thing_inside
653 = do { (res, fvs) <- thing_inside []
654 ; return (([], res), fvs) }
656 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
657 = do { ((stmts1, (stmts2, thing)), fvs)
659 rnStmt ctxt stmt $ \ bndrs1 ->
660 rnStmts ctxt stmts $ \ bndrs2 ->
661 thing_inside (bndrs1 ++ bndrs2)
662 ; return (((stmts1 ++ stmts2), thing), fvs) }
665 rnStmt :: HsStmtContext Name -> LStmt RdrName
666 -> ([Name] -> RnM (thing, FreeVars))
667 -> RnM (([LStmt Name], thing), FreeVars)
668 -- Variables bound by the Stmt, and mentioned in thing_inside,
669 -- do not appear in the result FreeVars
671 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
672 = do { (expr', fv_expr) <- rnLExpr expr
673 ; (then_op, fvs1) <- lookupSyntaxName thenMName
674 ; (thing, fvs2) <- thing_inside []
675 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
676 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
678 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
679 = do { (expr', fv_expr) <- rnLExpr expr
680 -- The binders do not scope over the expression
681 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
682 ; (fail_op, fvs2) <- lookupSyntaxName failMName
683 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
684 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
685 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
686 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
687 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
688 -- but it does not matter because the names are unique
690 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
691 = do { checkLetStmt ctxt binds
692 ; rnLocalBindsAndThen binds $ \binds' -> do
693 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
694 ; return (([L loc (LetStmt binds')], thing), fvs) } }
696 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
697 = do { checkRecStmt ctxt
699 -- Step1: Bring all the binders of the mdo into scope
700 -- (Remember that this also removes the binders from the
701 -- finally-returned free-vars.)
702 -- And rename each individual stmt, making a
703 -- singleton segment. At this stage the FwdRefs field
704 -- isn't finished: it's empty for all except a BindStmt
705 -- for which it's the fwd refs within the bind itself
706 -- (This set may not be empty, because we're in a recursive
708 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
710 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
712 ; (thing, fvs_later) <- thing_inside bndrs
713 ; (return_op, fvs1) <- lookupSyntaxName returnMName
714 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
715 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
717 -- Step 2: Fill in the fwd refs.
718 -- The segments are all singletons, but their fwd-ref
719 -- field mentions all the things used by the segment
720 -- that are bound after their use
721 segs_w_fwd_refs = addFwdRefs segs
723 -- Step 3: Group together the segments to make bigger segments
724 -- Invariant: in the result, no segment uses a variable
725 -- bound in a later segment
726 grouped_segs = glomSegments segs_w_fwd_refs
728 -- Step 4: Turn the segments into Stmts
729 -- Use RecStmt when and only when there are fwd refs
730 -- Also gather up the uses from the end towards the
731 -- start, so we can tell the RecStmt which things are
732 -- used 'after' the RecStmt
733 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
734 , recS_mfix_fn = mfix_op
735 , recS_bind_fn = bind_op }
736 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
738 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
740 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
741 = do { checkParStmt ctxt
742 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
743 ; return (([L loc (ParStmt segs')], thing), fvs) }
745 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
746 = do { checkTransformStmt ctxt
748 ; (using', fvs1) <- rnLExpr using
750 ; ((stmts', (by', used_bndrs, thing)), fvs2)
751 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
752 do { (by', fvs_by) <- case by of
753 Nothing -> return (Nothing, emptyFVs)
754 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
755 ; (thing, fvs_thing) <- thing_inside bndrs
756 ; let fvs = fvs_by `plusFV` fvs_thing
757 used_bndrs = filter (`elemNameSet` fvs) bndrs
758 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
759 -- the "thing inside", **or of the by-expression**, as used
760 ; return ((by', used_bndrs, thing), fvs) }
762 ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
763 fvs1 `plusFV` fvs2) }
765 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
766 = do { checkTransformStmt ctxt
768 -- Rename the 'using' expression in the context before the transform is begun
769 ; (using', fvs1) <- case using of
770 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
771 Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
772 ; return (Right e', fvs) }
774 -- Rename the stmts and the 'by' expression
775 -- Keep track of the variables mentioned in the 'by' expression
776 ; ((stmts', (by', used_bndrs, thing)), fvs2)
777 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
778 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
779 ; (thing, fvs_thing) <- thing_inside bndrs
780 ; let fvs = fvs_by `plusFV` fvs_thing
781 used_bndrs = filter (`elemNameSet` fvs) bndrs
782 ; return ((by', used_bndrs, thing), fvs) }
784 ; let all_fvs = fvs1 `plusFV` fvs2
785 bndr_map = used_bndrs `zip` used_bndrs
786 -- See Note [GroupStmt binder map] in HsExpr
788 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
789 ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
792 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
794 rnParallelStmts :: forall thing. HsStmtContext Name
796 -> ([Name] -> RnM (thing, FreeVars))
797 -> RnM (([ParSeg Name], thing), FreeVars)
798 -- Note [Renaming parallel Stmts]
799 rnParallelStmts ctxt segs thing_inside
800 = do { orig_lcl_env <- getLocalRdrEnv
801 ; rn_segs orig_lcl_env [] segs }
803 rn_segs :: LocalRdrEnv
804 -> [Name] -> [ParSeg RdrName]
805 -> RnM (([ParSeg Name], thing), FreeVars)
806 rn_segs _ bndrs_so_far []
807 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
809 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
810 ; return (([], thing), fvs) }
812 rn_segs env bndrs_so_far ((stmts,_) : segs)
813 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
814 <- rnStmts ctxt stmts $ \ bndrs ->
815 setLocalRdrEnv env $ do
816 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
817 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
818 ; return ((used_bndrs, segs', thing), fvs) }
820 ; let seg' = (stmts', used_bndrs)
821 ; return ((seg':segs', thing), fvs) }
823 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
824 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
825 <+> quotes (ppr (head vs)))
828 Note [Renaming parallel Stmts]
829 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
830 Renaming parallel statements is painful. Given, say
831 [ a+c | a <- as, bs <- bss
834 (a) In order to report "Defined by not used" about 'bs', we must rename
835 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
837 (b) We want to report that 'a' is illegally bound in both branches
839 (c) The 'bs' in the second group must obviously not be captured by
840 the binding in the first group
842 To satisfy (a) we nest the segements.
843 To satisfy (b) we check for duplicates just before thing_inside.
844 To satisfy (c) we reset the LocalRdrEnv each time.
846 %************************************************************************
848 \subsubsection{mdo expressions}
850 %************************************************************************
853 type FwdRefs = NameSet
854 type Segment stmts = (Defs,
855 Uses, -- May include defs
856 FwdRefs, -- A subset of uses that are
857 -- (a) used before they are bound in this segment, or
858 -- (b) used here, and bound in subsequent segments
859 stmts) -- Either Stmt or [Stmt]
862 -- wrapper that does both the left- and right-hand sides
863 rnRecStmtsAndThen :: [LStmt RdrName]
864 -- assumes that the FreeVars returned includes
865 -- the FreeVars of the Segments
866 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
868 rnRecStmtsAndThen s cont
869 = do { -- (A) Make the mini fixity env for all of the stmts
870 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
873 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
875 -- ...bring them and their fixities into scope
876 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
877 ; bindLocalNamesFV bound_names $
878 addLocalFixities fix_env bound_names $ do
880 -- (C) do the right-hand-sides and thing-inside
881 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
882 ; (res, fvs) <- cont segs
883 ; warnUnusedLocalBinds bound_names fvs
884 ; return (res, fvs) }}
886 -- get all the fixity decls in any Let stmt
887 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
888 collectRecStmtsFixities l =
889 foldr (\ s -> \acc -> case s of
890 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
891 foldr (\ sig -> \ acc -> case sig of
892 (L loc (FixSig s)) -> (L loc s) : acc
898 rn_rec_stmt_lhs :: MiniFixityEnv
900 -- rename LHS, and return its FVs
901 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
902 -- so we don't bother to compute it accurately in the other cases
903 -> RnM [(LStmtLR Name RdrName, FreeVars)]
905 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
906 -- this is actually correct
909 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
911 -- should the ctxt be MDo instead?
912 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
913 return [(L loc (BindStmt pat' expr a b),
916 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
917 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
919 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
920 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
921 return [(L loc (LetStmt (HsValBinds binds')),
922 -- Warning: this is bogus; see function invariant
926 -- XXX Do we need to do something with the return and mfix names?
927 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
928 = rn_rec_stmts_lhs fix_env stmts
930 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
931 = pprPanic "rn_rec_stmt" (ppr stmt)
933 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
934 = pprPanic "rn_rec_stmt" (ppr stmt)
936 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
937 = pprPanic "rn_rec_stmt" (ppr stmt)
939 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
940 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
942 rn_rec_stmts_lhs :: MiniFixityEnv
944 -> RnM [(LStmtLR Name RdrName, FreeVars)]
945 rn_rec_stmts_lhs fix_env stmts
946 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
947 ; let boundNames = collectLStmtsBinders (map fst ls)
948 -- First do error checking: we need to check for dups here because we
949 -- don't bind all of the variables from the Stmt at once
950 -- with bindLocatedLocals.
951 ; checkDupNames boundNames
957 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
958 -- Rename a Stmt that is inside a RecStmt (or mdo)
959 -- Assumes all binders are already in scope
960 -- Turns each stmt into a singleton Stmt
961 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
962 = rnLExpr expr `thenM` \ (expr', fvs) ->
963 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
964 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
965 L loc (ExprStmt expr' then_op placeHolderType))]
967 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
968 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
969 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
970 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
972 bndrs = mkNameSet (collectPatBinders pat')
973 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
975 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
976 L loc (BindStmt pat' expr' bind_op fail_op))]
978 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
979 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
981 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
982 (binds', du_binds) <-
983 -- fixities and unused are handled above in rnRecStmtsAndThen
984 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
985 return [(duDefs du_binds, allUses du_binds,
986 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
988 -- no RecStmt case becuase they get flattened above when doing the LHSes
989 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
990 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
992 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
993 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
995 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
996 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
998 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
999 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1001 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1002 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1004 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1005 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1006 return (concat segs_s)
1008 ---------------------------------------------
1009 addFwdRefs :: [Segment a] -> [Segment a]
1010 -- So far the segments only have forward refs *within* the Stmt
1011 -- (which happens for bind: x <- ...x...)
1012 -- This function adds the cross-seg fwd ref info
1015 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1017 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1018 = (new_seg : segs, all_defs)
1020 new_seg = (defs, uses, new_fwds, stmts)
1021 all_defs = later_defs `unionNameSets` defs
1022 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1023 -- Add the downstream fwd refs here
1025 ----------------------------------------------------
1026 -- Glomming the singleton segments of an mdo into
1027 -- minimal recursive groups.
1029 -- At first I thought this was just strongly connected components, but
1030 -- there's an important constraint: the order of the stmts must not change.
1033 -- mdo { x <- ...y...
1040 -- Here, the first stmt mention 'y', which is bound in the third.
1041 -- But that means that the innocent second stmt (p <- z) gets caught
1042 -- up in the recursion. And that in turn means that the binding for
1043 -- 'z' has to be included... and so on.
1045 -- Start at the tail { r <- x }
1046 -- Now add the next one { z <- y ; r <- x }
1047 -- Now add one more { q <- x ; z <- y ; r <- x }
1048 -- Now one more... but this time we have to group a bunch into rec
1049 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1050 -- Now one more, which we can add on without a rec
1052 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1054 -- Finally we add the last one; since it mentions y we have to
1055 -- glom it togeher with the first two groups
1056 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1057 -- q <- x ; z <- y } ;
1060 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1062 glomSegments [] = []
1063 glomSegments ((defs,uses,fwds,stmt) : segs)
1064 -- Actually stmts will always be a singleton
1065 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1067 segs' = glomSegments segs
1068 (extras, others) = grab uses segs'
1069 (ds, us, fs, ss) = unzip4 extras
1071 seg_defs = plusFVs ds `plusFV` defs
1072 seg_uses = plusFVs us `plusFV` uses
1073 seg_fwds = plusFVs fs `plusFV` fwds
1074 seg_stmts = stmt : concat ss
1076 grab :: NameSet -- The client
1078 -> ([Segment a], -- Needed by the 'client'
1079 [Segment a]) -- Not needed by the client
1080 -- The result is simply a split of the input
1082 = (reverse yeses, reverse noes)
1084 (noes, yeses) = span not_needed (reverse dus)
1085 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1088 ----------------------------------------------------
1089 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1090 -> [Segment [LStmt Name]]
1091 -> FreeVars -- Free vars used 'later'
1092 -> ([LStmt Name], FreeVars)
1094 segsToStmts _ [] fvs_later = ([], fvs_later)
1095 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1096 = ASSERT( not (null ss) )
1097 (new_stmt : later_stmts, later_uses `plusFV` uses)
1099 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1100 new_stmt | non_rec = head ss
1101 | otherwise = L (getLoc (head ss)) rec_stmt
1102 rec_stmt = empty_rec_stmt { recS_stmts = ss
1103 , recS_later_ids = nameSetToList used_later
1104 , recS_rec_ids = nameSetToList fwds }
1105 non_rec = isSingleton ss && isEmptyNameSet fwds
1106 used_later = defs `intersectNameSet` later_uses
1107 -- The ones needed after the RecStmt
1110 %************************************************************************
1112 \subsubsection{Assertion utils}
1114 %************************************************************************
1117 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1118 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1120 mkAssertErrorExpr :: RnM (HsExpr Name)
1121 -- Return an expression for (assertError "Foo.hs:27")
1123 = getSrcSpanM `thenM` \ sloc ->
1124 return (HsApp (L sloc (HsVar assertErrorName))
1125 (L sloc (srcSpanPrimLit sloc)))
1128 Note [Adding the implicit parameter to 'assert']
1129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1130 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1131 By doing this in the renamer we allow the typechecker to just see the
1132 expanded application and do the right thing. But it's not really
1133 the Right Thing because there's no way to "undo" if you want to see
1134 the original source code. We'll have fix this in due course, when
1135 we care more about being able to reconstruct the exact original
1138 %************************************************************************
1140 \subsubsection{Errors}
1142 %************************************************************************
1146 ----------------------
1147 -- Checking when a particular Stmt is ok
1148 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1149 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1150 checkLetStmt _ctxt _binds = return ()
1151 -- We do not allow implicit-parameter bindings in a parallel
1152 -- list comprehension. I'm not sure what it might mean.
1155 checkRecStmt :: HsStmtContext Name -> RnM ()
1156 checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
1157 checkRecStmt DoExpr = return () -- and in 'do'
1158 checkRecStmt ctxt = addErr msg
1160 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1163 checkParStmt :: HsStmtContext Name -> RnM ()
1165 = do { parallel_list_comp <- xoptM Opt_ParallelListComp
1166 ; checkErr parallel_list_comp msg }
1168 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1171 checkTransformStmt :: HsStmtContext Name -> RnM ()
1172 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1173 -- desugarer will break when we come to operate on a parallel array
1174 = do { transform_list_comp <- xoptM Opt_TransformListComp
1175 ; checkErr transform_list_comp msg }
1177 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1178 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1179 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1180 checkTransformStmt ctxt = addErr msg
1182 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1185 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1186 checkTupleSection args
1187 = do { tuple_section <- xoptM Opt_TupleSections
1188 ; checkErr (all tupArgPresent args || tuple_section) msg }
1190 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1193 sectionErr :: HsExpr RdrName -> SDoc
1195 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1196 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1198 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1199 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1201 ; return (EWildPat, emptyFVs) }
1203 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1204 badIpBinds what binds
1205 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)