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, findSplice )
24 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack, getHetMetLevel )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
34 import BasicTypes ( FixityDirection(..) )
37 import Var ( TyVar, varName )
41 import LoadIface ( loadInterfaceForName )
44 import Util ( isSingleton, snocView )
45 import ListSetOps ( removeDups )
55 thenM :: Monad a => a b -> (b -> a c) -> a c
58 thenM_ :: Monad a => a b -> a c -> a c
62 %************************************************************************
64 \subsubsection{Expressions}
66 %************************************************************************
69 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
70 rnExprs ls = rnExprs' ls emptyUniqSet
72 rnExprs' [] acc = return ([], acc)
73 rnExprs' (expr:exprs) acc
74 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
76 -- Now we do a "seq" on the free vars because typically it's small
77 -- or empty, especially in very long lists of constants
79 acc' = acc `plusFV` fvExpr
81 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
82 return (expr':exprs', fvExprs)
85 Variables. We look up the variable and return the resulting name.
89 -- during the renamer phase we only care about the length of the
90 -- current HetMet level; the actual tyvars don't
91 -- matter, so we use bottoms for them
93 dummyTyVar = error "tried to force RnExpr.dummyTyVar"
95 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
96 rnLExpr = wrapLocFstM rnExpr
98 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
100 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
101 -- Separated from rnExpr because it's also used
102 -- when renaming infix expressions
103 -- See Note [Adding the implicit parameter to 'assert']
105 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
106 ; if ignore_asserts || not (name `hasKey` assertIdKey)
107 then return (HsVar name, unitFV name)
108 else do { e <- mkAssertErrorExpr
109 ; return (e, unitFV name) } }
112 = do name <- lookupOccRn v
116 = newIPNameRn v `thenM` \ name ->
117 return (HsIPVar name, emptyFVs)
119 rnExpr (HsLit lit@(HsString s))
121 opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
122 ; if opt_OverloadedStrings then
123 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
124 else -- Same as below
126 return (HsLit lit, emptyFVs)
131 return (HsLit lit, emptyFVs)
133 rnExpr (HsOverLit lit)
134 = rnOverLit lit `thenM` \ (lit', fvs) ->
135 return (HsOverLit lit', fvs)
137 rnExpr (HsApp fun arg)
138 = rnLExpr fun `thenM` \ (fun',fvFun) ->
139 rnLExpr arg `thenM` \ (arg',fvArg) ->
140 return (HsApp fun' arg', fvFun `plusFV` fvArg)
142 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
143 = do { (e1', fv_e1) <- rnLExpr e1
144 ; (e2', fv_e2) <- rnLExpr e2
145 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
146 ; (op', fv_op) <- finishHsVar op_name
147 -- NB: op' is usually just a variable, but might be
148 -- an applicatoin (assert "Foo.hs:47")
150 -- When renaming code synthesised from "deriving" declarations
151 -- we used to avoid fixity stuff, but we can't easily tell any
152 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
153 -- should prevent bad things happening.
154 ; fixity <- lookupFixityRn op_name
155 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
156 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
157 rnExpr (OpApp _ other_op _ _)
158 = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
160 , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
163 = rnLExpr e `thenM` \ (e', fv_e) ->
164 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
165 mkNegAppRn e' neg_name `thenM` \ final_e ->
166 return (final_e, fv_e `plusFV` fv_neg)
168 rnExpr (HsHetMetBrak c e)
169 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e
170 ; return (HsHetMetBrak c e', fv_e)
172 rnExpr (HsHetMetEsc c t e)
173 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
174 ; return (HsHetMetEsc c t e', fv_e)
176 rnExpr (HsHetMetCSP c e)
177 = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
178 ; return (HsHetMetCSP c e', fv_e)
180 rnExpr (HsKappa matches)
181 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
182 return (HsKappa matches', fvMatch)
183 rnExpr (HsKappaApp fun arg)
184 = rnLExpr fun `thenM` \ (fun',fvFun) ->
185 rnLExpr arg `thenM` \ (arg',fvArg) ->
186 return (HsKappaApp fun' arg', fvFun `plusFV` fvArg)
190 ------------------------------------------
191 -- Template Haskell extensions
192 -- Don't ifdef-GHCI them because we want to fail gracefully
193 -- (not with an rnExpr crash) in a stage-1 compiler.
194 rnExpr e@(HsBracket br_body)
195 = checkTH e "bracket" `thenM_`
196 rnBracket br_body `thenM` \ (body', fvs_e) ->
197 return (HsBracket body', fvs_e)
199 rnExpr (HsSpliceE splice)
200 = rnSplice splice `thenM` \ (splice', fvs) ->
201 return (HsSpliceE splice', fvs)
204 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
206 rnExpr (HsQuasiQuoteE qq)
207 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
211 ---------------------------------------------
213 -- See Note [Parsing sections] in Parser.y.pp
214 rnExpr (HsPar (L loc (section@(SectionL {}))))
215 = do { (section', fvs) <- rnSection section
216 ; return (HsPar (L loc section'), fvs) }
218 rnExpr (HsPar (L loc (section@(SectionR {}))))
219 = do { (section', fvs) <- rnSection section
220 ; return (HsPar (L loc section'), fvs) }
223 = do { (e', fvs_e) <- rnLExpr e
224 ; return (HsPar e', fvs_e) }
226 rnExpr expr@(SectionL {})
227 = do { addErr (sectionErr expr); rnSection expr }
228 rnExpr expr@(SectionR {})
229 = do { addErr (sectionErr expr); rnSection expr }
231 ---------------------------------------------
232 rnExpr (HsCoreAnn ann expr)
233 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
234 return (HsCoreAnn ann expr', fvs_expr)
236 rnExpr (HsSCC lbl expr)
237 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
238 return (HsSCC lbl expr', fvs_expr)
239 rnExpr (HsTickPragma info expr)
240 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
241 return (HsTickPragma info expr', fvs_expr)
243 rnExpr (HsLam matches)
244 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
245 return (HsLam matches', fvMatch)
247 rnExpr (HsCase expr matches)
248 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
249 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
250 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
252 rnExpr (HsLet binds expr)
253 = rnLocalBindsAndThen binds $ \ binds' ->
254 rnLExpr expr `thenM` \ (expr',fvExpr) ->
255 return (HsLet binds' expr', fvExpr)
257 rnExpr (HsDo do_or_lc stmts _)
258 = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
259 ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
261 rnExpr (ExplicitList _ exps)
262 = rnExprs exps `thenM` \ (exps', fvs) ->
263 return (ExplicitList placeHolderType exps', fvs)
265 rnExpr (ExplicitPArr _ exps)
266 = rnExprs exps `thenM` \ (exps', fvs) ->
267 return (ExplicitPArr placeHolderType exps', fvs)
269 rnExpr (ExplicitTuple tup_args boxity)
270 = do { checkTupleSection tup_args
271 ; checkTupSize (length tup_args)
272 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
273 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
275 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
276 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
278 rnExpr (RecordCon con_id _ rbinds)
279 = do { conname <- lookupLocatedOccRn con_id
280 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
281 ; return (RecordCon conname noPostTcExpr rbinds',
282 fvRbinds `addOneFV` unLoc conname) }
284 rnExpr (RecordUpd expr rbinds _ _ _)
285 = do { (expr', fvExpr) <- rnLExpr expr
286 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
287 ; return (RecordUpd expr' rbinds' [] [] [],
288 fvExpr `plusFV` fvRbinds) }
290 rnExpr (ExprWithTySig expr pty)
291 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
292 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
294 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
296 doc = text "In an expression type signature"
298 rnExpr (HsIf _ p b1 b2)
299 = do { (p', fvP) <- rnLExpr p
300 ; (b1', fvB1) <- rnLExpr b1
301 ; (b2', fvB2) <- rnLExpr b2
302 ; (mb_ite, fvITE) <- lookupIfThenElse
303 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
306 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
307 return (HsType t, fvT)
309 doc = text "In a type argument"
311 rnExpr (ArithSeq _ seq)
312 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
313 return (ArithSeq noPostTcExpr new_seq, fvs)
315 rnExpr (PArrSeq _ seq)
316 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
317 return (PArrSeq noPostTcExpr new_seq, fvs)
320 These three are pattern syntax appearing in expressions.
321 Since all the symbols are reservedops we can simply reject them.
322 We return a (bogus) EWildPat in each case.
325 rnExpr e@EWildPat = patSynErr e
326 rnExpr e@(EAsPat {}) = patSynErr e
327 rnExpr e@(EViewPat {}) = patSynErr e
328 rnExpr e@(ELazyPat {}) = patSynErr e
331 %************************************************************************
335 %************************************************************************
338 rnExpr (HsProc pat body)
340 rnPat ProcExpr pat $ \ pat' ->
341 rnCmdTop body `thenM` \ (body',fvBody) ->
342 return (HsProc pat' body', fvBody)
344 rnExpr (HsArrApp arrow arg _ ho rtl)
345 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
346 rnLExpr arg `thenM` \ (arg',fvArg) ->
347 return (HsArrApp arrow' arg' placeHolderType ho rtl,
348 fvArrow `plusFV` fvArg)
350 select_arrow_scope tc = case ho of
351 HsHigherOrderApp -> tc
352 HsFirstOrderApp -> escapeArrowScope tc
355 rnExpr (HsArrForm op (Just _) [arg1, arg2])
356 = escapeArrowScope (rnLExpr op)
357 `thenM` \ (op',fv_op) ->
358 let L _ (HsVar op_name) = op' in
359 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
360 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
364 lookupFixityRn op_name `thenM` \ fixity ->
365 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
368 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
370 rnExpr (HsArrForm op fixity cmds)
371 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
372 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
373 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
375 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
378 ----------------------
379 -- See Note [Parsing sections] in Parser.y.pp
380 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
381 rnSection section@(SectionR op expr)
382 = do { (op', fvs_op) <- rnLExpr op
383 ; (expr', fvs_expr) <- rnLExpr expr
384 ; checkSectionPrec InfixR section op' expr'
385 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
387 rnSection section@(SectionL expr op)
388 = do { (expr', fvs_expr) <- rnLExpr expr
389 ; (op', fvs_op) <- rnLExpr op
390 ; checkSectionPrec InfixL section op' expr'
391 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
393 rnSection other = pprPanic "rnSection" (ppr other)
396 %************************************************************************
400 %************************************************************************
403 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
404 -> RnM (HsRecordBinds Name, FreeVars)
405 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
406 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
407 ; (flds', fvss) <- mapAndUnzipM rn_field flds
408 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
409 fvs `plusFV` plusFVs fvss) }
411 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
412 ; return (fld { hsRecFieldArg = arg' }, fvs) }
416 %************************************************************************
420 %************************************************************************
423 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
424 rnCmdArgs [] = return ([], emptyFVs)
426 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
427 rnCmdArgs args `thenM` \ (args',fvArgs) ->
428 return (arg':args', fvArg `plusFV` fvArgs)
430 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
431 rnCmdTop = wrapLocFstM rnCmdTop'
433 rnCmdTop' (HsCmdTop cmd _ _ _)
434 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
436 cmd_names = [arrAName, composeAName, firstAName] ++
437 nameSetToList (methodNamesCmd (unLoc cmd'))
439 -- Generate the rebindable syntax for the monad
440 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
442 return (HsCmdTop cmd' [] placeHolderType cmd_names',
443 fvCmd `plusFV` cmd_fvs)
445 ---------------------------------------------------
446 -- convert OpApp's in a command context to HsArrForm's
448 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
449 convertOpFormsLCmd = fmap convertOpFormsCmd
451 convertOpFormsCmd :: HsCmd id -> HsCmd id
453 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
454 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
455 convertOpFormsCmd (OpApp c1 op fixity c2)
457 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
458 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
460 HsArrForm op (Just fixity) [arg1, arg2]
462 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
464 convertOpFormsCmd (HsCase exp matches)
465 = HsCase exp (convertOpFormsMatch matches)
467 convertOpFormsCmd (HsIf f exp c1 c2)
468 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
470 convertOpFormsCmd (HsLet binds cmd)
471 = HsLet binds (convertOpFormsLCmd cmd)
473 convertOpFormsCmd (HsDo DoExpr stmts ty)
474 = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
475 -- Mark the HsDo as begin the body of an arrow command
477 -- Anything else is unchanged. This includes HsArrForm (already done),
478 -- things with no sub-commands, and illegal commands (which will be
479 -- caught by the type checker)
480 convertOpFormsCmd c = c
482 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
483 convertOpFormsStmt (BindStmt pat cmd _ _)
484 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
485 convertOpFormsStmt (ExprStmt cmd _ _ _)
486 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
487 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
488 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
489 convertOpFormsStmt stmt = stmt
491 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
492 convertOpFormsMatch (MatchGroup ms ty)
493 = MatchGroup (map (fmap convert) ms) ty
494 where convert (Match pat mty grhss)
495 = Match pat mty (convertOpFormsGRHSs grhss)
497 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
498 convertOpFormsGRHSs (GRHSs grhss binds)
499 = GRHSs (map convertOpFormsGRHS grhss) binds
501 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
502 convertOpFormsGRHS = fmap convert
504 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
506 ---------------------------------------------------
507 type CmdNeeds = FreeVars -- Only inhabitants are
508 -- appAName, choiceAName, loopAName
510 -- find what methods the Cmd needs (loop, choice, apply)
511 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
512 methodNamesLCmd = methodNamesCmd . unLoc
514 methodNamesCmd :: HsCmd Name -> CmdNeeds
516 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
518 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
520 methodNamesCmd (HsArrForm {}) = emptyFVs
522 methodNamesCmd (HsPar c) = methodNamesLCmd c
524 methodNamesCmd (HsIf _ _ c1 c2)
525 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
527 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
528 methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
529 methodNamesCmd (HsApp c _) = methodNamesLCmd c
530 methodNamesCmd (HsLam match) = methodNamesMatch match
532 methodNamesCmd (HsCase _ matches)
533 = methodNamesMatch matches `addOneFV` choiceAName
535 methodNamesCmd _ = emptyFVs
536 -- Other forms can't occur in commands, but it's not convenient
537 -- to error here so we just do what's convenient.
538 -- The type checker will complain later
540 ---------------------------------------------------
541 methodNamesMatch :: MatchGroup Name -> FreeVars
542 methodNamesMatch (MatchGroup ms _)
543 = plusFVs (map do_one ms)
545 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
547 -------------------------------------------------
549 methodNamesGRHSs :: GRHSs Name -> FreeVars
550 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
552 -------------------------------------------------
554 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
555 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
557 ---------------------------------------------------
558 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
559 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
561 ---------------------------------------------------
562 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
563 methodNamesLStmt = methodNamesStmt . unLoc
565 methodNamesStmt :: StmtLR Name Name -> FreeVars
566 methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
567 methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
568 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
569 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
570 methodNamesStmt (LetStmt _) = emptyFVs
571 methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
572 methodNamesStmt (TransStmt {}) = emptyFVs
573 -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
574 -- here so we just do what's convenient
578 %************************************************************************
582 %************************************************************************
585 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
586 rnArithSeq (From expr)
587 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
588 return (From expr', fvExpr)
590 rnArithSeq (FromThen expr1 expr2)
591 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
592 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
593 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
595 rnArithSeq (FromTo expr1 expr2)
596 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
597 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
598 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
600 rnArithSeq (FromThenTo expr1 expr2 expr3)
601 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
602 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
603 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
604 return (FromThenTo expr1' expr2' expr3',
605 plusFVs [fvExpr1, fvExpr2, fvExpr3])
608 %************************************************************************
610 Template Haskell brackets
612 %************************************************************************
615 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
617 = do { name <- lookupOccRn n
618 ; this_mod <- getModule
619 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes
620 do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and
621 ; return () } -- this is the only way that is going
623 ; return (VarBr name, unitFV name) }
625 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
627 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
628 ; return (ExpBr e', fvs) }
630 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
632 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
633 ; return (TypBr t', fvs) }
635 doc = ptext (sLit "In a Template-Haskell quoted type")
637 rnBracket (DecBrL decls)
638 = do { (group, mb_splice) <- findSplice decls
641 Just (SpliceDecl (L loc _) _, _)
643 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
644 -- Why not? See Section 7.3 of the TH paper.
646 ; gbl_env <- getGblEnv
647 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
648 -- The emptyDUs is so that we just collect uses for this
649 -- group alone in the call to rnSrcDecls below
650 ; (tcg_env, group') <- setGblEnv new_gbl_env $
654 -- Discard the tcg_env; it contains only extra info about fixity
655 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
656 ppr (duUses (tcg_dus tcg_env))))
657 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
659 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
662 %************************************************************************
664 \subsubsection{@Stmt@s: in @do@ expressions}
666 %************************************************************************
669 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
670 -> ([Name] -> RnM (thing, FreeVars))
671 -> RnM (([LStmt Name], thing), FreeVars)
672 -- Variables bound by the Stmts, and mentioned in thing_inside,
673 -- do not appear in the result FreeVars
675 rnStmts ctxt [] thing_inside
676 = do { checkEmptyStmts ctxt
677 ; (thing, fvs) <- thing_inside []
678 ; return (([], thing), fvs) }
680 rnStmts MDoExpr stmts thing_inside -- Deal with mdo
681 = -- Behave like do { rec { ...all but last... }; last }
682 do { ((stmts1, (stmts2, thing)), fvs)
683 <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
684 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
685 ; rnStmt MDoExpr last_stmt' thing_inside }
686 ; return (((stmts1 ++ stmts2), thing), fvs) }
688 Just (all_but_last, last_stmt) = snocView stmts
690 rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
693 do { lstmt' <- checkLastStmt ctxt lstmt
694 ; rnStmt ctxt lstmt' thing_inside }
697 = do { ((stmts1, (stmts2, thing)), fvs)
699 do { checkStmt ctxt lstmt
700 ; rnStmt ctxt lstmt $ \ bndrs1 ->
701 rnStmts ctxt lstmts $ \ bndrs2 ->
702 thing_inside (bndrs1 ++ bndrs2) }
703 ; return (((stmts1 ++ stmts2), thing), fvs) }
705 ----------------------
706 rnStmt :: HsStmtContext Name
708 -> ([Name] -> RnM (thing, FreeVars))
709 -> RnM (([LStmt Name], thing), FreeVars)
710 -- Variables bound by the Stmt, and mentioned in thing_inside,
711 -- do not appear in the result FreeVars
713 rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
714 = do { (expr', fv_expr) <- rnLExpr expr
715 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
716 ; (thing, fvs3) <- thing_inside []
717 ; return (([L loc (LastStmt expr' ret_op)], thing),
718 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
720 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
721 = do { (expr', fv_expr) <- rnLExpr expr
722 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
723 ; (guard_op, fvs2) <- if isListCompExpr ctxt
724 then lookupStmtName ctxt guardMName
725 else return (noSyntaxExpr, emptyFVs)
726 -- Only list/parr/monad comprehensions use 'guard'
727 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
728 -- Here "gd" is a guard
729 ; (thing, fvs3) <- thing_inside []
730 ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
731 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
733 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
734 = do { (expr', fv_expr) <- rnLExpr expr
735 -- The binders do not scope over the expression
736 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
737 ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
738 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
739 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
740 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
741 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
742 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
743 -- but it does not matter because the names are unique
745 rnStmt _ (L loc (LetStmt binds)) thing_inside
746 = do { rnLocalBindsAndThen binds $ \binds' -> do
747 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
748 ; return (([L loc (LetStmt binds')], thing), fvs) } }
750 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
752 -- Step1: Bring all the binders of the mdo into scope
753 -- (Remember that this also removes the binders from the
754 -- finally-returned free-vars.)
755 -- And rename each individual stmt, making a
756 -- singleton segment. At this stage the FwdRefs field
757 -- isn't finished: it's empty for all except a BindStmt
758 -- for which it's the fwd refs within the bind itself
759 -- (This set may not be empty, because we're in a recursive
761 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
763 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
765 ; (thing, fvs_later) <- thing_inside bndrs
766 ; (return_op, fvs1) <- lookupStmtName ctxt returnMName
767 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
768 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
770 -- Step 2: Fill in the fwd refs.
771 -- The segments are all singletons, but their fwd-ref
772 -- field mentions all the things used by the segment
773 -- that are bound after their use
774 segs_w_fwd_refs = addFwdRefs segs
776 -- Step 3: Group together the segments to make bigger segments
777 -- Invariant: in the result, no segment uses a variable
778 -- bound in a later segment
779 grouped_segs = glomSegments segs_w_fwd_refs
781 -- Step 4: Turn the segments into Stmts
782 -- Use RecStmt when and only when there are fwd refs
783 -- Also gather up the uses from the end towards the
784 -- start, so we can tell the RecStmt which things are
785 -- used 'after' the RecStmt
786 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
787 , recS_mfix_fn = mfix_op
788 , recS_bind_fn = bind_op }
789 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
791 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
793 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
794 = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
795 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
796 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
797 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
798 ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
799 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
801 rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
802 , trS_using = using })) thing_inside
803 = do { -- Rename the 'using' expression in the context before the transform is begun
804 (using', fvs1) <- case form of
805 GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
806 ; return (noLoc e, fvs) }
809 -- Rename the stmts and the 'by' expression
810 -- Keep track of the variables mentioned in the 'by' expression
811 ; ((stmts', (by', used_bndrs, thing)), fvs2)
812 <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
813 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
814 ; (thing, fvs_thing) <- thing_inside bndrs
815 ; let fvs = fvs_by `plusFV` fvs_thing
816 used_bndrs = filter (`elemNameSet` fvs) bndrs
817 -- The paper (Fig 5) has a bug here; we must treat any free varaible
818 -- of the "thing inside", **or of the by-expression**, as used
819 ; return ((by', used_bndrs, thing), fvs) }
821 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
822 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
823 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
824 ; (fmap_op, fvs5) <- case form of
825 ThenForm -> return (noSyntaxExpr, emptyFVs)
826 _ -> lookupStmtName ctxt fmapName
828 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
829 `plusFV` fvs4 `plusFV` fvs5
830 bndr_map = used_bndrs `zip` used_bndrs
831 -- See Note [TransStmt binder map] in HsExpr
833 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
834 ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
835 , trS_by = by', trS_using = using', trS_form = form
836 , trS_ret = return_op, trS_bind = bind_op
837 , trS_fmap = fmap_op })], thing), all_fvs) }
839 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
841 rnParallelStmts :: forall thing. HsStmtContext Name
843 -> ([Name] -> RnM (thing, FreeVars))
844 -> RnM (([ParSeg Name], thing), FreeVars)
845 -- Note [Renaming parallel Stmts]
846 rnParallelStmts ctxt segs thing_inside
847 = do { orig_lcl_env <- getLocalRdrEnv
848 ; rn_segs orig_lcl_env [] segs }
850 rn_segs :: LocalRdrEnv
851 -> [Name] -> [ParSeg RdrName]
852 -> RnM (([ParSeg Name], thing), FreeVars)
853 rn_segs _ bndrs_so_far []
854 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
856 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
857 ; return (([], thing), fvs) }
859 rn_segs env bndrs_so_far ((stmts,_) : segs)
860 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
861 <- rnStmts ctxt stmts $ \ bndrs ->
862 setLocalRdrEnv env $ do
863 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
864 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
865 ; return ((used_bndrs, segs', thing), fvs) }
867 ; let seg' = (stmts', used_bndrs)
868 ; return ((seg':segs', thing), fvs) }
870 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
871 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
872 <+> quotes (ppr (head vs)))
874 lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
875 -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
876 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
877 lookupStmtName ctxt n
879 ListComp -> not_rebindable
880 PArrComp -> not_rebindable
881 ArrowExpr -> not_rebindable
882 PatGuard {} -> not_rebindable
885 MDoExpr -> rebindable
886 MonadComp -> rebindable
887 GhciStmt -> rebindable -- I suppose?
889 ParStmtCtxt c -> lookupStmtName c n -- Look inside to
890 TransStmtCtxt c -> lookupStmtName c n -- the parent context
892 rebindable = lookupSyntaxName n
893 not_rebindable = return (HsVar n, emptyFVs)
896 Note [Renaming parallel Stmts]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 Renaming parallel statements is painful. Given, say
899 [ a+c | a <- as, bs <- bss
902 (a) In order to report "Defined by not used" about 'bs', we must rename
903 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
905 (b) We want to report that 'a' is illegally bound in both branches
907 (c) The 'bs' in the second group must obviously not be captured by
908 the binding in the first group
910 To satisfy (a) we nest the segements.
911 To satisfy (b) we check for duplicates just before thing_inside.
912 To satisfy (c) we reset the LocalRdrEnv each time.
914 %************************************************************************
916 \subsubsection{mdo expressions}
918 %************************************************************************
921 type FwdRefs = NameSet
922 type Segment stmts = (Defs,
923 Uses, -- May include defs
924 FwdRefs, -- A subset of uses that are
925 -- (a) used before they are bound in this segment, or
926 -- (b) used here, and bound in subsequent segments
927 stmts) -- Either Stmt or [Stmt]
930 -- wrapper that does both the left- and right-hand sides
931 rnRecStmtsAndThen :: [LStmt RdrName]
932 -- assumes that the FreeVars returned includes
933 -- the FreeVars of the Segments
934 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
936 rnRecStmtsAndThen s cont
937 = do { -- (A) Make the mini fixity env for all of the stmts
938 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
941 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
943 -- ...bring them and their fixities into scope
944 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
945 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
946 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
947 ; bindLocalNamesFV bound_names $
948 addLocalFixities fix_env bound_names $ do
950 -- (C) do the right-hand-sides and thing-inside
951 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
952 ; (res, fvs) <- cont segs
953 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
954 ; return (res, fvs) }}
956 -- get all the fixity decls in any Let stmt
957 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
958 collectRecStmtsFixities l =
959 foldr (\ s -> \acc -> case s of
960 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
961 foldr (\ sig -> \ acc -> case sig of
962 (L loc (FixSig s)) -> (L loc s) : acc
968 rn_rec_stmt_lhs :: MiniFixityEnv
970 -- rename LHS, and return its FVs
971 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
972 -- so we don't bother to compute it accurately in the other cases
973 -> RnM [(LStmtLR Name RdrName, FreeVars)]
975 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
976 = return [(L loc (ExprStmt expr a b c), emptyFVs)]
978 rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
979 = return [(L loc (LastStmt expr a), emptyFVs)]
981 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
983 -- should the ctxt be MDo instead?
984 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
985 return [(L loc (BindStmt pat' expr a b),
988 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
989 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
991 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
992 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
993 return [(L loc (LetStmt (HsValBinds binds')),
994 -- Warning: this is bogus; see function invariant
998 -- XXX Do we need to do something with the return and mfix names?
999 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1000 = rn_rec_stmts_lhs fix_env stmts
1002 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
1003 = pprPanic "rn_rec_stmt" (ppr stmt)
1005 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1006 = pprPanic "rn_rec_stmt" (ppr stmt)
1008 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
1009 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1011 rn_rec_stmts_lhs :: MiniFixityEnv
1013 -> RnM [(LStmtLR Name RdrName, FreeVars)]
1014 rn_rec_stmts_lhs fix_env stmts
1015 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1016 ; let boundNames = collectLStmtsBinders (map fst ls)
1017 -- First do error checking: we need to check for dups here because we
1018 -- don't bind all of the variables from the Stmt at once
1019 -- with bindLocatedLocals.
1020 ; checkDupNames boundNames
1026 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
1027 -- Rename a Stmt that is inside a RecStmt (or mdo)
1028 -- Assumes all binders are already in scope
1029 -- Turns each stmt into a singleton Stmt
1030 rn_rec_stmt _ (L loc (LastStmt expr _)) _
1031 = do { (expr', fv_expr) <- rnLExpr expr
1032 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1033 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1034 L loc (LastStmt expr' ret_op))] }
1036 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
1037 = rnLExpr expr `thenM` \ (expr', fvs) ->
1038 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1039 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1040 L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
1042 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1043 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1044 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1045 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1047 bndrs = mkNameSet (collectPatBinders pat')
1048 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1050 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1051 L loc (BindStmt pat' expr' bind_op fail_op))]
1053 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1054 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1056 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1057 (binds', du_binds) <-
1058 -- fixities and unused are handled above in rnRecStmtsAndThen
1059 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1060 return [(duDefs du_binds, allUses du_binds,
1061 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1063 -- no RecStmt case becuase they get flattened above when doing the LHSes
1064 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1065 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1067 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1068 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1070 rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
1071 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1073 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1074 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1076 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1077 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1078 return (concat segs_s)
1080 ---------------------------------------------
1081 addFwdRefs :: [Segment a] -> [Segment a]
1082 -- So far the segments only have forward refs *within* the Stmt
1083 -- (which happens for bind: x <- ...x...)
1084 -- This function adds the cross-seg fwd ref info
1087 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1089 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1090 = (new_seg : segs, all_defs)
1092 new_seg = (defs, uses, new_fwds, stmts)
1093 all_defs = later_defs `unionNameSets` defs
1094 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1095 -- Add the downstream fwd refs here
1097 ----------------------------------------------------
1098 -- Glomming the singleton segments of an mdo into
1099 -- minimal recursive groups.
1101 -- At first I thought this was just strongly connected components, but
1102 -- there's an important constraint: the order of the stmts must not change.
1105 -- mdo { x <- ...y...
1112 -- Here, the first stmt mention 'y', which is bound in the third.
1113 -- But that means that the innocent second stmt (p <- z) gets caught
1114 -- up in the recursion. And that in turn means that the binding for
1115 -- 'z' has to be included... and so on.
1117 -- Start at the tail { r <- x }
1118 -- Now add the next one { z <- y ; r <- x }
1119 -- Now add one more { q <- x ; z <- y ; r <- x }
1120 -- Now one more... but this time we have to group a bunch into rec
1121 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1122 -- Now one more, which we can add on without a rec
1124 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1126 -- Finally we add the last one; since it mentions y we have to
1127 -- glom it togeher with the first two groups
1128 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1129 -- q <- x ; z <- y } ;
1132 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1134 glomSegments [] = []
1135 glomSegments ((defs,uses,fwds,stmt) : segs)
1136 -- Actually stmts will always be a singleton
1137 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1139 segs' = glomSegments segs
1140 (extras, others) = grab uses segs'
1141 (ds, us, fs, ss) = unzip4 extras
1143 seg_defs = plusFVs ds `plusFV` defs
1144 seg_uses = plusFVs us `plusFV` uses
1145 seg_fwds = plusFVs fs `plusFV` fwds
1146 seg_stmts = stmt : concat ss
1148 grab :: NameSet -- The client
1150 -> ([Segment a], -- Needed by the 'client'
1151 [Segment a]) -- Not needed by the client
1152 -- The result is simply a split of the input
1154 = (reverse yeses, reverse noes)
1156 (noes, yeses) = span not_needed (reverse dus)
1157 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1160 ----------------------------------------------------
1161 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1162 -> [Segment [LStmt Name]]
1163 -> FreeVars -- Free vars used 'later'
1164 -> ([LStmt Name], FreeVars)
1166 segsToStmts _ [] fvs_later = ([], fvs_later)
1167 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1168 = ASSERT( not (null ss) )
1169 (new_stmt : later_stmts, later_uses `plusFV` uses)
1171 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1172 new_stmt | non_rec = head ss
1173 | otherwise = L (getLoc (head ss)) rec_stmt
1174 rec_stmt = empty_rec_stmt { recS_stmts = ss
1175 , recS_later_ids = nameSetToList used_later
1176 , recS_rec_ids = nameSetToList fwds }
1177 non_rec = isSingleton ss && isEmptyNameSet fwds
1178 used_later = defs `intersectNameSet` later_uses
1179 -- The ones needed after the RecStmt
1182 %************************************************************************
1184 \subsubsection{Assertion utils}
1186 %************************************************************************
1189 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1190 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1192 mkAssertErrorExpr :: RnM (HsExpr Name)
1193 -- Return an expression for (assertError "Foo.hs:27")
1195 = getSrcSpanM `thenM` \ sloc ->
1196 return (HsApp (L sloc (HsVar assertErrorName))
1197 (L sloc (srcSpanPrimLit sloc)))
1200 Note [Adding the implicit parameter to 'assert']
1201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1202 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1203 By doing this in the renamer we allow the typechecker to just see the
1204 expanded application and do the right thing. But it's not really
1205 the Right Thing because there's no way to "undo" if you want to see
1206 the original source code. We'll have fix this in due course, when
1207 we care more about being able to reconstruct the exact original
1210 %************************************************************************
1212 \subsubsection{Errors}
1214 %************************************************************************
1217 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1218 -- We've seen an empty sequence of Stmts... is that ok?
1219 checkEmptyStmts ctxt
1220 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1222 okEmpty :: HsStmtContext a -> Bool
1223 okEmpty (PatGuard {}) = True
1226 emptyErr :: HsStmtContext Name -> SDoc
1227 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1228 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1229 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1231 ----------------------
1232 checkLastStmt :: HsStmtContext Name
1234 -> RnM (LStmt RdrName)
1235 checkLastStmt ctxt lstmt@(L loc stmt)
1237 ListComp -> check_comp
1238 MonadComp -> check_comp
1239 PArrComp -> check_comp
1240 ArrowExpr -> check_do
1245 check_do -- Expect ExprStmt, and change it to LastStmt
1247 ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
1248 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1249 -- LastStmt directly (unlike the parser)
1250 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1251 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1252 <+> ptext (sLit "must be an expression"))
1254 check_comp -- Expect LastStmt; this should be enforced by the parser!
1256 LastStmt {} -> return lstmt
1257 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1259 check_other -- Behave just as if this wasn't the last stmt
1260 = do { checkStmt ctxt lstmt; return lstmt }
1262 -- Checking when a particular Stmt is ok
1263 checkStmt :: HsStmtContext Name
1266 checkStmt ctxt (L _ stmt)
1267 = do { dflags <- getDOpts
1268 ; case okStmt dflags ctxt stmt of
1269 Nothing -> return ()
1270 Just extra -> addErr (msg $$ extra) }
1272 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1273 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1275 pprStmtCat :: Stmt a -> SDoc
1276 pprStmtCat (TransStmt {}) = ptext (sLit "transform")
1277 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1278 pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
1279 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1280 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1281 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1282 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1285 isOK, notOK :: Maybe SDoc
1289 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1290 :: DynFlags -> HsStmtContext Name
1291 -> Stmt RdrName -> Maybe SDoc
1292 -- Return Nothing if OK, (Just extra) if not ok
1293 -- The "extra" is an SDoc that is appended to an generic error message
1295 okStmt dflags ctxt stmt
1297 PatGuard {} -> okPatGuardStmt stmt
1298 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1299 DoExpr -> okDoStmt dflags ctxt stmt
1300 MDoExpr -> okDoStmt dflags ctxt stmt
1301 ArrowExpr -> okDoStmt dflags ctxt stmt
1302 GhciStmt -> okDoStmt dflags ctxt stmt
1303 ListComp -> okCompStmt dflags ctxt stmt
1304 MonadComp -> okCompStmt dflags ctxt stmt
1305 PArrComp -> okPArrStmt dflags ctxt stmt
1306 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1309 okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
1318 okParStmt dflags ctxt stmt
1320 LetStmt (HsIPBinds {}) -> notOK
1321 _ -> okStmt dflags ctxt stmt
1324 okDoStmt dflags ctxt stmt
1327 | Opt_DoRec `xopt` dflags -> isOK
1328 | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec'
1329 | otherwise -> Just (ptext (sLit "Use -XDoRec"))
1336 okCompStmt dflags _ stmt
1342 | Opt_ParallelListComp `xopt` dflags -> isOK
1343 | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1345 | Opt_TransformListComp `xopt` dflags -> isOK
1346 | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1348 LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
1351 okPArrStmt dflags _ stmt
1357 | Opt_ParallelListComp `xopt` dflags -> isOK
1358 | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1359 TransStmt {} -> notOK
1361 LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
1364 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1365 checkTupleSection args
1366 = do { tuple_section <- xoptM Opt_TupleSections
1367 ; checkErr (all tupArgPresent args || tuple_section) msg }
1369 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1372 sectionErr :: HsExpr RdrName -> SDoc
1374 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1375 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1377 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1378 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1380 ; return (EWildPat, emptyFVs) }
1382 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1383 badIpBinds what binds
1384 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)