2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnLExpr, rnExpr, rnStmts
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
23 import RnSource ( rnSrcDecls )
24 import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
33 import DynFlags ( DynFlag(..) )
34 import BasicTypes ( FixityDirection(..) )
35 import PrelNames ( hasKey, assertIdKey, assertErrorName,
36 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
37 negateName, thenMName, bindMName, failMName, groupWithName )
42 import LoadIface ( loadInterfaceForName )
45 import Util ( isSingleton )
46 import ListSetOps ( removeDups )
47 import Maybes ( expectJust )
52 import List ( unzip4 )
58 thenM :: Monad a => a b -> (b -> a c) -> a c
61 thenM_ :: Monad a => a b -> a c -> a c
65 %************************************************************************
67 \subsubsection{Expressions}
69 %************************************************************************
72 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
73 rnExprs ls = rnExprs' ls emptyUniqSet
75 rnExprs' [] acc = return ([], acc)
76 rnExprs' (expr:exprs) acc
77 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
79 -- Now we do a "seq" on the free vars because typically it's small
80 -- or empty, especially in very long lists of constants
82 acc' = acc `plusFV` fvExpr
84 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
85 return (expr':exprs', fvExprs)
88 Variables. We look up the variable and return the resulting name.
91 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
92 rnLExpr = wrapLocFstM rnExpr
94 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
96 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
97 -- Separated from rnExpr because it's also used
98 -- when renaming infix expressions
99 -- See Note [Adding the implicit parameter to 'assert']
101 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
102 ; if ignore_asserts || not (name `hasKey` assertIdKey)
103 then return (HsVar name, unitFV name)
104 else do { e <- mkAssertErrorExpr
105 ; return (e, unitFV name) } }
108 = do name <- lookupOccRn v
112 = newIPNameRn v `thenM` \ name ->
113 return (HsIPVar name, emptyFVs)
115 rnExpr (HsLit lit@(HsString s))
117 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
118 ; if opt_OverloadedStrings then
119 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
120 else -- Same as below
122 return (HsLit lit, emptyFVs)
127 return (HsLit lit, emptyFVs)
129 rnExpr (HsOverLit lit)
130 = rnOverLit lit `thenM` \ (lit', fvs) ->
131 return (HsOverLit lit', fvs)
133 rnExpr (HsApp fun arg)
134 = rnLExpr fun `thenM` \ (fun',fvFun) ->
135 rnLExpr arg `thenM` \ (arg',fvArg) ->
136 return (HsApp fun' arg', fvFun `plusFV` fvArg)
138 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
139 = do { (e1', fv_e1) <- rnLExpr e1
140 ; (e2', fv_e2) <- rnLExpr e2
141 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
142 ; (op', fv_op) <- finishHsVar op_name
143 -- NB: op' is usually just a variable, but might be
144 -- an applicatoin (assert "Foo.hs:47")
146 -- When renaming code synthesised from "deriving" declarations
147 -- we used to avoid fixity stuff, but we can't easily tell any
148 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
149 -- should prevent bad things happening.
150 ; fixity <- lookupFixityRn op_name
151 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
152 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
155 = rnLExpr e `thenM` \ (e', fv_e) ->
156 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
157 mkNegAppRn e' neg_name `thenM` \ final_e ->
158 return (final_e, fv_e `plusFV` fv_neg)
160 ------------------------------------------
161 -- Template Haskell extensions
162 -- Don't ifdef-GHCI them because we want to fail gracefully
163 -- (not with an rnExpr crash) in a stage-1 compiler.
164 rnExpr e@(HsBracket br_body)
165 = checkTH e "bracket" `thenM_`
166 rnBracket br_body `thenM` \ (body', fvs_e) ->
167 return (HsBracket body', fvs_e)
169 rnExpr (HsSpliceE splice)
170 = rnSplice splice `thenM` \ (splice', fvs) ->
171 return (HsSpliceE splice', fvs)
174 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
176 rnExpr (HsQuasiQuoteE qq)
177 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
178 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
179 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
180 return (expr'', fvs_qq `plusFV` fvs_expr)
183 ---------------------------------------------
185 -- See Note [Parsing sections] in Parser.y.pp
186 rnExpr (HsPar (L loc (section@(SectionL {}))))
187 = do { (section', fvs) <- rnSection section
188 ; return (HsPar (L loc section'), fvs) }
190 rnExpr (HsPar (L loc (section@(SectionR {}))))
191 = do { (section', fvs) <- rnSection section
192 ; return (HsPar (L loc section'), fvs) }
195 = do { (e', fvs_e) <- rnLExpr e
196 ; return (HsPar e', fvs_e) }
198 rnExpr expr@(SectionL {})
199 = do { addErr (sectionErr expr); rnSection expr }
200 rnExpr expr@(SectionR {})
201 = do { addErr (sectionErr expr); rnSection expr }
203 ---------------------------------------------
204 rnExpr (HsCoreAnn ann expr)
205 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
206 return (HsCoreAnn ann expr', fvs_expr)
208 rnExpr (HsSCC lbl expr)
209 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
210 return (HsSCC lbl expr', fvs_expr)
211 rnExpr (HsTickPragma info expr)
212 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
213 return (HsTickPragma info expr', fvs_expr)
215 rnExpr (HsLam matches)
216 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
217 return (HsLam matches', fvMatch)
219 rnExpr (HsCase expr matches)
220 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
221 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
222 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
224 rnExpr (HsLet binds expr)
225 = rnLocalBindsAndThen binds $ \ binds' ->
226 rnLExpr expr `thenM` \ (expr',fvExpr) ->
227 return (HsLet binds' expr', fvExpr)
229 rnExpr (HsDo do_or_lc stmts body _)
230 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
232 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
234 rnExpr (ExplicitList _ exps)
235 = rnExprs exps `thenM` \ (exps', fvs) ->
236 return (ExplicitList placeHolderType exps', fvs)
238 rnExpr (ExplicitPArr _ exps)
239 = rnExprs exps `thenM` \ (exps', fvs) ->
240 return (ExplicitPArr placeHolderType exps', fvs)
242 rnExpr (ExplicitTuple tup_args boxity)
243 = do { checkTupleSection tup_args
244 ; checkTupSize (length tup_args)
245 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
246 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
248 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
249 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
251 rnExpr (RecordCon con_id _ rbinds)
252 = do { conname <- lookupLocatedOccRn con_id
253 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
254 ; return (RecordCon conname noPostTcExpr rbinds',
255 fvRbinds `addOneFV` unLoc conname) }
257 rnExpr (RecordUpd expr rbinds _ _ _)
258 = do { (expr', fvExpr) <- rnLExpr expr
259 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
260 ; return (RecordUpd expr' rbinds' [] [] [],
261 fvExpr `plusFV` fvRbinds) }
263 rnExpr (ExprWithTySig expr pty)
264 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
265 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
267 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
269 doc = text "In an expression type signature"
271 rnExpr (HsIf p b1 b2)
272 = rnLExpr p `thenM` \ (p', fvP) ->
273 rnLExpr b1 `thenM` \ (b1', fvB1) ->
274 rnLExpr b2 `thenM` \ (b2', fvB2) ->
275 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
278 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
279 return (HsType t, fvT)
281 doc = text "In a type argument"
283 rnExpr (ArithSeq _ seq)
284 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
285 return (ArithSeq noPostTcExpr new_seq, fvs)
287 rnExpr (PArrSeq _ seq)
288 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
289 return (PArrSeq noPostTcExpr new_seq, fvs)
292 These three are pattern syntax appearing in expressions.
293 Since all the symbols are reservedops we can simply reject them.
294 We return a (bogus) EWildPat in each case.
297 rnExpr e@EWildPat = patSynErr e
298 rnExpr e@(EAsPat {}) = patSynErr e
299 rnExpr e@(EViewPat {}) = patSynErr e
300 rnExpr e@(ELazyPat {}) = patSynErr e
303 %************************************************************************
307 %************************************************************************
310 rnExpr (HsProc pat body)
312 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
313 rnCmdTop body `thenM` \ (body',fvBody) ->
314 return (HsProc pat' body', fvBody)
316 rnExpr (HsArrApp arrow arg _ ho rtl)
317 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
318 rnLExpr arg `thenM` \ (arg',fvArg) ->
319 return (HsArrApp arrow' arg' placeHolderType ho rtl,
320 fvArrow `plusFV` fvArg)
322 select_arrow_scope tc = case ho of
323 HsHigherOrderApp -> tc
324 HsFirstOrderApp -> escapeArrowScope tc
327 rnExpr (HsArrForm op (Just _) [arg1, arg2])
328 = escapeArrowScope (rnLExpr op)
329 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
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 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
375 rnCmdArgs [] = return ([], emptyFVs)
377 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
378 rnCmdArgs args `thenM` \ (args',fvArgs) ->
379 return (arg':args', fvArg `plusFV` fvArgs)
381 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
382 rnCmdTop = wrapLocFstM rnCmdTop'
384 rnCmdTop' (HsCmdTop cmd _ _ _)
385 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
387 cmd_names = [arrAName, composeAName, firstAName] ++
388 nameSetToList (methodNamesCmd (unLoc cmd'))
390 -- Generate the rebindable syntax for the monad
391 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
393 return (HsCmdTop cmd' [] placeHolderType cmd_names',
394 fvCmd `plusFV` cmd_fvs)
396 ---------------------------------------------------
397 -- convert OpApp's in a command context to HsArrForm's
399 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
400 convertOpFormsLCmd = fmap convertOpFormsCmd
402 convertOpFormsCmd :: HsCmd id -> HsCmd id
404 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
405 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
406 convertOpFormsCmd (OpApp c1 op fixity c2)
408 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
409 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
411 HsArrForm op (Just fixity) [arg1, arg2]
413 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
415 convertOpFormsCmd (HsCase exp matches)
416 = HsCase exp (convertOpFormsMatch matches)
418 convertOpFormsCmd (HsIf exp c1 c2)
419 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
421 convertOpFormsCmd (HsLet binds cmd)
422 = HsLet binds (convertOpFormsLCmd cmd)
424 convertOpFormsCmd (HsDo ctxt stmts body ty)
425 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
426 (convertOpFormsLCmd body) ty
428 -- Anything else is unchanged. This includes HsArrForm (already done),
429 -- things with no sub-commands, and illegal commands (which will be
430 -- caught by the type checker)
431 convertOpFormsCmd c = c
433 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
434 convertOpFormsStmt (BindStmt pat cmd _ _)
435 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
436 convertOpFormsStmt (ExprStmt cmd _ _)
437 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
438 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
439 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
440 convertOpFormsStmt stmt = stmt
442 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
443 convertOpFormsMatch (MatchGroup ms ty)
444 = MatchGroup (map (fmap convert) ms) ty
445 where convert (Match pat mty grhss)
446 = Match pat mty (convertOpFormsGRHSs grhss)
448 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
449 convertOpFormsGRHSs (GRHSs grhss binds)
450 = GRHSs (map convertOpFormsGRHS grhss) binds
452 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
453 convertOpFormsGRHS = fmap convert
455 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
457 ---------------------------------------------------
458 type CmdNeeds = FreeVars -- Only inhabitants are
459 -- appAName, choiceAName, loopAName
461 -- find what methods the Cmd needs (loop, choice, apply)
462 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
463 methodNamesLCmd = methodNamesCmd . unLoc
465 methodNamesCmd :: HsCmd Name -> CmdNeeds
467 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
469 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
471 methodNamesCmd (HsArrForm {}) = emptyFVs
473 methodNamesCmd (HsPar c) = methodNamesLCmd c
475 methodNamesCmd (HsIf _ c1 c2)
476 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
478 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
480 methodNamesCmd (HsDo _ stmts body _)
481 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
483 methodNamesCmd (HsApp c _) = methodNamesLCmd c
485 methodNamesCmd (HsLam match) = methodNamesMatch match
487 methodNamesCmd (HsCase _ matches)
488 = methodNamesMatch matches `addOneFV` choiceAName
490 methodNamesCmd _ = emptyFVs
491 -- Other forms can't occur in commands, but it's not convenient
492 -- to error here so we just do what's convenient.
493 -- The type checker will complain later
495 ---------------------------------------------------
496 methodNamesMatch :: MatchGroup Name -> FreeVars
497 methodNamesMatch (MatchGroup ms _)
498 = plusFVs (map do_one ms)
500 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
502 -------------------------------------------------
504 methodNamesGRHSs :: GRHSs Name -> FreeVars
505 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
507 -------------------------------------------------
509 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
510 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
512 ---------------------------------------------------
513 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
514 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
516 ---------------------------------------------------
517 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
518 methodNamesLStmt = methodNamesStmt . unLoc
520 methodNamesStmt :: StmtLR Name Name -> FreeVars
521 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
522 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
523 methodNamesStmt (RecStmt stmts _ _ _ _)
524 = methodNamesStmts stmts `addOneFV` loopAName
525 methodNamesStmt (LetStmt _) = emptyFVs
526 methodNamesStmt (ParStmt _) = emptyFVs
527 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
528 methodNamesStmt (GroupStmt _ _) = emptyFVs
529 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
530 -- here so we just do what's convenient
534 %************************************************************************
538 %************************************************************************
541 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
542 rnArithSeq (From expr)
543 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
544 return (From expr', fvExpr)
546 rnArithSeq (FromThen expr1 expr2)
547 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
548 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
549 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
551 rnArithSeq (FromTo expr1 expr2)
552 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
553 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
554 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
556 rnArithSeq (FromThenTo expr1 expr2 expr3)
557 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
558 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
559 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
560 return (FromThenTo expr1' expr2' expr3',
561 plusFVs [fvExpr1, fvExpr2, fvExpr3])
564 %************************************************************************
566 Template Haskell brackets
568 %************************************************************************
571 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
572 rnBracket (VarBr n) = do { name <- lookupOccRn n
573 ; this_mod <- getModule
574 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
575 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
576 ; return () } -- only way that is going to happen
577 ; return (VarBr name, unitFV name) }
579 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
581 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
582 ; return (ExpBr e', fvs) }
584 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
585 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
586 ; return (TypBr t', fvs) }
588 doc = ptext (sLit "In a Template-Haskell quoted type")
589 rnBracket (DecBr group)
590 = do { gbl_env <- getGblEnv
592 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
593 -- The emptyDUs is so that we just collect uses for this
594 -- group alone in the call to rnSrcDecls below
595 ; (tcg_env, group') <- setGblEnv new_gbl_env $
599 -- Discard the tcg_env; it contains only extra info about fixity
600 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
603 %************************************************************************
605 \subsubsection{@Stmt@s: in @do@ expressions}
607 %************************************************************************
610 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
611 -> RnM (thing, FreeVars)
612 -> RnM (([LStmt Name], thing), FreeVars)
614 rnStmts (MDoExpr _) = rnMDoStmts
615 rnStmts ctxt = rnNormalStmts ctxt
617 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
618 -> RnM (thing, FreeVars)
619 -> RnM (([LStmt Name], thing), FreeVars)
620 -- Used for cases *other* than recursive mdo
621 -- Implements nested scopes
623 rnNormalStmts _ [] thing_inside
624 = do { (thing, fvs) <- thing_inside
625 ; return (([],thing), fvs) }
627 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
628 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
629 rnNormalStmts ctxt stmts thing_inside
630 ; return (((L loc stmt' : stmts'), thing), fvs) }
633 rnStmt :: HsStmtContext Name -> Stmt RdrName
634 -> RnM (thing, FreeVars)
635 -> RnM ((Stmt Name, thing), FreeVars)
637 rnStmt _ (ExprStmt expr _ _) thing_inside
638 = do { (expr', fv_expr) <- rnLExpr expr
639 ; (then_op, fvs1) <- lookupSyntaxName thenMName
640 ; (thing, fvs2) <- thing_inside
641 ; return ((ExprStmt expr' then_op placeHolderType, thing),
642 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
644 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
645 = do { (expr', fv_expr) <- rnLExpr expr
646 -- The binders do not scope over the expression
647 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
648 ; (fail_op, fvs2) <- lookupSyntaxName failMName
649 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
650 { (thing, fvs3) <- thing_inside
651 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
652 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
653 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
654 -- but it does not matter because the names are unique
656 rnStmt ctxt (LetStmt binds) thing_inside
657 = do { checkLetStmt ctxt binds
658 ; rnLocalBindsAndThen binds $ \binds' -> do
659 { (thing, fvs) <- thing_inside
660 ; return ((LetStmt binds', thing), fvs) } }
662 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
663 = do { checkRecStmt ctxt
664 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
665 { (thing, fvs) <- thing_inside
667 segs_w_fwd_refs = addFwdRefs segs
668 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
669 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
670 fwd_vars = nameSetToList (plusFVs fs)
672 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
673 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
675 rnStmt ctxt (ParStmt segs) thing_inside
676 = do { checkParStmt ctxt
677 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
678 ; return ((ParStmt segs', thing), fvs) }
680 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
681 checkTransformStmt ctxt
683 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
684 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
685 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
686 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
687 (thing, fv_thing) <- thing_inside
689 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
691 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
693 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
694 rnMaybeLExpr (Just expr) = do
695 (expr', fv_expr) <- rnLExpr expr
696 return (Just expr', fv_expr)
698 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
699 checkTransformStmt ctxt
701 -- We must rename the using expression in the context before the transform is begun
702 groupByClauseAction <-
703 case groupByClause of
704 GroupByNothing usingExpr -> do
705 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
706 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
707 GroupBySomething eitherUsingExpr byExpr -> do
708 (eitherUsingExpr', fv_eitherUsingExpr) <-
709 case eitherUsingExpr of
710 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
712 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
713 return (Left usingExpr', fv_usingExpr)
716 (byExpr', fv_byExpr) <- rnLExpr byExpr
717 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
719 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
720 -- perhaps we could refactor this to use rnNormalStmts directly?
721 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
722 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
723 (groupByClause', fv_groupByClause) <- groupByClauseAction
725 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
726 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
728 -- Bind the "thing" inside a context where we have REBOUND everything
729 -- bound by the statements before the group. This is necessary since after
730 -- the grouping the same identifiers actually have different meanings
731 -- i.e. they refer to lists not singletons!
732 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
734 -- We remove entries from the binder map that are not used in the thing_inside.
735 -- We can then use that usage information to ensure that the free variables do
736 -- not contain the things we just bound, but do contain the things we need to
737 -- make those bindings (i.e. the corresponding non-listy variables)
739 -- Note that we also retain those entries which have an old binder in our
740 -- own free variables (the using or by expression). This is because this map
741 -- is reused in the desugarer to create the type to bind from the statements
742 -- that occur before this one. If the binders we need are not in the map, they
743 -- will never get bound into our desugared expression and hence the simplifier
744 -- crashes as we refer to variables that don't exist!
745 let usedBinderMap = filter
746 (\(old_binder, new_binder) ->
747 (new_binder `elemNameSet` fv_thing) ||
748 (old_binder `elemNameSet` fv_groupByClause)) binderMap
749 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
750 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
752 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
754 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
755 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
757 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
759 -> ([Name] -> RnM (thing, FreeVars))
760 -> RnM (([LStmt Name], [Name], thing), FreeVars)
761 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
762 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
763 -- Find the Names that are bound by stmts that
764 -- by assumption we have just renamed
765 local_env <- getLocalRdrEnv
767 stmts_binders = collectLStmtsBinders stmts
768 bndrs = map (expectJust "rnStmt"
769 . lookupLocalRdrEnv local_env
770 . unLoc) stmts_binders
772 -- If shadow, we'll look up (Unqual x) twice, getting
773 -- the second binding both times, which is the
775 unshadowed_bndrs = nub bndrs
777 -- Typecheck the thing inside, passing on all
778 -- the Names bound before it for its information
779 (thing, fvs) <- thing_inside unshadowed_bndrs
781 -- Figure out which of the bound names are used
782 -- after the statements we renamed
783 let used_bndrs = filter (`elemNameSet` fvs) bndrs
784 return ((used_bndrs, thing), fvs)
786 -- Flatten the tuple returned by the above call a bit!
787 return ((stmts', used_bndrs, inner_thing), fvs)
789 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
790 -> RnM (thing, FreeVars)
791 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
792 rnParallelStmts ctxt segs thing_inside = do
793 orig_lcl_env <- getLocalRdrEnv
794 go orig_lcl_env [] segs
796 go orig_lcl_env bndrs [] = do
797 let (bndrs', dups) = removeDups cmpByOcc bndrs
798 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
801 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
802 return (([], thing), fvs)
804 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
805 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
806 -- Typecheck the thing inside, passing on all
807 -- the Names bound, but separately; revert the envt
808 setLocalRdrEnv orig_lcl_env $ do
809 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
811 let seg' = (stmts', bndrs)
812 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
814 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
815 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
816 <+> quotes (ppr (head vs)))
820 %************************************************************************
822 \subsubsection{mdo expressions}
824 %************************************************************************
827 type FwdRefs = NameSet
828 type Segment stmts = (Defs,
829 Uses, -- May include defs
830 FwdRefs, -- A subset of uses that are
831 -- (a) used before they are bound in this segment, or
832 -- (b) used here, and bound in subsequent segments
833 stmts) -- Either Stmt or [Stmt]
836 ----------------------------------------------------
838 rnMDoStmts :: [LStmt RdrName]
839 -> RnM (thing, FreeVars)
840 -> RnM (([LStmt Name], thing), FreeVars)
841 rnMDoStmts stmts thing_inside
842 = -- Step1: Bring all the binders of the mdo into scope
843 -- (Remember that this also removes the binders from the
844 -- finally-returned free-vars.)
845 -- And rename each individual stmt, making a
846 -- singleton segment. At this stage the FwdRefs field
847 -- isn't finished: it's empty for all except a BindStmt
848 -- for which it's the fwd refs within the bind itself
849 -- (This set may not be empty, because we're in a recursive
851 rn_rec_stmts_and_then stmts $ \ segs -> do {
853 ; (thing, fvs_later) <- thing_inside
856 -- Step 2: Fill in the fwd refs.
857 -- The segments are all singletons, but their fwd-ref
858 -- field mentions all the things used by the segment
859 -- that are bound after their use
860 segs_w_fwd_refs = addFwdRefs segs
862 -- Step 3: Group together the segments to make bigger segments
863 -- Invariant: in the result, no segment uses a variable
864 -- bound in a later segment
865 grouped_segs = glomSegments segs_w_fwd_refs
867 -- Step 4: Turn the segments into Stmts
868 -- Use RecStmt when and only when there are fwd refs
869 -- Also gather up the uses from the end towards the
870 -- start, so we can tell the RecStmt which things are
871 -- used 'after' the RecStmt
872 (stmts', fvs) = segsToStmts grouped_segs fvs_later
874 ; return ((stmts', thing), fvs) }
876 ---------------------------------------------
878 -- wrapper that does both the left- and right-hand sides
879 rn_rec_stmts_and_then :: [LStmt RdrName]
880 -- assumes that the FreeVars returned includes
881 -- the FreeVars of the Segments
882 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
884 rn_rec_stmts_and_then s cont
885 = do { -- (A) Make the mini fixity env for all of the stmts
886 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
889 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
891 -- ...bring them and their fixities into scope
892 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
893 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
895 -- (C) do the right-hand-sides and thing-inside
896 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
897 ; (res, fvs) <- cont segs
898 ; warnUnusedLocalBinds bound_names fvs
899 ; return (res, fvs) }}
901 -- get all the fixity decls in any Let stmt
902 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
903 collectRecStmtsFixities l =
904 foldr (\ s -> \acc -> case s of
905 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
906 foldr (\ sig -> \ acc -> case sig of
907 (L loc (FixSig s)) -> (L loc s) : acc
913 rn_rec_stmt_lhs :: MiniFixityEnv
915 -- rename LHS, and return its FVs
916 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
917 -- so we don't bother to compute it accurately in the other cases
918 -> RnM [(LStmtLR Name RdrName, FreeVars)]
920 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
921 -- this is actually correct
924 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
926 -- should the ctxt be MDo instead?
927 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
928 return [(L loc (BindStmt pat' expr a b),
931 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
932 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
934 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
935 = do binds' <- rnValBindsLHS fix_env binds
936 return [(L loc (LetStmt (HsValBinds binds')),
937 -- Warning: this is bogus; see function invariant
941 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
942 = rn_rec_stmts_lhs fix_env stmts
944 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
945 = pprPanic "rn_rec_stmt" (ppr stmt)
947 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
948 = pprPanic "rn_rec_stmt" (ppr stmt)
950 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
951 = pprPanic "rn_rec_stmt" (ppr stmt)
953 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
954 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
956 rn_rec_stmts_lhs :: MiniFixityEnv
958 -> RnM [(LStmtLR Name RdrName, FreeVars)]
959 rn_rec_stmts_lhs fix_env stmts =
960 let boundNames = collectLStmtsBinders stmts
961 doc = text "In a recursive mdo-expression"
963 -- First do error checking: we need to check for dups here because we
964 -- don't bind all of the variables from the Stmt at once
965 -- with bindLocatedLocals.
966 checkDupRdrNames doc boundNames
967 mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
972 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
973 -- Rename a Stmt that is inside a RecStmt (or mdo)
974 -- Assumes all binders are already in scope
975 -- Turns each stmt into a singleton Stmt
976 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
977 = rnLExpr expr `thenM` \ (expr', fvs) ->
978 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
979 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
980 L loc (ExprStmt expr' then_op placeHolderType))]
982 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
983 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
984 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
985 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
987 bndrs = mkNameSet (collectPatBinders pat')
988 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
990 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
991 L loc (BindStmt pat' expr' bind_op fail_op))]
993 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
994 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
996 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
997 (binds', du_binds) <-
998 -- fixities and unused are handled above in rn_rec_stmts_and_then
999 rnValBindsRHS (mkNameSet all_bndrs) binds'
1000 return [(duDefs du_binds, duUses du_binds,
1001 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1003 -- no RecStmt case becuase they get flattened above when doing the LHSes
1004 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1005 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1007 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1008 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1010 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1011 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1013 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1014 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1016 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1017 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1019 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1020 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1021 return (concat segs_s)
1023 ---------------------------------------------
1024 addFwdRefs :: [Segment a] -> [Segment a]
1025 -- So far the segments only have forward refs *within* the Stmt
1026 -- (which happens for bind: x <- ...x...)
1027 -- This function adds the cross-seg fwd ref info
1030 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1032 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1033 = (new_seg : segs, all_defs)
1035 new_seg = (defs, uses, new_fwds, stmts)
1036 all_defs = later_defs `unionNameSets` defs
1037 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1038 -- Add the downstream fwd refs here
1040 ----------------------------------------------------
1041 -- Glomming the singleton segments of an mdo into
1042 -- minimal recursive groups.
1044 -- At first I thought this was just strongly connected components, but
1045 -- there's an important constraint: the order of the stmts must not change.
1048 -- mdo { x <- ...y...
1055 -- Here, the first stmt mention 'y', which is bound in the third.
1056 -- But that means that the innocent second stmt (p <- z) gets caught
1057 -- up in the recursion. And that in turn means that the binding for
1058 -- 'z' has to be included... and so on.
1060 -- Start at the tail { r <- x }
1061 -- Now add the next one { z <- y ; r <- x }
1062 -- Now add one more { q <- x ; z <- y ; r <- x }
1063 -- Now one more... but this time we have to group a bunch into rec
1064 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1065 -- Now one more, which we can add on without a rec
1067 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1069 -- Finally we add the last one; since it mentions y we have to
1070 -- glom it togeher with the first two groups
1071 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1072 -- q <- x ; z <- y } ;
1075 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1077 glomSegments [] = []
1078 glomSegments ((defs,uses,fwds,stmt) : segs)
1079 -- Actually stmts will always be a singleton
1080 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1082 segs' = glomSegments segs
1083 (extras, others) = grab uses segs'
1084 (ds, us, fs, ss) = unzip4 extras
1086 seg_defs = plusFVs ds `plusFV` defs
1087 seg_uses = plusFVs us `plusFV` uses
1088 seg_fwds = plusFVs fs `plusFV` fwds
1089 seg_stmts = stmt : concat ss
1091 grab :: NameSet -- The client
1093 -> ([Segment a], -- Needed by the 'client'
1094 [Segment a]) -- Not needed by the client
1095 -- The result is simply a split of the input
1097 = (reverse yeses, reverse noes)
1099 (noes, yeses) = span not_needed (reverse dus)
1100 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1103 ----------------------------------------------------
1104 segsToStmts :: [Segment [LStmt Name]]
1105 -> FreeVars -- Free vars used 'later'
1106 -> ([LStmt Name], FreeVars)
1108 segsToStmts [] fvs_later = ([], fvs_later)
1109 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1110 = ASSERT( not (null ss) )
1111 (new_stmt : later_stmts, later_uses `plusFV` uses)
1113 (later_stmts, later_uses) = segsToStmts segs fvs_later
1114 new_stmt | non_rec = head ss
1115 | otherwise = L (getLoc (head ss)) $
1116 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1119 non_rec = isSingleton ss && isEmptyNameSet fwds
1120 used_later = defs `intersectNameSet` later_uses
1121 -- The ones needed after the RecStmt
1124 %************************************************************************
1126 \subsubsection{Assertion utils}
1128 %************************************************************************
1131 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1132 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1134 mkAssertErrorExpr :: RnM (HsExpr Name)
1135 -- Return an expression for (assertError "Foo.hs:27")
1137 = getSrcSpanM `thenM` \ sloc ->
1138 return (HsApp (L sloc (HsVar assertErrorName))
1139 (L sloc (srcSpanPrimLit sloc)))
1142 Note [Adding the implicit parameter to 'assert']
1143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1144 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1145 By doing this in the renamer we allow the typechecker to just see the
1146 expanded application and do the right thing. But it's not really
1147 the Right Thing because there's no way to "undo" if you want to see
1148 the original source code. We'll have fix this in due course, when
1149 we care more about being able to reconstruct the exact original
1152 %************************************************************************
1154 \subsubsection{Errors}
1156 %************************************************************************
1160 ----------------------
1161 -- Checking when a particular Stmt is ok
1162 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1163 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1164 checkLetStmt _ctxt _binds = return ()
1165 -- We do not allow implicit-parameter bindings in a parallel
1166 -- list comprehension. I'm not sure what it might mean.
1169 checkRecStmt :: HsStmtContext Name -> RnM ()
1170 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1171 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1172 -- proc x -> do { ...rec... }
1173 -- We don't have enough context to distinguish this situation here
1174 -- so we leave it to the type checker
1175 checkRecStmt ctxt = addErr msg
1177 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1180 checkParStmt :: HsStmtContext Name -> RnM ()
1182 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1183 ; checkErr parallel_list_comp msg }
1185 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1188 checkTransformStmt :: HsStmtContext Name -> RnM ()
1189 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1190 -- desugarer will break when we come to operate on a parallel array
1191 = do { transform_list_comp <- doptM Opt_TransformListComp
1192 ; checkErr transform_list_comp msg }
1194 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1195 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1196 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1197 checkTransformStmt ctxt = addErr msg
1199 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1202 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1203 checkTupleSection args
1204 = do { tuple_section <- doptM Opt_TupleSections
1205 ; checkErr (all tupArgPresent args || tuple_section) msg }
1207 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1210 sectionErr :: HsExpr RdrName -> SDoc
1212 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1213 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1215 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1216 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1218 ; return (EWildPat, emptyFVs) }
1220 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1221 badIpBinds what binds
1222 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)