Fixes handling of where/hidden and side-condition/hidden clauses in reduction-relation.

svn: r18683

collects/redex/private/pict.ss

@@ -792,10 +792,7 @@
                                             (* 2 sep)))))
                                   lhss rhss linebreak-list))]
          [scs (map (lambda (eqn)
-                     (let ([scs (filter (lambda (v)
-                                          (not (or (metafunc-extra-side-cond/hidden? v)
-                                                   (metafunc-extra-where/hidden? v))))
-                                        (reverse (list-ref eqn 1)))])
+                     (let ([scs (reverse (list-ref eqn 1))])
                      (if (null? scs)
                          #f
                          (let-values ([(fresh where/sc) (partition metafunc-extra-fresh? scs)])

collects/redex/private/reduction-semantics.ss

@@ -406,7 +406,9 @@
                        (cond
                          [(null? stuffs) (values label (reverse scs/withs) (reverse fvars))]
                          [else
-                          (syntax-case (car stuffs) (fresh variable-not-in)
+                          (syntax-case (car stuffs) (where where/hidden
+                                                           side-condition side-condition/hidden
+                                                           fresh variable-not-in)
                             [(fresh xs ...) 
                              (loop (cdr stuffs)
                                    label
@@ -433,21 +435,21 @@
                                                          #'y)])))
                                                   (syntax->list #'(xs ...))))
                                     fvars))]
-                            [(-where x e)
-                             (or (free-identifier=? #'-where #'where)
-                                 (free-identifier=? #'-where #'where/hidden))
+                            [(where x e)
                              (loop (cdr stuffs)
                                    label
                                    (cons #`(cons #,(to-lw/proc #'x) #,(to-lw/proc #'e))
                                          scs/withs)
                                    fvars)]
-                            [(-side-condition sc)
-                             (or (free-identifier=? #'-side-condition #'side-condition)
-                                 (free-identifier=? #'-side-condition #'side-condition/hidden))
+                            [(where/hidden x e)
+                             (loop (cdr stuffs) label scs/withs fvars)]
+                            [(side-condition sc)
                              (loop (cdr stuffs)
                                    label
                                    (cons (to-lw/uq/proc #'sc) scs/withs)
                                    fvars)]
+                            [(side-condition/hidden sc)
+                             (loop (cdr stuffs) label scs/withs fvars)]
                             [x
                              (identifier? #'x)
                              (loop (cdr stuffs)
@@ -1051,9 +1053,7 @@
 
 ;; Intermediate structures recording clause "extras" for typesetting.
 (define-struct metafunc-extra-side-cond (expr))
-(define-struct (metafunc-extra-side-cond/hidden metafunc-extra-side-cond) ())
 (define-struct metafunc-extra-where (lhs rhs))
-(define-struct (metafunc-extra-where/hidden metafunc-extra-where) ())
 (define-struct metafunc-extra-fresh (vars))
 
 (define-syntax (in-domain? stx)
@@ -1289,9 +1289,7 @@
                                                                          (map (λ (hm)
                                                                                 (map
                                                                                  (λ (lst)
-                                                                                   (syntax-case lst (unquote
-                                                                                                     side-condition where
-                                                                                                     side-condition/hidden where/hidden)
+                                                                                   (syntax-case lst (unquote side-condition where)
                                                                                      [(where pat (unquote (f _ _)))
                                                                                       (and (or (identifier? #'pat)
                                                                                                (andmap identifier? (syntax->list #'pat)))
@@ -1307,16 +1305,17 @@
                                                                                      [(where pat exp)
                                                                                       #`(make-metafunc-extra-where
                                                                                          #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
-                                                                                     [(where/hidden pat exp)
-                                                                                      #`(make-metafunc-extra-where/hidden
-                                                                                         #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
                                                                                      [(side-condition x)
                                                                                       #`(make-metafunc-extra-side-cond
-                                                                                         #,(to-lw/uq/proc #'x))]
-                                                                                     [(side-condition/hidden x)
-                                                                                      #`(make-metafunc-extra-side-cond/hidden
                                                                                          #,(to-lw/uq/proc #'x))]))
-                                                                                 (reverse (syntax->list hm))))
+                                                                                 (reverse 
+                                                                                  (filter (λ (lst)
+                                                                                            (syntax-case lst (where/hidden
+                                                                                                              side-condition/hidden)
+                                                                                              [(where/hidden pat exp) #f]
+                                                                                              [(side-condition/hidden x) #f]
+                                                                                              [_ #t])) 
+                                                                                          (syntax->list hm)))))
                                                                               (syntax->list #'(... seq-of-tl-side-cond/binds)))]
                                                                         
                                                                         [(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
@@ -2185,9 +2184,7 @@
          (struct-out metafunc-case)
          
          (struct-out metafunc-extra-side-cond)
-         (struct-out metafunc-extra-side-cond/hidden)
          (struct-out metafunc-extra-where)
-         (struct-out metafunc-extra-where/hidden)
          (struct-out metafunc-extra-fresh)
          
          (struct-out binds))

collects/redex/redex.scrbl

@@ -682,7 +682,9 @@ all non-GUI portions of Redex) and also exported by
                [extras name
                        (fresh fresh-clause ...)
                        (side-condition scheme-expression)
-                       (where tl-pat @#,tttterm)]
+                       (where tl-pat @#,tttterm)
+                       (side-condition/hidden scheme-expression)
+                       (where/hidden tl-pat @#,tttterm)]
                [fresh-clause var ((var1 ...) (var2 ...))]
                [tl-pat identifier (tl-pat-ele ...)]
                [tl-pat-ele tl-pat (code:line tl-pat ... (code:comment "a literal ellipsis"))])]{
@@ -717,15 +719,22 @@ a sequence of variables. The variable @scheme[var2] is used to
 determine the number of variables generated and @scheme[var2] must be
 bound by the left-hand side of the rule.
 
-The side-conditions are expected to all hold, and have the
-format of the second argument to the @pattech[side-condition] pattern,
-described above.
+All side-conditions provided with @scheme[side-condition] and
+@scheme[hidden-side-condition] are collected with @scheme[and] and
+used as guards on the case being matched. The argument to each
+side-condition should be a Scheme expression, and the pattern
+variables in the @|ttpattern| are bound in that expression. A
+@scheme[side-condition/hidden] form is the same as
+@scheme[side-condition], except that the side condition is not
+rendered when typesetting via @schememodname[redex/pict].
 
 Each @scheme[where] clause acts as a side condition requiring a
 successful pattern match, and it can bind pattern variables in the
 side-conditions (and @scheme[where] clauses) that follow and in the
-reduction result. The bindings are the same as bindings in a
-@scheme[term-let] expression.
+metafunction result. The bindings are the same as bindings in a
+@scheme[term-let] expression. A @scheme[where/hidden] clause is the
+same as a @scheme[where] clause, but the clause is not
+rendered when typesetting via @schememodname[redex/pict].
 
 As an example, this
 
@@ -905,22 +914,9 @@ expressions. The first argument indicates the language used
 to resolve non-terminals in the pattern expressions. Each of
 the rhs-expressions is implicitly wrapped in @|tttterm|. 
 
-All side-conditions provided with @scheme[side-condition] and
-@scheme[hidden-side-condition] are collected with @scheme[and] and
-used as guards on the case being matched. The argument to each
-side-condition should be a Scheme expression, and the pattern
-variables in the @|ttpattern| are bound in that expression. A
-@scheme[side-condition/hidden] form is the same as
-@scheme[side-condition], except that the side condition is not
-rendered when typesetting via @schememodname[redex/pict].
-
-Each @scheme[where] clause acts as a side condition requiring a
-successful pattern match, and it can bind pattern variables in the
-side-conditions (and @scheme[where] clauses) that follow and in the
-metafunction result. The bindings are the same as bindings in a
-@scheme[term-let] expression. A @scheme[where/hidden] clause is the
-same as a @scheme[where] clause, but the clause is not
-rendered when typesetting via @schememodname[redex/pict].
+The @scheme[side-condition], @scheme[hidden-side-condition],
+@scheme[where], and @scheme[where/hidden] clauses behave as
+in the @scheme[reduction-relation] form.
 
 Raises an exception recognized by @scheme[exn:fail:redex?] if
 no clauses match, if one of the clauses matches multiple ways

collects/redex/tests/bitmap-test.ss

@@ -178,5 +178,21 @@
      (where x ,(variable-not-in 'y 'x))])
   (test (render-metafunction g) "var-not-in-rebound.png"))
 
+;; hidden `where' and `side-condition' clauses
+(define-metafunction lang
+  [(mf-hidden 1)
+   2
+   (where/hidden number 7)
+   (side-condition/hidden (= 1 2))])
+(test (render-metafunction mf-hidden) "mf-hidden.png")
+(test (render-reduction-relation
+       (reduction-relation
+        lang
+        (--> 1
+             2
+             (where/hidden number 7)
+             (side-condition/hidden (= 1 2)))))
+      "rr-hidden.png")
+
 (printf "bitmap-test.ss: ")
 (done)