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)
169 ------------------------------------------
170 -- Template Haskell extensions
171 -- Don't ifdef-GHCI them because we want to fail gracefully
172 -- (not with an rnExpr crash) in a stage-1 compiler.
173 rnExpr e@(HsBracket br_body)
174 = checkTH e "bracket" `thenM_`
175 rnBracket br_body `thenM` \ (body', fvs_e) ->
176 returnM (HsBracket body', fvs_e)
178 rnExpr (HsSpliceE splice)
179 = rnSplice splice `thenM` \ (splice', fvs) ->
180 returnM (HsSpliceE splice', fvs)
183 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
185 rnExpr (HsQuasiQuoteE qq)
186 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
187 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
188 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
189 returnM (expr'', fvs_qq `plusFV` fvs_expr)
192 ---------------------------------------------
194 -- See Note [Parsing sections] in Parser.y.pp
195 rnExpr (HsPar (L loc (section@(SectionL {}))))
196 = do { (section', fvs) <- rnSection section
197 ; return (HsPar (L loc section'), fvs) }
199 rnExpr (HsPar (L loc (section@(SectionR {}))))
200 = do { (section', fvs) <- rnSection section
201 ; return (HsPar (L loc section'), fvs) }
204 = do { (e', fvs_e) <- rnLExpr e
205 ; return (HsPar e', fvs_e) }
207 rnExpr expr@(SectionL {})
208 = do { addErr (sectionErr expr); rnSection expr }
209 rnExpr expr@(SectionR {})
210 = do { addErr (sectionErr expr); rnSection expr }
212 ---------------------------------------------
213 rnExpr (HsCoreAnn ann expr)
214 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
215 returnM (HsCoreAnn ann expr', fvs_expr)
217 rnExpr (HsSCC lbl expr)
218 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
219 returnM (HsSCC lbl expr', fvs_expr)
220 rnExpr (HsTickPragma info expr)
221 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
222 returnM (HsTickPragma info expr', fvs_expr)
224 rnExpr (HsLam matches)
225 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
226 returnM (HsLam matches', fvMatch)
228 rnExpr (HsCase expr matches)
229 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
230 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
231 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
233 rnExpr (HsLet binds expr)
234 = rnLocalBindsAndThen binds $ \ binds' ->
235 rnLExpr expr `thenM` \ (expr',fvExpr) ->
236 returnM (HsLet binds' expr', fvExpr)
238 rnExpr (HsDo do_or_lc stmts body _)
239 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
241 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
243 rnExpr (ExplicitList _ exps)
244 = rnExprs exps `thenM` \ (exps', fvs) ->
245 returnM (ExplicitList placeHolderType exps', fvs)
247 rnExpr (ExplicitPArr _ exps)
248 = rnExprs exps `thenM` \ (exps', fvs) ->
249 returnM (ExplicitPArr placeHolderType exps', fvs)
251 rnExpr (ExplicitTuple exps boxity)
252 = checkTupSize (length exps) `thenM_`
253 rnExprs exps `thenM` \ (exps', fvs) ->
254 returnM (ExplicitTuple exps' boxity, fvs)
256 rnExpr (RecordCon con_id _ rbinds)
257 = do { conname <- lookupLocatedOccRn con_id
258 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
259 ; return (RecordCon conname noPostTcExpr rbinds',
260 fvRbinds `addOneFV` unLoc conname) }
262 rnExpr (RecordUpd expr rbinds _ _ _)
263 = do { (expr', fvExpr) <- rnLExpr expr
264 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
265 ; return (RecordUpd expr' rbinds' [] [] [],
266 fvExpr `plusFV` fvRbinds) }
268 rnExpr (ExprWithTySig expr pty)
269 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
270 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
272 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
274 doc = text "In an expression type signature"
276 rnExpr (HsIf p b1 b2)
277 = rnLExpr p `thenM` \ (p', fvP) ->
278 rnLExpr b1 `thenM` \ (b1', fvB1) ->
279 rnLExpr b2 `thenM` \ (b2', fvB2) ->
280 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
283 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
284 returnM (HsType t, fvT)
286 doc = text "In a type argument"
288 rnExpr (ArithSeq _ seq)
289 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
290 returnM (ArithSeq noPostTcExpr new_seq, fvs)
292 rnExpr (PArrSeq _ seq)
293 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
294 returnM (PArrSeq noPostTcExpr new_seq, fvs)
297 These three are pattern syntax appearing in expressions.
298 Since all the symbols are reservedops we can simply reject them.
299 We return a (bogus) EWildPat in each case.
302 rnExpr e@EWildPat = patSynErr e
303 rnExpr e@(EAsPat {}) = patSynErr e
304 rnExpr e@(EViewPat {}) = patSynErr e
305 rnExpr e@(ELazyPat {}) = patSynErr e
308 %************************************************************************
312 %************************************************************************
315 rnExpr (HsProc pat body)
317 rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
318 rnCmdTop body `thenM` \ (body',fvBody) ->
319 returnM (HsProc pat' body', fvBody)
321 rnExpr (HsArrApp arrow arg _ ho rtl)
322 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
323 rnLExpr arg `thenM` \ (arg',fvArg) ->
324 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
325 fvArrow `plusFV` fvArg)
327 select_arrow_scope tc = case ho of
328 HsHigherOrderApp -> tc
329 HsFirstOrderApp -> escapeArrowScope tc
332 rnExpr (HsArrForm op (Just _) [arg1, arg2])
333 = escapeArrowScope (rnLExpr op)
334 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
335 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
336 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
340 lookupFixityRn op_name `thenM` \ fixity ->
341 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
344 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
346 rnExpr (HsArrForm op fixity cmds)
347 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
348 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
349 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
351 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
354 ----------------------
355 -- See Note [Parsing sections] in Parser.y.pp
356 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
357 rnSection section@(SectionR op expr)
358 = do { (op', fvs_op) <- rnLExpr op
359 ; (expr', fvs_expr) <- rnLExpr expr
360 ; checkSectionPrec InfixR section op' expr'
361 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
363 rnSection section@(SectionL expr op)
364 = do { (expr', fvs_expr) <- rnLExpr expr
365 ; (op', fvs_op) <- rnLExpr op
366 ; checkSectionPrec InfixL section op' expr'
367 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
369 rnSection other = pprPanic "rnSection" (ppr other)
372 %************************************************************************
376 %************************************************************************
379 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
380 rnCmdArgs [] = returnM ([], emptyFVs)
382 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
383 rnCmdArgs args `thenM` \ (args',fvArgs) ->
384 returnM (arg':args', fvArg `plusFV` fvArgs)
386 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
387 rnCmdTop = wrapLocFstM rnCmdTop'
389 rnCmdTop' (HsCmdTop cmd _ _ _)
390 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
392 cmd_names = [arrAName, composeAName, firstAName] ++
393 nameSetToList (methodNamesCmd (unLoc cmd'))
395 -- Generate the rebindable syntax for the monad
396 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
398 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
399 fvCmd `plusFV` cmd_fvs)
401 ---------------------------------------------------
402 -- convert OpApp's in a command context to HsArrForm's
404 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
405 convertOpFormsLCmd = fmap convertOpFormsCmd
407 convertOpFormsCmd :: HsCmd id -> HsCmd id
409 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
410 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
411 convertOpFormsCmd (OpApp c1 op fixity c2)
413 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
414 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
416 HsArrForm op (Just fixity) [arg1, arg2]
418 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
420 convertOpFormsCmd (HsCase exp matches)
421 = HsCase exp (convertOpFormsMatch matches)
423 convertOpFormsCmd (HsIf exp c1 c2)
424 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
426 convertOpFormsCmd (HsLet binds cmd)
427 = HsLet binds (convertOpFormsLCmd cmd)
429 convertOpFormsCmd (HsDo ctxt stmts body ty)
430 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
431 (convertOpFormsLCmd body) ty
433 -- Anything else is unchanged. This includes HsArrForm (already done),
434 -- things with no sub-commands, and illegal commands (which will be
435 -- caught by the type checker)
436 convertOpFormsCmd c = c
438 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
439 convertOpFormsStmt (BindStmt pat cmd _ _)
440 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
441 convertOpFormsStmt (ExprStmt cmd _ _)
442 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
443 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
444 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
445 convertOpFormsStmt stmt = stmt
447 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
448 convertOpFormsMatch (MatchGroup ms ty)
449 = MatchGroup (map (fmap convert) ms) ty
450 where convert (Match pat mty grhss)
451 = Match pat mty (convertOpFormsGRHSs grhss)
453 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
454 convertOpFormsGRHSs (GRHSs grhss binds)
455 = GRHSs (map convertOpFormsGRHS grhss) binds
457 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
458 convertOpFormsGRHS = fmap convert
460 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
462 ---------------------------------------------------
463 type CmdNeeds = FreeVars -- Only inhabitants are
464 -- appAName, choiceAName, loopAName
466 -- find what methods the Cmd needs (loop, choice, apply)
467 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
468 methodNamesLCmd = methodNamesCmd . unLoc
470 methodNamesCmd :: HsCmd Name -> CmdNeeds
472 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
474 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
476 methodNamesCmd (HsArrForm {}) = emptyFVs
478 methodNamesCmd (HsPar c) = methodNamesLCmd c
480 methodNamesCmd (HsIf _ c1 c2)
481 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
483 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
485 methodNamesCmd (HsDo _ stmts body _)
486 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
488 methodNamesCmd (HsApp c _) = methodNamesLCmd c
490 methodNamesCmd (HsLam match) = methodNamesMatch match
492 methodNamesCmd (HsCase _ matches)
493 = methodNamesMatch matches `addOneFV` choiceAName
495 methodNamesCmd _ = emptyFVs
496 -- Other forms can't occur in commands, but it's not convenient
497 -- to error here so we just do what's convenient.
498 -- The type checker will complain later
500 ---------------------------------------------------
501 methodNamesMatch :: MatchGroup Name -> FreeVars
502 methodNamesMatch (MatchGroup ms _)
503 = plusFVs (map do_one ms)
505 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
507 -------------------------------------------------
509 methodNamesGRHSs :: GRHSs Name -> FreeVars
510 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
512 -------------------------------------------------
514 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
515 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
517 ---------------------------------------------------
518 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
519 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
521 ---------------------------------------------------
522 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
523 methodNamesLStmt = methodNamesStmt . unLoc
525 methodNamesStmt :: StmtLR Name Name -> FreeVars
526 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
527 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
528 methodNamesStmt (RecStmt stmts _ _ _ _)
529 = methodNamesStmts stmts `addOneFV` loopAName
530 methodNamesStmt (LetStmt _) = emptyFVs
531 methodNamesStmt (ParStmt _) = emptyFVs
532 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
533 methodNamesStmt (GroupStmt _ _) = emptyFVs
534 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
535 -- here so we just do what's convenient
539 %************************************************************************
543 %************************************************************************
546 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
547 rnArithSeq (From expr)
548 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
549 returnM (From expr', fvExpr)
551 rnArithSeq (FromThen expr1 expr2)
552 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
553 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
554 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
556 rnArithSeq (FromTo expr1 expr2)
557 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
558 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
559 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
561 rnArithSeq (FromThenTo expr1 expr2 expr3)
562 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
563 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
564 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
565 returnM (FromThenTo expr1' expr2' expr3',
566 plusFVs [fvExpr1, fvExpr2, fvExpr3])
569 %************************************************************************
571 Template Haskell brackets
573 %************************************************************************
576 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
577 rnBracket (VarBr n) = do { name <- lookupOccRn n
578 ; this_mod <- getModule
579 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
580 do { loadInterfaceForName msg name -- home interface is loaded, and this is the
581 ; return () } -- only way that is going to happen
582 ; returnM (VarBr name, unitFV name) }
584 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
586 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
587 ; return (ExpBr e', fvs) }
589 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
590 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
591 ; return (TypBr t', fvs) }
593 doc = ptext (sLit "In a Template-Haskell quoted type")
594 rnBracket (DecBr group)
595 = do { gbl_env <- getGblEnv
597 ; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed
598 -- declarations will go into the name cache, and we don't want them to
599 -- confuse the Names for the current module.
600 -- By using a pretend module, thFAKE, we keep them safely out of the way.
603 -- The emptyDUs is so that we just collect uses for this group alone
604 -- in the call to rnSrcDecls below
606 ; setGblEnv new_gbl_env $ do {
608 -- In this situation we want to *shadow* top-level bindings.
610 -- bar = [d| foo = 1 |]
611 -- If we don't shadow, we'll get an ambiguity complaint when we do
612 -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
614 -- Furthermore, arguably if the splice does define foo, that should hide
615 -- any foo's further out
617 -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag
618 ; (tcg_env, group') <- rnSrcDecls True group
620 -- Discard the tcg_env; it contains only extra info about fixity
621 ; return (DecBr group', allUses (tcg_dus tcg_env)) } }
624 %************************************************************************
626 \subsubsection{@Stmt@s: in @do@ expressions}
628 %************************************************************************
631 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
632 -> RnM (thing, FreeVars)
633 -> RnM (([LStmt Name], thing), FreeVars)
635 rnStmts (MDoExpr _) = rnMDoStmts
636 rnStmts ctxt = rnNormalStmts ctxt
638 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
639 -> RnM (thing, FreeVars)
640 -> RnM (([LStmt Name], thing), FreeVars)
641 -- Used for cases *other* than recursive mdo
642 -- Implements nested scopes
644 rnNormalStmts _ [] thing_inside
645 = do { (thing, fvs) <- thing_inside
646 ; return (([],thing), fvs) }
648 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
649 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
650 rnNormalStmts ctxt stmts thing_inside
651 ; return (((L loc stmt' : stmts'), thing), fvs) }
654 rnStmt :: HsStmtContext Name -> Stmt RdrName
655 -> RnM (thing, FreeVars)
656 -> RnM ((Stmt Name, thing), FreeVars)
658 rnStmt _ (ExprStmt expr _ _) thing_inside
659 = do { (expr', fv_expr) <- rnLExpr expr
660 ; (then_op, fvs1) <- lookupSyntaxName thenMName
661 ; (thing, fvs2) <- thing_inside
662 ; return ((ExprStmt expr' then_op placeHolderType, thing),
663 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
665 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
666 = do { (expr', fv_expr) <- rnLExpr expr
667 -- The binders do not scope over the expression
668 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
669 ; (fail_op, fvs2) <- lookupSyntaxName failMName
670 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
671 { (thing, fvs3) <- thing_inside
672 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
673 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
674 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
675 -- but it does not matter because the names are unique
677 rnStmt ctxt (LetStmt binds) thing_inside
678 = do { checkLetStmt ctxt binds
679 ; rnLocalBindsAndThen binds $ \binds' -> do
680 { (thing, fvs) <- thing_inside
681 ; return ((LetStmt binds', thing), fvs) } }
683 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
684 = do { checkRecStmt ctxt
685 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
686 { (thing, fvs) <- thing_inside
688 segs_w_fwd_refs = addFwdRefs segs
689 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
690 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
691 fwd_vars = nameSetToList (plusFVs fs)
693 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
694 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
696 rnStmt ctxt (ParStmt segs) thing_inside
697 = do { checkParStmt ctxt
698 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
699 ; return ((ParStmt segs', thing), fvs) }
701 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
702 checkTransformStmt ctxt
704 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
705 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
706 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
707 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
708 (thing, fv_thing) <- thing_inside
710 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
712 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
714 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
715 rnMaybeLExpr (Just expr) = do
716 (expr', fv_expr) <- rnLExpr expr
717 return (Just expr', fv_expr)
719 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
720 checkTransformStmt ctxt
722 -- We must rename the using expression in the context before the transform is begun
723 groupByClauseAction <-
724 case groupByClause of
725 GroupByNothing usingExpr -> do
726 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
727 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
728 GroupBySomething eitherUsingExpr byExpr -> do
729 (eitherUsingExpr', fv_eitherUsingExpr) <-
730 case eitherUsingExpr of
731 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
733 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
734 return (Left usingExpr', fv_usingExpr)
737 (byExpr', fv_byExpr) <- rnLExpr byExpr
738 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
740 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
741 -- perhaps we could refactor this to use rnNormalStmts directly?
742 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
743 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
744 (groupByClause', fv_groupByClause) <- groupByClauseAction
746 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
747 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
749 -- Bind the "thing" inside a context where we have REBOUND everything
750 -- bound by the statements before the group. This is necessary since after
751 -- the grouping the same identifiers actually have different meanings
752 -- i.e. they refer to lists not singletons!
753 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
755 -- We remove entries from the binder map that are not used in the thing_inside.
756 -- We can then use that usage information to ensure that the free variables do
757 -- not contain the things we just bound, but do contain the things we need to
758 -- make those bindings (i.e. the corresponding non-listy variables)
760 -- Note that we also retain those entries which have an old binder in our
761 -- own free variables (the using or by expression). This is because this map
762 -- is reused in the desugarer to create the type to bind from the statements
763 -- that occur before this one. If the binders we need are not in the map, they
764 -- will never get bound into our desugared expression and hence the simplifier
765 -- crashes as we refer to variables that don't exist!
766 let usedBinderMap = filter
767 (\(old_binder, new_binder) ->
768 (new_binder `elemNameSet` fv_thing) ||
769 (old_binder `elemNameSet` fv_groupByClause)) binderMap
770 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
771 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
773 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
775 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
776 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
778 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
780 -> ([Name] -> RnM (thing, FreeVars))
781 -> RnM (([LStmt Name], [Name], thing), FreeVars)
782 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
783 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
784 -- Find the Names that are bound by stmts that
785 -- by assumption we have just renamed
786 local_env <- getLocalRdrEnv
788 stmts_binders = collectLStmtsBinders stmts
789 bndrs = map (expectJust "rnStmt"
790 . lookupLocalRdrEnv local_env
791 . unLoc) stmts_binders
793 -- If shadow, we'll look up (Unqual x) twice, getting
794 -- the second binding both times, which is the
796 unshadowed_bndrs = nub bndrs
798 -- Typecheck the thing inside, passing on all
799 -- the Names bound before it for its information
800 (thing, fvs) <- thing_inside unshadowed_bndrs
802 -- Figure out which of the bound names are used
803 -- after the statements we renamed
804 let used_bndrs = filter (`elemNameSet` fvs) bndrs
805 return ((used_bndrs, thing), fvs)
807 -- Flatten the tuple returned by the above call a bit!
808 return ((stmts', used_bndrs, inner_thing), fvs)
810 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
811 -> RnM (thing, FreeVars)
812 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
813 rnParallelStmts ctxt segs thing_inside = do
814 orig_lcl_env <- getLocalRdrEnv
815 go orig_lcl_env [] segs
817 go orig_lcl_env bndrs [] = do
818 let (bndrs', dups) = removeDups cmpByOcc bndrs
819 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
822 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
823 return (([], thing), fvs)
825 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
826 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
827 -- Typecheck the thing inside, passing on all
828 -- the Names bound, but separately; revert the envt
829 setLocalRdrEnv orig_lcl_env $ do
830 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
832 let seg' = (stmts', bndrs)
833 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
835 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
836 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
837 <+> quotes (ppr (head vs)))
841 %************************************************************************
843 \subsubsection{mdo expressions}
845 %************************************************************************
848 type FwdRefs = NameSet
849 type Segment stmts = (Defs,
850 Uses, -- May include defs
851 FwdRefs, -- A subset of uses that are
852 -- (a) used before they are bound in this segment, or
853 -- (b) used here, and bound in subsequent segments
854 stmts) -- Either Stmt or [Stmt]
857 ----------------------------------------------------
859 rnMDoStmts :: [LStmt RdrName]
860 -> RnM (thing, FreeVars)
861 -> RnM (([LStmt Name], thing), FreeVars)
862 rnMDoStmts stmts thing_inside
863 = -- Step1: Bring all the binders of the mdo into scope
864 -- (Remember that this also removes the binders from the
865 -- finally-returned free-vars.)
866 -- And rename each individual stmt, making a
867 -- singleton segment. At this stage the FwdRefs field
868 -- isn't finished: it's empty for all except a BindStmt
869 -- for which it's the fwd refs within the bind itself
870 -- (This set may not be empty, because we're in a recursive
872 rn_rec_stmts_and_then stmts $ \ segs -> do {
874 ; (thing, fvs_later) <- thing_inside
877 -- Step 2: Fill in the fwd refs.
878 -- The segments are all singletons, but their fwd-ref
879 -- field mentions all the things used by the segment
880 -- that are bound after their use
881 segs_w_fwd_refs = addFwdRefs segs
883 -- Step 3: Group together the segments to make bigger segments
884 -- Invariant: in the result, no segment uses a variable
885 -- bound in a later segment
886 grouped_segs = glomSegments segs_w_fwd_refs
888 -- Step 4: Turn the segments into Stmts
889 -- Use RecStmt when and only when there are fwd refs
890 -- Also gather up the uses from the end towards the
891 -- start, so we can tell the RecStmt which things are
892 -- used 'after' the RecStmt
893 (stmts', fvs) = segsToStmts grouped_segs fvs_later
895 ; return ((stmts', thing), fvs) }
897 ---------------------------------------------
899 -- wrapper that does both the left- and right-hand sides
900 rn_rec_stmts_and_then :: [LStmt RdrName]
901 -- assumes that the FreeVars returned includes
902 -- the FreeVars of the Segments
903 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
905 rn_rec_stmts_and_then s cont
906 = do { -- (A) Make the mini fixity env for all of the stmts
907 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
910 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
912 -- ...bring them and their fixities into scope
913 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
914 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
916 -- (C) do the right-hand-sides and thing-inside
917 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
918 ; (res, fvs) <- cont segs
919 ; warnUnusedLocalBinds bound_names fvs
920 ; return (res, fvs) }}
922 -- get all the fixity decls in any Let stmt
923 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
924 collectRecStmtsFixities l =
925 foldr (\ s -> \acc -> case s of
926 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
927 foldr (\ sig -> \ acc -> case sig of
928 (L loc (FixSig s)) -> (L loc s) : acc
934 rn_rec_stmt_lhs :: MiniFixityEnv
936 -- rename LHS, and return its FVs
937 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
938 -- so we don't bother to compute it accurately in the other cases
939 -> RnM [(LStmtLR Name RdrName, FreeVars)]
941 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
942 -- this is actually correct
945 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
947 -- should the ctxt be MDo instead?
948 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
949 return [(L loc (BindStmt pat' expr a b),
952 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
953 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
955 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
956 = do binds' <- rnValBindsLHS fix_env binds
957 return [(L loc (LetStmt (HsValBinds binds')),
958 -- Warning: this is bogus; see function invariant
962 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
963 = rn_rec_stmts_lhs fix_env stmts
965 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
966 = pprPanic "rn_rec_stmt" (ppr stmt)
968 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
969 = pprPanic "rn_rec_stmt" (ppr stmt)
971 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
972 = pprPanic "rn_rec_stmt" (ppr stmt)
974 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
975 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
977 rn_rec_stmts_lhs :: MiniFixityEnv
979 -> RnM [(LStmtLR Name RdrName, FreeVars)]
980 rn_rec_stmts_lhs fix_env stmts =
981 let boundNames = collectLStmtsBinders stmts
982 doc = text "In a recursive mdo-expression"
984 -- First do error checking: we need to check for dups here because we
985 -- don't bind all of the variables from the Stmt at once
986 -- with bindLocatedLocals.
987 checkDupRdrNames doc boundNames
988 mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls)
993 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
994 -- Rename a Stmt that is inside a RecStmt (or mdo)
995 -- Assumes all binders are already in scope
996 -- Turns each stmt into a singleton Stmt
997 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
998 = rnLExpr expr `thenM` \ (expr', fvs) ->
999 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1000 returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1001 L loc (ExprStmt expr' then_op placeHolderType))]
1003 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1004 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1005 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1006 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1008 bndrs = mkNameSet (collectPatBinders pat')
1009 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1011 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1012 L loc (BindStmt pat' expr' bind_op fail_op))]
1014 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1015 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1017 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1018 (binds', du_binds) <-
1019 -- fixities and unused are handled above in rn_rec_stmts_and_then
1020 rnValBindsRHS all_bndrs binds'
1021 returnM [(duDefs du_binds, duUses du_binds,
1022 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1024 -- no RecStmt case becuase they get flattened above when doing the LHSes
1025 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1026 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1028 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1029 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1031 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1032 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1034 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1035 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1037 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1038 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1040 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1041 rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1042 returnM (concat segs_s)
1044 ---------------------------------------------
1045 addFwdRefs :: [Segment a] -> [Segment a]
1046 -- So far the segments only have forward refs *within* the Stmt
1047 -- (which happens for bind: x <- ...x...)
1048 -- This function adds the cross-seg fwd ref info
1051 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1053 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1054 = (new_seg : segs, all_defs)
1056 new_seg = (defs, uses, new_fwds, stmts)
1057 all_defs = later_defs `unionNameSets` defs
1058 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1059 -- Add the downstream fwd refs here
1061 ----------------------------------------------------
1062 -- Glomming the singleton segments of an mdo into
1063 -- minimal recursive groups.
1065 -- At first I thought this was just strongly connected components, but
1066 -- there's an important constraint: the order of the stmts must not change.
1069 -- mdo { x <- ...y...
1076 -- Here, the first stmt mention 'y', which is bound in the third.
1077 -- But that means that the innocent second stmt (p <- z) gets caught
1078 -- up in the recursion. And that in turn means that the binding for
1079 -- 'z' has to be included... and so on.
1081 -- Start at the tail { r <- x }
1082 -- Now add the next one { z <- y ; r <- x }
1083 -- Now add one more { q <- x ; z <- y ; r <- x }
1084 -- Now one more... but this time we have to group a bunch into rec
1085 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1086 -- Now one more, which we can add on without a rec
1088 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1090 -- Finally we add the last one; since it mentions y we have to
1091 -- glom it togeher with the first two groups
1092 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1093 -- q <- x ; z <- y } ;
1096 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1098 glomSegments [] = []
1099 glomSegments ((defs,uses,fwds,stmt) : segs)
1100 -- Actually stmts will always be a singleton
1101 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1103 segs' = glomSegments segs
1104 (extras, others) = grab uses segs'
1105 (ds, us, fs, ss) = unzip4 extras
1107 seg_defs = plusFVs ds `plusFV` defs
1108 seg_uses = plusFVs us `plusFV` uses
1109 seg_fwds = plusFVs fs `plusFV` fwds
1110 seg_stmts = stmt : concat ss
1112 grab :: NameSet -- The client
1114 -> ([Segment a], -- Needed by the 'client'
1115 [Segment a]) -- Not needed by the client
1116 -- The result is simply a split of the input
1118 = (reverse yeses, reverse noes)
1120 (noes, yeses) = span not_needed (reverse dus)
1121 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1124 ----------------------------------------------------
1125 segsToStmts :: [Segment [LStmt Name]]
1126 -> FreeVars -- Free vars used 'later'
1127 -> ([LStmt Name], FreeVars)
1129 segsToStmts [] fvs_later = ([], fvs_later)
1130 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1131 = ASSERT( not (null ss) )
1132 (new_stmt : later_stmts, later_uses `plusFV` uses)
1134 (later_stmts, later_uses) = segsToStmts segs fvs_later
1135 new_stmt | non_rec = head ss
1136 | otherwise = L (getLoc (head ss)) $
1137 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1140 non_rec = isSingleton ss && isEmptyNameSet fwds
1141 used_later = defs `intersectNameSet` later_uses
1142 -- The ones needed after the RecStmt
1145 %************************************************************************
1147 \subsubsection{Assertion utils}
1149 %************************************************************************
1152 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1153 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
1155 mkAssertErrorExpr :: RnM (HsExpr Name)
1156 -- Return an expression for (assertError "Foo.hs:27")
1158 = getSrcSpanM `thenM` \ sloc ->
1159 return (HsApp (L sloc (HsVar assertErrorName))
1160 (L sloc (srcSpanPrimLit sloc)))
1163 Note [Adding the implicit parameter to 'assert']
1164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1165 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1166 By doing this in the renamer we allow the typechecker to just see the
1167 expanded application and do the right thing. But it's not really
1168 the Right Thing because there's no way to "undo" if you want to see
1169 the original source code. We'll have fix this in due course, when
1170 we care more about being able to reconstruct the exact original
1173 %************************************************************************
1175 \subsubsection{Errors}
1177 %************************************************************************
1181 ----------------------
1182 -- Checking when a particular Stmt is ok
1183 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1184 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1185 checkLetStmt _ctxt _binds = return ()
1186 -- We do not allow implicit-parameter bindings in a parallel
1187 -- list comprehension. I'm not sure what it might mean.
1190 checkRecStmt :: HsStmtContext Name -> RnM ()
1191 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1192 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1193 -- proc x -> do { ...rec... }
1194 -- We don't have enough context to distinguish this situation here
1195 -- so we leave it to the type checker
1196 checkRecStmt ctxt = addErr msg
1198 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1201 checkParStmt :: HsStmtContext Name -> RnM ()
1203 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1204 ; checkErr parallel_list_comp msg }
1206 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1209 checkTransformStmt :: HsStmtContext Name -> RnM ()
1210 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1211 -- desugarer will break when we come to operate on a parallel array
1212 = do { transform_list_comp <- doptM Opt_TransformListComp
1213 ; checkErr transform_list_comp msg }
1215 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1216 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1217 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1218 checkTransformStmt ctxt = addErr msg
1220 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1223 sectionErr :: HsExpr RdrName -> SDoc
1225 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1226 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1228 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1229 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1231 ; return (EWildPat, emptyFVs) }
1233 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1234 badIpBinds what binds
1235 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)