2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnLExpr, rnExpr, rnStmts
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
23 import RnSource ( rnSrcDecls, rnSplice, checkTH )
24 import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
33 import DynFlags ( DynFlag(..) )
34 import BasicTypes ( FixityDirection(..) )
35 import PrelNames ( hasKey, assertIdKey, assertErrorName,
36 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
37 negateName, thenMName, bindMName, failMName, groupWithName )
42 import LoadIface ( loadInterfaceForName )
45 import Util ( isSingleton )
46 import ListSetOps ( removeDups )
47 import Maybes ( expectJust )
52 import List ( unzip4 )
59 thenM :: Monad a => a b -> (b -> a c) -> a c
62 thenM_ :: Monad a => a b -> a c -> a c
66 %************************************************************************
68 \subsubsection{Expressions}
70 %************************************************************************
73 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
74 rnExprs ls = rnExprs' ls emptyUniqSet
76 rnExprs' [] acc = return ([], acc)
77 rnExprs' (expr:exprs) acc
78 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
80 -- Now we do a "seq" on the free vars because typically it's small
81 -- or empty, especially in very long lists of constants
83 acc' = acc `plusFV` fvExpr
85 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
86 return (expr':exprs', fvExprs)
89 Variables. We look up the variable and return the resulting name.
92 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
93 rnLExpr = wrapLocFstM rnExpr
95 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
97 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
98 -- Separated from rnExpr because it's also used
99 -- when renaming infix expressions
100 -- See Note [Adding the implicit parameter to 'assert']
102 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
103 ; if ignore_asserts || not (name `hasKey` assertIdKey)
104 then return (HsVar name, unitFV name)
105 else do { e <- mkAssertErrorExpr
106 ; return (e, unitFV name) } }
109 = do name <- lookupOccRn v
113 = newIPNameRn v `thenM` \ name ->
114 return (HsIPVar name, emptyFVs)
116 rnExpr (HsLit lit@(HsString s))
118 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
119 ; if opt_OverloadedStrings then
120 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
121 else -- Same as below
123 return (HsLit lit, emptyFVs)
128 return (HsLit lit, emptyFVs)
130 rnExpr (HsOverLit lit)
131 = rnOverLit lit `thenM` \ (lit', fvs) ->
132 return (HsOverLit lit', fvs)
134 rnExpr (HsApp fun arg)
135 = rnLExpr fun `thenM` \ (fun',fvFun) ->
136 rnLExpr arg `thenM` \ (arg',fvArg) ->
137 return (HsApp fun' arg', fvFun `plusFV` fvArg)
139 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
140 = do { (e1', fv_e1) <- rnLExpr e1
141 ; (e2', fv_e2) <- rnLExpr e2
142 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
143 ; (op', fv_op) <- finishHsVar op_name
144 -- NB: op' is usually just a variable, but might be
145 -- an applicatoin (assert "Foo.hs:47")
147 -- When renaming code synthesised from "deriving" declarations
148 -- we used to avoid fixity stuff, but we can't easily tell any
149 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
150 -- should prevent bad things happening.
151 ; fixity <- lookupFixityRn op_name
152 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
153 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
156 = rnLExpr e `thenM` \ (e', fv_e) ->
157 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
158 mkNegAppRn e' neg_name `thenM` \ final_e ->
159 return (final_e, fv_e `plusFV` fv_neg)
161 ------------------------------------------
162 -- Template Haskell extensions
163 -- Don't ifdef-GHCI them because we want to fail gracefully
164 -- (not with an rnExpr crash) in a stage-1 compiler.
165 rnExpr e@(HsBracket br_body)
166 = checkTH e "bracket" `thenM_`
167 rnBracket br_body `thenM` \ (body', fvs_e) ->
168 return (HsBracket body', fvs_e)
170 rnExpr (HsSpliceE splice)
171 = rnSplice splice `thenM` \ (splice', fvs) ->
172 return (HsSpliceE splice', fvs)
175 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
177 rnExpr (HsQuasiQuoteE qq)
178 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
179 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
180 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
181 return (expr'', fvs_qq `plusFV` fvs_expr)
184 ---------------------------------------------
186 -- See Note [Parsing sections] in Parser.y.pp
187 rnExpr (HsPar (L loc (section@(SectionL {}))))
188 = do { (section', fvs) <- rnSection section
189 ; return (HsPar (L loc section'), fvs) }
191 rnExpr (HsPar (L loc (section@(SectionR {}))))
192 = do { (section', fvs) <- rnSection section
193 ; return (HsPar (L loc section'), fvs) }
196 = do { (e', fvs_e) <- rnLExpr e
197 ; return (HsPar e', fvs_e) }
199 rnExpr expr@(SectionL {})
200 = do { addErr (sectionErr expr); rnSection expr }
201 rnExpr expr@(SectionR {})
202 = do { addErr (sectionErr expr); rnSection expr }
204 ---------------------------------------------
205 rnExpr (HsCoreAnn ann expr)
206 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
207 return (HsCoreAnn ann expr', fvs_expr)
209 rnExpr (HsSCC lbl expr)
210 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
211 return (HsSCC lbl expr', fvs_expr)
212 rnExpr (HsTickPragma info expr)
213 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
214 return (HsTickPragma info expr', fvs_expr)
216 rnExpr (HsLam matches)
217 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
218 return (HsLam matches', fvMatch)
220 rnExpr (HsCase expr matches)
221 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
222 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
223 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
225 rnExpr (HsLet binds expr)
226 = rnLocalBindsAndThen binds $ \ binds' ->
227 rnLExpr expr `thenM` \ (expr',fvExpr) ->
228 return (HsLet binds' expr', fvExpr)
230 rnExpr (HsDo do_or_lc stmts body _)
231 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
233 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
235 rnExpr (ExplicitList _ exps)
236 = rnExprs exps `thenM` \ (exps', fvs) ->
237 return (ExplicitList placeHolderType exps', fvs)
239 rnExpr (ExplicitPArr _ exps)
240 = rnExprs exps `thenM` \ (exps', fvs) ->
241 return (ExplicitPArr placeHolderType exps', fvs)
243 rnExpr (ExplicitTuple exps boxity)
244 = checkTupSize (length exps) `thenM_`
245 rnExprs exps `thenM` \ (exps', fvs) ->
246 return (ExplicitTuple exps' boxity, fvs)
248 rnExpr (RecordCon con_id _ rbinds)
249 = do { conname <- lookupLocatedOccRn con_id
250 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
251 ; return (RecordCon conname noPostTcExpr rbinds',
252 fvRbinds `addOneFV` unLoc conname) }
254 rnExpr (RecordUpd expr rbinds _ _ _)
255 = do { (expr', fvExpr) <- rnLExpr expr
256 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
257 ; return (RecordUpd expr' rbinds' [] [] [],
258 fvExpr `plusFV` fvRbinds) }
260 rnExpr (ExprWithTySig expr pty)
261 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
262 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
264 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
266 doc = text "In an expression type signature"
268 rnExpr (HsIf p b1 b2)
269 = rnLExpr p `thenM` \ (p', fvP) ->
270 rnLExpr b1 `thenM` \ (b1', fvB1) ->
271 rnLExpr b2 `thenM` \ (b2', fvB2) ->
272 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
275 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
276 return (HsType t, fvT)
278 doc = text "In a type argument"
280 rnExpr (ArithSeq _ seq)
281 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
282 return (ArithSeq noPostTcExpr new_seq, fvs)
284 rnExpr (PArrSeq _ seq)
285 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
286 return (PArrSeq noPostTcExpr new_seq, fvs)
289 These three are pattern syntax appearing in expressions.
290 Since all the symbols are reservedops we can simply reject them.
291 We return a (bogus) EWildPat in each case.
294 rnExpr e@EWildPat = patSynErr e
295 rnExpr e@(EAsPat {}) = patSynErr e
296 rnExpr e@(EViewPat {}) = patSynErr e
297 rnExpr e@(ELazyPat {}) = patSynErr e
300 %************************************************************************
304 %************************************************************************
307 rnExpr (HsProc pat body)
309 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
310 rnCmdTop body `thenM` \ (body',fvBody) ->
311 return (HsProc pat' body', fvBody)
313 rnExpr (HsArrApp arrow arg _ ho rtl)
314 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
315 rnLExpr arg `thenM` \ (arg',fvArg) ->
316 return (HsArrApp arrow' arg' placeHolderType ho rtl,
317 fvArrow `plusFV` fvArg)
319 select_arrow_scope tc = case ho of
320 HsHigherOrderApp -> tc
321 HsFirstOrderApp -> escapeArrowScope tc
324 rnExpr (HsArrForm op (Just _) [arg1, arg2])
325 = escapeArrowScope (rnLExpr op)
326 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
327 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
328 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
332 lookupFixityRn op_name `thenM` \ fixity ->
333 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
336 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
338 rnExpr (HsArrForm op fixity cmds)
339 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
340 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
341 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
343 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
346 ----------------------
347 -- See Note [Parsing sections] in Parser.y.pp
348 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
349 rnSection section@(SectionR op expr)
350 = do { (op', fvs_op) <- rnLExpr op
351 ; (expr', fvs_expr) <- rnLExpr expr
352 ; checkSectionPrec InfixR section op' expr'
353 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
355 rnSection section@(SectionL expr op)
356 = do { (expr', fvs_expr) <- rnLExpr expr
357 ; (op', fvs_op) <- rnLExpr op
358 ; checkSectionPrec InfixL section op' expr'
359 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
361 rnSection other = pprPanic "rnSection" (ppr other)
364 %************************************************************************
368 %************************************************************************
371 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
372 rnCmdArgs [] = return ([], emptyFVs)
374 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
375 rnCmdArgs args `thenM` \ (args',fvArgs) ->
376 return (arg':args', fvArg `plusFV` fvArgs)
378 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
379 rnCmdTop = wrapLocFstM rnCmdTop'
381 rnCmdTop' (HsCmdTop cmd _ _ _)
382 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
384 cmd_names = [arrAName, composeAName, firstAName] ++
385 nameSetToList (methodNamesCmd (unLoc cmd'))
387 -- Generate the rebindable syntax for the monad
388 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
390 return (HsCmdTop cmd' [] placeHolderType cmd_names',
391 fvCmd `plusFV` cmd_fvs)
393 ---------------------------------------------------
394 -- convert OpApp's in a command context to HsArrForm's
396 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
397 convertOpFormsLCmd = fmap convertOpFormsCmd
399 convertOpFormsCmd :: HsCmd id -> HsCmd id
401 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
402 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
403 convertOpFormsCmd (OpApp c1 op fixity c2)
405 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
406 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
408 HsArrForm op (Just fixity) [arg1, arg2]
410 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
412 convertOpFormsCmd (HsCase exp matches)
413 = HsCase exp (convertOpFormsMatch matches)
415 convertOpFormsCmd (HsIf exp c1 c2)
416 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
418 convertOpFormsCmd (HsLet binds cmd)
419 = HsLet binds (convertOpFormsLCmd cmd)
421 convertOpFormsCmd (HsDo ctxt stmts body ty)
422 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
423 (convertOpFormsLCmd body) ty
425 -- Anything else is unchanged. This includes HsArrForm (already done),
426 -- things with no sub-commands, and illegal commands (which will be
427 -- caught by the type checker)
428 convertOpFormsCmd c = c
430 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
431 convertOpFormsStmt (BindStmt pat cmd _ _)
432 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
433 convertOpFormsStmt (ExprStmt cmd _ _)
434 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
435 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
436 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
437 convertOpFormsStmt stmt = stmt
439 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
440 convertOpFormsMatch (MatchGroup ms ty)
441 = MatchGroup (map (fmap convert) ms) ty
442 where convert (Match pat mty grhss)
443 = Match pat mty (convertOpFormsGRHSs grhss)
445 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
446 convertOpFormsGRHSs (GRHSs grhss binds)
447 = GRHSs (map convertOpFormsGRHS grhss) binds
449 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
450 convertOpFormsGRHS = fmap convert
452 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
454 ---------------------------------------------------
455 type CmdNeeds = FreeVars -- Only inhabitants are
456 -- appAName, choiceAName, loopAName
458 -- find what methods the Cmd needs (loop, choice, apply)
459 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
460 methodNamesLCmd = methodNamesCmd . unLoc
462 methodNamesCmd :: HsCmd Name -> CmdNeeds
464 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
466 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
468 methodNamesCmd (HsArrForm {}) = emptyFVs
470 methodNamesCmd (HsPar c) = methodNamesLCmd c
472 methodNamesCmd (HsIf _ c1 c2)
473 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
475 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
477 methodNamesCmd (HsDo _ stmts body _)
478 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
480 methodNamesCmd (HsApp c _) = methodNamesLCmd c
482 methodNamesCmd (HsLam match) = methodNamesMatch match
484 methodNamesCmd (HsCase _ matches)
485 = methodNamesMatch matches `addOneFV` choiceAName
487 methodNamesCmd _ = emptyFVs
488 -- Other forms can't occur in commands, but it's not convenient
489 -- to error here so we just do what's convenient.
490 -- The type checker will complain later
492 ---------------------------------------------------
493 methodNamesMatch :: MatchGroup Name -> FreeVars
494 methodNamesMatch (MatchGroup ms _)
495 = plusFVs (map do_one ms)
497 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
499 -------------------------------------------------
501 methodNamesGRHSs :: GRHSs Name -> FreeVars
502 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
504 -------------------------------------------------
506 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
507 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
509 ---------------------------------------------------
510 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
511 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
513 ---------------------------------------------------
514 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
515 methodNamesLStmt = methodNamesStmt . unLoc
517 methodNamesStmt :: StmtLR Name Name -> FreeVars
518 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
519 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
520 methodNamesStmt (RecStmt stmts _ _ _ _)
521 = methodNamesStmts stmts `addOneFV` loopAName
522 methodNamesStmt (LetStmt _) = emptyFVs
523 methodNamesStmt (ParStmt _) = emptyFVs
524 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
525 methodNamesStmt (GroupStmt _ _) = emptyFVs
526 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
527 -- here so we just do what's convenient
531 %************************************************************************
535 %************************************************************************
538 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
539 rnArithSeq (From expr)
540 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
541 return (From expr', fvExpr)
543 rnArithSeq (FromThen expr1 expr2)
544 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
545 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
546 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
548 rnArithSeq (FromTo expr1 expr2)
549 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
550 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
551 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
553 rnArithSeq (FromThenTo expr1 expr2 expr3)
554 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
555 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
556 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
557 return (FromThenTo expr1' expr2' expr3',
558 plusFVs [fvExpr1, fvExpr2, fvExpr3])
561 %************************************************************************
563 Template Haskell brackets
565 %************************************************************************
568 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
569 rnBracket (VarBr n) = do { name <- lookupOccRn n
570 ; this_mod <- getModule
571 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
572 do { loadInterfaceForName msg name -- home interface is loaded, and this is the
573 ; return () } -- only way that is going to happen
574 ; return (VarBr name, unitFV name) }
576 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
578 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
579 ; return (ExpBr e', fvs) }
581 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
582 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
583 ; return (TypBr t', fvs) }
585 doc = ptext (sLit "In a Template-Haskell quoted type")
586 rnBracket (DecBr group)
587 = do { gbl_env <- getGblEnv
589 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
590 -- The emptyDUs is so that we just collect uses for this
591 -- group alone in the call to rnSrcDecls below
592 ; (tcg_env, group') <- setGblEnv new_gbl_env $
596 -- Discard the tcg_env; it contains only extra info about fixity
597 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
600 %************************************************************************
602 \subsubsection{@Stmt@s: in @do@ expressions}
604 %************************************************************************
607 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
608 -> RnM (thing, FreeVars)
609 -> RnM (([LStmt Name], thing), FreeVars)
611 rnStmts (MDoExpr _) = rnMDoStmts
612 rnStmts ctxt = rnNormalStmts ctxt
614 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
615 -> RnM (thing, FreeVars)
616 -> RnM (([LStmt Name], thing), FreeVars)
617 -- Used for cases *other* than recursive mdo
618 -- Implements nested scopes
620 rnNormalStmts _ [] thing_inside
621 = do { (thing, fvs) <- thing_inside
622 ; return (([],thing), fvs) }
624 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
625 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
626 rnNormalStmts ctxt stmts thing_inside
627 ; return (((L loc stmt' : stmts'), thing), fvs) }
630 rnStmt :: HsStmtContext Name -> Stmt RdrName
631 -> RnM (thing, FreeVars)
632 -> RnM ((Stmt Name, thing), FreeVars)
634 rnStmt _ (ExprStmt expr _ _) thing_inside
635 = do { (expr', fv_expr) <- rnLExpr expr
636 ; (then_op, fvs1) <- lookupSyntaxName thenMName
637 ; (thing, fvs2) <- thing_inside
638 ; return ((ExprStmt expr' then_op placeHolderType, thing),
639 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
641 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
642 = do { (expr', fv_expr) <- rnLExpr expr
643 -- The binders do not scope over the expression
644 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
645 ; (fail_op, fvs2) <- lookupSyntaxName failMName
646 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
647 { (thing, fvs3) <- thing_inside
648 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
649 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
650 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
651 -- but it does not matter because the names are unique
653 rnStmt ctxt (LetStmt binds) thing_inside
654 = do { checkLetStmt ctxt binds
655 ; rnLocalBindsAndThen binds $ \binds' -> do
656 { (thing, fvs) <- thing_inside
657 ; return ((LetStmt binds', thing), fvs) } }
659 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
660 = do { checkRecStmt ctxt
661 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
662 { (thing, fvs) <- thing_inside
664 segs_w_fwd_refs = addFwdRefs segs
665 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
666 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
667 fwd_vars = nameSetToList (plusFVs fs)
669 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
670 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
672 rnStmt ctxt (ParStmt segs) thing_inside
673 = do { checkParStmt ctxt
674 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
675 ; return ((ParStmt segs', thing), fvs) }
677 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
678 checkTransformStmt ctxt
680 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
681 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
682 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
683 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
684 (thing, fv_thing) <- thing_inside
686 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
688 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
690 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
691 rnMaybeLExpr (Just expr) = do
692 (expr', fv_expr) <- rnLExpr expr
693 return (Just expr', fv_expr)
695 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
696 checkTransformStmt ctxt
698 -- We must rename the using expression in the context before the transform is begun
699 groupByClauseAction <-
700 case groupByClause of
701 GroupByNothing usingExpr -> do
702 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
703 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
704 GroupBySomething eitherUsingExpr byExpr -> do
705 (eitherUsingExpr', fv_eitherUsingExpr) <-
706 case eitherUsingExpr of
707 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
709 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
710 return (Left usingExpr', fv_usingExpr)
713 (byExpr', fv_byExpr) <- rnLExpr byExpr
714 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
716 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
717 -- perhaps we could refactor this to use rnNormalStmts directly?
718 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
719 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
720 (groupByClause', fv_groupByClause) <- groupByClauseAction
722 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
723 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
725 -- Bind the "thing" inside a context where we have REBOUND everything
726 -- bound by the statements before the group. This is necessary since after
727 -- the grouping the same identifiers actually have different meanings
728 -- i.e. they refer to lists not singletons!
729 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
731 -- We remove entries from the binder map that are not used in the thing_inside.
732 -- We can then use that usage information to ensure that the free variables do
733 -- not contain the things we just bound, but do contain the things we need to
734 -- make those bindings (i.e. the corresponding non-listy variables)
736 -- Note that we also retain those entries which have an old binder in our
737 -- own free variables (the using or by expression). This is because this map
738 -- is reused in the desugarer to create the type to bind from the statements
739 -- that occur before this one. If the binders we need are not in the map, they
740 -- will never get bound into our desugared expression and hence the simplifier
741 -- crashes as we refer to variables that don't exist!
742 let usedBinderMap = filter
743 (\(old_binder, new_binder) ->
744 (new_binder `elemNameSet` fv_thing) ||
745 (old_binder `elemNameSet` fv_groupByClause)) binderMap
746 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
747 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
749 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
751 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
752 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
754 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
756 -> ([Name] -> RnM (thing, FreeVars))
757 -> RnM (([LStmt Name], [Name], thing), FreeVars)
758 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
759 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
760 -- Find the Names that are bound by stmts that
761 -- by assumption we have just renamed
762 local_env <- getLocalRdrEnv
764 stmts_binders = collectLStmtsBinders stmts
765 bndrs = map (expectJust "rnStmt"
766 . lookupLocalRdrEnv local_env
767 . unLoc) stmts_binders
769 -- If shadow, we'll look up (Unqual x) twice, getting
770 -- the second binding both times, which is the
772 unshadowed_bndrs = nub bndrs
774 -- Typecheck the thing inside, passing on all
775 -- the Names bound before it for its information
776 (thing, fvs) <- thing_inside unshadowed_bndrs
778 -- Figure out which of the bound names are used
779 -- after the statements we renamed
780 let used_bndrs = filter (`elemNameSet` fvs) bndrs
781 return ((used_bndrs, thing), fvs)
783 -- Flatten the tuple returned by the above call a bit!
784 return ((stmts', used_bndrs, inner_thing), fvs)
786 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
787 -> RnM (thing, FreeVars)
788 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
789 rnParallelStmts ctxt segs thing_inside = do
790 orig_lcl_env <- getLocalRdrEnv
791 go orig_lcl_env [] segs
793 go orig_lcl_env bndrs [] = do
794 let (bndrs', dups) = removeDups cmpByOcc bndrs
795 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
798 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
799 return (([], thing), fvs)
801 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
802 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
803 -- Typecheck the thing inside, passing on all
804 -- the Names bound, but separately; revert the envt
805 setLocalRdrEnv orig_lcl_env $ do
806 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
808 let seg' = (stmts', bndrs)
809 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
811 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
812 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
813 <+> quotes (ppr (head vs)))
817 %************************************************************************
819 \subsubsection{mdo expressions}
821 %************************************************************************
824 type FwdRefs = NameSet
825 type Segment stmts = (Defs,
826 Uses, -- May include defs
827 FwdRefs, -- A subset of uses that are
828 -- (a) used before they are bound in this segment, or
829 -- (b) used here, and bound in subsequent segments
830 stmts) -- Either Stmt or [Stmt]
833 ----------------------------------------------------
835 rnMDoStmts :: [LStmt RdrName]
836 -> RnM (thing, FreeVars)
837 -> RnM (([LStmt Name], thing), FreeVars)
838 rnMDoStmts stmts thing_inside
839 = -- Step1: Bring all the binders of the mdo into scope
840 -- (Remember that this also removes the binders from the
841 -- finally-returned free-vars.)
842 -- And rename each individual stmt, making a
843 -- singleton segment. At this stage the FwdRefs field
844 -- isn't finished: it's empty for all except a BindStmt
845 -- for which it's the fwd refs within the bind itself
846 -- (This set may not be empty, because we're in a recursive
848 rn_rec_stmts_and_then stmts $ \ segs -> do {
850 ; (thing, fvs_later) <- thing_inside
853 -- Step 2: Fill in the fwd refs.
854 -- The segments are all singletons, but their fwd-ref
855 -- field mentions all the things used by the segment
856 -- that are bound after their use
857 segs_w_fwd_refs = addFwdRefs segs
859 -- Step 3: Group together the segments to make bigger segments
860 -- Invariant: in the result, no segment uses a variable
861 -- bound in a later segment
862 grouped_segs = glomSegments segs_w_fwd_refs
864 -- Step 4: Turn the segments into Stmts
865 -- Use RecStmt when and only when there are fwd refs
866 -- Also gather up the uses from the end towards the
867 -- start, so we can tell the RecStmt which things are
868 -- used 'after' the RecStmt
869 (stmts', fvs) = segsToStmts grouped_segs fvs_later
871 ; return ((stmts', thing), fvs) }
873 ---------------------------------------------
875 -- wrapper that does both the left- and right-hand sides
876 rn_rec_stmts_and_then :: [LStmt RdrName]
877 -- assumes that the FreeVars returned includes
878 -- the FreeVars of the Segments
879 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
881 rn_rec_stmts_and_then s cont
882 = do { -- (A) Make the mini fixity env for all of the stmts
883 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
886 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
888 -- ...bring them and their fixities into scope
889 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
890 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
892 -- (C) do the right-hand-sides and thing-inside
893 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
894 ; (res, fvs) <- cont segs
895 ; warnUnusedLocalBinds bound_names fvs
896 ; return (res, fvs) }}
898 -- get all the fixity decls in any Let stmt
899 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
900 collectRecStmtsFixities l =
901 foldr (\ s -> \acc -> case s of
902 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
903 foldr (\ sig -> \ acc -> case sig of
904 (L loc (FixSig s)) -> (L loc s) : acc
910 rn_rec_stmt_lhs :: MiniFixityEnv
912 -- rename LHS, and return its FVs
913 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
914 -- so we don't bother to compute it accurately in the other cases
915 -> RnM [(LStmtLR Name RdrName, FreeVars)]
917 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
918 -- this is actually correct
921 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
923 -- should the ctxt be MDo instead?
924 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
925 return [(L loc (BindStmt pat' expr a b),
928 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
929 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
931 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
932 = do binds' <- rnValBindsLHS fix_env binds
933 return [(L loc (LetStmt (HsValBinds binds')),
934 -- Warning: this is bogus; see function invariant
938 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
939 = rn_rec_stmts_lhs fix_env stmts
941 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
942 = pprPanic "rn_rec_stmt" (ppr stmt)
944 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
945 = pprPanic "rn_rec_stmt" (ppr stmt)
947 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
948 = pprPanic "rn_rec_stmt" (ppr stmt)
950 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
951 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
953 rn_rec_stmts_lhs :: MiniFixityEnv
955 -> RnM [(LStmtLR Name RdrName, FreeVars)]
956 rn_rec_stmts_lhs fix_env stmts =
957 let boundNames = collectLStmtsBinders stmts
958 doc = text "In a recursive mdo-expression"
960 -- First do error checking: we need to check for dups here because we
961 -- don't bind all of the variables from the Stmt at once
962 -- with bindLocatedLocals.
963 checkDupRdrNames doc boundNames
964 mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
969 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
970 -- Rename a Stmt that is inside a RecStmt (or mdo)
971 -- Assumes all binders are already in scope
972 -- Turns each stmt into a singleton Stmt
973 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
974 = rnLExpr expr `thenM` \ (expr', fvs) ->
975 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
976 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
977 L loc (ExprStmt expr' then_op placeHolderType))]
979 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
980 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
981 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
982 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
984 bndrs = mkNameSet (collectPatBinders pat')
985 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
987 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
988 L loc (BindStmt pat' expr' bind_op fail_op))]
990 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
991 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
993 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
994 (binds', du_binds) <-
995 -- fixities and unused are handled above in rn_rec_stmts_and_then
996 rnValBindsRHS (mkNameSet all_bndrs) binds'
997 return [(duDefs du_binds, duUses du_binds,
998 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1000 -- no RecStmt case becuase they get flattened above when doing the LHSes
1001 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1002 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1004 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1005 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1007 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1008 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1010 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1011 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1013 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1014 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1016 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1017 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1018 return (concat segs_s)
1020 ---------------------------------------------
1021 addFwdRefs :: [Segment a] -> [Segment a]
1022 -- So far the segments only have forward refs *within* the Stmt
1023 -- (which happens for bind: x <- ...x...)
1024 -- This function adds the cross-seg fwd ref info
1027 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1029 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1030 = (new_seg : segs, all_defs)
1032 new_seg = (defs, uses, new_fwds, stmts)
1033 all_defs = later_defs `unionNameSets` defs
1034 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1035 -- Add the downstream fwd refs here
1037 ----------------------------------------------------
1038 -- Glomming the singleton segments of an mdo into
1039 -- minimal recursive groups.
1041 -- At first I thought this was just strongly connected components, but
1042 -- there's an important constraint: the order of the stmts must not change.
1045 -- mdo { x <- ...y...
1052 -- Here, the first stmt mention 'y', which is bound in the third.
1053 -- But that means that the innocent second stmt (p <- z) gets caught
1054 -- up in the recursion. And that in turn means that the binding for
1055 -- 'z' has to be included... and so on.
1057 -- Start at the tail { r <- x }
1058 -- Now add the next one { z <- y ; r <- x }
1059 -- Now add one more { q <- x ; z <- y ; r <- x }
1060 -- Now one more... but this time we have to group a bunch into rec
1061 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1062 -- Now one more, which we can add on without a rec
1064 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1066 -- Finally we add the last one; since it mentions y we have to
1067 -- glom it togeher with the first two groups
1068 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1069 -- q <- x ; z <- y } ;
1072 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1074 glomSegments [] = []
1075 glomSegments ((defs,uses,fwds,stmt) : segs)
1076 -- Actually stmts will always be a singleton
1077 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1079 segs' = glomSegments segs
1080 (extras, others) = grab uses segs'
1081 (ds, us, fs, ss) = unzip4 extras
1083 seg_defs = plusFVs ds `plusFV` defs
1084 seg_uses = plusFVs us `plusFV` uses
1085 seg_fwds = plusFVs fs `plusFV` fwds
1086 seg_stmts = stmt : concat ss
1088 grab :: NameSet -- The client
1090 -> ([Segment a], -- Needed by the 'client'
1091 [Segment a]) -- Not needed by the client
1092 -- The result is simply a split of the input
1094 = (reverse yeses, reverse noes)
1096 (noes, yeses) = span not_needed (reverse dus)
1097 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1100 ----------------------------------------------------
1101 segsToStmts :: [Segment [LStmt Name]]
1102 -> FreeVars -- Free vars used 'later'
1103 -> ([LStmt Name], FreeVars)
1105 segsToStmts [] fvs_later = ([], fvs_later)
1106 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1107 = ASSERT( not (null ss) )
1108 (new_stmt : later_stmts, later_uses `plusFV` uses)
1110 (later_stmts, later_uses) = segsToStmts segs fvs_later
1111 new_stmt | non_rec = head ss
1112 | otherwise = L (getLoc (head ss)) $
1113 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1116 non_rec = isSingleton ss && isEmptyNameSet fwds
1117 used_later = defs `intersectNameSet` later_uses
1118 -- The ones needed after the RecStmt
1121 %************************************************************************
1123 \subsubsection{Assertion utils}
1125 %************************************************************************
1128 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1129 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1131 mkAssertErrorExpr :: RnM (HsExpr Name)
1132 -- Return an expression for (assertError "Foo.hs:27")
1134 = getSrcSpanM `thenM` \ sloc ->
1135 return (HsApp (L sloc (HsVar assertErrorName))
1136 (L sloc (srcSpanPrimLit sloc)))
1139 Note [Adding the implicit parameter to 'assert']
1140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1141 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1142 By doing this in the renamer we allow the typechecker to just see the
1143 expanded application and do the right thing. But it's not really
1144 the Right Thing because there's no way to "undo" if you want to see
1145 the original source code. We'll have fix this in due course, when
1146 we care more about being able to reconstruct the exact original
1149 %************************************************************************
1151 \subsubsection{Errors}
1153 %************************************************************************
1157 ----------------------
1158 -- Checking when a particular Stmt is ok
1159 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1160 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1161 checkLetStmt _ctxt _binds = return ()
1162 -- We do not allow implicit-parameter bindings in a parallel
1163 -- list comprehension. I'm not sure what it might mean.
1166 checkRecStmt :: HsStmtContext Name -> RnM ()
1167 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1168 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1169 -- proc x -> do { ...rec... }
1170 -- We don't have enough context to distinguish this situation here
1171 -- so we leave it to the type checker
1172 checkRecStmt ctxt = addErr msg
1174 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1177 checkParStmt :: HsStmtContext Name -> RnM ()
1179 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1180 ; checkErr parallel_list_comp msg }
1182 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1185 checkTransformStmt :: HsStmtContext Name -> RnM ()
1186 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1187 -- desugarer will break when we come to operate on a parallel array
1188 = do { transform_list_comp <- doptM Opt_TransformListComp
1189 ; checkErr transform_list_comp msg }
1191 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1192 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1193 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1194 checkTransformStmt ctxt = addErr msg
1196 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1199 sectionErr :: HsExpr RdrName -> SDoc
1201 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1202 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1204 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1205 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1207 ; return (EWildPat, emptyFVs) }
1209 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1210 badIpBinds what binds
1211 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)