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 )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
34 import BasicTypes ( FixityDirection(..) )
40 import LoadIface ( loadInterfaceForName )
43 import Util ( isSingleton, snocView )
44 import ListSetOps ( removeDups )
54 thenM :: Monad a => a b -> (b -> a c) -> a c
57 thenM_ :: Monad a => a b -> a c -> a c
61 %************************************************************************
63 \subsubsection{Expressions}
65 %************************************************************************
68 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
69 rnExprs ls = rnExprs' ls emptyUniqSet
71 rnExprs' [] acc = return ([], acc)
72 rnExprs' (expr:exprs) acc
73 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
75 -- Now we do a "seq" on the free vars because typically it's small
76 -- or empty, especially in very long lists of constants
78 acc' = acc `plusFV` fvExpr
80 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
81 return (expr':exprs', fvExprs)
84 Variables. We look up the variable and return the resulting name.
87 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
88 rnLExpr = wrapLocFstM rnExpr
90 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
92 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
93 -- Separated from rnExpr because it's also used
94 -- when renaming infix expressions
95 -- See Note [Adding the implicit parameter to 'assert']
97 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
98 ; if ignore_asserts || not (name `hasKey` assertIdKey)
99 then return (HsVar name, unitFV name)
100 else do { e <- mkAssertErrorExpr
101 ; return (e, unitFV name) } }
104 = do name <- lookupOccRn v
108 = newIPNameRn v `thenM` \ name ->
109 return (HsIPVar name, emptyFVs)
111 rnExpr (HsLit lit@(HsString s))
113 opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
114 ; if opt_OverloadedStrings then
115 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
116 else -- Same as below
118 return (HsLit lit, emptyFVs)
123 return (HsLit lit, emptyFVs)
125 rnExpr (HsOverLit lit)
126 = rnOverLit lit `thenM` \ (lit', fvs) ->
127 return (HsOverLit lit', fvs)
129 rnExpr (HsApp fun arg)
130 = rnLExpr fun `thenM` \ (fun',fvFun) ->
131 rnLExpr arg `thenM` \ (arg',fvArg) ->
132 return (HsApp fun' arg', fvFun `plusFV` fvArg)
134 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
135 = do { (e1', fv_e1) <- rnLExpr e1
136 ; (e2', fv_e2) <- rnLExpr e2
137 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
138 ; (op', fv_op) <- finishHsVar op_name
139 -- NB: op' is usually just a variable, but might be
140 -- an applicatoin (assert "Foo.hs:47")
142 -- When renaming code synthesised from "deriving" declarations
143 -- we used to avoid fixity stuff, but we can't easily tell any
144 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
145 -- should prevent bad things happening.
146 ; fixity <- lookupFixityRn op_name
147 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
148 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
149 rnExpr (OpApp _ other_op _ _)
150 = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
152 , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
155 = rnLExpr e `thenM` \ (e', fv_e) ->
156 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
157 mkNegAppRn e' neg_name `thenM` \ final_e ->
158 return (final_e, fv_e `plusFV` fv_neg)
160 ------------------------------------------
161 -- Template Haskell extensions
162 -- Don't ifdef-GHCI them because we want to fail gracefully
163 -- (not with an rnExpr crash) in a stage-1 compiler.
164 rnExpr e@(HsBracket br_body)
165 = checkTH e "bracket" `thenM_`
166 rnBracket br_body `thenM` \ (body', fvs_e) ->
167 return (HsBracket body', fvs_e)
169 rnExpr (HsSpliceE splice)
170 = rnSplice splice `thenM` \ (splice', fvs) ->
171 return (HsSpliceE splice', fvs)
174 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
176 rnExpr (HsQuasiQuoteE qq)
177 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
181 ---------------------------------------------
183 -- See Note [Parsing sections] in Parser.y.pp
184 rnExpr (HsPar (L loc (section@(SectionL {}))))
185 = do { (section', fvs) <- rnSection section
186 ; return (HsPar (L loc section'), fvs) }
188 rnExpr (HsPar (L loc (section@(SectionR {}))))
189 = do { (section', fvs) <- rnSection section
190 ; return (HsPar (L loc section'), fvs) }
193 = do { (e', fvs_e) <- rnLExpr e
194 ; return (HsPar e', fvs_e) }
196 rnExpr expr@(SectionL {})
197 = do { addErr (sectionErr expr); rnSection expr }
198 rnExpr expr@(SectionR {})
199 = do { addErr (sectionErr expr); rnSection expr }
201 ---------------------------------------------
202 rnExpr (HsCoreAnn ann expr)
203 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
204 return (HsCoreAnn ann expr', fvs_expr)
206 rnExpr (HsSCC lbl expr)
207 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
208 return (HsSCC lbl expr', fvs_expr)
209 rnExpr (HsTickPragma info expr)
210 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
211 return (HsTickPragma info expr', fvs_expr)
213 rnExpr (HsLam matches)
214 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
215 return (HsLam matches', fvMatch)
217 rnExpr (HsCase expr matches)
218 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
219 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
220 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
222 rnExpr (HsLet binds expr)
223 = rnLocalBindsAndThen binds $ \ binds' ->
224 rnLExpr expr `thenM` \ (expr',fvExpr) ->
225 return (HsLet binds' expr', fvExpr)
227 rnExpr (HsDo do_or_lc stmts _)
228 = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
229 ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
231 rnExpr (ExplicitList _ exps)
232 = rnExprs exps `thenM` \ (exps', fvs) ->
233 return (ExplicitList placeHolderType exps', fvs)
235 rnExpr (ExplicitPArr _ exps)
236 = rnExprs exps `thenM` \ (exps', fvs) ->
237 return (ExplicitPArr placeHolderType exps', fvs)
239 rnExpr (ExplicitTuple tup_args boxity)
240 = do { checkTupleSection tup_args
241 ; checkTupSize (length tup_args)
242 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
243 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
245 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
246 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
248 rnExpr (RecordCon con_id _ rbinds)
249 = do { conname <- lookupLocatedOccRn con_id
250 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
251 ; return (RecordCon conname noPostTcExpr rbinds',
252 fvRbinds `addOneFV` unLoc conname) }
254 rnExpr (RecordUpd expr rbinds _ _ _)
255 = do { (expr', fvExpr) <- rnLExpr expr
256 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
257 ; return (RecordUpd expr' rbinds' [] [] [],
258 fvExpr `plusFV` fvRbinds) }
260 rnExpr (ExprWithTySig expr pty)
261 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
262 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
264 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
266 doc = text "In an expression type signature"
268 rnExpr (HsIf _ p b1 b2)
269 = do { (p', fvP) <- rnLExpr p
270 ; (b1', fvB1) <- rnLExpr b1
271 ; (b2', fvB2) <- rnLExpr b2
272 ; (mb_ite, fvITE) <- lookupIfThenElse
273 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
276 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
277 return (HsType t, fvT)
279 doc = text "In a type argument"
281 rnExpr (ArithSeq _ seq)
282 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
283 return (ArithSeq noPostTcExpr new_seq, fvs)
285 rnExpr (PArrSeq _ seq)
286 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
287 return (PArrSeq noPostTcExpr new_seq, fvs)
290 These three are pattern syntax appearing in expressions.
291 Since all the symbols are reservedops we can simply reject them.
292 We return a (bogus) EWildPat in each case.
295 rnExpr e@EWildPat = patSynErr e
296 rnExpr e@(EAsPat {}) = patSynErr e
297 rnExpr e@(EViewPat {}) = patSynErr e
298 rnExpr e@(ELazyPat {}) = patSynErr e
301 %************************************************************************
305 %************************************************************************
308 rnExpr (HsProc pat body)
310 rnPat ProcExpr pat $ \ pat' ->
311 rnCmdTop body `thenM` \ (body',fvBody) ->
312 return (HsProc pat' body', fvBody)
314 rnExpr (HsArrApp arrow arg _ ho rtl)
315 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
316 rnLExpr arg `thenM` \ (arg',fvArg) ->
317 return (HsArrApp arrow' arg' placeHolderType ho rtl,
318 fvArrow `plusFV` fvArg)
320 select_arrow_scope tc = case ho of
321 HsHigherOrderApp -> tc
322 HsFirstOrderApp -> escapeArrowScope tc
325 rnExpr (HsArrForm op (Just _) [arg1, arg2])
326 = escapeArrowScope (rnLExpr op)
327 `thenM` \ (op',fv_op) ->
328 let L _ (HsVar op_name) = op' in
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 f exp c1 c2)
438 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
440 convertOpFormsCmd (HsLet binds cmd)
441 = HsLet binds (convertOpFormsLCmd cmd)
443 convertOpFormsCmd (HsDo ctxt stmts ty)
444 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty
446 -- Anything else is unchanged. This includes HsArrForm (already done),
447 -- things with no sub-commands, and illegal commands (which will be
448 -- caught by the type checker)
449 convertOpFormsCmd c = c
451 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
452 convertOpFormsStmt (BindStmt pat cmd _ _)
453 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
454 convertOpFormsStmt (ExprStmt cmd _ _ _)
455 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
456 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
457 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
458 convertOpFormsStmt stmt = stmt
460 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
461 convertOpFormsMatch (MatchGroup ms ty)
462 = MatchGroup (map (fmap convert) ms) ty
463 where convert (Match pat mty grhss)
464 = Match pat mty (convertOpFormsGRHSs grhss)
466 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
467 convertOpFormsGRHSs (GRHSs grhss binds)
468 = GRHSs (map convertOpFormsGRHS grhss) binds
470 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
471 convertOpFormsGRHS = fmap convert
473 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
475 ---------------------------------------------------
476 type CmdNeeds = FreeVars -- Only inhabitants are
477 -- appAName, choiceAName, loopAName
479 -- find what methods the Cmd needs (loop, choice, apply)
480 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
481 methodNamesLCmd = methodNamesCmd . unLoc
483 methodNamesCmd :: HsCmd Name -> CmdNeeds
485 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
487 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
489 methodNamesCmd (HsArrForm {}) = emptyFVs
491 methodNamesCmd (HsPar c) = methodNamesLCmd c
493 methodNamesCmd (HsIf _ _ c1 c2)
494 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
496 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
497 methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
498 methodNamesCmd (HsApp c _) = methodNamesLCmd c
499 methodNamesCmd (HsLam match) = methodNamesMatch match
501 methodNamesCmd (HsCase _ matches)
502 = methodNamesMatch matches `addOneFV` choiceAName
504 methodNamesCmd _ = emptyFVs
505 -- Other forms can't occur in commands, but it's not convenient
506 -- to error here so we just do what's convenient.
507 -- The type checker will complain later
509 ---------------------------------------------------
510 methodNamesMatch :: MatchGroup Name -> FreeVars
511 methodNamesMatch (MatchGroup ms _)
512 = plusFVs (map do_one ms)
514 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
516 -------------------------------------------------
518 methodNamesGRHSs :: GRHSs Name -> FreeVars
519 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
521 -------------------------------------------------
523 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
524 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
526 ---------------------------------------------------
527 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
528 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
530 ---------------------------------------------------
531 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
532 methodNamesLStmt = methodNamesStmt . unLoc
534 methodNamesStmt :: StmtLR Name Name -> FreeVars
535 methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
536 methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
537 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
538 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
539 methodNamesStmt (LetStmt _) = emptyFVs
540 methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
541 methodNamesStmt (TransformStmt {}) = emptyFVs
542 methodNamesStmt (GroupStmt {}) = emptyFVs
543 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
544 -- here so we just do what's convenient
548 %************************************************************************
552 %************************************************************************
555 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
556 rnArithSeq (From expr)
557 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
558 return (From expr', fvExpr)
560 rnArithSeq (FromThen expr1 expr2)
561 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
562 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
563 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
565 rnArithSeq (FromTo expr1 expr2)
566 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
567 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
568 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
570 rnArithSeq (FromThenTo expr1 expr2 expr3)
571 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
572 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
573 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
574 return (FromThenTo expr1' expr2' expr3',
575 plusFVs [fvExpr1, fvExpr2, fvExpr3])
578 %************************************************************************
580 Template Haskell brackets
582 %************************************************************************
585 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
586 rnBracket (VarBr n) = do { name <- lookupOccRn n
587 ; this_mod <- getModule
588 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
589 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
590 ; return () } -- only way that is going to happen
591 ; return (VarBr name, unitFV name) }
593 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
595 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
596 ; return (ExpBr e', fvs) }
598 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
600 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
601 ; return (TypBr t', fvs) }
603 doc = ptext (sLit "In a Template-Haskell quoted type")
605 rnBracket (DecBrL decls)
606 = do { (group, mb_splice) <- findSplice decls
609 Just (SpliceDecl (L loc _) _, _)
611 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
612 -- Why not? See Section 7.3 of the TH paper.
614 ; gbl_env <- getGblEnv
615 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
616 -- The emptyDUs is so that we just collect uses for this
617 -- group alone in the call to rnSrcDecls below
618 ; (tcg_env, group') <- setGblEnv new_gbl_env $
622 -- Discard the tcg_env; it contains only extra info about fixity
623 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
624 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
626 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
629 %************************************************************************
631 \subsubsection{@Stmt@s: in @do@ expressions}
633 %************************************************************************
636 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
637 -> ([Name] -> RnM (thing, FreeVars))
638 -> RnM (([LStmt Name], thing), FreeVars)
639 -- Variables bound by the Stmts, and mentioned in thing_inside,
640 -- do not appear in the result FreeVars
642 rnStmts ctxt [] thing_inside
643 = do { checkEmptyStmts ctxt
644 ; (thing, fvs) <- thing_inside []
645 ; return (([], thing), fvs) }
647 rnStmts MDoExpr stmts thing_inside -- Deal with mdo
648 = -- Behave like do { rec { ...all but last... }; last }
649 do { ((stmts1, (stmts2, thing)), fvs)
650 <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
651 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
652 ; rnStmt MDoExpr last_stmt' thing_inside }
653 ; return (((stmts1 ++ stmts2), thing), fvs) }
655 Just (all_but_last, last_stmt) = snocView stmts
657 rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
660 do { lstmt' <- checkLastStmt ctxt lstmt
661 ; rnStmt ctxt lstmt' thing_inside }
664 = do { ((stmts1, (stmts2, thing)), fvs)
666 do { checkStmt ctxt lstmt
667 ; rnStmt ctxt lstmt $ \ bndrs1 ->
668 rnStmts ctxt lstmts $ \ bndrs2 ->
669 thing_inside (bndrs1 ++ bndrs2) }
670 ; return (((stmts1 ++ stmts2), thing), fvs) }
672 ----------------------
673 rnStmt :: HsStmtContext Name
675 -> ([Name] -> RnM (thing, FreeVars))
676 -> RnM (([LStmt Name], thing), FreeVars)
677 -- Variables bound by the Stmt, and mentioned in thing_inside,
678 -- do not appear in the result FreeVars
680 rnStmt _ (L loc (LastStmt expr _)) thing_inside
681 = do { (expr', fv_expr) <- rnLExpr expr
682 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
683 ; (thing, fvs3) <- thing_inside []
684 ; return (([L loc (LastStmt expr' ret_op)], thing),
685 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
687 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
688 = do { (expr', fv_expr) <- rnLExpr expr
689 ; (then_op, fvs1) <- lookupSyntaxName thenMName
690 ; (guard_op, fvs2) <- if isMonadCompExpr ctxt
691 then lookupSyntaxName guardMName
692 else return (noSyntaxExpr, emptyFVs)
693 ; (thing, fvs3) <- thing_inside []
694 ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
695 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
697 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
698 = do { (expr', fv_expr) <- rnLExpr expr
699 -- The binders do not scope over the expression
700 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
701 ; (fail_op, fvs2) <- lookupSyntaxName failMName
702 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
703 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
704 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
705 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
706 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
707 -- but it does not matter because the names are unique
709 rnStmt _ (L loc (LetStmt binds)) thing_inside
710 = do { rnLocalBindsAndThen binds $ \binds' -> do
711 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
712 ; return (([L loc (LetStmt binds')], thing), fvs) } }
714 rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
716 -- Step1: Bring all the binders of the mdo into scope
717 -- (Remember that this also removes the binders from the
718 -- finally-returned free-vars.)
719 -- And rename each individual stmt, making a
720 -- singleton segment. At this stage the FwdRefs field
721 -- isn't finished: it's empty for all except a BindStmt
722 -- for which it's the fwd refs within the bind itself
723 -- (This set may not be empty, because we're in a recursive
725 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
727 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
729 ; (thing, fvs_later) <- thing_inside bndrs
730 ; (return_op, fvs1) <- lookupSyntaxName returnMName
731 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
732 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
734 -- Step 2: Fill in the fwd refs.
735 -- The segments are all singletons, but their fwd-ref
736 -- field mentions all the things used by the segment
737 -- that are bound after their use
738 segs_w_fwd_refs = addFwdRefs segs
740 -- Step 3: Group together the segments to make bigger segments
741 -- Invariant: in the result, no segment uses a variable
742 -- bound in a later segment
743 grouped_segs = glomSegments segs_w_fwd_refs
745 -- Step 4: Turn the segments into Stmts
746 -- Use RecStmt when and only when there are fwd refs
747 -- Also gather up the uses from the end towards the
748 -- start, so we can tell the RecStmt which things are
749 -- used 'after' the RecStmt
750 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
751 , recS_mfix_fn = mfix_op
752 , recS_bind_fn = bind_op }
753 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
755 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
757 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
758 = do { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
759 then (,,) <$> lookupSyntaxName mzipName
760 <*> lookupSyntaxName bindMName
761 <*> lookupSyntaxName returnMName
762 else return ( (noSyntaxExpr, emptyFVs)
763 , (noSyntaxExpr, emptyFVs)
764 , (noSyntaxExpr, emptyFVs) )
765 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
766 ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
767 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
769 rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
770 = do { (using', fvs1) <- rnLExpr using
772 ; ((stmts', (by', used_bndrs, thing)), fvs2)
773 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
774 do { (by', fvs_by) <- case by of
775 Nothing -> return (Nothing, emptyFVs)
776 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
777 ; (thing, fvs_thing) <- thing_inside bndrs
778 ; let fvs = fvs_by `plusFV` fvs_thing
779 used_bndrs = filter (`elemNameSet` fvs) bndrs
780 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
781 -- the "thing inside", **or of the by-expression**, as used
782 ; return ((by', used_bndrs, thing), fvs) }
784 -- Lookup `(>>=)` and `fail` for monad comprehensions
785 ; ((return_op, fvs3), (bind_op, fvs4)) <-
786 if isMonadCompExpr ctxt
787 then (,) <$> lookupSyntaxName returnMName
788 <*> lookupSyntaxName bindMName
789 else return ( (noSyntaxExpr, emptyFVs)
790 , (noSyntaxExpr, emptyFVs) )
792 ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
793 fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
795 rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit
796 , grpS_using = using })) thing_inside
797 = do { -- Rename the 'using' expression in the context before the transform is begun
798 let implicit_name | isMonadCompExpr ctxt = groupMName
799 | otherwise = groupWithName
800 ; (using', fvs1) <- if explicit
802 else do { (e,fvs) <- lookupSyntaxName implicit_name
803 ; return (noLoc e, fvs) }
805 -- Rename the stmts and the 'by' expression
806 -- Keep track of the variables mentioned in the 'by' expression
807 ; ((stmts', (by', used_bndrs, thing)), fvs2)
808 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
809 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
810 ; (thing, fvs_thing) <- thing_inside bndrs
811 ; let fvs = fvs_by `plusFV` fvs_thing
812 used_bndrs = filter (`elemNameSet` fvs) bndrs
813 ; return ((by', used_bndrs, thing), fvs) }
815 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
816 ; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
817 if isMonadCompExpr ctxt
818 then (,,) <$> lookupSyntaxName returnMName
819 <*> lookupSyntaxName bindMName
820 <*> lookupSyntaxName fmapName
821 else return ( (noSyntaxExpr, emptyFVs)
822 , (noSyntaxExpr, emptyFVs)
823 , (noSyntaxExpr, emptyFVs) )
825 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
827 bndr_map = used_bndrs `zip` used_bndrs
828 -- See Note [GroupStmt binder map] in HsExpr
830 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
831 ; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map
832 , grpS_by = by', grpS_using = using', grpS_explicit = explicit
833 , grpS_ret = return_op, grpS_bind = bind_op
834 , grpS_fmap = fmap_op })], thing), all_fvs) }
836 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
838 rnParallelStmts :: forall thing. HsStmtContext Name
840 -> ([Name] -> RnM (thing, FreeVars))
841 -> RnM (([ParSeg Name], thing), FreeVars)
842 -- Note [Renaming parallel Stmts]
843 rnParallelStmts ctxt segs thing_inside
844 = do { orig_lcl_env <- getLocalRdrEnv
845 ; rn_segs orig_lcl_env [] segs }
847 rn_segs :: LocalRdrEnv
848 -> [Name] -> [ParSeg RdrName]
849 -> RnM (([ParSeg Name], thing), FreeVars)
850 rn_segs _ bndrs_so_far []
851 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
853 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
854 ; return (([], thing), fvs) }
856 rn_segs env bndrs_so_far ((stmts,_) : segs)
857 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
858 <- rnStmts ctxt stmts $ \ bndrs ->
859 setLocalRdrEnv env $ do
860 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
861 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
862 ; return ((used_bndrs, segs', thing), fvs) }
864 ; let seg' = (stmts', used_bndrs)
865 ; return ((seg':segs', thing), fvs) }
867 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
868 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
869 <+> quotes (ppr (head vs)))
872 Note [Renaming parallel Stmts]
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
874 Renaming parallel statements is painful. Given, say
875 [ a+c | a <- as, bs <- bss
878 (a) In order to report "Defined by not used" about 'bs', we must rename
879 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
881 (b) We want to report that 'a' is illegally bound in both branches
883 (c) The 'bs' in the second group must obviously not be captured by
884 the binding in the first group
886 To satisfy (a) we nest the segements.
887 To satisfy (b) we check for duplicates just before thing_inside.
888 To satisfy (c) we reset the LocalRdrEnv each time.
890 %************************************************************************
892 \subsubsection{mdo expressions}
894 %************************************************************************
897 type FwdRefs = NameSet
898 type Segment stmts = (Defs,
899 Uses, -- May include defs
900 FwdRefs, -- A subset of uses that are
901 -- (a) used before they are bound in this segment, or
902 -- (b) used here, and bound in subsequent segments
903 stmts) -- Either Stmt or [Stmt]
906 -- wrapper that does both the left- and right-hand sides
907 rnRecStmtsAndThen :: [LStmt RdrName]
908 -- assumes that the FreeVars returned includes
909 -- the FreeVars of the Segments
910 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
912 rnRecStmtsAndThen s cont
913 = do { -- (A) Make the mini fixity env for all of the stmts
914 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
917 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
919 -- ...bring them and their fixities into scope
920 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
921 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
922 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
923 ; bindLocalNamesFV bound_names $
924 addLocalFixities fix_env bound_names $ do
926 -- (C) do the right-hand-sides and thing-inside
927 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
928 ; (res, fvs) <- cont segs
929 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
930 ; return (res, fvs) }}
932 -- get all the fixity decls in any Let stmt
933 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
934 collectRecStmtsFixities l =
935 foldr (\ s -> \acc -> case s of
936 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
937 foldr (\ sig -> \ acc -> case sig of
938 (L loc (FixSig s)) -> (L loc s) : acc
944 rn_rec_stmt_lhs :: MiniFixityEnv
946 -- rename LHS, and return its FVs
947 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
948 -- so we don't bother to compute it accurately in the other cases
949 -> RnM [(LStmtLR Name RdrName, FreeVars)]
951 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
952 = return [(L loc (ExprStmt expr a b c), emptyFVs)]
954 rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
955 = return [(L loc (LastStmt expr a), emptyFVs)]
957 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
959 -- should the ctxt be MDo instead?
960 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
961 return [(L loc (BindStmt pat' expr a b),
964 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
965 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
967 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
968 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
969 return [(L loc (LetStmt (HsValBinds binds')),
970 -- Warning: this is bogus; see function invariant
974 -- XXX Do we need to do something with the return and mfix names?
975 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
976 = rn_rec_stmts_lhs fix_env stmts
978 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
979 = pprPanic "rn_rec_stmt" (ppr stmt)
981 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
982 = pprPanic "rn_rec_stmt" (ppr stmt)
984 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
985 = pprPanic "rn_rec_stmt" (ppr stmt)
987 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
988 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
990 rn_rec_stmts_lhs :: MiniFixityEnv
992 -> RnM [(LStmtLR Name RdrName, FreeVars)]
993 rn_rec_stmts_lhs fix_env stmts
994 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
995 ; let boundNames = collectLStmtsBinders (map fst ls)
996 -- First do error checking: we need to check for dups here because we
997 -- don't bind all of the variables from the Stmt at once
998 -- with bindLocatedLocals.
999 ; checkDupNames boundNames
1005 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
1006 -- Rename a Stmt that is inside a RecStmt (or mdo)
1007 -- Assumes all binders are already in scope
1008 -- Turns each stmt into a singleton Stmt
1009 rn_rec_stmt _ (L loc (LastStmt expr _)) _
1010 = do { (expr', fv_expr) <- rnLExpr expr
1011 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1012 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1013 L loc (LastStmt expr' ret_op))] }
1015 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
1016 = rnLExpr expr `thenM` \ (expr', fvs) ->
1017 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1018 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1019 L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
1021 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1022 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1023 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1024 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1026 bndrs = mkNameSet (collectPatBinders pat')
1027 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1029 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1030 L loc (BindStmt pat' expr' bind_op fail_op))]
1032 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1033 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1035 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1036 (binds', du_binds) <-
1037 -- fixities and unused are handled above in rnRecStmtsAndThen
1038 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1039 return [(duDefs du_binds, allUses du_binds,
1040 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1042 -- no RecStmt case becuase they get flattened above when doing the LHSes
1043 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1044 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1046 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1047 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1049 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1050 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1052 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1053 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1055 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1056 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1058 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1059 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1060 return (concat segs_s)
1062 ---------------------------------------------
1063 addFwdRefs :: [Segment a] -> [Segment a]
1064 -- So far the segments only have forward refs *within* the Stmt
1065 -- (which happens for bind: x <- ...x...)
1066 -- This function adds the cross-seg fwd ref info
1069 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1071 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1072 = (new_seg : segs, all_defs)
1074 new_seg = (defs, uses, new_fwds, stmts)
1075 all_defs = later_defs `unionNameSets` defs
1076 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1077 -- Add the downstream fwd refs here
1079 ----------------------------------------------------
1080 -- Glomming the singleton segments of an mdo into
1081 -- minimal recursive groups.
1083 -- At first I thought this was just strongly connected components, but
1084 -- there's an important constraint: the order of the stmts must not change.
1087 -- mdo { x <- ...y...
1094 -- Here, the first stmt mention 'y', which is bound in the third.
1095 -- But that means that the innocent second stmt (p <- z) gets caught
1096 -- up in the recursion. And that in turn means that the binding for
1097 -- 'z' has to be included... and so on.
1099 -- Start at the tail { r <- x }
1100 -- Now add the next one { z <- y ; r <- x }
1101 -- Now add one more { q <- x ; z <- y ; r <- x }
1102 -- Now one more... but this time we have to group a bunch into rec
1103 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1104 -- Now one more, which we can add on without a rec
1106 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1108 -- Finally we add the last one; since it mentions y we have to
1109 -- glom it togeher with the first two groups
1110 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1111 -- q <- x ; z <- y } ;
1114 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1116 glomSegments [] = []
1117 glomSegments ((defs,uses,fwds,stmt) : segs)
1118 -- Actually stmts will always be a singleton
1119 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1121 segs' = glomSegments segs
1122 (extras, others) = grab uses segs'
1123 (ds, us, fs, ss) = unzip4 extras
1125 seg_defs = plusFVs ds `plusFV` defs
1126 seg_uses = plusFVs us `plusFV` uses
1127 seg_fwds = plusFVs fs `plusFV` fwds
1128 seg_stmts = stmt : concat ss
1130 grab :: NameSet -- The client
1132 -> ([Segment a], -- Needed by the 'client'
1133 [Segment a]) -- Not needed by the client
1134 -- The result is simply a split of the input
1136 = (reverse yeses, reverse noes)
1138 (noes, yeses) = span not_needed (reverse dus)
1139 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1142 ----------------------------------------------------
1143 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1144 -> [Segment [LStmt Name]]
1145 -> FreeVars -- Free vars used 'later'
1146 -> ([LStmt Name], FreeVars)
1148 segsToStmts _ [] fvs_later = ([], fvs_later)
1149 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1150 = ASSERT( not (null ss) )
1151 (new_stmt : later_stmts, later_uses `plusFV` uses)
1153 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1154 new_stmt | non_rec = head ss
1155 | otherwise = L (getLoc (head ss)) rec_stmt
1156 rec_stmt = empty_rec_stmt { recS_stmts = ss
1157 , recS_later_ids = nameSetToList used_later
1158 , recS_rec_ids = nameSetToList fwds }
1159 non_rec = isSingleton ss && isEmptyNameSet fwds
1160 used_later = defs `intersectNameSet` later_uses
1161 -- The ones needed after the RecStmt
1164 %************************************************************************
1166 \subsubsection{Assertion utils}
1168 %************************************************************************
1171 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1172 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1174 mkAssertErrorExpr :: RnM (HsExpr Name)
1175 -- Return an expression for (assertError "Foo.hs:27")
1177 = getSrcSpanM `thenM` \ sloc ->
1178 return (HsApp (L sloc (HsVar assertErrorName))
1179 (L sloc (srcSpanPrimLit sloc)))
1182 Note [Adding the implicit parameter to 'assert']
1183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1184 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1185 By doing this in the renamer we allow the typechecker to just see the
1186 expanded application and do the right thing. But it's not really
1187 the Right Thing because there's no way to "undo" if you want to see
1188 the original source code. We'll have fix this in due course, when
1189 we care more about being able to reconstruct the exact original
1192 %************************************************************************
1194 \subsubsection{Errors}
1196 %************************************************************************
1199 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1200 -- We've seen an empty sequence of Stmts... is that ok?
1201 checkEmptyStmts ctxt
1202 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1204 okEmpty :: HsStmtContext a -> Bool
1205 okEmpty (PatGuard {}) = True
1208 emptyErr :: HsStmtContext Name -> SDoc
1209 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1210 emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1211 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1213 ----------------------
1214 checkLastStmt :: HsStmtContext Name
1216 -> RnM (LStmt RdrName)
1217 checkLastStmt ctxt lstmt@(L loc stmt)
1219 ListComp -> check_comp
1220 MonadComp -> check_comp
1221 PArrComp -> check_comp
1226 check_do -- Expect ExprStmt, and change it to LastStmt
1228 ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
1229 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1230 -- LastStmt directly (unlike the parser)
1231 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1232 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1233 <+> ptext (sLit "must be an expression"))
1235 check_comp -- Expect LastStmt; this should be enforced by the parser!
1237 LastStmt {} -> return lstmt
1238 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1240 check_other -- Behave just as if this wasn't the last stmt
1241 = do { checkStmt ctxt lstmt; return lstmt }
1243 -- Checking when a particular Stmt is ok
1244 checkStmt :: HsStmtContext Name
1247 checkStmt ctxt (L _ stmt)
1248 = do { dflags <- getDOpts
1249 ; case okStmt dflags ctxt stmt of
1250 Nothing -> return ()
1251 Just extra -> addErr (msg $$ extra) }
1253 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1254 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1256 pprStmtCat :: Stmt a -> SDoc
1257 pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
1258 pprStmtCat (GroupStmt {}) = ptext (sLit "group")
1259 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1260 pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
1261 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1262 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1263 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1264 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1267 isOK, notOK :: Maybe SDoc
1271 okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name
1272 -> Stmt RdrName -> Maybe SDoc
1273 -- Return Nothing if OK, (Just extra) if not ok
1274 -- The "extra" is an SDoc that is appended to an generic error message
1275 okStmt _ (PatGuard {}) stmt
1282 okStmt dflags (ParStmtCtxt ctxt) stmt
1284 LetStmt (HsIPBinds {}) -> notOK
1285 _ -> okStmt dflags ctxt stmt
1287 okStmt dflags (TransformStmtCtxt ctxt) stmt
1288 = okStmt dflags ctxt stmt
1290 okStmt dflags ctxt stmt
1291 | isDoExpr ctxt = okDoStmt dflags ctxt stmt
1292 | isListCompExpr ctxt = okCompStmt dflags ctxt stmt
1293 | otherwise = pprPanic "okStmt" (pprStmtContext ctxt)
1296 okDoStmt dflags _ stmt
1299 | Opt_DoRec `xopt` dflags -> isOK
1300 | otherwise -> Just (ptext (sLit "Use -XDoRec"))
1308 okCompStmt dflags _ stmt
1314 | Opt_ParallelListComp `xopt` dflags -> isOK
1315 | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1317 | Opt_TransformListComp `xopt` dflags -> isOK
1318 | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1320 | Opt_TransformListComp `xopt` dflags -> isOK
1321 | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1322 LastStmt {} -> notOK
1326 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1327 checkTupleSection args
1328 = do { tuple_section <- xoptM Opt_TupleSections
1329 ; checkErr (all tupArgPresent args || tuple_section) msg }
1331 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1334 sectionErr :: HsExpr RdrName -> SDoc
1336 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1337 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1339 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1340 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1342 ; return (EWildPat, emptyFVs) }
1344 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1345 badIpBinds what binds
1346 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)