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)
29 import RnTypes ( rnHsTypeFVs,
30 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
32 import DynFlags ( DynFlag(..) )
33 import BasicTypes ( FixityDirection(..) )
34 import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
35 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
36 negateName, thenMName, bindMName, failMName, groupWithName )
41 import LoadIface ( loadInterfaceForName )
44 import Util ( isSingleton )
45 import ListSetOps ( removeDups )
46 import Maybes ( expectJust )
51 import List ( unzip4 )
58 thenM :: Monad a => a b -> (b -> a c) -> a c
61 thenM_ :: Monad a => a b -> a c -> a c
64 returnM :: Monad m => a -> m a
67 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
70 checkM :: Monad m => Bool -> m () -> m ()
74 %************************************************************************
76 \subsubsection{Expressions}
78 %************************************************************************
81 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
82 rnExprs ls = rnExprs' ls emptyUniqSet
84 rnExprs' [] acc = returnM ([], acc)
85 rnExprs' (expr:exprs) acc
86 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
88 -- Now we do a "seq" on the free vars because typically it's small
89 -- or empty, especially in very long lists of constants
91 acc' = acc `plusFV` fvExpr
93 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
94 returnM (expr':exprs', fvExprs)
97 Variables. We look up the variable and return the resulting name.
100 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
101 rnLExpr = wrapLocFstM rnExpr
103 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
105 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
106 -- Separated from rnExpr because it's also used
107 -- when renaming infix expressions
108 -- See Note [Adding the implicit parameter to 'assert']
110 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
111 ; if ignore_asserts || not (name `hasKey` assertIdKey)
112 then return (HsVar name, unitFV name)
113 else do { e <- mkAssertErrorExpr
114 ; return (e, unitFV name) } }
117 = do name <- lookupOccRn v
121 = newIPNameRn v `thenM` \ name ->
122 returnM (HsIPVar name, emptyFVs)
124 rnExpr (HsLit lit@(HsString s))
126 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
127 ; if opt_OverloadedStrings then
128 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
129 else -- Same as below
131 returnM (HsLit lit, emptyFVs)
136 returnM (HsLit lit, emptyFVs)
138 rnExpr (HsOverLit lit)
139 = rnOverLit lit `thenM` \ (lit', fvs) ->
140 returnM (HsOverLit lit', fvs)
142 rnExpr (HsApp fun arg)
143 = rnLExpr fun `thenM` \ (fun',fvFun) ->
144 rnLExpr arg `thenM` \ (arg',fvArg) ->
145 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
147 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
148 = do { (e1', fv_e1) <- rnLExpr e1
149 ; (e2', fv_e2) <- rnLExpr e2
150 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
151 ; (op', fv_op) <- finishHsVar op_name
152 -- NB: op' is usually just a variable, but might be
153 -- an applicatoin (assert "Foo.hs:47")
155 -- When renaming code synthesised from "deriving" declarations
156 -- we used to avoid fixity stuff, but we can't easily tell any
157 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
158 -- should prevent bad things happening.
159 ; fixity <- lookupFixityRn op_name
160 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
161 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
164 = rnLExpr e `thenM` \ (e', fv_e) ->
165 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
166 mkNegAppRn e' neg_name `thenM` \ final_e ->
167 returnM (final_e, fv_e `plusFV` fv_neg)
170 = rnLExpr e `thenM` \ (e', fvs_e) ->
171 returnM (HsPar e', fvs_e)
173 -- Template Haskell extensions
174 -- Don't ifdef-GHCI them because we want to fail gracefully
175 -- (not with an rnExpr crash) in a stage-1 compiler.
176 rnExpr e@(HsBracket br_body)
177 = checkTH e "bracket" `thenM_`
178 rnBracket br_body `thenM` \ (body', fvs_e) ->
179 returnM (HsBracket body', fvs_e)
181 rnExpr (HsSpliceE splice)
182 = rnSplice splice `thenM` \ (splice', fvs) ->
183 returnM (HsSpliceE splice', fvs)
186 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
188 rnExpr (HsQuasiQuoteE qq)
189 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
190 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
191 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
192 returnM (expr'', fvs_qq `plusFV` fvs_expr)
195 rnExpr section@(SectionL expr op)
196 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
197 rnLExpr op `thenM` \ (op', fvs_op) ->
198 checkSectionPrec InfixL section op' expr' `thenM_`
199 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
201 rnExpr section@(SectionR op expr)
202 = rnLExpr op `thenM` \ (op', fvs_op) ->
203 rnLExpr expr `thenM` \ (expr', fvs_expr) ->
204 checkSectionPrec InfixR section op' expr' `thenM_`
205 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
207 rnExpr (HsCoreAnn ann expr)
208 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
209 returnM (HsCoreAnn ann expr', fvs_expr)
211 rnExpr (HsSCC lbl expr)
212 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
213 returnM (HsSCC lbl expr', fvs_expr)
214 rnExpr (HsTickPragma info expr)
215 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
216 returnM (HsTickPragma info expr', fvs_expr)
218 rnExpr (HsLam matches)
219 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
220 returnM (HsLam matches', fvMatch)
222 rnExpr (HsCase expr matches)
223 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
224 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
225 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
227 rnExpr (HsLet binds expr)
228 = rnLocalBindsAndThen binds $ \ binds' ->
229 rnLExpr expr `thenM` \ (expr',fvExpr) ->
230 returnM (HsLet binds' expr', fvExpr)
232 rnExpr (HsDo do_or_lc stmts body _)
233 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
235 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
237 rnExpr (ExplicitList _ exps)
238 = rnExprs exps `thenM` \ (exps', fvs) ->
239 returnM (ExplicitList placeHolderType exps', fvs)
241 rnExpr (ExplicitPArr _ exps)
242 = rnExprs exps `thenM` \ (exps', fvs) ->
243 returnM (ExplicitPArr placeHolderType exps', fvs)
245 rnExpr (ExplicitTuple exps boxity)
246 = checkTupSize (length exps) `thenM_`
247 rnExprs exps `thenM` \ (exps', fvs) ->
248 returnM (ExplicitTuple exps' boxity, fvs)
250 rnExpr (RecordCon con_id _ rbinds)
251 = do { conname <- lookupLocatedOccRn con_id
252 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
253 ; return (RecordCon conname noPostTcExpr rbinds',
254 fvRbinds `addOneFV` unLoc conname) }
256 rnExpr (RecordUpd expr rbinds _ _ _)
257 = do { (expr', fvExpr) <- rnLExpr expr
258 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
259 ; return (RecordUpd expr' rbinds' [] [] [],
260 fvExpr `plusFV` fvRbinds) }
262 rnExpr (ExprWithTySig expr pty)
263 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
264 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
266 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
268 doc = text "In an expression type signature"
270 rnExpr (HsIf p b1 b2)
271 = rnLExpr p `thenM` \ (p', fvP) ->
272 rnLExpr b1 `thenM` \ (b1', fvB1) ->
273 rnLExpr b2 `thenM` \ (b2', fvB2) ->
274 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
277 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
278 returnM (HsType t, fvT)
280 doc = text "In a type argument"
282 rnExpr (ArithSeq _ seq)
283 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
284 returnM (ArithSeq noPostTcExpr new_seq, fvs)
286 rnExpr (PArrSeq _ seq)
287 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
288 returnM (PArrSeq noPostTcExpr new_seq, fvs)
291 These three are pattern syntax appearing in expressions.
292 Since all the symbols are reservedops we can simply reject them.
293 We return a (bogus) EWildPat in each case.
296 rnExpr e@EWildPat = patSynErr e
297 rnExpr e@(EAsPat {}) = patSynErr e
298 rnExpr e@(EViewPat {}) = patSynErr e
299 rnExpr e@(ELazyPat {}) = patSynErr e
302 %************************************************************************
306 %************************************************************************
309 rnExpr (HsProc pat body)
311 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
312 rnCmdTop body `thenM` \ (body',fvBody) ->
313 returnM (HsProc pat' body', fvBody)
315 rnExpr (HsArrApp arrow arg _ ho rtl)
316 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
317 rnLExpr arg `thenM` \ (arg',fvArg) ->
318 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
319 fvArrow `plusFV` fvArg)
321 select_arrow_scope tc = case ho of
322 HsHigherOrderApp -> tc
323 HsFirstOrderApp -> escapeArrowScope tc
326 rnExpr (HsArrForm op (Just _) [arg1, arg2])
327 = escapeArrowScope (rnLExpr op)
328 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
329 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
330 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
334 lookupFixityRn op_name `thenM` \ fixity ->
335 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
338 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
340 rnExpr (HsArrForm op fixity cmds)
341 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
342 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
343 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
345 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
350 %************************************************************************
354 %************************************************************************
357 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
358 rnCmdArgs [] = returnM ([], emptyFVs)
360 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
361 rnCmdArgs args `thenM` \ (args',fvArgs) ->
362 returnM (arg':args', fvArg `plusFV` fvArgs)
364 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
365 rnCmdTop = wrapLocFstM rnCmdTop'
367 rnCmdTop' (HsCmdTop cmd _ _ _)
368 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
370 cmd_names = [arrAName, composeAName, firstAName] ++
371 nameSetToList (methodNamesCmd (unLoc cmd'))
373 -- Generate the rebindable syntax for the monad
374 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
376 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
377 fvCmd `plusFV` cmd_fvs)
379 ---------------------------------------------------
380 -- convert OpApp's in a command context to HsArrForm's
382 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
383 convertOpFormsLCmd = fmap convertOpFormsCmd
385 convertOpFormsCmd :: HsCmd id -> HsCmd id
387 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
388 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
389 convertOpFormsCmd (OpApp c1 op fixity c2)
391 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
392 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
394 HsArrForm op (Just fixity) [arg1, arg2]
396 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
398 convertOpFormsCmd (HsCase exp matches)
399 = HsCase exp (convertOpFormsMatch matches)
401 convertOpFormsCmd (HsIf exp c1 c2)
402 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
404 convertOpFormsCmd (HsLet binds cmd)
405 = HsLet binds (convertOpFormsLCmd cmd)
407 convertOpFormsCmd (HsDo ctxt stmts body ty)
408 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
409 (convertOpFormsLCmd body) ty
411 -- Anything else is unchanged. This includes HsArrForm (already done),
412 -- things with no sub-commands, and illegal commands (which will be
413 -- caught by the type checker)
414 convertOpFormsCmd c = c
416 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
417 convertOpFormsStmt (BindStmt pat cmd _ _)
418 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
419 convertOpFormsStmt (ExprStmt cmd _ _)
420 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
421 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
422 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
423 convertOpFormsStmt stmt = stmt
425 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
426 convertOpFormsMatch (MatchGroup ms ty)
427 = MatchGroup (map (fmap convert) ms) ty
428 where convert (Match pat mty grhss)
429 = Match pat mty (convertOpFormsGRHSs grhss)
431 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
432 convertOpFormsGRHSs (GRHSs grhss binds)
433 = GRHSs (map convertOpFormsGRHS grhss) binds
435 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
436 convertOpFormsGRHS = fmap convert
438 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
440 ---------------------------------------------------
441 type CmdNeeds = FreeVars -- Only inhabitants are
442 -- appAName, choiceAName, loopAName
444 -- find what methods the Cmd needs (loop, choice, apply)
445 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
446 methodNamesLCmd = methodNamesCmd . unLoc
448 methodNamesCmd :: HsCmd Name -> CmdNeeds
450 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
452 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
454 methodNamesCmd (HsArrForm {}) = emptyFVs
456 methodNamesCmd (HsPar c) = methodNamesLCmd c
458 methodNamesCmd (HsIf _ c1 c2)
459 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
461 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
463 methodNamesCmd (HsDo _ stmts body _)
464 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
466 methodNamesCmd (HsApp c _) = methodNamesLCmd c
468 methodNamesCmd (HsLam match) = methodNamesMatch match
470 methodNamesCmd (HsCase _ matches)
471 = methodNamesMatch matches `addOneFV` choiceAName
473 methodNamesCmd _ = emptyFVs
474 -- Other forms can't occur in commands, but it's not convenient
475 -- to error here so we just do what's convenient.
476 -- The type checker will complain later
478 ---------------------------------------------------
479 methodNamesMatch :: MatchGroup Name -> FreeVars
480 methodNamesMatch (MatchGroup ms _)
481 = plusFVs (map do_one ms)
483 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
485 -------------------------------------------------
487 methodNamesGRHSs :: GRHSs Name -> FreeVars
488 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
490 -------------------------------------------------
492 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
493 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
495 ---------------------------------------------------
496 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
497 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
499 ---------------------------------------------------
500 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
501 methodNamesLStmt = methodNamesStmt . unLoc
503 methodNamesStmt :: StmtLR Name Name -> FreeVars
504 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
505 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
506 methodNamesStmt (RecStmt stmts _ _ _ _)
507 = methodNamesStmts stmts `addOneFV` loopAName
508 methodNamesStmt (LetStmt _) = emptyFVs
509 methodNamesStmt (ParStmt _) = emptyFVs
510 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
511 methodNamesStmt (GroupStmt _ _) = emptyFVs
512 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
513 -- here so we just do what's convenient
517 %************************************************************************
521 %************************************************************************
524 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
525 rnArithSeq (From expr)
526 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
527 returnM (From expr', fvExpr)
529 rnArithSeq (FromThen expr1 expr2)
530 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
531 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
532 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
534 rnArithSeq (FromTo expr1 expr2)
535 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
536 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
537 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
539 rnArithSeq (FromThenTo expr1 expr2 expr3)
540 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
541 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
542 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
543 returnM (FromThenTo expr1' expr2' expr3',
544 plusFVs [fvExpr1, fvExpr2, fvExpr3])
547 %************************************************************************
549 Template Haskell brackets
551 %************************************************************************
554 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
555 rnBracket (VarBr n) = do { name <- lookupOccRn n
556 ; this_mod <- getModule
557 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
558 do { loadInterfaceForName msg name -- home interface is loaded, and this is the
559 ; return () } -- only way that is going to happen
560 ; returnM (VarBr name, unitFV name) }
562 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
564 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
565 ; return (ExpBr e', fvs) }
567 rnBracket (PatBr _) = do { addErr (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"));
570 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
571 ; return (TypBr t', fvs) }
573 doc = ptext (sLit "In a Template-Haskell quoted type")
574 rnBracket (DecBr group)
575 = do { gbl_env <- getGblEnv
577 ; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed
578 -- declarations will go into the name cache, and we don't want them to
579 -- confuse the Names for the current module.
580 -- By using a pretend module, thFAKE, we keep them safely out of the way.
583 -- The emptyDUs is so that we just collect uses for this group alone
584 -- in the call to rnSrcDecls below
586 ; setGblEnv new_gbl_env $ do {
588 -- In this situation we want to *shadow* top-level bindings.
590 -- bar = [d| foo = 1 |]
591 -- If we don't shadow, we'll get an ambiguity complaint when we do
592 -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
594 -- Furthermore, arguably if the splice does define foo, that should hide
595 -- any foo's further out
597 -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag
598 ; (tcg_env, group') <- rnSrcDecls True group
600 -- Discard the tcg_env; it contains only extra info about fixity
601 ; return (DecBr group', allUses (tcg_dus tcg_env)) } }
604 %************************************************************************
606 \subsubsection{@Stmt@s: in @do@ expressions}
608 %************************************************************************
611 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
612 -> RnM (thing, FreeVars)
613 -> RnM (([LStmt Name], thing), FreeVars)
615 rnStmts (MDoExpr _) = rnMDoStmts
616 rnStmts ctxt = rnNormalStmts ctxt
618 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
619 -> RnM (thing, FreeVars)
620 -> RnM (([LStmt Name], thing), FreeVars)
621 -- Used for cases *other* than recursive mdo
622 -- Implements nested scopes
624 rnNormalStmts _ [] thing_inside
625 = do { (thing, fvs) <- thing_inside
626 ; return (([],thing), fvs) }
628 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
629 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
630 rnNormalStmts ctxt stmts thing_inside
631 ; return (((L loc stmt' : stmts'), thing), fvs) }
634 rnStmt :: HsStmtContext Name -> Stmt RdrName
635 -> RnM (thing, FreeVars)
636 -> RnM ((Stmt Name, thing), FreeVars)
638 rnStmt _ (ExprStmt expr _ _) thing_inside
639 = do { (expr', fv_expr) <- rnLExpr expr
640 ; (then_op, fvs1) <- lookupSyntaxName thenMName
641 ; (thing, fvs2) <- thing_inside
642 ; return ((ExprStmt expr' then_op placeHolderType, thing),
643 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
645 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
646 = do { (expr', fv_expr) <- rnLExpr expr
647 -- The binders do not scope over the expression
648 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
649 ; (fail_op, fvs2) <- lookupSyntaxName failMName
650 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
651 { (thing, fvs3) <- thing_inside
652 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
653 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
654 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
655 -- but it does not matter because the names are unique
657 rnStmt ctxt (LetStmt binds) thing_inside
658 = do { checkLetStmt ctxt binds
659 ; rnLocalBindsAndThen binds $ \binds' -> do
660 { (thing, fvs) <- thing_inside
661 ; return ((LetStmt binds', thing), fvs) } }
663 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
664 = do { checkRecStmt ctxt
665 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
666 { (thing, fvs) <- thing_inside
668 segs_w_fwd_refs = addFwdRefs segs
669 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
670 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
671 fwd_vars = nameSetToList (plusFVs fs)
673 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
674 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
676 rnStmt ctxt (ParStmt segs) thing_inside
677 = do { checkParStmt ctxt
678 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
679 ; return ((ParStmt segs', thing), fvs) }
681 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
682 checkTransformStmt ctxt
684 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
685 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
686 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
687 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
688 (thing, fv_thing) <- thing_inside
690 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
692 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
694 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
695 rnMaybeLExpr (Just expr) = do
696 (expr', fv_expr) <- rnLExpr expr
697 return (Just expr', fv_expr)
699 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
700 checkTransformStmt ctxt
702 -- We must rename the using expression in the context before the transform is begun
703 groupByClauseAction <-
704 case groupByClause of
705 GroupByNothing usingExpr -> do
706 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
707 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
708 GroupBySomething eitherUsingExpr byExpr -> do
709 (eitherUsingExpr', fv_eitherUsingExpr) <-
710 case eitherUsingExpr of
711 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
713 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
714 return (Left usingExpr', fv_usingExpr)
717 (byExpr', fv_byExpr) <- rnLExpr byExpr
718 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
720 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
721 -- perhaps we could refactor this to use rnNormalStmts directly?
722 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
723 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
724 (groupByClause', fv_groupByClause) <- groupByClauseAction
726 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
727 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
729 -- Bind the "thing" inside a context where we have REBOUND everything
730 -- bound by the statements before the group. This is necessary since after
731 -- the grouping the same identifiers actually have different meanings
732 -- i.e. they refer to lists not singletons!
733 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
735 -- We remove entries from the binder map that are not used in the thing_inside.
736 -- We can then use that usage information to ensure that the free variables do
737 -- not contain the things we just bound, but do contain the things we need to
738 -- make those bindings (i.e. the corresponding non-listy variables)
740 -- Note that we also retain those entries which have an old binder in our
741 -- own free variables (the using or by expression). This is because this map
742 -- is reused in the desugarer to create the type to bind from the statements
743 -- that occur before this one. If the binders we need are not in the map, they
744 -- will never get bound into our desugared expression and hence the simplifier
745 -- crashes as we refer to variables that don't exist!
746 let usedBinderMap = filter
747 (\(old_binder, new_binder) ->
748 (new_binder `elemNameSet` fv_thing) ||
749 (old_binder `elemNameSet` fv_groupByClause)) binderMap
750 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
751 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
753 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
755 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
756 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
758 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
760 -> ([Name] -> RnM (thing, FreeVars))
761 -> RnM (([LStmt Name], [Name], thing), FreeVars)
762 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
763 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
764 -- Find the Names that are bound by stmts that
765 -- by assumption we have just renamed
766 local_env <- getLocalRdrEnv
768 stmts_binders = collectLStmtsBinders stmts
769 bndrs = map (expectJust "rnStmt"
770 . lookupLocalRdrEnv local_env
771 . unLoc) stmts_binders
773 -- If shadow, we'll look up (Unqual x) twice, getting
774 -- the second binding both times, which is the
776 unshadowed_bndrs = nub bndrs
778 -- Typecheck the thing inside, passing on all
779 -- the Names bound before it for its information
780 (thing, fvs) <- thing_inside unshadowed_bndrs
782 -- Figure out which of the bound names are used
783 -- after the statements we renamed
784 let used_bndrs = filter (`elemNameSet` fvs) bndrs
785 return ((used_bndrs, thing), fvs)
787 -- Flatten the tuple returned by the above call a bit!
788 return ((stmts', used_bndrs, inner_thing), fvs)
790 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
791 -> RnM (thing, FreeVars)
792 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
793 rnParallelStmts ctxt segs thing_inside = do
794 orig_lcl_env <- getLocalRdrEnv
795 go orig_lcl_env [] segs
797 go orig_lcl_env bndrs [] = do
798 let (bndrs', dups) = removeDups cmpByOcc bndrs
799 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
802 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
803 return (([], thing), fvs)
805 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
806 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
807 -- Typecheck the thing inside, passing on all
808 -- the Names bound, but separately; revert the envt
809 setLocalRdrEnv orig_lcl_env $ do
810 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
812 let seg' = (stmts', bndrs)
813 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
815 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
816 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
817 <+> quotes (ppr (head vs)))
821 %************************************************************************
823 \subsubsection{mdo expressions}
825 %************************************************************************
828 type FwdRefs = NameSet
829 type Segment stmts = (Defs,
830 Uses, -- May include defs
831 FwdRefs, -- A subset of uses that are
832 -- (a) used before they are bound in this segment, or
833 -- (b) used here, and bound in subsequent segments
834 stmts) -- Either Stmt or [Stmt]
837 ----------------------------------------------------
839 rnMDoStmts :: [LStmt RdrName]
840 -> RnM (thing, FreeVars)
841 -> RnM (([LStmt Name], thing), FreeVars)
842 rnMDoStmts stmts thing_inside
843 = -- Step1: Bring all the binders of the mdo into scope
844 -- (Remember that this also removes the binders from the
845 -- finally-returned free-vars.)
846 -- And rename each individual stmt, making a
847 -- singleton segment. At this stage the FwdRefs field
848 -- isn't finished: it's empty for all except a BindStmt
849 -- for which it's the fwd refs within the bind itself
850 -- (This set may not be empty, because we're in a recursive
852 rn_rec_stmts_and_then stmts $ \ segs -> do {
854 ; (thing, fvs_later) <- thing_inside
857 -- Step 2: Fill in the fwd refs.
858 -- The segments are all singletons, but their fwd-ref
859 -- field mentions all the things used by the segment
860 -- that are bound after their use
861 segs_w_fwd_refs = addFwdRefs segs
863 -- Step 3: Group together the segments to make bigger segments
864 -- Invariant: in the result, no segment uses a variable
865 -- bound in a later segment
866 grouped_segs = glomSegments segs_w_fwd_refs
868 -- Step 4: Turn the segments into Stmts
869 -- Use RecStmt when and only when there are fwd refs
870 -- Also gather up the uses from the end towards the
871 -- start, so we can tell the RecStmt which things are
872 -- used 'after' the RecStmt
873 (stmts', fvs) = segsToStmts grouped_segs fvs_later
875 ; return ((stmts', thing), fvs) }
877 ---------------------------------------------
879 -- wrapper that does both the left- and right-hand sides
880 rn_rec_stmts_and_then :: [LStmt RdrName]
881 -- assumes that the FreeVars returned includes
882 -- the FreeVars of the Segments
883 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
885 rn_rec_stmts_and_then s cont
886 = do { -- (A) Make the mini fixity env for all of the stmts
887 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
890 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
892 -- ...bring them and their fixities into scope
893 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
894 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
896 -- (C) do the right-hand-sides and thing-inside
897 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
898 ; (res, fvs) <- cont segs
899 ; warnUnusedLocalBinds bound_names fvs
900 ; return (res, fvs) }}
902 -- get all the fixity decls in any Let stmt
903 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
904 collectRecStmtsFixities l =
905 foldr (\ s -> \acc -> case s of
906 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
907 foldr (\ sig -> \ acc -> case sig of
908 (L loc (FixSig s)) -> (L loc s) : acc
914 rn_rec_stmt_lhs :: MiniFixityEnv
916 -- rename LHS, and return its FVs
917 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
918 -- so we don't bother to compute it accurately in the other cases
919 -> RnM [(LStmtLR Name RdrName, FreeVars)]
921 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
922 -- this is actually correct
925 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
927 -- should the ctxt be MDo instead?
928 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
929 return [(L loc (BindStmt pat' expr a b),
932 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
933 = do { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
936 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
937 = do binds' <- rnValBindsLHS fix_env binds
938 return [(L loc (LetStmt (HsValBinds binds')),
939 -- Warning: this is bogus; see function invariant
943 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
944 = rn_rec_stmts_lhs fix_env stmts
946 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
947 = pprPanic "rn_rec_stmt" (ppr stmt)
949 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
950 = pprPanic "rn_rec_stmt" (ppr stmt)
952 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
953 = pprPanic "rn_rec_stmt" (ppr stmt)
955 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
956 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
958 rn_rec_stmts_lhs :: MiniFixityEnv
960 -> RnM [(LStmtLR Name RdrName, FreeVars)]
961 rn_rec_stmts_lhs fix_env stmts =
962 let boundNames = collectLStmtsBinders stmts
963 doc = text "In a recursive mdo-expression"
965 -- First do error checking: we need to check for dups here because we
966 -- don't bind all of the variables from the Stmt at once
967 -- with bindLocatedLocals.
968 checkDupRdrNames doc boundNames
969 mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls)
974 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
975 -- Rename a Stmt that is inside a RecStmt (or mdo)
976 -- Assumes all binders are already in scope
977 -- Turns each stmt into a singleton Stmt
978 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
979 = rnLExpr expr `thenM` \ (expr', fvs) ->
980 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
981 returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
982 L loc (ExprStmt expr' then_op placeHolderType))]
984 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
985 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
986 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
987 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
989 bndrs = mkNameSet (collectPatBinders pat')
990 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
992 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
993 L loc (BindStmt pat' expr' bind_op fail_op))]
995 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
996 = do { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
999 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1000 (binds', du_binds) <-
1001 -- fixities and unused are handled above in rn_rec_stmts_and_then
1002 rnValBindsRHS all_bndrs binds'
1003 returnM [(duDefs du_binds, duUses du_binds,
1004 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1006 -- no RecStmt case becuase they get flattened above when doing the LHSes
1007 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1008 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1010 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1011 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1013 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1014 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1016 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1017 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1019 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1020 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1022 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1023 rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1024 returnM (concat segs_s)
1026 ---------------------------------------------
1027 addFwdRefs :: [Segment a] -> [Segment a]
1028 -- So far the segments only have forward refs *within* the Stmt
1029 -- (which happens for bind: x <- ...x...)
1030 -- This function adds the cross-seg fwd ref info
1033 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1035 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1036 = (new_seg : segs, all_defs)
1038 new_seg = (defs, uses, new_fwds, stmts)
1039 all_defs = later_defs `unionNameSets` defs
1040 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1041 -- Add the downstream fwd refs here
1043 ----------------------------------------------------
1044 -- Glomming the singleton segments of an mdo into
1045 -- minimal recursive groups.
1047 -- At first I thought this was just strongly connected components, but
1048 -- there's an important constraint: the order of the stmts must not change.
1051 -- mdo { x <- ...y...
1058 -- Here, the first stmt mention 'y', which is bound in the third.
1059 -- But that means that the innocent second stmt (p <- z) gets caught
1060 -- up in the recursion. And that in turn means that the binding for
1061 -- 'z' has to be included... and so on.
1063 -- Start at the tail { r <- x }
1064 -- Now add the next one { z <- y ; r <- x }
1065 -- Now add one more { q <- x ; z <- y ; r <- x }
1066 -- Now one more... but this time we have to group a bunch into rec
1067 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1068 -- Now one more, which we can add on without a rec
1070 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1072 -- Finally we add the last one; since it mentions y we have to
1073 -- glom it togeher with the first two groups
1074 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1075 -- q <- x ; z <- y } ;
1078 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1080 glomSegments [] = []
1081 glomSegments ((defs,uses,fwds,stmt) : segs)
1082 -- Actually stmts will always be a singleton
1083 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1085 segs' = glomSegments segs
1086 (extras, others) = grab uses segs'
1087 (ds, us, fs, ss) = unzip4 extras
1089 seg_defs = plusFVs ds `plusFV` defs
1090 seg_uses = plusFVs us `plusFV` uses
1091 seg_fwds = plusFVs fs `plusFV` fwds
1092 seg_stmts = stmt : concat ss
1094 grab :: NameSet -- The client
1096 -> ([Segment a], -- Needed by the 'client'
1097 [Segment a]) -- Not needed by the client
1098 -- The result is simply a split of the input
1100 = (reverse yeses, reverse noes)
1102 (noes, yeses) = span not_needed (reverse dus)
1103 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1106 ----------------------------------------------------
1107 segsToStmts :: [Segment [LStmt Name]]
1108 -> FreeVars -- Free vars used 'later'
1109 -> ([LStmt Name], FreeVars)
1111 segsToStmts [] fvs_later = ([], fvs_later)
1112 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1113 = ASSERT( not (null ss) )
1114 (new_stmt : later_stmts, later_uses `plusFV` uses)
1116 (later_stmts, later_uses) = segsToStmts segs fvs_later
1117 new_stmt | non_rec = head ss
1118 | otherwise = L (getLoc (head ss)) $
1119 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1122 non_rec = isSingleton ss && isEmptyNameSet fwds
1123 used_later = defs `intersectNameSet` later_uses
1124 -- The ones needed after the RecStmt
1127 %************************************************************************
1129 \subsubsection{Assertion utils}
1131 %************************************************************************
1134 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1135 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
1137 mkAssertErrorExpr :: RnM (HsExpr Name)
1138 -- Return an expression for (assertError "Foo.hs:27")
1140 = getSrcSpanM `thenM` \ sloc ->
1141 return (HsApp (L sloc (HsVar assertErrorName))
1142 (L sloc (srcSpanPrimLit sloc)))
1145 Note [Adding the implicit parameter to 'assert']
1146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1147 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1148 By doing this in the renamer we allow the typechecker to just see the
1149 expanded application and do the right thing. But it's not really
1150 the Right Thing because there's no way to "undo" if you want to see
1151 the original source code. We'll have fix this in due course, when
1152 we care more about being able to reconstruct the exact original
1155 %************************************************************************
1157 \subsubsection{Errors}
1159 %************************************************************************
1163 ----------------------
1164 -- Checking when a particular Stmt is ok
1165 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1166 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1167 checkLetStmt _ctxt _binds = return ()
1168 -- We do not allow implicit-parameter bindings in a parallel
1169 -- list comprehension. I'm not sure what it might mean.
1172 checkRecStmt :: HsStmtContext Name -> RnM ()
1173 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1174 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1175 -- proc x -> do { ...rec... }
1176 -- We don't have enough context to distinguish this situation here
1177 -- so we leave it to the type checker
1178 checkRecStmt ctxt = addErr msg
1180 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1183 checkParStmt :: HsStmtContext Name -> RnM ()
1185 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1186 ; checkErr parallel_list_comp msg }
1188 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1191 checkTransformStmt :: HsStmtContext Name -> RnM ()
1192 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1193 -- desugarer will break when we come to operate on a parallel array
1194 = do { transform_list_comp <- doptM Opt_TransformListComp
1195 ; checkErr transform_list_comp msg }
1197 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1198 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1199 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1200 checkTransformStmt ctxt = addErr msg
1202 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1205 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1206 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1208 ; return (EWildPat, emptyFVs) }
1210 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1211 badIpBinds what binds
1212 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)