2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnLExpr, rnExpr, rnStmts
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
23 import RnSource ( rnSrcDecls )
24 import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
25 rnMatchGroup, makeMiniFixityEnv)
28 import TcEnv ( thRnBrack )
30 import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
31 mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
33 import DynFlags ( DynFlag(..) )
34 import BasicTypes ( FixityDirection(..) )
35 import PrelNames ( hasKey, assertIdKey, assertErrorName,
36 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
37 negateName, thenMName, bindMName, failMName, groupWithName )
42 import LoadIface ( loadInterfaceForName )
45 import Util ( isSingleton )
46 import ListSetOps ( removeDups )
47 import Maybes ( expectJust )
56 thenM :: Monad a => a b -> (b -> a c) -> a c
59 thenM_ :: Monad a => a b -> a c -> a c
63 %************************************************************************
65 \subsubsection{Expressions}
67 %************************************************************************
70 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
71 rnExprs ls = rnExprs' ls emptyUniqSet
73 rnExprs' [] acc = return ([], acc)
74 rnExprs' (expr:exprs) acc
75 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
77 -- Now we do a "seq" on the free vars because typically it's small
78 -- or empty, especially in very long lists of constants
80 acc' = acc `plusFV` fvExpr
82 acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
83 return (expr':exprs', fvExprs)
86 Variables. We look up the variable and return the resulting name.
89 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
90 rnLExpr = wrapLocFstM rnExpr
92 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
94 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
95 -- Separated from rnExpr because it's also used
96 -- when renaming infix expressions
97 -- See Note [Adding the implicit parameter to 'assert']
99 = do { ignore_asserts <- doptM Opt_IgnoreAsserts
100 ; if ignore_asserts || not (name `hasKey` assertIdKey)
101 then return (HsVar name, unitFV name)
102 else do { e <- mkAssertErrorExpr
103 ; return (e, unitFV name) } }
106 = do name <- lookupOccRn v
110 = newIPNameRn v `thenM` \ name ->
111 return (HsIPVar name, emptyFVs)
113 rnExpr (HsLit lit@(HsString s))
115 opt_OverloadedStrings <- doptM Opt_OverloadedStrings
116 ; if opt_OverloadedStrings then
117 rnExpr (HsOverLit (mkHsIsString s placeHolderType))
118 else -- Same as below
120 return (HsLit lit, emptyFVs)
125 return (HsLit lit, emptyFVs)
127 rnExpr (HsOverLit lit)
128 = rnOverLit lit `thenM` \ (lit', fvs) ->
129 return (HsOverLit lit', fvs)
131 rnExpr (HsApp fun arg)
132 = rnLExpr fun `thenM` \ (fun',fvFun) ->
133 rnLExpr arg `thenM` \ (arg',fvArg) ->
134 return (HsApp fun' arg', fvFun `plusFV` fvArg)
136 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
137 = do { (e1', fv_e1) <- rnLExpr e1
138 ; (e2', fv_e2) <- rnLExpr e2
139 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
140 ; (op', fv_op) <- finishHsVar op_name
141 -- NB: op' is usually just a variable, but might be
142 -- an applicatoin (assert "Foo.hs:47")
144 -- When renaming code synthesised from "deriving" declarations
145 -- we used to avoid fixity stuff, but we can't easily tell any
146 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
147 -- should prevent bad things happening.
148 ; fixity <- lookupFixityRn op_name
149 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
150 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
153 = rnLExpr e `thenM` \ (e', fv_e) ->
154 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
155 mkNegAppRn e' neg_name `thenM` \ final_e ->
156 return (final_e, fv_e `plusFV` fv_neg)
158 ------------------------------------------
159 -- Template Haskell extensions
160 -- Don't ifdef-GHCI them because we want to fail gracefully
161 -- (not with an rnExpr crash) in a stage-1 compiler.
162 rnExpr e@(HsBracket br_body)
163 = checkTH e "bracket" `thenM_`
164 rnBracket br_body `thenM` \ (body', fvs_e) ->
165 return (HsBracket body', fvs_e)
167 rnExpr (HsSpliceE splice)
168 = rnSplice splice `thenM` \ (splice', fvs) ->
169 return (HsSpliceE splice', fvs)
172 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
174 rnExpr (HsQuasiQuoteE qq)
175 = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) ->
176 runQuasiQuoteExpr qq' `thenM` \ (L _ expr') ->
177 rnExpr expr' `thenM` \ (expr'', fvs_expr) ->
178 return (expr'', fvs_qq `plusFV` fvs_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'), fvs) <- rnStmts do_or_lc stmts $
230 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
232 rnExpr (ExplicitList _ exps)
233 = rnExprs exps `thenM` \ (exps', fvs) ->
234 return (ExplicitList placeHolderType exps', fvs)
236 rnExpr (ExplicitPArr _ exps)
237 = rnExprs exps `thenM` \ (exps', fvs) ->
238 return (ExplicitPArr placeHolderType exps', fvs)
240 rnExpr (ExplicitTuple tup_args boxity)
241 = do { checkTupleSection tup_args
242 ; checkTupSize (length tup_args)
243 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
244 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
246 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
247 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
249 rnExpr (RecordCon con_id _ rbinds)
250 = do { conname <- lookupLocatedOccRn con_id
251 ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
252 ; return (RecordCon conname noPostTcExpr rbinds',
253 fvRbinds `addOneFV` unLoc conname) }
255 rnExpr (RecordUpd expr rbinds _ _ _)
256 = do { (expr', fvExpr) <- rnLExpr expr
257 ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
258 ; return (RecordUpd expr' rbinds' [] [] [],
259 fvExpr `plusFV` fvRbinds) }
261 rnExpr (ExprWithTySig expr pty)
262 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
263 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
265 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
267 doc = text "In an expression type signature"
269 rnExpr (HsIf p b1 b2)
270 = rnLExpr p `thenM` \ (p', fvP) ->
271 rnLExpr b1 `thenM` \ (b1', fvB1) ->
272 rnLExpr b2 `thenM` \ (b2', fvB2) ->
273 return (HsIf p' b1' b2', plusFVs [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 rnPatsAndThen_LocalRightwards 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'@(L _ (HsVar op_name)),fv_op) ->
328 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
329 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
333 lookupFixityRn op_name `thenM` \ fixity ->
334 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
337 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
339 rnExpr (HsArrForm op fixity cmds)
340 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
341 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
342 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
344 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
347 ----------------------
348 -- See Note [Parsing sections] in Parser.y.pp
349 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
350 rnSection section@(SectionR op expr)
351 = do { (op', fvs_op) <- rnLExpr op
352 ; (expr', fvs_expr) <- rnLExpr expr
353 ; checkSectionPrec InfixR section op' expr'
354 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
356 rnSection section@(SectionL expr op)
357 = do { (expr', fvs_expr) <- rnLExpr expr
358 ; (op', fvs_op) <- rnLExpr op
359 ; checkSectionPrec InfixL section op' expr'
360 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
362 rnSection other = pprPanic "rnSection" (ppr other)
365 %************************************************************************
369 %************************************************************************
372 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
373 rnCmdArgs [] = return ([], emptyFVs)
375 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
376 rnCmdArgs args `thenM` \ (args',fvArgs) ->
377 return (arg':args', fvArg `plusFV` fvArgs)
379 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
380 rnCmdTop = wrapLocFstM rnCmdTop'
382 rnCmdTop' (HsCmdTop cmd _ _ _)
383 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
385 cmd_names = [arrAName, composeAName, firstAName] ++
386 nameSetToList (methodNamesCmd (unLoc cmd'))
388 -- Generate the rebindable syntax for the monad
389 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
391 return (HsCmdTop cmd' [] placeHolderType cmd_names',
392 fvCmd `plusFV` cmd_fvs)
394 ---------------------------------------------------
395 -- convert OpApp's in a command context to HsArrForm's
397 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
398 convertOpFormsLCmd = fmap convertOpFormsCmd
400 convertOpFormsCmd :: HsCmd id -> HsCmd id
402 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
403 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
404 convertOpFormsCmd (OpApp c1 op fixity c2)
406 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
407 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
409 HsArrForm op (Just fixity) [arg1, arg2]
411 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
413 convertOpFormsCmd (HsCase exp matches)
414 = HsCase exp (convertOpFormsMatch matches)
416 convertOpFormsCmd (HsIf exp c1 c2)
417 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
419 convertOpFormsCmd (HsLet binds cmd)
420 = HsLet binds (convertOpFormsLCmd cmd)
422 convertOpFormsCmd (HsDo ctxt stmts body ty)
423 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
424 (convertOpFormsLCmd body) ty
426 -- Anything else is unchanged. This includes HsArrForm (already done),
427 -- things with no sub-commands, and illegal commands (which will be
428 -- caught by the type checker)
429 convertOpFormsCmd c = c
431 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
432 convertOpFormsStmt (BindStmt pat cmd _ _)
433 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
434 convertOpFormsStmt (ExprStmt cmd _ _)
435 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
436 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
437 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
438 convertOpFormsStmt stmt = stmt
440 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
441 convertOpFormsMatch (MatchGroup ms ty)
442 = MatchGroup (map (fmap convert) ms) ty
443 where convert (Match pat mty grhss)
444 = Match pat mty (convertOpFormsGRHSs grhss)
446 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
447 convertOpFormsGRHSs (GRHSs grhss binds)
448 = GRHSs (map convertOpFormsGRHS grhss) binds
450 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
451 convertOpFormsGRHS = fmap convert
453 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
455 ---------------------------------------------------
456 type CmdNeeds = FreeVars -- Only inhabitants are
457 -- appAName, choiceAName, loopAName
459 -- find what methods the Cmd needs (loop, choice, apply)
460 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
461 methodNamesLCmd = methodNamesCmd . unLoc
463 methodNamesCmd :: HsCmd Name -> CmdNeeds
465 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
467 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
469 methodNamesCmd (HsArrForm {}) = emptyFVs
471 methodNamesCmd (HsPar c) = methodNamesLCmd c
473 methodNamesCmd (HsIf _ c1 c2)
474 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
476 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
478 methodNamesCmd (HsDo _ stmts body _)
479 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
481 methodNamesCmd (HsApp c _) = methodNamesLCmd c
483 methodNamesCmd (HsLam match) = methodNamesMatch match
485 methodNamesCmd (HsCase _ matches)
486 = methodNamesMatch matches `addOneFV` choiceAName
488 methodNamesCmd _ = emptyFVs
489 -- Other forms can't occur in commands, but it's not convenient
490 -- to error here so we just do what's convenient.
491 -- The type checker will complain later
493 ---------------------------------------------------
494 methodNamesMatch :: MatchGroup Name -> FreeVars
495 methodNamesMatch (MatchGroup ms _)
496 = plusFVs (map do_one ms)
498 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
500 -------------------------------------------------
502 methodNamesGRHSs :: GRHSs Name -> FreeVars
503 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
505 -------------------------------------------------
507 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
508 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
510 ---------------------------------------------------
511 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
512 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
514 ---------------------------------------------------
515 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
516 methodNamesLStmt = methodNamesStmt . unLoc
518 methodNamesStmt :: StmtLR Name Name -> FreeVars
519 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
520 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
521 methodNamesStmt (RecStmt stmts _ _ _ _)
522 = methodNamesStmts stmts `addOneFV` loopAName
523 methodNamesStmt (LetStmt _) = emptyFVs
524 methodNamesStmt (ParStmt _) = emptyFVs
525 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
526 methodNamesStmt (GroupStmt _ _) = emptyFVs
527 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
528 -- here so we just do what's convenient
532 %************************************************************************
536 %************************************************************************
539 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
540 rnArithSeq (From expr)
541 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
542 return (From expr', fvExpr)
544 rnArithSeq (FromThen expr1 expr2)
545 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
546 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
547 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
549 rnArithSeq (FromTo expr1 expr2)
550 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
551 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
552 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
554 rnArithSeq (FromThenTo expr1 expr2 expr3)
555 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
556 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
557 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
558 return (FromThenTo expr1' expr2' expr3',
559 plusFVs [fvExpr1, fvExpr2, fvExpr3])
562 %************************************************************************
564 Template Haskell brackets
566 %************************************************************************
569 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
570 rnBracket (VarBr n) = do { name <- lookupOccRn n
571 ; this_mod <- getModule
572 ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
573 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
574 ; return () } -- only way that is going to happen
575 ; return (VarBr name, unitFV name) }
577 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
579 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
580 ; return (ExpBr e', fvs) }
582 rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
583 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
584 ; return (TypBr t', fvs) }
586 doc = ptext (sLit "In a Template-Haskell quoted type")
587 rnBracket (DecBr group)
588 = do { gbl_env <- getGblEnv
590 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
591 -- The emptyDUs is so that we just collect uses for this
592 -- group alone in the call to rnSrcDecls below
593 ; (tcg_env, group') <- setGblEnv new_gbl_env $
597 -- Discard the tcg_env; it contains only extra info about fixity
598 ; return (DecBr group', allUses (tcg_dus tcg_env)) }
601 %************************************************************************
603 \subsubsection{@Stmt@s: in @do@ expressions}
605 %************************************************************************
608 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
609 -> RnM (thing, FreeVars)
610 -> RnM (([LStmt Name], thing), FreeVars)
612 rnStmts (MDoExpr _) = rnMDoStmts
613 rnStmts ctxt = rnNormalStmts ctxt
615 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
616 -> RnM (thing, FreeVars)
617 -> RnM (([LStmt Name], thing), FreeVars)
618 -- Used for cases *other* than recursive mdo
619 -- Implements nested scopes
621 rnNormalStmts _ [] thing_inside
622 = do { (thing, fvs) <- thing_inside
623 ; return (([],thing), fvs) }
625 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
626 = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $
627 rnNormalStmts ctxt stmts thing_inside
628 ; return (((L loc stmt' : stmts'), thing), fvs) }
631 rnStmt :: HsStmtContext Name -> Stmt RdrName
632 -> RnM (thing, FreeVars)
633 -> RnM ((Stmt Name, thing), FreeVars)
635 rnStmt _ (ExprStmt expr _ _) thing_inside
636 = do { (expr', fv_expr) <- rnLExpr expr
637 ; (then_op, fvs1) <- lookupSyntaxName thenMName
638 ; (thing, fvs2) <- thing_inside
639 ; return ((ExprStmt expr' then_op placeHolderType, thing),
640 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
642 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
643 = do { (expr', fv_expr) <- rnLExpr expr
644 -- The binders do not scope over the expression
645 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
646 ; (fail_op, fvs2) <- lookupSyntaxName failMName
647 ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
648 { (thing, fvs3) <- thing_inside
649 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
650 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
651 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
652 -- but it does not matter because the names are unique
654 rnStmt ctxt (LetStmt binds) thing_inside
655 = do { checkLetStmt ctxt binds
656 ; rnLocalBindsAndThen binds $ \binds' -> do
657 { (thing, fvs) <- thing_inside
658 ; return ((LetStmt binds', thing), fvs) } }
660 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
661 = do { checkRecStmt ctxt
662 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
663 { (thing, fvs) <- thing_inside
665 segs_w_fwd_refs = addFwdRefs segs
666 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
667 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
668 fwd_vars = nameSetToList (plusFVs fs)
670 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
671 ; return ((rec_stmt, thing), uses `plusFV` fvs) } }
673 rnStmt ctxt (ParStmt segs) thing_inside
674 = do { checkParStmt ctxt
675 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
676 ; return ((ParStmt segs', thing), fvs) }
678 rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do
679 checkTransformStmt ctxt
681 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
682 ((stmts', binders, (maybeByExpr', thing)), fvs) <-
683 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \_unshadowed_bndrs -> do
684 (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr
685 (thing, fv_thing) <- thing_inside
687 return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing)
689 return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs)
691 rnMaybeLExpr Nothing = return (Nothing, emptyFVs)
692 rnMaybeLExpr (Just expr) = do
693 (expr', fv_expr) <- rnLExpr expr
694 return (Just expr', fv_expr)
696 rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do
697 checkTransformStmt ctxt
699 -- We must rename the using expression in the context before the transform is begun
700 groupByClauseAction <-
701 case groupByClause of
702 GroupByNothing usingExpr -> do
703 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
704 (return . return) (GroupByNothing usingExpr', fv_usingExpr)
705 GroupBySomething eitherUsingExpr byExpr -> do
706 (eitherUsingExpr', fv_eitherUsingExpr) <-
707 case eitherUsingExpr of
708 Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName)
710 (usingExpr', fv_usingExpr) <- rnLExpr usingExpr
711 return (Left usingExpr', fv_usingExpr)
714 (byExpr', fv_byExpr) <- rnLExpr byExpr
715 return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr)
717 -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so
718 -- perhaps we could refactor this to use rnNormalStmts directly?
719 ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <-
720 rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do
721 (groupByClause', fv_groupByClause) <- groupByClauseAction
723 unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs
724 let binderMap = zip unshadowed_bndrs unshadowed_bndrs'
726 -- Bind the "thing" inside a context where we have REBOUND everything
727 -- bound by the statements before the group. This is necessary since after
728 -- the grouping the same identifiers actually have different meanings
729 -- i.e. they refer to lists not singletons!
730 (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside
732 -- We remove entries from the binder map that are not used in the thing_inside.
733 -- We can then use that usage information to ensure that the free variables do
734 -- not contain the things we just bound, but do contain the things we need to
735 -- make those bindings (i.e. the corresponding non-listy variables)
737 -- Note that we also retain those entries which have an old binder in our
738 -- own free variables (the using or by expression). This is because this map
739 -- is reused in the desugarer to create the type to bind from the statements
740 -- that occur before this one. If the binders we need are not in the map, they
741 -- will never get bound into our desugared expression and hence the simplifier
742 -- crashes as we refer to variables that don't exist!
743 let usedBinderMap = filter
744 (\(old_binder, new_binder) ->
745 (new_binder `elemNameSet` fv_thing) ||
746 (old_binder `elemNameSet` fv_groupByClause)) binderMap
747 (usedOldBinders, usedNewBinders) = unzip usedBinderMap
748 real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders)
750 return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing)
752 traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap)
753 return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs)
755 rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name
757 -> ([Name] -> RnM (thing, FreeVars))
758 -> RnM (([LStmt Name], [Name], thing), FreeVars)
759 rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do
760 ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do
761 -- Find the Names that are bound by stmts that
762 -- by assumption we have just renamed
763 local_env <- getLocalRdrEnv
765 stmts_binders = collectLStmtsBinders stmts
766 bndrs = map (expectJust "rnStmt"
767 . lookupLocalRdrEnv local_env
768 . unLoc) stmts_binders
770 -- If shadow, we'll look up (Unqual x) twice, getting
771 -- the second binding both times, which is the
773 unshadowed_bndrs = nub bndrs
775 -- Typecheck the thing inside, passing on all
776 -- the Names bound before it for its information
777 (thing, fvs) <- thing_inside unshadowed_bndrs
779 -- Figure out which of the bound names are used
780 -- after the statements we renamed
781 let used_bndrs = filter (`elemNameSet` fvs) bndrs
782 return ((used_bndrs, thing), fvs)
784 -- Flatten the tuple returned by the above call a bit!
785 return ((stmts', used_bndrs, inner_thing), fvs)
787 rnParallelStmts :: HsStmtContext Name -> [([LStmt RdrName], [RdrName])]
788 -> RnM (thing, FreeVars)
789 -> RnM (([([LStmt Name], [Name])], thing), FreeVars)
790 rnParallelStmts ctxt segs thing_inside = do
791 orig_lcl_env <- getLocalRdrEnv
792 go orig_lcl_env [] segs
794 go orig_lcl_env bndrs [] = do
795 let (bndrs', dups) = removeDups cmpByOcc bndrs
796 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
799 (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
800 return (([], thing), fvs)
802 go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do
803 ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do
804 -- Typecheck the thing inside, passing on all
805 -- the Names bound, but separately; revert the envt
806 setLocalRdrEnv orig_lcl_env $ do
807 go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs
809 let seg' = (stmts', bndrs)
810 return (((seg':segs'), thing), delListFromNameSet fvs bndrs)
812 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
813 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
814 <+> quotes (ppr (head vs)))
818 %************************************************************************
820 \subsubsection{mdo expressions}
822 %************************************************************************
825 type FwdRefs = NameSet
826 type Segment stmts = (Defs,
827 Uses, -- May include defs
828 FwdRefs, -- A subset of uses that are
829 -- (a) used before they are bound in this segment, or
830 -- (b) used here, and bound in subsequent segments
831 stmts) -- Either Stmt or [Stmt]
834 ----------------------------------------------------
836 rnMDoStmts :: [LStmt RdrName]
837 -> RnM (thing, FreeVars)
838 -> RnM (([LStmt Name], thing), FreeVars)
839 rnMDoStmts stmts thing_inside
840 = -- Step1: Bring all the binders of the mdo into scope
841 -- (Remember that this also removes the binders from the
842 -- finally-returned free-vars.)
843 -- And rename each individual stmt, making a
844 -- singleton segment. At this stage the FwdRefs field
845 -- isn't finished: it's empty for all except a BindStmt
846 -- for which it's the fwd refs within the bind itself
847 -- (This set may not be empty, because we're in a recursive
849 rn_rec_stmts_and_then stmts $ \ segs -> do {
851 ; (thing, fvs_later) <- thing_inside
854 -- Step 2: Fill in the fwd refs.
855 -- The segments are all singletons, but their fwd-ref
856 -- field mentions all the things used by the segment
857 -- that are bound after their use
858 segs_w_fwd_refs = addFwdRefs segs
860 -- Step 3: Group together the segments to make bigger segments
861 -- Invariant: in the result, no segment uses a variable
862 -- bound in a later segment
863 grouped_segs = glomSegments segs_w_fwd_refs
865 -- Step 4: Turn the segments into Stmts
866 -- Use RecStmt when and only when there are fwd refs
867 -- Also gather up the uses from the end towards the
868 -- start, so we can tell the RecStmt which things are
869 -- used 'after' the RecStmt
870 (stmts', fvs) = segsToStmts grouped_segs fvs_later
872 ; return ((stmts', thing), fvs) }
874 ---------------------------------------------
876 -- wrapper that does both the left- and right-hand sides
877 rn_rec_stmts_and_then :: [LStmt RdrName]
878 -- assumes that the FreeVars returned includes
879 -- the FreeVars of the Segments
880 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
882 rn_rec_stmts_and_then s cont
883 = do { -- (A) Make the mini fixity env for all of the stmts
884 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
887 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
889 -- ...bring them and their fixities into scope
890 ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
891 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
893 -- (C) do the right-hand-sides and thing-inside
894 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
895 ; (res, fvs) <- cont segs
896 ; warnUnusedLocalBinds bound_names fvs
897 ; return (res, fvs) }}
899 -- get all the fixity decls in any Let stmt
900 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
901 collectRecStmtsFixities l =
902 foldr (\ s -> \acc -> case s of
903 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
904 foldr (\ sig -> \ acc -> case sig of
905 (L loc (FixSig s)) -> (L loc s) : acc
911 rn_rec_stmt_lhs :: MiniFixityEnv
913 -- rename LHS, and return its FVs
914 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
915 -- so we don't bother to compute it accurately in the other cases
916 -> RnM [(LStmtLR Name RdrName, FreeVars)]
918 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
919 -- this is actually correct
922 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
924 -- should the ctxt be MDo instead?
925 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
926 return [(L loc (BindStmt pat' expr a b),
929 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
930 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
932 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
933 = do binds' <- rnValBindsLHS fix_env binds
934 return [(L loc (LetStmt (HsValBinds binds')),
935 -- Warning: this is bogus; see function invariant
939 rn_rec_stmt_lhs fix_env (L _ (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
940 = rn_rec_stmts_lhs fix_env stmts
942 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
943 = pprPanic "rn_rec_stmt" (ppr stmt)
945 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo
946 = pprPanic "rn_rec_stmt" (ppr stmt)
948 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo
949 = pprPanic "rn_rec_stmt" (ppr stmt)
951 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
952 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
954 rn_rec_stmts_lhs :: MiniFixityEnv
956 -> RnM [(LStmtLR Name RdrName, FreeVars)]
957 rn_rec_stmts_lhs fix_env stmts =
958 let boundNames = collectLStmtsBinders stmts
959 doc = text "In a recursive mdo-expression"
961 -- First do error checking: we need to check for dups here because we
962 -- don't bind all of the variables from the Stmt at once
963 -- with bindLocatedLocals.
964 checkDupRdrNames doc boundNames
965 mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
970 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
971 -- Rename a Stmt that is inside a RecStmt (or mdo)
972 -- Assumes all binders are already in scope
973 -- Turns each stmt into a singleton Stmt
974 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
975 = rnLExpr expr `thenM` \ (expr', fvs) ->
976 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
977 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
978 L loc (ExprStmt expr' then_op placeHolderType))]
980 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
981 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
982 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
983 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
985 bndrs = mkNameSet (collectPatBinders pat')
986 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
988 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
989 L loc (BindStmt pat' expr' bind_op fail_op))]
991 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
992 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
994 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
995 (binds', du_binds) <-
996 -- fixities and unused are handled above in rn_rec_stmts_and_then
997 rnValBindsRHS (mkNameSet all_bndrs) binds'
998 return [(duDefs du_binds, duUses du_binds,
999 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1001 -- no RecStmt case becuase they get flattened above when doing the LHSes
1002 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1003 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1005 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
1006 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1008 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo
1009 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1011 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo
1012 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1014 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1015 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1017 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1018 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1019 return (concat segs_s)
1021 ---------------------------------------------
1022 addFwdRefs :: [Segment a] -> [Segment a]
1023 -- So far the segments only have forward refs *within* the Stmt
1024 -- (which happens for bind: x <- ...x...)
1025 -- This function adds the cross-seg fwd ref info
1028 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1030 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1031 = (new_seg : segs, all_defs)
1033 new_seg = (defs, uses, new_fwds, stmts)
1034 all_defs = later_defs `unionNameSets` defs
1035 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1036 -- Add the downstream fwd refs here
1038 ----------------------------------------------------
1039 -- Glomming the singleton segments of an mdo into
1040 -- minimal recursive groups.
1042 -- At first I thought this was just strongly connected components, but
1043 -- there's an important constraint: the order of the stmts must not change.
1046 -- mdo { x <- ...y...
1053 -- Here, the first stmt mention 'y', which is bound in the third.
1054 -- But that means that the innocent second stmt (p <- z) gets caught
1055 -- up in the recursion. And that in turn means that the binding for
1056 -- 'z' has to be included... and so on.
1058 -- Start at the tail { r <- x }
1059 -- Now add the next one { z <- y ; r <- x }
1060 -- Now add one more { q <- x ; z <- y ; r <- x }
1061 -- Now one more... but this time we have to group a bunch into rec
1062 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1063 -- Now one more, which we can add on without a rec
1065 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1067 -- Finally we add the last one; since it mentions y we have to
1068 -- glom it togeher with the first two groups
1069 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1070 -- q <- x ; z <- y } ;
1073 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1075 glomSegments [] = []
1076 glomSegments ((defs,uses,fwds,stmt) : segs)
1077 -- Actually stmts will always be a singleton
1078 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1080 segs' = glomSegments segs
1081 (extras, others) = grab uses segs'
1082 (ds, us, fs, ss) = unzip4 extras
1084 seg_defs = plusFVs ds `plusFV` defs
1085 seg_uses = plusFVs us `plusFV` uses
1086 seg_fwds = plusFVs fs `plusFV` fwds
1087 seg_stmts = stmt : concat ss
1089 grab :: NameSet -- The client
1091 -> ([Segment a], -- Needed by the 'client'
1092 [Segment a]) -- Not needed by the client
1093 -- The result is simply a split of the input
1095 = (reverse yeses, reverse noes)
1097 (noes, yeses) = span not_needed (reverse dus)
1098 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1101 ----------------------------------------------------
1102 segsToStmts :: [Segment [LStmt Name]]
1103 -> FreeVars -- Free vars used 'later'
1104 -> ([LStmt Name], FreeVars)
1106 segsToStmts [] fvs_later = ([], fvs_later)
1107 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1108 = ASSERT( not (null ss) )
1109 (new_stmt : later_stmts, later_uses `plusFV` uses)
1111 (later_stmts, later_uses) = segsToStmts segs fvs_later
1112 new_stmt | non_rec = head ss
1113 | otherwise = L (getLoc (head ss)) $
1114 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1117 non_rec = isSingleton ss && isEmptyNameSet fwds
1118 used_later = defs `intersectNameSet` later_uses
1119 -- The ones needed after the RecStmt
1122 %************************************************************************
1124 \subsubsection{Assertion utils}
1126 %************************************************************************
1129 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1130 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1132 mkAssertErrorExpr :: RnM (HsExpr Name)
1133 -- Return an expression for (assertError "Foo.hs:27")
1135 = getSrcSpanM `thenM` \ sloc ->
1136 return (HsApp (L sloc (HsVar assertErrorName))
1137 (L sloc (srcSpanPrimLit sloc)))
1140 Note [Adding the implicit parameter to 'assert']
1141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1143 By doing this in the renamer we allow the typechecker to just see the
1144 expanded application and do the right thing. But it's not really
1145 the Right Thing because there's no way to "undo" if you want to see
1146 the original source code. We'll have fix this in due course, when
1147 we care more about being able to reconstruct the exact original
1150 %************************************************************************
1152 \subsubsection{Errors}
1154 %************************************************************************
1158 ----------------------
1159 -- Checking when a particular Stmt is ok
1160 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1161 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1162 checkLetStmt _ctxt _binds = return ()
1163 -- We do not allow implicit-parameter bindings in a parallel
1164 -- list comprehension. I'm not sure what it might mean.
1167 checkRecStmt :: HsStmtContext Name -> RnM ()
1168 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1169 checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows:
1170 -- proc x -> do { ...rec... }
1171 -- We don't have enough context to distinguish this situation here
1172 -- so we leave it to the type checker
1173 checkRecStmt ctxt = addErr msg
1175 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1178 checkParStmt :: HsStmtContext Name -> RnM ()
1180 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1181 ; checkErr parallel_list_comp msg }
1183 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1186 checkTransformStmt :: HsStmtContext Name -> RnM ()
1187 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1188 -- desugarer will break when we come to operate on a parallel array
1189 = do { transform_list_comp <- doptM Opt_TransformListComp
1190 ; checkErr transform_list_comp msg }
1192 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1193 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1194 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1195 checkTransformStmt ctxt = addErr msg
1197 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1200 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1201 checkTupleSection args
1202 = do { tuple_section <- doptM Opt_TupleSections
1203 ; checkErr (all tupArgPresent args || tuple_section) msg }
1205 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1208 sectionErr :: HsExpr RdrName -> SDoc
1210 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1211 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1213 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1214 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1216 ; return (EWildPat, emptyFVs) }
1218 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1219 badIpBinds what binds
1220 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)