From e8e2898359c4aa92577f06cb8f885dcf0f8ce824 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Tue, 24 May 2011 11:03:34 -0500
Subject: [PATCH] Fixes rendering of relations with `name' patterns

---
 collects/redex/private/pict.rkt               |  29 +++++++++---------
 collects/redex/tests/bitmap-test.rkt          |   7 ++++-
 .../tests/bmps-macosx/relation-with-name.png  | Bin 0 -> 1496 bytes
 3 files changed, 20 insertions(+), 16 deletions(-)
 create mode 100644 collects/redex/tests/bmps-macosx/relation-with-name.png

diff --git a/collects/redex/private/pict.rkt b/collects/redex/private/pict.rkt
index 1020c95daf..717701fe4f 100644
--- a/collects/redex/private/pict.rkt
+++ b/collects/redex/private/pict.rkt
@@ -150,7 +150,7 @@
                                 (tp rewritten))))
                     (map (lambda (v) 
                            (if (pair? v)
-                               (cons (tp (car v)) (tp (cdr v)))
+                               (where-pict (tp (car v)) (tp (cdr v)))
                                (tp v)))
                          (rule-pict-side-conditions/pattern-binds rp))
                     (map tp (rule-pict-fresh-vars rp)))))
@@ -306,9 +306,7 @@
                ltl-superimpose ltl-superimpose
                2 2))))
 
-;; side-condition-pict : (listof pict) (listof (or/c (cons/c pict pict) pict)) number -> pict
-;; the elements of pattern-binds/sc that are pairs are bindings (ie "x = <something>")
-;;     and the elements of pattern-binds/sc that are just picts are just plain side-conditions
+;; side-condition-pict : (listof pict) (listof pict) number -> pict
 (define (side-condition-pict fresh-vars pattern-binds/sc max-w)
   (let* ([frsh 
           (if (null? fresh-vars)
@@ -321,18 +319,10 @@
                   (basic-text ", " (default-style))
                   fresh-vars))
                 (basic-text " fresh" (default-style)))))]
-         [binds (map (lambda (b)
-                       (if (pair? b)
-                           (htl-append
-                            (car b)
-                            (make-=)
-                            (cdr b))
-                           b))
-                     pattern-binds/sc)]
          [lst (add-between
                'comma
                (append
-                binds
+                pattern-binds/sc
                 frsh))])
     (if (null? lst)
         (blank)
@@ -350,6 +340,9 @@
                                         (loop (car lst) (cdr lst)))]
                             [else (loop (htl-append p (car lst)) (cdr lst))]))))))))
 
+(define (where-pict lhs rhs)
+  (htl-append lhs (make-=) rhs))
+
 (define (rp->side-condition-pict rp max-w)
   (side-condition-pict (rule-pict-fresh-vars rp)
                        (rule-pict-side-conditions/pattern-binds rp)
@@ -857,7 +850,7 @@
                                                        '() fresh)
                                                 (map (match-lambda
                                                       [(struct metafunc-extra-where (lhs rhs))
-                                                       (cons (wrapper->pict lhs) (wrapper->pict rhs))]
+                                                       (where-pict (wrapper->pict lhs) (wrapper->pict rhs))]
                                                       [(struct metafunc-extra-side-cond (expr))
                                                        (wrapper->pict expr)])
                                                      where/sc)
@@ -1070,7 +1063,13 @@
                (metafunc-proc-pict-info (metafunction-proc mf)))]
          [eqns (select-cases all-eqns)]
          [conclusions (select-cases all-conclusions)]
-         [premisess (map (lambda (eqn) (map wrapper->pict (list-ref eqn 2))) eqns)])
+         [premisess (map (lambda (eqn)
+                           (append (map wrapper->pict (list-ref eqn 2))
+                                   (map (match-lambda
+                                          [(struct metafunc-extra-where (lhs rhs))
+                                           (where-pict (wrapper->pict lhs) (wrapper->pict rhs))])
+                                        (list-ref eqn 1))))
+                         eqns)])
     ((relation-clauses-combine)
      (for/list ([conclusion (in-list conclusions)]
                 [premises (in-list premisess)])
diff --git a/collects/redex/tests/bitmap-test.rkt b/collects/redex/tests/bitmap-test.rkt
index 3cfd2663bc..e231d693e4 100644
--- a/collects/redex/tests/bitmap-test.rkt
+++ b/collects/redex/tests/bitmap-test.rkt
@@ -250,7 +250,12 @@
     [(r x)])
   (test (render-relation r) "relation.png"))
 
-    
+(let ()
+  ;; a relation with a `name' pattern in its conclusion
+  (define-relation lang
+    [(r (name e (λ (x) x)))
+     (r x)])
+  (test (render-relation r) "relation-with-name.png"))    
 
 (printf "bitmap-test.ss: ")
 (done)
diff --git a/collects/redex/tests/bmps-macosx/relation-with-name.png b/collects/redex/tests/bmps-macosx/relation-with-name.png
new file mode 100644
index 0000000000000000000000000000000000000000..5a8f1dd6127c285ae2567b119cd4732369ed28a6
GIT binary patch
literal 1496
zcmV;}1t<E6P)<h;3K|Lk000e1NJLTq0049V001Tk0ssI2n!YHE00006VoOIv0RI60
z0RN!9r;`8x1&v8WK~!jg?V4XmT5lM~-;>A68(WccmC!~P6~++S*rpP!Kf4)>?8o9P
zbFt{A!a-~>=57WhL}IjMQH0d~1i~2fXMfmCq9CD0;8>Gc5ed$muC1K1W}3f?GvwtQ
z(^JcNCVsA-bI$jB-sgRMdC$>DBp3{W#AR!1D?L3uJv}`xqo<HhiN#`>O!n;AvkMn4
z;KBCxHd$senI1iQbn4V8g+hS`{r&y1PdGY0pHHLFc)eZ#Kx=C&m&=`*nW1hW@c#XK
zy<SgoXreesLL?Hsc<}-bB7k9-Mx%j)_~P^VZrr%xa=Gxsy}iBm_V&`!QtB2mlarGp
zBO??OfW;{uk4GdDEi5e5)YNo!bx~a&5D0=0f;jTz$&=HkPiJRm<A(@>+_`hdY&O4p
z_l}~4%;n3Mhlhtf9uJiSU~!7y?>8Ea7>4ca?1;tU1I~qB1cO1PQdwPH4WBd`jX!_>
z92^{^ZXtjmh)5(F7#N_E11$c%=hoKNzIydaC=~AJ@%#M~6BD_)xl2n+FJHbC2n1HE
zmC9g;z-%_F)oQg`tyC)E^9qF`m&Ahy4?=>^pFdlz*8Kc@*rnBKD=I2<I-T3?CXYq1
z>^IGll9H*ZDS|hu7{zswKRN&ailSGpTp1r9SE*DonapG|QK-^k(ChWx-Q5!t6C)!d
z>+9?ACAnNKl}ZWv<HwJO;?>nv4u=EpPHwmR`Sa&*-@a{YYa1OMZEkKR*a?>XrkR<U
zxw5iC@J1E?Ub$>Go65{DUc9)rwpLkLNkx1JoKB}yDs5?L>Fw=ZU0qeFRPfcDoE$z0
z4u=yGkk_V8r{i+DLZPs(t}g7(5Oz6}r^#ZmTrOAGoFj<Q=re}+`t|Gb^74T!2V#7D
zoWtRyrKQQ`awd~Wxcczn!?Ce3!pX+Q#`^ktJT5FObUK}ZK!Cwu;Aga2tyC&S5Cp@p
z+qZAe&(EJbcMi6bEg;-9H#awVJYLwGBZv=B+}YXLs;a7<o}Q(pB@{)Aii)UvDdP2d
zv$L}=UAhDSuvjc7Po7LmOAB2sD=W*(%OhC$e10e{C@4rxO?5h*IXO81fR7(PE-WlO
ze*72!aN@*?^73-ETCLORQc_a(v+Orbhr<C66e6-X%$Eo<27{rrv~+iOm(S-{S6AP?
zdl$~{2)TCcn%!=1Y-}7I9o^d6f-4IE5C{bSk$^vA6h-B7`QqXteyG)I&zw0^SXhW3
zc64;i&CMwk3izI|CBiff2183r3v8q$Ccg$B^h-ovUmqOAm+kFs48xArVzb$<U%yWA
zZm>A~0-T$hTUl8N27`Fu^ZCe{Z{NOIES9ykHLur;2NaiQOkuOx3Weh7)2Bye+1%Vz
zsZ>KlLsV`>5F^1v{NcuKx3gHR%*@O`w|w~Up}4phMJYX;2;#&nE=`EZb14Z<vbZrM
zS==Q5Cdmg{3`uSaF(g^s7?Lb*3`rI@hA{5mzaQ@$!XOrlr>Ca_fk0DJ)6C3FAQ0g3
zc;vqym`tWOZ{A2G5~tH?v)LpPNos29*|TTkk~10lu3QYmu3o*$U@-6?BO`;X5eNhg
z4GrhdpU=z7!vk8q{LrGf3D({ZL5t!hQhOifU_G>$Qd?Ww+1VLYW;UB&zkUq>*xA{+
zckf>8^Ey1VSh+Y++xq|jy<UIo)~%a2Z?f5Jhr{s~vicKfv~r`i_wmNNR;%sp?fvrQ
z3!(8&Lugdos6=kO(-0bM3sDI*-kD6M#bWvO>sP!pio(BC+{lf08bXV0;n=ZbR9^nM
zT<-Gn^7rrGv$C@OLRNnceOGSS_CA6jaAoP)-VZ_3AIm>|`t;++4*&p@$=u!D1pt(k
yl(1MVg3M;KZES47vi$sf_<xV_g{H+#4E_g41z$8aVu8#60000<MNUMnLSTZloZYzq

literal 0
HcmV?d00001