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 )
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 body _ _)
228 = do { ((stmts', body'), fvs1) <- rnStmts do_or_lc stmts $ \ _ ->
230 ; (return_op, fvs2) <-
231 if isMonadCompExpr do_or_lc
232 then lookupSyntaxName returnMName
233 else return (noSyntaxExpr, emptyFVs)
235 ; return ( HsDo do_or_lc stmts' body' return_op placeHolderType
236 , fvs1 `plusFV` fvs2 ) }
238 rnExpr (ExplicitList _ exps)
239 = rnExprs exps `thenM` \ (exps', fvs) ->
240 return (ExplicitList placeHolderType exps', fvs)
242 rnExpr (ExplicitPArr _ exps)
243 = rnExprs exps `thenM` \ (exps', fvs) ->
244 return (ExplicitPArr placeHolderType exps', fvs)
246 rnExpr (ExplicitTuple tup_args boxity)
247 = do { checkTupleSection tup_args
248 ; checkTupSize (length tup_args)
249 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
250 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
252 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
253 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
255 rnExpr (RecordCon con_id _ rbinds)
256 = do { conname <- lookupLocatedOccRn con_id
257 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
258 ; return (RecordCon conname noPostTcExpr rbinds',
259 fvRbinds `addOneFV` unLoc conname) }
261 rnExpr (RecordUpd expr rbinds _ _ _)
262 = do { (expr', fvExpr) <- rnLExpr expr
263 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
264 ; return (RecordUpd expr' rbinds' [] [] [],
265 fvExpr `plusFV` fvRbinds) }
267 rnExpr (ExprWithTySig expr pty)
268 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
269 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
271 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
273 doc = text "In an expression type signature"
275 rnExpr (HsIf _ p b1 b2)
276 = do { (p', fvP) <- rnLExpr p
277 ; (b1', fvB1) <- rnLExpr b1
278 ; (b2', fvB2) <- rnLExpr b2
279 ; (mb_ite, fvITE) <- lookupIfThenElse
280 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
283 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
284 return (HsType t, fvT)
286 doc = text "In a type argument"
288 rnExpr (ArithSeq _ seq)
289 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
290 return (ArithSeq noPostTcExpr new_seq, fvs)
292 rnExpr (PArrSeq _ seq)
293 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
294 return (PArrSeq noPostTcExpr new_seq, fvs)
297 These three are pattern syntax appearing in expressions.
298 Since all the symbols are reservedops we can simply reject them.
299 We return a (bogus) EWildPat in each case.
302 rnExpr e@EWildPat = patSynErr e
303 rnExpr e@(EAsPat {}) = patSynErr e
304 rnExpr e@(EViewPat {}) = patSynErr e
305 rnExpr e@(ELazyPat {}) = patSynErr e
308 %************************************************************************
312 %************************************************************************
315 rnExpr (HsProc pat body)
317 rnPat ProcExpr pat $ \ pat' ->
318 rnCmdTop body `thenM` \ (body',fvBody) ->
319 return (HsProc pat' body', fvBody)
321 rnExpr (HsArrApp arrow arg _ ho rtl)
322 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
323 rnLExpr arg `thenM` \ (arg',fvArg) ->
324 return (HsArrApp arrow' arg' placeHolderType ho rtl,
325 fvArrow `plusFV` fvArg)
327 select_arrow_scope tc = case ho of
328 HsHigherOrderApp -> tc
329 HsFirstOrderApp -> escapeArrowScope tc
332 rnExpr (HsArrForm op (Just _) [arg1, arg2])
333 = escapeArrowScope (rnLExpr op)
334 `thenM` \ (op',fv_op) ->
335 let L _ (HsVar op_name) = op' in
336 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
337 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
341 lookupFixityRn op_name `thenM` \ fixity ->
342 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
345 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
347 rnExpr (HsArrForm op fixity cmds)
348 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
349 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
350 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
352 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
355 ----------------------
356 -- See Note [Parsing sections] in Parser.y.pp
357 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
358 rnSection section@(SectionR op expr)
359 = do { (op', fvs_op) <- rnLExpr op
360 ; (expr', fvs_expr) <- rnLExpr expr
361 ; checkSectionPrec InfixR section op' expr'
362 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
364 rnSection section@(SectionL expr op)
365 = do { (expr', fvs_expr) <- rnLExpr expr
366 ; (op', fvs_op) <- rnLExpr op
367 ; checkSectionPrec InfixL section op' expr'
368 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
370 rnSection other = pprPanic "rnSection" (ppr other)
373 %************************************************************************
377 %************************************************************************
380 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
381 -> RnM (HsRecordBinds Name, FreeVars)
382 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
383 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
384 ; (flds', fvss) <- mapAndUnzipM rn_field flds
385 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
386 fvs `plusFV` plusFVs fvss) }
388 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
389 ; return (fld { hsRecFieldArg = arg' }, fvs) }
393 %************************************************************************
397 %************************************************************************
400 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
401 rnCmdArgs [] = return ([], emptyFVs)
403 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
404 rnCmdArgs args `thenM` \ (args',fvArgs) ->
405 return (arg':args', fvArg `plusFV` fvArgs)
407 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
408 rnCmdTop = wrapLocFstM rnCmdTop'
410 rnCmdTop' (HsCmdTop cmd _ _ _)
411 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
413 cmd_names = [arrAName, composeAName, firstAName] ++
414 nameSetToList (methodNamesCmd (unLoc cmd'))
416 -- Generate the rebindable syntax for the monad
417 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
419 return (HsCmdTop cmd' [] placeHolderType cmd_names',
420 fvCmd `plusFV` cmd_fvs)
422 ---------------------------------------------------
423 -- convert OpApp's in a command context to HsArrForm's
425 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
426 convertOpFormsLCmd = fmap convertOpFormsCmd
428 convertOpFormsCmd :: HsCmd id -> HsCmd id
430 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
431 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
432 convertOpFormsCmd (OpApp c1 op fixity c2)
434 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
435 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
437 HsArrForm op (Just fixity) [arg1, arg2]
439 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
441 convertOpFormsCmd (HsCase exp matches)
442 = HsCase exp (convertOpFormsMatch matches)
444 convertOpFormsCmd (HsIf f exp c1 c2)
445 = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
447 convertOpFormsCmd (HsLet binds cmd)
448 = HsLet binds (convertOpFormsLCmd cmd)
450 convertOpFormsCmd (HsDo ctxt stmts body return_op ty)
451 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
452 (convertOpFormsLCmd body)
453 (convertOpFormsCmd return_op) ty
455 -- Anything else is unchanged. This includes HsArrForm (already done),
456 -- things with no sub-commands, and illegal commands (which will be
457 -- caught by the type checker)
458 convertOpFormsCmd c = c
460 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
461 convertOpFormsStmt (BindStmt pat cmd _ _)
462 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
463 convertOpFormsStmt (ExprStmt cmd _ _ _)
464 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
465 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
466 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
467 convertOpFormsStmt stmt = stmt
469 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
470 convertOpFormsMatch (MatchGroup ms ty)
471 = MatchGroup (map (fmap convert) ms) ty
472 where convert (Match pat mty grhss)
473 = Match pat mty (convertOpFormsGRHSs grhss)
475 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
476 convertOpFormsGRHSs (GRHSs grhss binds)
477 = GRHSs (map convertOpFormsGRHS grhss) binds
479 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
480 convertOpFormsGRHS = fmap convert
482 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
484 ---------------------------------------------------
485 type CmdNeeds = FreeVars -- Only inhabitants are
486 -- appAName, choiceAName, loopAName
488 -- find what methods the Cmd needs (loop, choice, apply)
489 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
490 methodNamesLCmd = methodNamesCmd . unLoc
492 methodNamesCmd :: HsCmd Name -> CmdNeeds
494 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
496 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
498 methodNamesCmd (HsArrForm {}) = emptyFVs
500 methodNamesCmd (HsPar c) = methodNamesLCmd c
502 methodNamesCmd (HsIf _ _ c1 c2)
503 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
505 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
507 methodNamesCmd (HsDo _ stmts body _ _)
508 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
510 methodNamesCmd (HsApp c _) = methodNamesLCmd c
512 methodNamesCmd (HsLam match) = methodNamesMatch match
514 methodNamesCmd (HsCase _ matches)
515 = methodNamesMatch matches `addOneFV` choiceAName
517 methodNamesCmd _ = emptyFVs
518 -- Other forms can't occur in commands, but it's not convenient
519 -- to error here so we just do what's convenient.
520 -- The type checker will complain later
522 ---------------------------------------------------
523 methodNamesMatch :: MatchGroup Name -> FreeVars
524 methodNamesMatch (MatchGroup ms _)
525 = plusFVs (map do_one ms)
527 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
529 -------------------------------------------------
531 methodNamesGRHSs :: GRHSs Name -> FreeVars
532 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
534 -------------------------------------------------
536 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
537 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
539 ---------------------------------------------------
540 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
541 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
543 ---------------------------------------------------
544 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
545 methodNamesLStmt = methodNamesStmt . unLoc
547 methodNamesStmt :: StmtLR Name Name -> FreeVars
548 methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
549 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
550 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
551 methodNamesStmt (LetStmt _) = emptyFVs
552 methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
553 methodNamesStmt (TransformStmt {}) = emptyFVs
554 methodNamesStmt (GroupStmt {}) = emptyFVs
555 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
556 -- here so we just do what's convenient
560 %************************************************************************
564 %************************************************************************
567 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
568 rnArithSeq (From expr)
569 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
570 return (From expr', fvExpr)
572 rnArithSeq (FromThen expr1 expr2)
573 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
574 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
575 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
577 rnArithSeq (FromTo expr1 expr2)
578 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
579 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
580 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
582 rnArithSeq (FromThenTo expr1 expr2 expr3)
583 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
584 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
585 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
586 return (FromThenTo expr1' expr2' expr3',
587 plusFVs [fvExpr1, fvExpr2, fvExpr3])
590 %************************************************************************
592 Template Haskell brackets
594 %************************************************************************
597 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
598 rnBracket (VarBr n) = do { name <- lookupOccRn n
599 ; this_mod <- getModule
600 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
601 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
602 ; return () } -- only way that is going to happen
603 ; return (VarBr name, unitFV name) }
605 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
607 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
608 ; return (ExpBr e', fvs) }
610 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
612 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
613 ; return (TypBr t', fvs) }
615 doc = ptext (sLit "In a Template-Haskell quoted type")
617 rnBracket (DecBrL decls)
618 = do { (group, mb_splice) <- findSplice decls
621 Just (SpliceDecl (L loc _) _, _)
623 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
624 -- Why not? See Section 7.3 of the TH paper.
626 ; gbl_env <- getGblEnv
627 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
628 -- The emptyDUs is so that we just collect uses for this
629 -- group alone in the call to rnSrcDecls below
630 ; (tcg_env, group') <- setGblEnv new_gbl_env $
634 -- Discard the tcg_env; it contains only extra info about fixity
635 ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
636 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
638 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
641 %************************************************************************
643 \subsubsection{@Stmt@s: in @do@ expressions}
645 %************************************************************************
648 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
649 -> ([Name] -> RnM (thing, FreeVars))
650 -> RnM (([LStmt Name], thing), FreeVars)
651 -- Variables bound by the Stmts, and mentioned in thing_inside,
652 -- do not appear in the result FreeVars
654 -- Renaming a single RecStmt can give a sequence of smaller Stmts
656 rnStmts _ [] thing_inside
657 = do { (res, fvs) <- thing_inside []
658 ; return (([], res), fvs) }
660 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
661 = do { ((stmts1, (stmts2, thing)), fvs)
663 rnStmt ctxt stmt $ \ bndrs1 ->
664 rnStmts ctxt stmts $ \ bndrs2 ->
665 thing_inside (bndrs1 ++ bndrs2)
666 ; return (((stmts1 ++ stmts2), thing), fvs) }
669 rnStmt :: HsStmtContext Name -> LStmt RdrName
670 -> ([Name] -> RnM (thing, FreeVars))
671 -> RnM (([LStmt Name], thing), FreeVars)
672 -- Variables bound by the Stmt, and mentioned in thing_inside,
673 -- do not appear in the result FreeVars
675 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
676 = do { (expr', fv_expr) <- rnLExpr expr
677 ; (then_op, fvs1) <- lookupSyntaxName thenMName
678 ; (guard_op, fvs2) <- if isMonadCompExpr ctxt
679 then lookupSyntaxName guardMName
680 else return (noSyntaxExpr, emptyFVs)
681 ; (thing, fvs3) <- thing_inside []
682 ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
683 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
685 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
686 = do { (expr', fv_expr) <- rnLExpr expr
687 -- The binders do not scope over the expression
688 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
689 ; (fail_op, fvs2) <- lookupSyntaxName failMName
690 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
691 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
692 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
693 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
694 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
695 -- but it does not matter because the names are unique
697 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
698 = do { checkLetStmt ctxt binds
699 ; rnLocalBindsAndThen binds $ \binds' -> do
700 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
701 ; return (([L loc (LetStmt binds')], thing), fvs) } }
703 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
704 = do { checkRecStmt ctxt
706 -- Step1: Bring all the binders of the mdo into scope
707 -- (Remember that this also removes the binders from the
708 -- finally-returned free-vars.)
709 -- And rename each individual stmt, making a
710 -- singleton segment. At this stage the FwdRefs field
711 -- isn't finished: it's empty for all except a BindStmt
712 -- for which it's the fwd refs within the bind itself
713 -- (This set may not be empty, because we're in a recursive
715 ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
717 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
719 ; (thing, fvs_later) <- thing_inside bndrs
720 ; (return_op, fvs1) <- lookupSyntaxName returnMName
721 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
722 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
724 -- Step 2: Fill in the fwd refs.
725 -- The segments are all singletons, but their fwd-ref
726 -- field mentions all the things used by the segment
727 -- that are bound after their use
728 segs_w_fwd_refs = addFwdRefs segs
730 -- Step 3: Group together the segments to make bigger segments
731 -- Invariant: in the result, no segment uses a variable
732 -- bound in a later segment
733 grouped_segs = glomSegments segs_w_fwd_refs
735 -- Step 4: Turn the segments into Stmts
736 -- Use RecStmt when and only when there are fwd refs
737 -- Also gather up the uses from the end towards the
738 -- start, so we can tell the RecStmt which things are
739 -- used 'after' the RecStmt
740 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
741 , recS_mfix_fn = mfix_op
742 , recS_bind_fn = bind_op }
743 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
745 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
747 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
748 = do { checkParStmt ctxt
749 ; ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
750 then (,,) <$> lookupSyntaxName mzipName
751 <*> lookupSyntaxName bindMName
752 <*> lookupSyntaxName returnMName
753 else return ( (noSyntaxExpr, emptyFVs)
754 , (noSyntaxExpr, emptyFVs)
755 , (noSyntaxExpr, emptyFVs) )
756 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
757 ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
758 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
760 rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
761 = do { checkTransformStmt ctxt
763 ; (using', fvs1) <- rnLExpr using
765 ; ((stmts', (by', used_bndrs, thing)), fvs2)
766 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
767 do { (by', fvs_by) <- case by of
768 Nothing -> return (Nothing, emptyFVs)
769 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
770 ; (thing, fvs_thing) <- thing_inside bndrs
771 ; let fvs = fvs_by `plusFV` fvs_thing
772 used_bndrs = filter (`elemNameSet` fvs) bndrs
773 -- The paper (Fig 5) has a bug here; we must treat any free varaible of
774 -- the "thing inside", **or of the by-expression**, as used
775 ; return ((by', used_bndrs, thing), fvs) }
777 -- Lookup `(>>=)` and `fail` for monad comprehensions
778 ; ((return_op, fvs3), (bind_op, fvs4)) <-
779 if isMonadCompExpr ctxt
780 then (,) <$> lookupSyntaxName returnMName
781 <*> lookupSyntaxName bindMName
782 else return ( (noSyntaxExpr, emptyFVs)
783 , (noSyntaxExpr, emptyFVs) )
785 ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
786 fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
788 rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside
789 = do { checkTransformStmt ctxt
791 -- Rename the 'using' expression in the context before the transform is begun
792 ; (using', fvs1) <- case using of
793 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
795 | isMonadCompExpr ctxt ->
796 do { (e', fvs) <- lookupSyntaxName groupMName
797 ; return (Right e', fvs) }
799 do { (e', fvs) <- lookupSyntaxName groupWithName
800 ; return (Right e', fvs) }
802 -- Rename the stmts and the 'by' expression
803 -- Keep track of the variables mentioned in the 'by' expression
804 ; ((stmts', (by', used_bndrs, thing)), fvs2)
805 <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
806 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
807 ; (thing, fvs_thing) <- thing_inside bndrs
808 ; let fvs = fvs_by `plusFV` fvs_thing
809 used_bndrs = filter (`elemNameSet` fvs) bndrs
810 ; return ((by', used_bndrs, thing), fvs) }
812 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
813 ; ((return_op, fvs3), (bind_op, fvs4), (liftM_op, fvs5)) <-
814 if isMonadCompExpr ctxt
815 then (,,) <$> lookupSyntaxName returnMName
816 <*> lookupSyntaxName bindMName
817 <*> lookupSyntaxName liftMName
818 else return ( (noSyntaxExpr, emptyFVs)
819 , (noSyntaxExpr, emptyFVs)
820 , (noSyntaxExpr, emptyFVs) )
822 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
824 bndr_map = used_bndrs `zip` used_bndrs
825 -- See Note [GroupStmt binder map] in HsExpr
827 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
828 ; return (([L loc (GroupStmt stmts' bndr_map by' using' return_op bind_op liftM_op)], thing), all_fvs) }
830 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
832 rnParallelStmts :: forall thing. HsStmtContext Name
834 -> ([Name] -> RnM (thing, FreeVars))
835 -> RnM (([ParSeg Name], thing), FreeVars)
836 -- Note [Renaming parallel Stmts]
837 rnParallelStmts ctxt segs thing_inside
838 = do { orig_lcl_env <- getLocalRdrEnv
839 ; rn_segs orig_lcl_env [] segs }
841 rn_segs :: LocalRdrEnv
842 -> [Name] -> [ParSeg RdrName]
843 -> RnM (([ParSeg Name], thing), FreeVars)
844 rn_segs _ bndrs_so_far []
845 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
847 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
848 ; return (([], thing), fvs) }
850 rn_segs env bndrs_so_far ((stmts,_) : segs)
851 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
852 <- rnStmts ctxt stmts $ \ bndrs ->
853 setLocalRdrEnv env $ do
854 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
855 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
856 ; return ((used_bndrs, segs', thing), fvs) }
858 ; let seg' = (stmts', used_bndrs)
859 ; return ((seg':segs', thing), fvs) }
861 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
862 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
863 <+> quotes (ppr (head vs)))
866 Note [Renaming parallel Stmts]
867 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
868 Renaming parallel statements is painful. Given, say
869 [ a+c | a <- as, bs <- bss
872 (a) In order to report "Defined by not used" about 'bs', we must rename
873 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
875 (b) We want to report that 'a' is illegally bound in both branches
877 (c) The 'bs' in the second group must obviously not be captured by
878 the binding in the first group
880 To satisfy (a) we nest the segements.
881 To satisfy (b) we check for duplicates just before thing_inside.
882 To satisfy (c) we reset the LocalRdrEnv each time.
884 %************************************************************************
886 \subsubsection{mdo expressions}
888 %************************************************************************
891 type FwdRefs = NameSet
892 type Segment stmts = (Defs,
893 Uses, -- May include defs
894 FwdRefs, -- A subset of uses that are
895 -- (a) used before they are bound in this segment, or
896 -- (b) used here, and bound in subsequent segments
897 stmts) -- Either Stmt or [Stmt]
900 -- wrapper that does both the left- and right-hand sides
901 rnRecStmtsAndThen :: [LStmt RdrName]
902 -- assumes that the FreeVars returned includes
903 -- the FreeVars of the Segments
904 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
906 rnRecStmtsAndThen s cont
907 = do { -- (A) Make the mini fixity env for all of the stmts
908 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
911 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
913 -- ...bring them and their fixities into scope
914 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
915 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
916 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
917 ; bindLocalNamesFV bound_names $
918 addLocalFixities fix_env bound_names $ do
920 -- (C) do the right-hand-sides and thing-inside
921 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
922 ; (res, fvs) <- cont segs
923 ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
924 ; return (res, fvs) }}
926 -- get all the fixity decls in any Let stmt
927 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
928 collectRecStmtsFixities l =
929 foldr (\ s -> \acc -> case s of
930 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
931 foldr (\ sig -> \ acc -> case sig of
932 (L loc (FixSig s)) -> (L loc s) : acc
938 rn_rec_stmt_lhs :: MiniFixityEnv
940 -- rename LHS, and return its FVs
941 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
942 -- so we don't bother to compute it accurately in the other cases
943 -> RnM [(LStmtLR Name RdrName, FreeVars)]
945 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) = return [(L loc (ExprStmt expr a b c),
946 -- this is actually correct
949 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
951 -- should the ctxt be MDo instead?
952 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
953 return [(L loc (BindStmt pat' expr a b),
956 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
957 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
959 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
960 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
961 return [(L loc (LetStmt (HsValBinds binds')),
962 -- Warning: this is bogus; see function invariant
966 -- XXX Do we need to do something with the return and mfix names?
967 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
968 = rn_rec_stmts_lhs fix_env stmts
970 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
971 = pprPanic "rn_rec_stmt" (ppr stmt)
973 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
974 = pprPanic "rn_rec_stmt" (ppr stmt)
976 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
977 = pprPanic "rn_rec_stmt" (ppr stmt)
979 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
980 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
982 rn_rec_stmts_lhs :: MiniFixityEnv
984 -> RnM [(LStmtLR Name RdrName, FreeVars)]
985 rn_rec_stmts_lhs fix_env stmts
986 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
987 ; let boundNames = collectLStmtsBinders (map fst ls)
988 -- First do error checking: we need to check for dups here because we
989 -- don't bind all of the variables from the Stmt at once
990 -- with bindLocatedLocals.
991 ; checkDupNames boundNames
997 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
998 -- Rename a Stmt that is inside a RecStmt (or mdo)
999 -- Assumes all binders are already in scope
1000 -- Turns each stmt into a singleton Stmt
1001 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
1002 = rnLExpr expr `thenM` \ (expr', fvs) ->
1003 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
1004 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1005 L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
1007 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1008 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
1009 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
1010 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
1012 bndrs = mkNameSet (collectPatBinders pat')
1013 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1015 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1016 L loc (BindStmt pat' expr' bind_op fail_op))]
1018 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1019 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1021 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1022 (binds', du_binds) <-
1023 -- fixities and unused are handled above in rnRecStmtsAndThen
1024 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1025 return [(duDefs du_binds, allUses du_binds,
1026 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1028 -- no RecStmt case becuase they get flattened above when doing the LHSes
1029 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1030 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1032 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1033 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1035 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1036 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1038 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1039 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1041 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1042 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1044 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1045 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1046 return (concat segs_s)
1048 ---------------------------------------------
1049 addFwdRefs :: [Segment a] -> [Segment a]
1050 -- So far the segments only have forward refs *within* the Stmt
1051 -- (which happens for bind: x <- ...x...)
1052 -- This function adds the cross-seg fwd ref info
1055 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1057 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1058 = (new_seg : segs, all_defs)
1060 new_seg = (defs, uses, new_fwds, stmts)
1061 all_defs = later_defs `unionNameSets` defs
1062 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1063 -- Add the downstream fwd refs here
1065 ----------------------------------------------------
1066 -- Glomming the singleton segments of an mdo into
1067 -- minimal recursive groups.
1069 -- At first I thought this was just strongly connected components, but
1070 -- there's an important constraint: the order of the stmts must not change.
1073 -- mdo { x <- ...y...
1080 -- Here, the first stmt mention 'y', which is bound in the third.
1081 -- But that means that the innocent second stmt (p <- z) gets caught
1082 -- up in the recursion. And that in turn means that the binding for
1083 -- 'z' has to be included... and so on.
1085 -- Start at the tail { r <- x }
1086 -- Now add the next one { z <- y ; r <- x }
1087 -- Now add one more { q <- x ; z <- y ; r <- x }
1088 -- Now one more... but this time we have to group a bunch into rec
1089 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1090 -- Now one more, which we can add on without a rec
1092 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1094 -- Finally we add the last one; since it mentions y we have to
1095 -- glom it togeher with the first two groups
1096 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1097 -- q <- x ; z <- y } ;
1100 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1102 glomSegments [] = []
1103 glomSegments ((defs,uses,fwds,stmt) : segs)
1104 -- Actually stmts will always be a singleton
1105 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1107 segs' = glomSegments segs
1108 (extras, others) = grab uses segs'
1109 (ds, us, fs, ss) = unzip4 extras
1111 seg_defs = plusFVs ds `plusFV` defs
1112 seg_uses = plusFVs us `plusFV` uses
1113 seg_fwds = plusFVs fs `plusFV` fwds
1114 seg_stmts = stmt : concat ss
1116 grab :: NameSet -- The client
1118 -> ([Segment a], -- Needed by the 'client'
1119 [Segment a]) -- Not needed by the client
1120 -- The result is simply a split of the input
1122 = (reverse yeses, reverse noes)
1124 (noes, yeses) = span not_needed (reverse dus)
1125 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1128 ----------------------------------------------------
1129 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1130 -> [Segment [LStmt Name]]
1131 -> FreeVars -- Free vars used 'later'
1132 -> ([LStmt Name], FreeVars)
1134 segsToStmts _ [] fvs_later = ([], fvs_later)
1135 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1136 = ASSERT( not (null ss) )
1137 (new_stmt : later_stmts, later_uses `plusFV` uses)
1139 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1140 new_stmt | non_rec = head ss
1141 | otherwise = L (getLoc (head ss)) rec_stmt
1142 rec_stmt = empty_rec_stmt { recS_stmts = ss
1143 , recS_later_ids = nameSetToList used_later
1144 , recS_rec_ids = nameSetToList fwds }
1145 non_rec = isSingleton ss && isEmptyNameSet fwds
1146 used_later = defs `intersectNameSet` later_uses
1147 -- The ones needed after the RecStmt
1150 %************************************************************************
1152 \subsubsection{Assertion utils}
1154 %************************************************************************
1157 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1158 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1160 mkAssertErrorExpr :: RnM (HsExpr Name)
1161 -- Return an expression for (assertError "Foo.hs:27")
1163 = getSrcSpanM `thenM` \ sloc ->
1164 return (HsApp (L sloc (HsVar assertErrorName))
1165 (L sloc (srcSpanPrimLit sloc)))
1168 Note [Adding the implicit parameter to 'assert']
1169 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1170 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1171 By doing this in the renamer we allow the typechecker to just see the
1172 expanded application and do the right thing. But it's not really
1173 the Right Thing because there's no way to "undo" if you want to see
1174 the original source code. We'll have fix this in due course, when
1175 we care more about being able to reconstruct the exact original
1178 %************************************************************************
1180 \subsubsection{Errors}
1182 %************************************************************************
1186 ----------------------
1187 -- Checking when a particular Stmt is ok
1188 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1189 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1190 checkLetStmt _ctxt _binds = return ()
1191 -- We do not allow implicit-parameter bindings in a parallel
1192 -- list comprehension. I'm not sure what it might mean.
1195 checkRecStmt :: HsStmtContext Name -> RnM ()
1196 checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
1197 checkRecStmt DoExpr = return () -- and in 'do'
1198 checkRecStmt ctxt = addErr msg
1200 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1203 checkParStmt :: HsStmtContext Name -> RnM ()
1205 = do { monad_comp <- xoptM Opt_MonadComprehensions
1206 ; unless monad_comp $ do
1207 { parallel_list_comp <- xoptM Opt_ParallelListComp
1208 ; checkErr parallel_list_comp msg }
1211 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp or -XMonadComprehensions")
1214 checkTransformStmt :: HsStmtContext Name -> RnM ()
1215 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1216 -- desugarer will break when we come to operate on a parallel array
1217 = do { transform_list_comp <- xoptM Opt_TransformListComp
1218 ; checkErr transform_list_comp msg }
1220 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp or -XMonadComprehensions")
1221 checkTransformStmt MonadComp -- Monad comprehensions are always fine, since the
1222 -- MonadComprehensions flag will already be turned on
1224 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1225 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1226 checkTransformStmt ctxt = addErr msg
1228 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1231 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1232 checkTupleSection args
1233 = do { tuple_section <- xoptM Opt_TupleSections
1234 ; checkErr (all tupArgPresent args || tuple_section) msg }
1236 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1239 sectionErr :: HsExpr RdrName -> SDoc
1241 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1242 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1244 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1245 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1247 ; return (EWildPat, emptyFVs) }
1249 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1250 badIpBinds what binds
1251 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)