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 )
57 thenM :: Monad a => a b -> (b -> a c) -> a c
60 thenM_ :: Monad a => a b -> a c -> a c
64 %************************************************************************
66 \subsubsection{Expressions}
68 %************************************************************************
71 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
72 rnExprs ls = rnExprs' ls emptyUniqSet
74 rnExprs' [] acc = return ([], acc)
75 rnExprs' (expr:exprs) acc
76 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
78 -- Now we do a "seq" on the free vars because typically it's small
79 -- or empty, especially in very long lists of constants
81 acc' = acc `plusFV` fvExpr
83 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
84 return (expr':exprs', fvExprs)
87 Variables. We look up the variable and return the resulting name.
90 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
91 rnLExpr = wrapLocFstM rnExpr
93 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
95 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
96 -- Separated from rnExpr because it's also used
97 -- when renaming infix expressions
98 -- See Note [Adding the implicit parameter to 'assert']
100 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
101 ; if ignore_asserts || not (name `hasKey` assertIdKey)
102 then return (HsVar name, unitFV name)
103 else do { e <- mkAssertErrorExpr
104 ; return (e, unitFV name) } }
107 = do name <- lookupOccRn v
111 = newIPNameRn v `thenM` \ name ->
112 return (HsIPVar name, emptyFVs)
114 rnExpr (HsLit lit@(HsString s))
116 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
117 ; if opt_OverloadedStrings then
118 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
119 else -- Same as below
121 return (HsLit lit, emptyFVs)
126 return (HsLit lit, emptyFVs)
128 rnExpr (HsOverLit lit)
129 = rnOverLit lit `thenM` \ (lit', fvs) ->
130 return (HsOverLit lit', fvs)
132 rnExpr (HsApp fun arg)
133 = rnLExpr fun `thenM` \ (fun',fvFun) ->
134 rnLExpr arg `thenM` \ (arg',fvArg) ->
135 return (HsApp fun' arg', fvFun `plusFV` fvArg)
137 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
138 = do { (e1', fv_e1) <- rnLExpr e1
139 ; (e2', fv_e2) <- rnLExpr e2
140 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
141 ; (op', fv_op) <- finishHsVar op_name
142 -- NB: op' is usually just a variable, but might be
143 -- an applicatoin (assert "Foo.hs:47")
145 -- When renaming code synthesised from "deriving" declarations
146 -- we used to avoid fixity stuff, but we can't easily tell any
147 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
148 -- should prevent bad things happening.
149 ; fixity <- lookupFixityRn op_name
150 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
151 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
154 = rnLExpr e `thenM` \ (e', fv_e) ->
155 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
156 mkNegAppRn e' neg_name `thenM` \ final_e ->
157 return (final_e, fv_e `plusFV` fv_neg)
159 ------------------------------------------
160 -- Template Haskell extensions
161 -- Don't ifdef-GHCI them because we want to fail gracefully
162 -- (not with an rnExpr crash) in a stage-1 compiler.
163 rnExpr e@(HsBracket br_body)
164 = checkTH e "bracket" `thenM_`
165 rnBracket br_body `thenM` \ (body', fvs_e) ->
166 return (HsBracket body', fvs_e)
168 rnExpr (HsSpliceE splice)
169 = rnSplice splice `thenM` \ (splice', fvs) ->
170 return (HsSpliceE splice', fvs)
173 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
175 rnExpr (HsQuasiQuoteE qq)
176 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
177 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
178 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
179 return (expr'', fvs_qq `plusFV` fvs_expr)
182 ---------------------------------------------
184 -- See Note [Parsing sections] in Parser.y.pp
185 rnExpr (HsPar (L loc (section@(SectionL {}))))
186 = do { (section', fvs) <- rnSection section
187 ; return (HsPar (L loc section'), fvs) }
189 rnExpr (HsPar (L loc (section@(SectionR {}))))
190 = do { (section', fvs) <- rnSection section
191 ; return (HsPar (L loc section'), fvs) }
194 = do { (e', fvs_e) <- rnLExpr e
195 ; return (HsPar e', fvs_e) }
197 rnExpr expr@(SectionL {})
198 = do { addErr (sectionErr expr); rnSection expr }
199 rnExpr expr@(SectionR {})
200 = do { addErr (sectionErr expr); rnSection expr }
202 ---------------------------------------------
203 rnExpr (HsCoreAnn ann expr)
204 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
205 return (HsCoreAnn ann expr', fvs_expr)
207 rnExpr (HsSCC lbl expr)
208 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
209 return (HsSCC lbl expr', fvs_expr)
210 rnExpr (HsTickPragma info expr)
211 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
212 return (HsTickPragma info expr', fvs_expr)
214 rnExpr (HsLam matches)
215 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
216 return (HsLam matches', fvMatch)
218 rnExpr (HsCase expr matches)
219 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
220 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
221 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
223 rnExpr (HsLet binds expr)
224 = rnLocalBindsAndThen binds $ \ binds' ->
225 rnLExpr expr `thenM` \ (expr',fvExpr) ->
226 return (HsLet binds' expr', fvExpr)
228 rnExpr (HsDo do_or_lc stmts body _)
229 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
231 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
233 rnExpr (ExplicitList _ exps)
234 = rnExprs exps `thenM` \ (exps', fvs) ->
235 return (ExplicitList placeHolderType exps', fvs)
237 rnExpr (ExplicitPArr _ exps)
238 = rnExprs exps `thenM` \ (exps', fvs) ->
239 return (ExplicitPArr placeHolderType exps', fvs)
241 rnExpr (ExplicitTuple tup_args boxity)
242 = do { checkTupleSection tup_args
243 ; checkTupSize (length tup_args)
244 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
245 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
247 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
248 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
250 rnExpr (RecordCon con_id _ rbinds)
251 = do { conname <- lookupLocatedOccRn con_id
252 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) 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) <- rnHsRecBinds HsRecFieldUpd 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 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
277 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
278 return (HsType t, fvT)
280 doc = text "In a type argument"
282 rnExpr (ArithSeq _ seq)
283 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
284 return (ArithSeq noPostTcExpr new_seq, fvs)
286 rnExpr (PArrSeq _ seq)
287 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
288 return (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 rnPats ProcExpr [pat] $ \ [pat'] ->
312 rnCmdTop body `thenM` \ (body',fvBody) ->
313 return (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 return (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 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
345 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
348 ----------------------
349 -- See Note [Parsing sections] in Parser.y.pp
350 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
351 rnSection section@(SectionR op expr)
352 = do { (op', fvs_op) <- rnLExpr op
353 ; (expr', fvs_expr) <- rnLExpr expr
354 ; checkSectionPrec InfixR section op' expr'
355 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
357 rnSection section@(SectionL expr op)
358 = do { (expr', fvs_expr) <- rnLExpr expr
359 ; (op', fvs_op) <- rnLExpr op
360 ; checkSectionPrec InfixL section op' expr'
361 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
363 rnSection other = pprPanic "rnSection" (ppr other)
366 %************************************************************************
370 %************************************************************************
373 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
374 -> RnM (HsRecordBinds Name, FreeVars)
375 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
376 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
377 ; (flds', fvss) <- mapAndUnzipM rn_field flds
378 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
379 fvs `plusFV` plusFVs fvss) }
381 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
382 ; return (fld { hsRecFieldArg = arg' }, fvs) }
386 %************************************************************************
390 %************************************************************************
393 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
394 rnCmdArgs [] = return ([], emptyFVs)
396 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
397 rnCmdArgs args `thenM` \ (args',fvArgs) ->
398 return (arg':args', fvArg `plusFV` fvArgs)
400 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
401 rnCmdTop = wrapLocFstM rnCmdTop'
403 rnCmdTop' (HsCmdTop cmd _ _ _)
404 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
406 cmd_names = [arrAName, composeAName, firstAName] ++
407 nameSetToList (methodNamesCmd (unLoc cmd'))
409 -- Generate the rebindable syntax for the monad
410 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
412 return (HsCmdTop cmd' [] placeHolderType cmd_names',
413 fvCmd `plusFV` cmd_fvs)
415 ---------------------------------------------------
416 -- convert OpApp's in a command context to HsArrForm's
418 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
419 convertOpFormsLCmd = fmap convertOpFormsCmd
421 convertOpFormsCmd :: HsCmd id -> HsCmd id
423 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
424 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
425 convertOpFormsCmd (OpApp c1 op fixity c2)
427 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
428 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
430 HsArrForm op (Just fixity) [arg1, arg2]
432 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
434 convertOpFormsCmd (HsCase exp matches)
435 = HsCase exp (convertOpFormsMatch matches)
437 convertOpFormsCmd (HsIf exp c1 c2)
438 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
440 convertOpFormsCmd (HsLet binds cmd)
441 = HsLet binds (convertOpFormsLCmd cmd)
443 convertOpFormsCmd (HsDo ctxt stmts body ty)
444 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
445 (convertOpFormsLCmd body) ty
447 -- Anything else is unchanged. This includes HsArrForm (already done),
448 -- things with no sub-commands, and illegal commands (which will be
449 -- caught by the type checker)
450 convertOpFormsCmd c = c
452 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
453 convertOpFormsStmt (BindStmt pat cmd _ _)
454 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
455 convertOpFormsStmt (ExprStmt cmd _ _)
456 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
457 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
458 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
459 convertOpFormsStmt stmt = stmt
461 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
462 convertOpFormsMatch (MatchGroup ms ty)
463 = MatchGroup (map (fmap convert) ms) ty
464 where convert (Match pat mty grhss)
465 = Match pat mty (convertOpFormsGRHSs grhss)
467 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
468 convertOpFormsGRHSs (GRHSs grhss binds)
469 = GRHSs (map convertOpFormsGRHS grhss) binds
471 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
472 convertOpFormsGRHS = fmap convert
474 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
476 ---------------------------------------------------
477 type CmdNeeds = FreeVars -- Only inhabitants are
478 -- appAName, choiceAName, loopAName
480 -- find what methods the Cmd needs (loop, choice, apply)
481 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
482 methodNamesLCmd = methodNamesCmd . unLoc
484 methodNamesCmd :: HsCmd Name -> CmdNeeds
486 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
488 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
490 methodNamesCmd (HsArrForm {}) = emptyFVs
492 methodNamesCmd (HsPar c) = methodNamesLCmd c
494 methodNamesCmd (HsIf _ c1 c2)
495 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
497 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
499 methodNamesCmd (HsDo _ stmts body _)
500 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
502 methodNamesCmd (HsApp c _) = methodNamesLCmd c
504 methodNamesCmd (HsLam match) = methodNamesMatch match
506 methodNamesCmd (HsCase _ matches)
507 = methodNamesMatch matches `addOneFV` choiceAName
509 methodNamesCmd _ = emptyFVs
510 -- Other forms can't occur in commands, but it's not convenient
511 -- to error here so we just do what's convenient.
512 -- The type checker will complain later
514 ---------------------------------------------------
515 methodNamesMatch :: MatchGroup Name -> FreeVars
516 methodNamesMatch (MatchGroup ms _)
517 = plusFVs (map do_one ms)
519 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
521 -------------------------------------------------
523 methodNamesGRHSs :: GRHSs Name -> FreeVars
524 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
526 -------------------------------------------------
528 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
529 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
531 ---------------------------------------------------
532 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
533 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
535 ---------------------------------------------------
536 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
537 methodNamesLStmt = methodNamesStmt . unLoc
539 methodNamesStmt :: StmtLR Name Name -> FreeVars
540 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
541 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
542 methodNamesStmt (RecStmt stmts _ _ _ _)
543 = methodNamesStmts stmts `addOneFV` loopAName
544 methodNamesStmt (LetStmt _) = emptyFVs
545 methodNamesStmt (ParStmt _) = emptyFVs
546 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
547 methodNamesStmt (GroupStmt _ _) = emptyFVs
548 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
549 -- here so we just do what's convenient
553 %************************************************************************
557 %************************************************************************
560 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
561 rnArithSeq (From expr)
562 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
563 return (From expr', fvExpr)
565 rnArithSeq (FromThen expr1 expr2)
566 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
567 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
568 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
570 rnArithSeq (FromTo expr1 expr2)
571 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
572 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
573 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
575 rnArithSeq (FromThenTo expr1 expr2 expr3)
576 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
577 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
578 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
579 return (FromThenTo expr1' expr2' expr3',
580 plusFVs [fvExpr1, fvExpr2, fvExpr3])
583 %************************************************************************
585 Template Haskell brackets
587 %************************************************************************
590 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
591 rnBracket (VarBr n) = do { name <- lookupOccRn n
592 ; this_mod <- getModule
593 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
594 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
595 ; return () } -- only way that is going to happen
596 ; return (VarBr name, unitFV name) }
598 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
600 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
601 ; return (ExpBr e', fvs) }
603 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
604 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
605 ; return (TypBr t', fvs) }
607 doc = ptext (sLit "In a Template-Haskell quoted type")
608 rnBracket (DecBr group)
609 = do { gbl_env <- getGblEnv
611 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
612 -- The emptyDUs is so that we just collect uses for this
613 -- group alone in the call to rnSrcDecls below
614 ; (tcg_env, group') <- setGblEnv new_gbl_env $
618 -- Discard the tcg_env; it contains only extra info about fixity
619 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
622 %************************************************************************
624 \subsubsection{@Stmt@s: in @do@ expressions}
626 %************************************************************************
629 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
630 -> RnM (thing, FreeVars)
631 -> RnM (([LStmt Name], thing), FreeVars)
633 rnStmts (MDoExpr _) = rnMDoStmts
634 rnStmts ctxt = rnNormalStmts ctxt
636 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
637 -> RnM (thing, FreeVars)
638 -> RnM (([LStmt Name], thing), FreeVars)
639 -- Used for cases *other* than recursive mdo
640 -- Implements nested scopes
642 rnNormalStmts _ [] thing_inside
643 = do { (thing, fvs) <- thing_inside
644 ; return (([],thing), fvs) }
646 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
647 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
648 rnNormalStmts ctxt stmts thing_inside
649 ; return (((L loc stmt' : stmts'), thing), fvs) }
652 rnStmt :: HsStmtContext Name -> Stmt RdrName
653 -> RnM (thing, FreeVars)
654 -> RnM ((Stmt Name, thing), FreeVars)
656 rnStmt _ (ExprStmt expr _ _) thing_inside
657 = do { (expr', fv_expr) <- rnLExpr expr
658 ; (then_op, fvs1) <- lookupSyntaxName thenMName
659 ; (thing, fvs2) <- thing_inside
660 ; return ((ExprStmt expr' then_op placeHolderType, thing),
661 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
663 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
664 = do { (expr', fv_expr) <- rnLExpr expr
665 -- The binders do not scope over the expression
666 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
667 ; (fail_op, fvs2) <- lookupSyntaxName failMName
668 ; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
669 { (thing, fvs3) <- thing_inside
670 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
671 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
672 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
673 -- but it does not matter because the names are unique
675 rnStmt ctxt (LetStmt binds) thing_inside
676 = do { checkLetStmt ctxt binds
677 ; rnLocalBindsAndThen binds $ \binds' -> do
678 { (thing, fvs) <- thing_inside
679 ; return ((LetStmt binds', thing), fvs) } }
681 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
682 = do { checkRecStmt ctxt
683 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
684 { (thing, fvs) <- thing_inside
686 segs_w_fwd_refs = addFwdRefs segs
687 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
688 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
689 fwd_vars = nameSetToList (plusFVs fs)
691 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
692 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
694 rnStmt ctxt (ParStmt segs) thing_inside
695 = do { checkParStmt ctxt
696 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
697 ; return ((ParStmt segs', thing), fvs) }
699 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
700 checkTransformStmt ctxt
702 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
703 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
704 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
705 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
706 (thing, fv_thing) <- thing_inside
708 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
710 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
712 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
713 rnMaybeLExpr (Just expr) = do
714 (expr', fv_expr) <- rnLExpr expr
715 return (Just expr', fv_expr)
717 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
718 checkTransformStmt ctxt
720 -- We must rename the using expression in the context before the transform is begun
721 groupByClauseAction <-
722 case groupByClause of
723 GroupByNothing usingExpr -> do
724 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
725 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
726 GroupBySomething eitherUsingExpr byExpr -> do
727 (eitherUsingExpr', fv_eitherUsingExpr) <-
728 case eitherUsingExpr of
729 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
731 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
732 return (Left usingExpr', fv_usingExpr)
735 (byExpr', fv_byExpr) <- rnLExpr byExpr
736 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
738 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
739 -- perhaps we could refactor this to use rnNormalStmts directly?
740 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
741 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
742 (groupByClause', fv_groupByClause) <- groupByClauseAction
744 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
745 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
747 -- Bind the "thing" inside a context where we have REBOUND everything
748 -- bound by the statements before the group. This is necessary since after
749 -- the grouping the same identifiers actually have different meanings
750 -- i.e. they refer to lists not singletons!
751 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
753 -- We remove entries from the binder map that are not used in the thing_inside.
754 -- We can then use that usage information to ensure that the free variables do
755 -- not contain the things we just bound, but do contain the things we need to
756 -- make those bindings (i.e. the corresponding non-listy variables)
758 -- Note that we also retain those entries which have an old binder in our
759 -- own free variables (the using or by expression). This is because this map
760 -- is reused in the desugarer to create the type to bind from the statements
761 -- that occur before this one. If the binders we need are not in the map, they
762 -- will never get bound into our desugared expression and hence the simplifier
763 -- crashes as we refer to variables that don't exist!
764 let usedBinderMap = filter
765 (\(old_binder, new_binder) ->
766 (new_binder `elemNameSet` fv_thing) ||
767 (old_binder `elemNameSet` fv_groupByClause)) binderMap
768 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
769 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
771 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
773 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
774 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
776 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
778 -> ([Name] -> RnM (thing, FreeVars))
779 -> RnM (([LStmt Name], [Name], thing), FreeVars)
780 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
781 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
782 -- Find the Names that are bound by stmts that
783 -- by assumption we have just renamed
784 local_env <- getLocalRdrEnv
786 stmts_binders = collectLStmtsBinders stmts
787 bndrs = map (expectJust "rnStmt"
788 . lookupLocalRdrEnv local_env
789 . unLoc) stmts_binders
791 -- If shadow, we'll look up (Unqual x) twice, getting
792 -- the second binding both times, which is the
794 unshadowed_bndrs = nub bndrs
796 -- Typecheck the thing inside, passing on all
797 -- the Names bound before it for its information
798 (thing, fvs) <- thing_inside unshadowed_bndrs
800 -- Figure out which of the bound names are used
801 -- after the statements we renamed
802 let used_bndrs = filter (`elemNameSet` fvs) bndrs
803 return ((used_bndrs, thing), fvs)
805 -- Flatten the tuple returned by the above call a bit!
806 return ((stmts', used_bndrs, inner_thing), fvs)
808 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
809 -> RnM (thing, FreeVars)
810 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
811 rnParallelStmts ctxt segs thing_inside = do
812 orig_lcl_env <- getLocalRdrEnv
813 go orig_lcl_env [] segs
815 go orig_lcl_env bndrs [] = do
816 let (bndrs', dups) = removeDups cmpByOcc bndrs
817 inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
820 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
821 return (([], thing), fvs)
823 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
824 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
825 -- Typecheck the thing inside, passing on all
826 -- the Names bound, but separately; revert the envt
827 setLocalRdrEnv orig_lcl_env $ do
828 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
830 let seg' = (stmts', bndrs)
831 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
833 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
834 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
835 <+> quotes (ppr (head vs)))
839 %************************************************************************
841 \subsubsection{mdo expressions}
843 %************************************************************************
846 type FwdRefs = NameSet
847 type Segment stmts = (Defs,
848 Uses, -- May include defs
849 FwdRefs, -- A subset of uses that are
850 -- (a) used before they are bound in this segment, or
851 -- (b) used here, and bound in subsequent segments
852 stmts) -- Either Stmt or [Stmt]
855 ----------------------------------------------------
857 rnMDoStmts :: [LStmt RdrName]
858 -> RnM (thing, FreeVars)
859 -> RnM (([LStmt Name], thing), FreeVars)
860 rnMDoStmts stmts thing_inside
861 = -- Step1: Bring all the binders of the mdo into scope
862 -- (Remember that this also removes the binders from the
863 -- finally-returned free-vars.)
864 -- And rename each individual stmt, making a
865 -- singleton segment. At this stage the FwdRefs field
866 -- isn't finished: it's empty for all except a BindStmt
867 -- for which it's the fwd refs within the bind itself
868 -- (This set may not be empty, because we're in a recursive
870 rn_rec_stmts_and_then stmts $ \ segs -> do {
872 ; (thing, fvs_later) <- thing_inside
875 -- Step 2: Fill in the fwd refs.
876 -- The segments are all singletons, but their fwd-ref
877 -- field mentions all the things used by the segment
878 -- that are bound after their use
879 segs_w_fwd_refs = addFwdRefs segs
881 -- Step 3: Group together the segments to make bigger segments
882 -- Invariant: in the result, no segment uses a variable
883 -- bound in a later segment
884 grouped_segs = glomSegments segs_w_fwd_refs
886 -- Step 4: Turn the segments into Stmts
887 -- Use RecStmt when and only when there are fwd refs
888 -- Also gather up the uses from the end towards the
889 -- start, so we can tell the RecStmt which things are
890 -- used 'after' the RecStmt
891 (stmts', fvs) = segsToStmts grouped_segs fvs_later
893 ; return ((stmts', thing), fvs) }
895 ---------------------------------------------
897 -- wrapper that does both the left- and right-hand sides
898 rn_rec_stmts_and_then :: [LStmt RdrName]
899 -- assumes that the FreeVars returned includes
900 -- the FreeVars of the Segments
901 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
903 rn_rec_stmts_and_then s cont
904 = do { -- (A) Make the mini fixity env for all of the stmts
905 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
908 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
910 -- ...bring them and their fixities into scope
911 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
912 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
914 -- (C) do the right-hand-sides and thing-inside
915 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
916 ; (res, fvs) <- cont segs
917 ; warnUnusedLocalBinds bound_names fvs
918 ; return (res, fvs) }}
920 -- get all the fixity decls in any Let stmt
921 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
922 collectRecStmtsFixities l =
923 foldr (\ s -> \acc -> case s of
924 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
925 foldr (\ sig -> \ acc -> case sig of
926 (L loc (FixSig s)) -> (L loc s) : acc
932 rn_rec_stmt_lhs :: MiniFixityEnv
934 -- rename LHS, and return its FVs
935 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
936 -- so we don't bother to compute it accurately in the other cases
937 -> RnM [(LStmtLR Name RdrName, FreeVars)]
939 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
940 -- this is actually correct
943 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
945 -- should the ctxt be MDo instead?
946 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
947 return [(L loc (BindStmt pat' expr a b),
950 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
951 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
953 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
954 = do binds' <- rnValBindsLHS fix_env binds
955 return [(L loc (LetStmt (HsValBinds binds')),
956 -- Warning: this is bogus; see function invariant
960 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
961 = rn_rec_stmts_lhs fix_env stmts
963 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
964 = pprPanic "rn_rec_stmt" (ppr stmt)
966 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
967 = pprPanic "rn_rec_stmt" (ppr stmt)
969 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
970 = pprPanic "rn_rec_stmt" (ppr stmt)
972 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
973 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
975 rn_rec_stmts_lhs :: MiniFixityEnv
977 -> RnM [(LStmtLR Name RdrName, FreeVars)]
978 rn_rec_stmts_lhs fix_env stmts =
979 let boundNames = collectLStmtsBinders stmts
980 doc = text "In a recursive mdo-expression"
982 -- First do error checking: we need to check for dups here because we
983 -- don't bind all of the variables from the Stmt at once
984 -- with bindLocatedLocals.
985 checkDupRdrNames doc boundNames
986 mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
991 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
992 -- Rename a Stmt that is inside a RecStmt (or mdo)
993 -- Assumes all binders are already in scope
994 -- Turns each stmt into a singleton Stmt
995 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
996 = rnLExpr expr `thenM` \ (expr', fvs) ->
997 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
998 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
999 L loc (ExprStmt expr' then_op placeHolderType))]
1001 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1002 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1003 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1004 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1006 bndrs = mkNameSet (collectPatBinders pat')
1007 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1009 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1010 L loc (BindStmt pat' expr' bind_op fail_op))]
1012 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1013 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1015 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1016 (binds', du_binds) <-
1017 -- fixities and unused are handled above in rn_rec_stmts_and_then
1018 rnValBindsRHS (mkNameSet all_bndrs) binds'
1019 return [(duDefs du_binds, duUses du_binds,
1020 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1022 -- no RecStmt case becuase they get flattened above when doing the LHSes
1023 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1024 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1026 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1027 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1029 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1030 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1032 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1033 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1035 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1036 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1038 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1039 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1040 return (concat segs_s)
1042 ---------------------------------------------
1043 addFwdRefs :: [Segment a] -> [Segment a]
1044 -- So far the segments only have forward refs *within* the Stmt
1045 -- (which happens for bind: x <- ...x...)
1046 -- This function adds the cross-seg fwd ref info
1049 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1051 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1052 = (new_seg : segs, all_defs)
1054 new_seg = (defs, uses, new_fwds, stmts)
1055 all_defs = later_defs `unionNameSets` defs
1056 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1057 -- Add the downstream fwd refs here
1059 ----------------------------------------------------
1060 -- Glomming the singleton segments of an mdo into
1061 -- minimal recursive groups.
1063 -- At first I thought this was just strongly connected components, but
1064 -- there's an important constraint: the order of the stmts must not change.
1067 -- mdo { x <- ...y...
1074 -- Here, the first stmt mention 'y', which is bound in the third.
1075 -- But that means that the innocent second stmt (p <- z) gets caught
1076 -- up in the recursion. And that in turn means that the binding for
1077 -- 'z' has to be included... and so on.
1079 -- Start at the tail { r <- x }
1080 -- Now add the next one { z <- y ; r <- x }
1081 -- Now add one more { q <- x ; z <- y ; r <- x }
1082 -- Now one more... but this time we have to group a bunch into rec
1083 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1084 -- Now one more, which we can add on without a rec
1086 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1088 -- Finally we add the last one; since it mentions y we have to
1089 -- glom it togeher with the first two groups
1090 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1091 -- q <- x ; z <- y } ;
1094 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1096 glomSegments [] = []
1097 glomSegments ((defs,uses,fwds,stmt) : segs)
1098 -- Actually stmts will always be a singleton
1099 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1101 segs' = glomSegments segs
1102 (extras, others) = grab uses segs'
1103 (ds, us, fs, ss) = unzip4 extras
1105 seg_defs = plusFVs ds `plusFV` defs
1106 seg_uses = plusFVs us `plusFV` uses
1107 seg_fwds = plusFVs fs `plusFV` fwds
1108 seg_stmts = stmt : concat ss
1110 grab :: NameSet -- The client
1112 -> ([Segment a], -- Needed by the 'client'
1113 [Segment a]) -- Not needed by the client
1114 -- The result is simply a split of the input
1116 = (reverse yeses, reverse noes)
1118 (noes, yeses) = span not_needed (reverse dus)
1119 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1122 ----------------------------------------------------
1123 segsToStmts :: [Segment [LStmt Name]]
1124 -> FreeVars -- Free vars used 'later'
1125 -> ([LStmt Name], FreeVars)
1127 segsToStmts [] fvs_later = ([], fvs_later)
1128 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1129 = ASSERT( not (null ss) )
1130 (new_stmt : later_stmts, later_uses `plusFV` uses)
1132 (later_stmts, later_uses) = segsToStmts segs fvs_later
1133 new_stmt | non_rec = head ss
1134 | otherwise = L (getLoc (head ss)) $
1135 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1138 non_rec = isSingleton ss && isEmptyNameSet fwds
1139 used_later = defs `intersectNameSet` later_uses
1140 -- The ones needed after the RecStmt
1143 %************************************************************************
1145 \subsubsection{Assertion utils}
1147 %************************************************************************
1150 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1151 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1153 mkAssertErrorExpr :: RnM (HsExpr Name)
1154 -- Return an expression for (assertError "Foo.hs:27")
1156 = getSrcSpanM `thenM` \ sloc ->
1157 return (HsApp (L sloc (HsVar assertErrorName))
1158 (L sloc (srcSpanPrimLit sloc)))
1161 Note [Adding the implicit parameter to 'assert']
1162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1163 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1164 By doing this in the renamer we allow the typechecker to just see the
1165 expanded application and do the right thing. But it's not really
1166 the Right Thing because there's no way to "undo" if you want to see
1167 the original source code. We'll have fix this in due course, when
1168 we care more about being able to reconstruct the exact original
1171 %************************************************************************
1173 \subsubsection{Errors}
1175 %************************************************************************
1179 ----------------------
1180 -- Checking when a particular Stmt is ok
1181 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1182 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1183 checkLetStmt _ctxt _binds = return ()
1184 -- We do not allow implicit-parameter bindings in a parallel
1185 -- list comprehension. I'm not sure what it might mean.
1188 checkRecStmt :: HsStmtContext Name -> RnM ()
1189 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1190 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1191 -- proc x -> do { ...rec... }
1192 -- We don't have enough context to distinguish this situation here
1193 -- so we leave it to the type checker
1194 checkRecStmt ctxt = addErr msg
1196 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1199 checkParStmt :: HsStmtContext Name -> RnM ()
1201 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1202 ; checkErr parallel_list_comp msg }
1204 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1207 checkTransformStmt :: HsStmtContext Name -> RnM ()
1208 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1209 -- desugarer will break when we come to operate on a parallel array
1210 = do { transform_list_comp <- doptM Opt_TransformListComp
1211 ; checkErr transform_list_comp msg }
1213 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1214 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1215 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1216 checkTransformStmt ctxt = addErr msg
1218 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1221 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1222 checkTupleSection args
1223 = do { tuple_section <- doptM Opt_TupleSections
1224 ; checkErr (all tupArgPresent args || tuple_section) msg }
1226 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1229 sectionErr :: HsExpr RdrName -> SDoc
1231 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1232 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1234 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1235 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1237 ; return (EWildPat, emptyFVs) }
1239 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1240 badIpBinds what binds
1241 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)