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, 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(..) )
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 <- doptM 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) }
151 = rnLExpr e `thenM` \ (e', fv_e) ->
152 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
153 mkNegAppRn e' neg_name `thenM` \ final_e ->
154 return (final_e, fv_e `plusFV` fv_neg)
156 ------------------------------------------
157 -- Template Haskell extensions
158 -- Don't ifdef-GHCI them because we want to fail gracefully
159 -- (not with an rnExpr crash) in a stage-1 compiler.
160 rnExpr e@(HsBracket br_body)
161 = checkTH e "bracket" `thenM_`
162 rnBracket br_body `thenM` \ (body', fvs_e) ->
163 return (HsBracket body', fvs_e)
165 rnExpr (HsSpliceE splice)
166 = rnSplice splice `thenM` \ (splice', fvs) ->
167 return (HsSpliceE splice', fvs)
170 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
172 rnExpr (HsQuasiQuoteE qq)
173 = runQuasiQuoteExpr qq `thenM` \ (L _ expr') ->
177 ---------------------------------------------
179 -- See Note [Parsing sections] in Parser.y.pp
180 rnExpr (HsPar (L loc (section@(SectionL {}))))
181 = do { (section', fvs) <- rnSection section
182 ; return (HsPar (L loc section'), fvs) }
184 rnExpr (HsPar (L loc (section@(SectionR {}))))
185 = do { (section', fvs) <- rnSection section
186 ; return (HsPar (L loc section'), fvs) }
189 = do { (e', fvs_e) <- rnLExpr e
190 ; return (HsPar e', fvs_e) }
192 rnExpr expr@(SectionL {})
193 = do { addErr (sectionErr expr); rnSection expr }
194 rnExpr expr@(SectionR {})
195 = do { addErr (sectionErr expr); rnSection expr }
197 ---------------------------------------------
198 rnExpr (HsCoreAnn ann expr)
199 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
200 return (HsCoreAnn ann expr', fvs_expr)
202 rnExpr (HsSCC lbl expr)
203 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
204 return (HsSCC lbl expr', fvs_expr)
205 rnExpr (HsTickPragma info expr)
206 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
207 return (HsTickPragma info expr', fvs_expr)
209 rnExpr (HsLam matches)
210 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
211 return (HsLam matches', fvMatch)
213 rnExpr (HsCase expr matches)
214 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
215 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
216 return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
218 rnExpr (HsLet binds expr)
219 = rnLocalBindsAndThen binds $ \ binds' ->
220 rnLExpr expr `thenM` \ (expr',fvExpr) ->
221 return (HsLet binds' expr', fvExpr)
223 rnExpr (HsDo do_or_lc stmts body _)
224 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
226 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
228 rnExpr (ExplicitList _ exps)
229 = rnExprs exps `thenM` \ (exps', fvs) ->
230 return (ExplicitList placeHolderType exps', fvs)
232 rnExpr (ExplicitPArr _ exps)
233 = rnExprs exps `thenM` \ (exps', fvs) ->
234 return (ExplicitPArr placeHolderType exps', fvs)
236 rnExpr (ExplicitTuple tup_args boxity)
237 = do { checkTupleSection tup_args
238 ; checkTupSize (length tup_args)
239 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
240 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
242 rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
243 rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
245 rnExpr (RecordCon con_id _ rbinds)
246 = do { conname <- lookupLocatedOccRn con_id
247 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
248 ; return (RecordCon conname noPostTcExpr rbinds',
249 fvRbinds `addOneFV` unLoc conname) }
251 rnExpr (RecordUpd expr rbinds _ _ _)
252 = do { (expr', fvExpr) <- rnLExpr expr
253 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
254 ; return (RecordUpd expr' rbinds' [] [] [],
255 fvExpr `plusFV` fvRbinds) }
257 rnExpr (ExprWithTySig expr pty)
258 = do { (pty', fvTy) <- rnHsTypeFVs doc pty
259 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
261 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
263 doc = text "In an expression type signature"
265 rnExpr (HsIf p b1 b2)
266 = rnLExpr p `thenM` \ (p', fvP) ->
267 rnLExpr b1 `thenM` \ (b1', fvB1) ->
268 rnLExpr b2 `thenM` \ (b2', fvB2) ->
269 return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
272 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
273 return (HsType t, fvT)
275 doc = text "In a type argument"
277 rnExpr (ArithSeq _ seq)
278 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
279 return (ArithSeq noPostTcExpr new_seq, fvs)
281 rnExpr (PArrSeq _ seq)
282 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
283 return (PArrSeq noPostTcExpr new_seq, fvs)
286 These three are pattern syntax appearing in expressions.
287 Since all the symbols are reservedops we can simply reject them.
288 We return a (bogus) EWildPat in each case.
291 rnExpr e@EWildPat = patSynErr e
292 rnExpr e@(EAsPat {}) = patSynErr e
293 rnExpr e@(EViewPat {}) = patSynErr e
294 rnExpr e@(ELazyPat {}) = patSynErr e
297 %************************************************************************
301 %************************************************************************
304 rnExpr (HsProc pat body)
306 rnPat ProcExpr pat $ \ pat' ->
307 rnCmdTop body `thenM` \ (body',fvBody) ->
308 return (HsProc pat' body', fvBody)
310 rnExpr (HsArrApp arrow arg _ ho rtl)
311 = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
312 rnLExpr arg `thenM` \ (arg',fvArg) ->
313 return (HsArrApp arrow' arg' placeHolderType ho rtl,
314 fvArrow `plusFV` fvArg)
316 select_arrow_scope tc = case ho of
317 HsHigherOrderApp -> tc
318 HsFirstOrderApp -> escapeArrowScope tc
321 rnExpr (HsArrForm op (Just _) [arg1, arg2])
322 = escapeArrowScope (rnLExpr op)
323 `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
324 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
325 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
329 lookupFixityRn op_name `thenM` \ fixity ->
330 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
333 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
335 rnExpr (HsArrForm op fixity cmds)
336 = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
337 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
338 return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
340 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
343 ----------------------
344 -- See Note [Parsing sections] in Parser.y.pp
345 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
346 rnSection section@(SectionR op expr)
347 = do { (op', fvs_op) <- rnLExpr op
348 ; (expr', fvs_expr) <- rnLExpr expr
349 ; checkSectionPrec InfixR section op' expr'
350 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
352 rnSection section@(SectionL expr op)
353 = do { (expr', fvs_expr) <- rnLExpr expr
354 ; (op', fvs_op) <- rnLExpr op
355 ; checkSectionPrec InfixL section op' expr'
356 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
358 rnSection other = pprPanic "rnSection" (ppr other)
361 %************************************************************************
365 %************************************************************************
368 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
369 -> RnM (HsRecordBinds Name, FreeVars)
370 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
371 = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
372 ; (flds', fvss) <- mapAndUnzipM rn_field flds
373 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
374 fvs `plusFV` plusFVs fvss) }
376 rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
377 ; return (fld { hsRecFieldArg = arg' }, fvs) }
381 %************************************************************************
385 %************************************************************************
388 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
389 rnCmdArgs [] = return ([], emptyFVs)
391 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
392 rnCmdArgs args `thenM` \ (args',fvArgs) ->
393 return (arg':args', fvArg `plusFV` fvArgs)
395 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
396 rnCmdTop = wrapLocFstM rnCmdTop'
398 rnCmdTop' (HsCmdTop cmd _ _ _)
399 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
401 cmd_names = [arrAName, composeAName, firstAName] ++
402 nameSetToList (methodNamesCmd (unLoc cmd'))
404 -- Generate the rebindable syntax for the monad
405 lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
407 return (HsCmdTop cmd' [] placeHolderType cmd_names',
408 fvCmd `plusFV` cmd_fvs)
410 ---------------------------------------------------
411 -- convert OpApp's in a command context to HsArrForm's
413 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
414 convertOpFormsLCmd = fmap convertOpFormsCmd
416 convertOpFormsCmd :: HsCmd id -> HsCmd id
418 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
419 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
420 convertOpFormsCmd (OpApp c1 op fixity c2)
422 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
423 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
425 HsArrForm op (Just fixity) [arg1, arg2]
427 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
429 convertOpFormsCmd (HsCase exp matches)
430 = HsCase exp (convertOpFormsMatch matches)
432 convertOpFormsCmd (HsIf exp c1 c2)
433 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
435 convertOpFormsCmd (HsLet binds cmd)
436 = HsLet binds (convertOpFormsLCmd cmd)
438 convertOpFormsCmd (HsDo ctxt stmts body ty)
439 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
440 (convertOpFormsLCmd body) ty
442 -- Anything else is unchanged. This includes HsArrForm (already done),
443 -- things with no sub-commands, and illegal commands (which will be
444 -- caught by the type checker)
445 convertOpFormsCmd c = c
447 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
448 convertOpFormsStmt (BindStmt pat cmd _ _)
449 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
450 convertOpFormsStmt (ExprStmt cmd _ _)
451 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
452 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
453 = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
454 convertOpFormsStmt stmt = stmt
456 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
457 convertOpFormsMatch (MatchGroup ms ty)
458 = MatchGroup (map (fmap convert) ms) ty
459 where convert (Match pat mty grhss)
460 = Match pat mty (convertOpFormsGRHSs grhss)
462 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
463 convertOpFormsGRHSs (GRHSs grhss binds)
464 = GRHSs (map convertOpFormsGRHS grhss) binds
466 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
467 convertOpFormsGRHS = fmap convert
469 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
471 ---------------------------------------------------
472 type CmdNeeds = FreeVars -- Only inhabitants are
473 -- appAName, choiceAName, loopAName
475 -- find what methods the Cmd needs (loop, choice, apply)
476 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
477 methodNamesLCmd = methodNamesCmd . unLoc
479 methodNamesCmd :: HsCmd Name -> CmdNeeds
481 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
483 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
485 methodNamesCmd (HsArrForm {}) = emptyFVs
487 methodNamesCmd (HsPar c) = methodNamesLCmd c
489 methodNamesCmd (HsIf _ c1 c2)
490 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
492 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
494 methodNamesCmd (HsDo _ stmts body _)
495 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
497 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 (ExprStmt cmd _ _) = methodNamesLCmd cmd
536 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
537 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
538 methodNamesStmt (LetStmt _) = emptyFVs
539 methodNamesStmt (ParStmt _) = emptyFVs
540 methodNamesStmt (TransformStmt {}) = emptyFVs
541 methodNamesStmt (GroupStmt {}) = emptyFVs
542 -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
543 -- here so we just do what's convenient
547 %************************************************************************
551 %************************************************************************
554 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
555 rnArithSeq (From expr)
556 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
557 return (From expr', fvExpr)
559 rnArithSeq (FromThen expr1 expr2)
560 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
561 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
562 return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
564 rnArithSeq (FromTo expr1 expr2)
565 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
566 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
567 return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
569 rnArithSeq (FromThenTo expr1 expr2 expr3)
570 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
571 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
572 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
573 return (FromThenTo expr1' expr2' expr3',
574 plusFVs [fvExpr1, fvExpr2, fvExpr3])
577 %************************************************************************
579 Template Haskell brackets
581 %************************************************************************
584 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
585 rnBracket (VarBr n) = do { name <- lookupOccRn n
586 ; this_mod <- getModule
587 ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
588 do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
589 ; return () } -- only way that is going to happen
590 ; return (VarBr name, unitFV name) }
592 msg = ptext (sLit "Need interface for Template Haskell quoted Name")
594 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
595 ; return (ExpBr e', fvs) }
597 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
599 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
600 ; return (TypBr t', fvs) }
602 doc = ptext (sLit "In a Template-Haskell quoted type")
604 rnBracket (DecBrL decls)
605 = do { (group, mb_splice) <- findSplice decls
608 Just (SpliceDecl (L loc _), _)
610 addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
611 -- Why not? See Section 7.3 of the TH paper.
613 ; gbl_env <- getGblEnv
614 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
615 -- The emptyDUs is so that we just collect uses for this
616 -- group alone in the call to rnSrcDecls below
617 ; (tcg_env, group') <- setGblEnv new_gbl_env $
621 -- Discard the tcg_env; it contains only extra info about fixity
622 ; return (DecBrG group', allUses (tcg_dus tcg_env)) }
624 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
627 %************************************************************************
629 \subsubsection{@Stmt@s: in @do@ expressions}
631 %************************************************************************
634 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
635 -> RnM (thing, FreeVars)
636 -> RnM (([LStmt Name], thing), FreeVars)
637 -- Variables bound by the Stmts, and mentioned in thing_inside,
638 -- do not appear in the result FreeVars
640 rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside
641 rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
643 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
644 -> ([Name] -> RnM (thing, FreeVars))
645 -> RnM (([LStmt Name], thing), FreeVars)
646 -- Variables bound by the Stmts, and mentioned in thing_inside,
647 -- do not appear in the result FreeVars
649 -- Renaming a single RecStmt can give a sequence of smaller Stmts
651 rnNormalStmts _ [] thing_inside
652 = do { (res, fvs) <- thing_inside []
653 ; return (([], res), fvs) }
655 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
656 = do { ((stmts1, (stmts2, thing)), fvs)
658 rnStmt ctxt stmt $ \ bndrs1 ->
659 rnNormalStmts ctxt stmts $ \ bndrs2 ->
660 thing_inside (bndrs1 ++ bndrs2)
661 ; return (((stmts1 ++ stmts2), thing), fvs) }
664 rnStmt :: HsStmtContext Name -> LStmt RdrName
665 -> ([Name] -> RnM (thing, FreeVars))
666 -> RnM (([LStmt Name], thing), FreeVars)
667 -- Variables bound by the Stmt, and mentioned in thing_inside,
668 -- do not appear in the result FreeVars
670 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
671 = do { (expr', fv_expr) <- rnLExpr expr
672 ; (then_op, fvs1) <- lookupSyntaxName thenMName
673 ; (thing, fvs2) <- thing_inside []
674 ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
675 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
677 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
678 = do { (expr', fv_expr) <- rnLExpr expr
679 -- The binders do not scope over the expression
680 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
681 ; (fail_op, fvs2) <- lookupSyntaxName failMName
682 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
683 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
684 ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
685 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
686 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
687 -- but it does not matter because the names are unique
689 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
690 = do { checkLetStmt ctxt binds
691 ; rnLocalBindsAndThen binds $ \binds' -> do
692 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
693 ; return (([L loc (LetStmt binds')], thing), fvs) } }
695 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
696 = do { checkRecStmt ctxt
698 -- Step1: Bring all the binders of the mdo into scope
699 -- (Remember that this also removes the binders from the
700 -- finally-returned free-vars.)
701 -- And rename each individual stmt, making a
702 -- singleton segment. At this stage the FwdRefs field
703 -- isn't finished: it's empty for all except a BindStmt
704 -- for which it's the fwd refs within the bind itself
705 -- (This set may not be empty, because we're in a recursive
707 ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
709 { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
711 ; (thing, fvs_later) <- thing_inside bndrs
712 ; (return_op, fvs1) <- lookupSyntaxName returnMName
713 ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
714 ; (bind_op, fvs3) <- lookupSyntaxName bindMName
716 -- Step 2: Fill in the fwd refs.
717 -- The segments are all singletons, but their fwd-ref
718 -- field mentions all the things used by the segment
719 -- that are bound after their use
720 segs_w_fwd_refs = addFwdRefs segs
722 -- Step 3: Group together the segments to make bigger segments
723 -- Invariant: in the result, no segment uses a variable
724 -- bound in a later segment
725 grouped_segs = glomSegments segs_w_fwd_refs
727 -- Step 4: Turn the segments into Stmts
728 -- Use RecStmt when and only when there are fwd refs
729 -- Also gather up the uses from the end towards the
730 -- start, so we can tell the RecStmt which things are
731 -- used 'after' the RecStmt
732 empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op
733 , recS_mfix_fn = mfix_op
734 , recS_bind_fn = bind_op }
735 (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
737 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
739 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
740 = do { checkParStmt ctxt
741 ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
742 ; return (([L loc (ParStmt segs')], thing), fvs) }
744 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
745 = do { checkTransformStmt ctxt
747 ; (using', fvs1) <- rnLExpr using
749 ; ((stmts', (by', used_bndrs, thing)), fvs2)
750 <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
751 do { (by', fvs_by) <- case by of
752 Nothing -> return (Nothing, emptyFVs)
753 Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
754 ; (thing, fvs_thing) <- thing_inside bndrs
755 ; let fvs = fvs_by `plusFV` fvs_thing
756 used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
757 ; return ((by', used_bndrs, thing), fvs) }
759 ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
760 fvs1 `plusFV` fvs2) }
762 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
763 = do { checkTransformStmt ctxt
765 -- Rename the 'using' expression in the context before the transform is begun
766 ; (using', fvs1) <- case using of
767 Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
768 Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
769 ; return (Right e', fvs) }
771 -- Rename the stmts and the 'by' expression
772 -- Keep track of the variables mentioned in the 'by' expression
773 ; ((stmts', (by', used_bndrs, thing)), fvs2)
774 <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
775 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
776 ; (thing, fvs_thing) <- thing_inside bndrs
777 ; let fvs = fvs_by `plusFV` fvs_thing
778 used_bndrs = filter (`elemNameSet` fvs) bndrs
779 ; return ((by', used_bndrs, thing), fvs) }
781 ; let all_fvs = fvs1 `plusFV` fvs2
782 bndr_map = used_bndrs `zip` used_bndrs
784 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
785 ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
788 type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
790 rnParallelStmts :: forall thing. HsStmtContext Name
792 -> ([Name] -> RnM (thing, FreeVars))
793 -> RnM (([ParSeg Name], thing), FreeVars)
794 -- Note [Renaming parallel Stmts]
795 rnParallelStmts ctxt segs thing_inside
796 = do { orig_lcl_env <- getLocalRdrEnv
797 ; rn_segs orig_lcl_env [] segs }
799 rn_segs :: LocalRdrEnv
800 -> [Name] -> [ParSeg RdrName]
801 -> RnM (([ParSeg Name], thing), FreeVars)
802 rn_segs _ bndrs_so_far []
803 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
805 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
806 ; return (([], thing), fvs) }
808 rn_segs env bndrs_so_far ((stmts,_) : segs)
809 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
810 <- rnNormalStmts ctxt stmts $ \ bndrs ->
811 setLocalRdrEnv env $ do
812 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
813 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
814 ; return ((used_bndrs, segs', thing), fvs) }
816 ; let seg' = (stmts', used_bndrs)
817 ; return ((seg':segs', thing), fvs) }
819 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
820 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
821 <+> quotes (ppr (head vs)))
824 Note [Renaming parallel Stmts]
825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
826 Renaming parallel statements is painful. Given, say
827 [ a+c | a <- as, bs <- bss
830 (a) In order to report "Defined by not used" about 'bs', we must rename
831 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
833 (b) We want to report that 'a' is illegally bound in both branches
835 (c) The 'bs' in the second group must obviously not be captured by
836 the binding in the first group
838 To satisfy (a) we nest the segements.
839 To satisfy (b) we check for duplicates just before thing_inside.
840 To satisfy (c) we reset the LocalRdrEnv each time.
842 %************************************************************************
844 \subsubsection{mdo expressions}
846 %************************************************************************
849 type FwdRefs = NameSet
850 type Segment stmts = (Defs,
851 Uses, -- May include defs
852 FwdRefs, -- A subset of uses that are
853 -- (a) used before they are bound in this segment, or
854 -- (b) used here, and bound in subsequent segments
855 stmts) -- Either Stmt or [Stmt]
858 ----------------------------------------------------
860 rnMDoStmts :: [LStmt RdrName]
861 -> RnM (thing, FreeVars)
862 -> RnM (([LStmt Name], thing), FreeVars)
863 rnMDoStmts stmts thing_inside
864 = rn_rec_stmts_and_then stmts $ \ segs -> do
865 { (thing, fvs_later) <- thing_inside
866 ; let segs_w_fwd_refs = addFwdRefs segs
867 grouped_segs = glomSegments segs_w_fwd_refs
868 (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
869 ; return ((stmts', thing), fvs) }
871 ---------------------------------------------
873 -- wrapper that does both the left- and right-hand sides
874 rn_rec_stmts_and_then :: [LStmt RdrName]
875 -- assumes that the FreeVars returned includes
876 -- the FreeVars of the Segments
877 -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
879 rn_rec_stmts_and_then s cont
880 = do { -- (A) Make the mini fixity env for all of the stmts
881 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
884 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
886 -- ...bring them and their fixities into scope
887 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
888 ; bindLocalNamesFV_WithFixities bound_names fix_env $ do
890 -- (C) do the right-hand-sides and thing-inside
891 { segs <- rn_rec_stmts bound_names new_lhs_and_fv
892 ; (res, fvs) <- cont segs
893 ; warnUnusedLocalBinds bound_names fvs
894 ; return (res, fvs) }}
896 -- get all the fixity decls in any Let stmt
897 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
898 collectRecStmtsFixities l =
899 foldr (\ s -> \acc -> case s of
900 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
901 foldr (\ sig -> \ acc -> case sig of
902 (L loc (FixSig s)) -> (L loc s) : acc
908 rn_rec_stmt_lhs :: MiniFixityEnv
910 -- rename LHS, and return its FVs
911 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
912 -- so we don't bother to compute it accurately in the other cases
913 -> RnM [(LStmtLR Name RdrName, FreeVars)]
915 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
916 -- this is actually correct
919 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
921 -- should the ctxt be MDo instead?
922 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
923 return [(L loc (BindStmt pat' expr a b),
926 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
927 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
929 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
930 = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
931 return [(L loc (LetStmt (HsValBinds binds')),
932 -- Warning: this is bogus; see function invariant
936 -- XXX Do we need to do something with the return and mfix names?
937 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
938 = rn_rec_stmts_lhs fix_env stmts
940 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
941 = pprPanic "rn_rec_stmt" (ppr stmt)
943 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
944 = pprPanic "rn_rec_stmt" (ppr stmt)
946 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
947 = pprPanic "rn_rec_stmt" (ppr stmt)
949 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
950 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
952 rn_rec_stmts_lhs :: MiniFixityEnv
954 -> RnM [(LStmtLR Name RdrName, FreeVars)]
955 rn_rec_stmts_lhs fix_env stmts
956 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
957 ; let boundNames = collectLStmtsBinders (map fst ls)
958 -- First do error checking: we need to check for dups here because we
959 -- don't bind all of the variables from the Stmt at once
960 -- with bindLocatedLocals.
961 ; checkDupNames boundNames
967 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
968 -- Rename a Stmt that is inside a RecStmt (or mdo)
969 -- Assumes all binders are already in scope
970 -- Turns each stmt into a singleton Stmt
971 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
972 = rnLExpr expr `thenM` \ (expr', fvs) ->
973 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
974 return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
975 L loc (ExprStmt expr' then_op placeHolderType))]
977 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
978 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
979 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
980 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
982 bndrs = mkNameSet (collectPatBinders pat')
983 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
985 return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
986 L loc (BindStmt pat' expr' bind_op fail_op))]
988 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
989 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
991 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
992 (binds', du_binds) <-
993 -- fixities and unused are handled above in rn_rec_stmts_and_then
994 rnValBindsRHS (mkNameSet all_bndrs) binds'
995 return [(duDefs du_binds, duUses du_binds,
996 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
998 -- no RecStmt case becuase they get flattened above when doing the LHSes
999 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1000 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1002 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1003 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1005 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
1006 = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1008 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
1009 = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1011 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1012 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1014 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1015 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
1016 return (concat segs_s)
1018 ---------------------------------------------
1019 addFwdRefs :: [Segment a] -> [Segment a]
1020 -- So far the segments only have forward refs *within* the Stmt
1021 -- (which happens for bind: x <- ...x...)
1022 -- This function adds the cross-seg fwd ref info
1025 = fst (foldr mk_seg ([], emptyNameSet) pairs)
1027 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1028 = (new_seg : segs, all_defs)
1030 new_seg = (defs, uses, new_fwds, stmts)
1031 all_defs = later_defs `unionNameSets` defs
1032 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1033 -- Add the downstream fwd refs here
1035 ----------------------------------------------------
1036 -- Glomming the singleton segments of an mdo into
1037 -- minimal recursive groups.
1039 -- At first I thought this was just strongly connected components, but
1040 -- there's an important constraint: the order of the stmts must not change.
1043 -- mdo { x <- ...y...
1050 -- Here, the first stmt mention 'y', which is bound in the third.
1051 -- But that means that the innocent second stmt (p <- z) gets caught
1052 -- up in the recursion. And that in turn means that the binding for
1053 -- 'z' has to be included... and so on.
1055 -- Start at the tail { r <- x }
1056 -- Now add the next one { z <- y ; r <- x }
1057 -- Now add one more { q <- x ; z <- y ; r <- x }
1058 -- Now one more... but this time we have to group a bunch into rec
1059 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1060 -- Now one more, which we can add on without a rec
1062 -- rec { y <- ...x... ; q <- x ; z <- y } ;
1064 -- Finally we add the last one; since it mentions y we have to
1065 -- glom it togeher with the first two groups
1066 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
1067 -- q <- x ; z <- y } ;
1070 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1072 glomSegments [] = []
1073 glomSegments ((defs,uses,fwds,stmt) : segs)
1074 -- Actually stmts will always be a singleton
1075 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1077 segs' = glomSegments segs
1078 (extras, others) = grab uses segs'
1079 (ds, us, fs, ss) = unzip4 extras
1081 seg_defs = plusFVs ds `plusFV` defs
1082 seg_uses = plusFVs us `plusFV` uses
1083 seg_fwds = plusFVs fs `plusFV` fwds
1084 seg_stmts = stmt : concat ss
1086 grab :: NameSet -- The client
1088 -> ([Segment a], -- Needed by the 'client'
1089 [Segment a]) -- Not needed by the client
1090 -- The result is simply a split of the input
1092 = (reverse yeses, reverse noes)
1094 (noes, yeses) = span not_needed (reverse dus)
1095 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1098 ----------------------------------------------------
1099 segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in
1100 -> [Segment [LStmt Name]]
1101 -> FreeVars -- Free vars used 'later'
1102 -> ([LStmt Name], FreeVars)
1104 segsToStmts _ [] fvs_later = ([], fvs_later)
1105 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1106 = ASSERT( not (null ss) )
1107 (new_stmt : later_stmts, later_uses `plusFV` uses)
1109 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1110 new_stmt | non_rec = head ss
1111 | otherwise = L (getLoc (head ss)) rec_stmt
1112 rec_stmt = empty_rec_stmt { recS_stmts = ss
1113 , recS_later_ids = nameSetToList used_later
1114 , recS_rec_ids = nameSetToList fwds }
1115 non_rec = isSingleton ss && isEmptyNameSet fwds
1116 used_later = defs `intersectNameSet` later_uses
1117 -- The ones needed after the RecStmt
1120 %************************************************************************
1122 \subsubsection{Assertion utils}
1124 %************************************************************************
1127 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1128 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1130 mkAssertErrorExpr :: RnM (HsExpr Name)
1131 -- Return an expression for (assertError "Foo.hs:27")
1133 = getSrcSpanM `thenM` \ sloc ->
1134 return (HsApp (L sloc (HsVar assertErrorName))
1135 (L sloc (srcSpanPrimLit sloc)))
1138 Note [Adding the implicit parameter to 'assert']
1139 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1140 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1141 By doing this in the renamer we allow the typechecker to just see the
1142 expanded application and do the right thing. But it's not really
1143 the Right Thing because there's no way to "undo" if you want to see
1144 the original source code. We'll have fix this in due course, when
1145 we care more about being able to reconstruct the exact original
1148 %************************************************************************
1150 \subsubsection{Errors}
1152 %************************************************************************
1156 ----------------------
1157 -- Checking when a particular Stmt is ok
1158 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1159 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1160 checkLetStmt _ctxt _binds = return ()
1161 -- We do not allow implicit-parameter bindings in a parallel
1162 -- list comprehension. I'm not sure what it might mean.
1165 checkRecStmt :: HsStmtContext Name -> RnM ()
1166 checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
1167 checkRecStmt (DoExpr {}) = return () -- and in 'do'
1168 checkRecStmt ctxt = addErr msg
1170 msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1173 checkParStmt :: HsStmtContext Name -> RnM ()
1175 = do { parallel_list_comp <- doptM Opt_ParallelListComp
1176 ; checkErr parallel_list_comp msg }
1178 msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1181 checkTransformStmt :: HsStmtContext Name -> RnM ()
1182 checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
1183 -- desugarer will break when we come to operate on a parallel array
1184 = do { transform_list_comp <- doptM Opt_TransformListComp
1185 ; checkErr transform_list_comp msg }
1187 msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1188 checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1189 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
1190 checkTransformStmt ctxt = addErr msg
1192 msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1195 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1196 checkTupleSection args
1197 = do { tuple_section <- doptM Opt_TupleSections
1198 ; checkErr (all tupArgPresent args || tuple_section) msg }
1200 msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1203 sectionErr :: HsExpr RdrName -> SDoc
1205 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1206 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1208 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1209 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1211 ; return (EWildPat, emptyFVs) }
1213 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1214 badIpBinds what binds
1215 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)