diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index 5614499d40..234479f153 100644 --- a/collects/redex/private/pict.ss +++ b/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)]) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 38c6f72a5d..d17da17341 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/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)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 5607b322df..5ccef04d8d 100644 --- a/collects/redex/redex.scrbl +++ b/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 diff --git a/collects/redex/tests/bitmap-test.ss b/collects/redex/tests/bitmap-test.ss index 9bc12d9697..350708f8c8 100644 --- a/collects/redex/tests/bitmap-test.ss +++ b/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) diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png index 631aa05f6d..32fe0babfc 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png and b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name.png b/collects/redex/tests/bmps-macosx/metafunction-Name.png index e4f7dc5331..58452d8229 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name.png and b/collects/redex/tests/bmps-macosx/metafunction-Name.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-T.png b/collects/redex/tests/bmps-macosx/metafunction-T.png index 23606d0bd5..a9d5a093b6 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-T.png and b/collects/redex/tests/bmps-macosx/metafunction-T.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png index 84b93559ce..3b40817a40 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png and b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png differ diff --git a/collects/redex/tests/bmps-macosx/mf-hidden.png b/collects/redex/tests/bmps-macosx/mf-hidden.png new file mode 100644 index 0000000000..8545f0f19b Binary files /dev/null and b/collects/redex/tests/bmps-macosx/mf-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/rr-hidden.png b/collects/redex/tests/bmps-macosx/rr-hidden.png new file mode 100644 index 0000000000..46e14cf703 Binary files /dev/null and b/collects/redex/tests/bmps-macosx/rr-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in.png b/collects/redex/tests/bmps-macosx/var-not-in.png index e6efc40fec..0b27baf538 100644 Binary files a/collects/redex/tests/bmps-macosx/var-not-in.png and b/collects/redex/tests/bmps-macosx/var-not-in.png differ