From 62bc659ec8977d13933e2275382d6c396a2f7123 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 1 Jul 2009 16:29:57 +0000
Subject: [PATCH] fixed bug in rendering of reduction relations; they now
 preserve the relative ordering of side-conditions and where clauses

svn: r15354
---
 collects/redex/private/pict.ss                | 14 +--
 collects/redex/private/reduction-semantics.ss | 86 ++++++++-----------
 collects/redex/private/struct.ss              |  2 +-
 3 files changed, 46 insertions(+), 56 deletions(-)

diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss
index 31597b3501..6f9c02b5f1 100644
--- a/collects/redex/private/pict.ss
+++ b/collects/redex/private/pict.ss
@@ -120,11 +120,12 @@
                     (tp (rule-pict-lhs rp))
                     (tp (rule-pict-rhs rp))
                     (rule-pict-label rp)
-                    (map tp (rule-pict-side-conditions rp))
-                    (map tp (rule-pict-fresh-vars rp))
-                    (map (lambda (v)
-                           (cons (tp (car v)) (tp (cdr v))))
-                         (rule-pict-pattern-binds rp)))))
+                    (map (lambda (v) 
+                           (if (pair? v)
+                               (cons (tp (car v)) (tp (cdr v)))
+                               (tp v)))
+                         (rule-pict-side-conditions/pattern-binds rp))
+                    (map tp (rule-pict-fresh-vars rp)))))
 
 (define current-label-extra-space (make-parameter 0))
 (define reduction-relation-rule-separation (make-parameter 4))
@@ -304,8 +305,7 @@
 
 (define (rp->side-condition-pict rp max-w)
   (side-condition-pict (rule-pict-fresh-vars rp)
-                       (append (rule-pict-side-conditions rp)
-                               (rule-pict-pattern-binds rp))
+                       (rule-pict-side-conditions/pattern-binds rp)
                        max-w))
 
 (define (rp->pict-label rp)
diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss
index 506aee3a0d..7fb622f09a 100644
--- a/collects/redex/private/reduction-semantics.ss
+++ b/collects/redex/private/reduction-semantics.ss
@@ -391,71 +391,66 @@
   (define (rule->lws rule)
     (syntax-case rule ()
       [(arrow lhs rhs stuff ...)
-       (let-values ([(label scs fvars withs)
+       (let-values ([(label scs/withs fvars)
                      (let loop ([stuffs (syntax->list #'(stuff ...))]
                                 [label #f]
-                                [scs null]
-                                [fvars null]
-                                [withs null])
+                                [scs/withs null]
+                                [fvars null])
                        (cond
-                         [(null? stuffs) (values label (reverse scs) (reverse fvars) (reverse withs))]
+                         [(null? stuffs) (values label (reverse scs/withs) (reverse fvars))]
                          [else
                           (syntax-case (car stuffs) (where fresh variable-not-in)
                             [(fresh xs ...) 
                              (loop (cdr stuffs)
                                    label
-                                   scs
+                                   scs/withs
                                    (append 
                                     (reverse (map (λ (x)
-                                                    (syntax-case x ()
-                                                      [x
-                                                       (identifier? #'x)
-                                                       #'x]
-                                                      [(x whatever)
-                                                       (identifier? #'x)
-                                                       #'x]
-                                                      [((y dots) (x dots2))
-                                                       (datum->syntax 
-                                                        #f 
-                                                        `(,(syntax->datum #'y) ...) 
-                                                        #'y)]
-                                                      [((y dots) (x dots2) whatever)
-                                                       (datum->syntax 
-                                                        #f 
-                                                        `(,(syntax->datum #'y) ...) 
-                                                        #'y)]))
+                                                    (to-lw/proc
+                                                     (syntax-case x ()
+                                                       [x
+                                                        (identifier? #'x)
+                                                        #'x]
+                                                       [(x whatever)
+                                                        (identifier? #'x)
+                                                        #'x]
+                                                       [((y dots) (x dots2))
+                                                        (datum->syntax 
+                                                         #f 
+                                                         `(,(syntax->datum #'y) ...) 
+                                                         #'y)]
+                                                       [((y dots) (x dots2) whatever)
+                                                        (datum->syntax 
+                                                         #f 
+                                                         `(,(syntax->datum #'y) ...) 
+                                                         #'y)])))
                                                   (syntax->list #'(xs ...))))
-                                    fvars)
-                                   withs)]
+                                    fvars))]
                             [(where x e)
                              (loop (cdr stuffs)
                                    label
-                                   scs
-                                   fvars
-                                   (cons #'(x e) withs))]
+                                   (cons #`(cons #,(to-lw/proc #'x) #,(to-lw/proc #'e))
+                                         scs/withs)
+                                   fvars)]
                             [(side-condition sc)
                              (loop (cdr stuffs)
                                    label
-                                   (cons #'sc scs)
-                                   fvars
-                                   withs)]
+                                   (cons (to-lw/uq/proc #'sc) scs/withs)
+                                   fvars)]
                             [x
                              (identifier? #'x)
                              (loop (cdr stuffs)
                                    #''x
-                                   scs
-                                   fvars
-                                   withs)]
+                                   scs/withs
+                                   fvars)]
                             [x
                              (string? (syntax-e #'x))
                              (loop (cdr stuffs)
                                    #'x
-                                   scs
-                                   fvars
-                                   withs)])]))])
-         (with-syntax ([(scs ...) scs]
+                                   scs/withs
+                                   fvars)])]))])
+         (with-syntax ([(scs/withs ...) scs/withs]
                        [(fvars ...) fvars]
-                       [((where-id where-expr) ...) withs]
                        [((bind-id . bind-pat) ...) 
                         (extract-pattern-binds #'lhs)]
                        [((tl-id . tl-pat) ...)
@@ -464,9 +459,8 @@
                              #,(to-lw/proc #'lhs)
                              #,(to-lw/proc #'rhs)
                              #,label
-                             (list #,@(map to-lw/uq/proc (syntax->list #'(scs ...))))
-                             (list #,@(map to-lw/proc (syntax->list #'(fvars ...))))
-                             (list #,@(map (λ (bind-id bind-pat)
+                             (list scs/withs ...
+                                   #,@(map (λ (bind-id bind-pat)
                                              #`(cons #,(to-lw/proc bind-id)
                                                      #,(to-lw/proc bind-pat)))
                                            (syntax->list #'(bind-id ...))
@@ -475,12 +469,8 @@
                                              #`(cons #,(to-lw/proc tl-id)
                                                      #,(to-lw/uq/proc tl-pat)))
                                            (syntax->list #'(tl-id ...))
-                                           (syntax->list #'(tl-pat ...)))
-                                   #,@(map (λ (where-id where-expr)
-                                             #`(cons #,(to-lw/proc where-id)
-                                                     #,(to-lw/proc where-expr)))
-                                           (syntax->list #'(where-id ...))
-                                           (syntax->list #'(where-expr ...)))))))]))
+                                           (syntax->list #'(tl-pat ...))))
+                             (list fvars ...))))]))
   
   (define (reduction-relation/helper stx orig-name orig-red-expr lang-id rules shortcuts 
                                      lws 
diff --git a/collects/redex/private/struct.ss b/collects/redex/private/struct.ss
index d080348826..0c69d780da 100644
--- a/collects/redex/private/struct.ss
+++ b/collects/redex/private/struct.ss
@@ -14,7 +14,7 @@
          make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id
          (struct-out rule-pict))
 
-(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
+(define-struct rule-pict (arrow lhs rhs label side-conditions/pattern-binds fresh-vars))
 
 ;; type proc = (exp exp (any -> any) (listof any) -> (listof any)))
 ;;   a proc is a `cached' version of a make-proc, specialized to a particular langugage