Commit 78363495 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix Trac #4534: renamer bug

  
The renamer wasn't attaching the right used-variables to a
TransformStmt constructor.

The real modification is in RnExpr; the rest is just
pretty-printing and white space.
parent 3e09edbc
......@@ -92,12 +92,12 @@ dsInnerListComp (stmts, bndrs) = do
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) = do
(expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
usingExpr' <- dsLExpr usingExpr
dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
= do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
; usingExpr' <- dsLExpr usingExpr
using_args <-
case maybeByExpr of
; using_args <-
case maybeByExpr of
Nothing -> return [expr]
Just byExpr -> do
byExpr' <- dsLExpr byExpr
......@@ -108,10 +108,9 @@ dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) = do
return [Lam tuple_binder byExprWrapper, expr]
let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
let pat = mkBigLHsVarPatTup binders
return (inner_list_expr, pat)
; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
pat = mkBigLHsVarPatTup binders
; return (inner_list_expr, pat) }
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
......
......@@ -1008,8 +1008,8 @@ pprStmt (ExprStmt expr _ _) = ppr expr
pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
pprStmt (TransformStmt stmts _ using by)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by])
pprStmt (TransformStmt stmts bndrs using by)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
pprStmt (GroupStmt stmts _ by using)
= sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
......@@ -1021,8 +1021,11 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
, ptext (sLit "later_ids=") <> ppr later_ids])]
pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt bndrs using by
= sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
, nest 2 (pprBy by)]
pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
-> Either (LHsExpr id) (SyntaxExpr is)
......@@ -1288,7 +1291,7 @@ pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext c
4 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
ppr_stmt (TransformStmt _ _ using by) = pprTransformStmt using by
ppr_stmt stmt = pprStmt stmt
ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by
ppr_stmt stmt = pprStmt stmt
\end{code}
......@@ -759,7 +759,9 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
used_bndrs = filter (`elemNameSet` fvs) bndrs
-- The paper (Fig 5) has a bug here; we must treat any free varaible of
-- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment