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.

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 166bfc2..2292aed 100644 (file)
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -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

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index ee1aeca..7857707 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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}

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 73dcfdb..310d075 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -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),