added metafunction-cases and fixed a layout bug

svn: r15299

collects/redex/pict.ss

@@ -69,6 +69,7 @@
   (parameter/c reduction-rule-style/c)]
  [arrow-space (parameter/c natural-number/c)]
  [label-space (parameter/c natural-number/c)]
+ [metafunction-cases (parameter/c (or/c #f (and/c pair? (listof (and/c integer? (or/c zero? positive?))))))]
  [metafunction-pict-style 
   (parameter/c (symbols 'left-right
                         'left-right/vertical-side-conditions

collects/redex/private/core-layout.ss

@@ -259,7 +259,9 @@
                [(null? lst) null]
                [(null? (cdr lst))
                 (let ([last (car lst)])
-                  (list (just-before (close-white-square-bracket) last)))]
+                  (list (build-lw "" (lw-line last) 0 (lw-column last) 0)
+                        'spring
+                        (just-after (close-white-square-bracket) last)))]
                [(null? (cddr lst))
                 (cons (car lst) (loop (cdr lst)))]
                [else (list* (car lst) 

collects/redex/private/pict.ss

@@ -45,6 +45,7 @@
          arrow-space
          label-space
          metafunction-pict-style
+         metafunction-cases
          compact-vertical-min-width
          extend-language-show-union
          set-arrow-pict!)
@@ -682,6 +683,35 @@
 (define linebreaks (make-parameter #f))
 
 (define metafunction-pict-style (make-parameter 'left-right))
+(define metafunction-cases (make-parameter #f))
+(define (select-cases eqns)
+  (let ([cases (metafunction-cases)])
+    (if cases
+        (let loop ([eqns eqns]
+                   [cases (remove-dups (sort cases <))]
+                   [i 0])
+          (cond
+            [(null? eqns) null]
+            [(null? cases) null]
+            [else 
+             (cond
+               [(= i (car cases))
+                (cons (car eqns)
+                      (loop (cdr eqns) (cdr cases) (+ i 1)))]
+               [else
+                (loop (cdr eqns) cases (+ i 1))])]))
+        eqns)))
+
+;; remove-dups : (listof number)[sorted] -> (listof number)[sorted]
+;; removes duplicate numbers from 'l'
+(define (remove-dups l)
+  (let loop ([l l])
+    (cond
+      [(null? (cdr l)) l]
+      [(= (car l) (cadr l))
+       (loop (cdr l))]
+      [else
+       (cons (car l) (loop (cdr l)))])))
 
 (define (metafunctions->pict/proc mfs name)
   (unless (andmap (λ (mf) (eq? (metafunc-proc-lang (metafunction-proc (car mfs)))
@@ -693,8 +723,8 @@
          [sep 2]
          [style (metafunction-pict-style)]
          [wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
-         [eqns (apply append (map (λ (mf) (metafunc-proc-pict-info (metafunction-proc mf))) mfs))]
-         [lhss 
+         [all-eqns (apply append (map (λ (mf) (metafunc-proc-pict-info (metafunction-proc mf))) mfs))]
+         [all-lhss 
           (apply append
                  (map (λ (mf)
                         (map (lambda (eqn) 
@@ -704,6 +734,8 @@
                                                    (metafunc-proc-multi-arg? (metafunction-proc mf)))))
                              (metafunc-proc-pict-info (metafunction-proc mf))))
                       mfs))]
+         [eqns (select-cases all-eqns)]
+         [lhss (select-cases all-lhss)]
          [scs (map (lambda (eqn)
                      (if (and (null? (list-ref eqn 1))
                               (null? (list-ref eqn 2)))

collects/redex/redex.scrbl

@@ -1756,15 +1756,29 @@ label on each rule, but only in horizontal mode. Defaults to
 0.
 }
 
-@defparam[metafunction-pict-style style (parameter/c (symbols 'left-right 'up-down 'left-right/vertical-side-conditions 'up-down/vertical-side-conditions))]{
+@defparam[metafunction-pict-style style 
+                                  (or/c 'left-right
+                                        'up-down
+                                        'left-right/vertical-side-conditions
+                                        'up-down/vertical-side-conditions)]{
 
 This parameter controls the style used for typesetting
-metafunctions. The 'left-right style means that the
+metafunctions. The @scheme['left-right] style means that the
 results of calling the metafunction are displayed to the 
-right of the arguments and the 'up-down style means that
+right of the arguments and the @scheme['up-down] style means that
 the results are displayed below the arguments.
 }
 
+@defparam[metafunction-cases 
+          cases
+          (or/c #f (and/c (listof (and/c integer?
+                                         (or/c zero? positive?)))
+                          pair?))]{
+
+This parameter controls which cases in a metafunction are rendered. If it is @scheme[#f] (the default), then all of the
+cases appear. If it is a list of numbers, then only the selected cases appear (counting from @scheme[0]).
+}
+
 @deftogether[[
 @defparam[label-style style text-style/c]{}
 @defparam[literal-style style text-style/c]{}