From 7804143400b9cab01aad3e8af57f7da2d01d2b8c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Jun 2009 01:19:45 +0000 Subject: [PATCH] merge from branch branches/robby/redex-pat2; improved where patterns and a few bug fixes svn: r15294 --- collects/redex/gui.ss | 1 + collects/redex/private/color-test.ss | 10 +- collects/redex/private/reduction-semantics.ss | 313 ++++++++++++------ collects/redex/private/rg-test.ss | 10 +- collects/redex/private/rg.ss | 5 +- collects/redex/private/test-util.ss | 5 +- collects/redex/private/tl-test.ss | 95 ++++-- collects/redex/private/traces.ss | 4 + collects/redex/redex.scrbl | 11 +- 9 files changed, 313 insertions(+), 141 deletions(-) diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index c97233b178..8e978cdd28 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -67,6 +67,7 @@ [term-node-set-color! (-> term-node? (or/c string? (is-a?/c color%) false/c) void?)] + [term-node-color (-> term-node? (or/c string? (is-a?/c color%) false/c))] [term-node-expr (-> term-node? any)] [term-node-set-position! (-> term-node? real? real? void?)] [term-node-x (-> term-node? real?)] diff --git a/collects/redex/private/color-test.ss b/collects/redex/private/color-test.ss index e010120f9a..d13d212756 100644 --- a/collects/redex/private/color-test.ss +++ b/collects/redex/private/color-test.ss @@ -35,7 +35,8 @@ In the other window, you expect to see the currently unreducted terms in green a (floor (- 255 (* val (/ 255 max-val)))) 0 (floor (* val (/ 255 max-val))))))) - parents))) + parents) + (term-node-color term-node))) (define-language empty-language) @@ -52,10 +53,9 @@ In the other window, you expect to see the currently unreducted terms in green a (define-language empty-language) (define (last-color-pred sexp term-node) - (term-node-set-color! term-node - (if (null? (term-node-children term-node)) - "green" - "white"))) + (if (null? (term-node-children term-node)) + "green" + "white")) (traces (reduction-relation empty-language diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index da20055d94..eaaf1a49d9 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -221,32 +221,68 @@ (syntax/loc stx (do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...))])) ;; the withs, freshs, and side-conditions come in backwards order -(define-for-syntax (bind-withs orig-name main stx body) +(define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body) (let loop ([stx stx] - [body body]) + [body body] + [bindings '()]) (syntax-case stx (side-condition where fresh) - [() body] - [((where x e) y ...) - (loop #'(y ...) #`(term-let ([x (term e)]) #,body))] + [() (values body bindings)] + [((where x e) y ...) + (let-values ([(names names/ellipses) (extract-names lang-nts 'reduction-relation #t #'x)]) + (with-syntax ([(cpat) (generate-temporaries '(compiled-pattern))] + [side-conditions-rewritten (rewrite-side-conditions/check-errs + lang-nts + 'reduction-relation + #f + #'x)] + [(names ...) names] + [(names/ellipses ...) names/ellipses]) + (loop #'(y ...) + #`(let ([mtchs (match-pattern cpat (term e))]) + (if mtchs + #, + (case where-mode + [(flatten) + #`(apply + append + (map (λ (mtch) + (let ([bindings (mtch-bindings mtch)]) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + #,body))) + mtchs))] + [(predicate) + #`(andmap (λ (mtch) + (let ([bindings (mtch-bindings mtch)]) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + #,body))) + mtchs)] + [else (error 'unknown-where-mode "~s" where-mode)]) + #f)) + (cons #`[cpat (compile-pattern #,lang `side-conditions-rewritten #t)] + bindings))))] [((side-condition s ...) y ...) - (loop #'(y ...) #`(and s ... #,body))] + (loop #'(y ...) #`(and s ... #,body) bindings)] [((fresh x) y ...) (identifier? #'x) - (loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))] + (loop #'(y ...) + #`(term-let ([x (variable-not-in #,main 'x)]) #,body) + bindings)] [((fresh x name) y ...) (identifier? #'x) (loop #'(y ...) #`(term-let ([x (let ([the-name (term name)]) (verify-name-ok '#,orig-name the-name) (variable-not-in #,main the-name))]) - #,body))] + #,body) + bindings)] [((fresh (y) (x ...)) z ...) (loop #'(z ...) #`(term-let ([(y #,'...) (variables-not-in #,main (map (λ (_ignore_) 'y) (term (x ...))))]) - #,body))] + #,body) + bindings)] [((fresh (y) (x ...) names) z ...) (loop #'(z ...) #`(term-let ([(y #,'...) @@ -254,9 +290,8 @@ [len-counter (term (x ...))]) (verify-names-ok '#,orig-name the-names len-counter) (variables-not-in #,main the-names))]) - #,body))]))) - -(define-struct successful (result)) + #,body) + bindings)]))) (define-syntax-set (do-reduction-relation) (define (do-reduction-relation/proc stx) @@ -651,25 +686,67 @@ (let* ([lang-nts (language-id-nts lang-id orig-name)] [rw-sc (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))]) (let-values ([(name sides/withs/freshs) (process-extras stx orig-name name-table extras)]) - (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)]) + (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)] + [(body-code compile-pattern-bindings) + (bind-withs orig-name + #'main-exp + lang + lang-nts + sides/withs/freshs + 'flatten + #`(list (term #,to)))] + [(test-case-body-code test-case-compile-pattern-bindings) + ;; this contains some redundant code, eg. the test-case-compile-pattern-bindings + ;; are (morally) the same as the compile-pattern-bindings + (bind-withs orig-name + #'#t + lang + lang-nts + sides/withs/freshs + 'predicate + #'#t)]) (with-syntax ([side-conditions-rewritten (rw-sc from)] - [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs orig-name #'#t sides/withs/freshs #'#t)))] - [to to] + [lhs-w/extras (rw-sc #`(side-condition + #,from + #,test-case-body-code))] [name name] [lang lang] [(names ...) names] - [(names/ellipses ...) names/ellipses]) - #`(do-leaf-match + [(names/ellipses ...) names/ellipses] + [body-code body-code] + [(test-case-compile-pattern-bindings ...) test-case-compile-pattern-bindings] + [(compile-pattern-bindings ...) compile-pattern-bindings]) + #` + (let ([case-id (gensym)]) + (make-rewrite-proc + (λ (lang) + (let ([cp (compile-pattern lang `side-conditions-rewritten #t)] + compile-pattern-bindings ...) + (λ (main-exp exp f other-matches) + (let ([mtchs (match-pattern cp exp)]) + (if mtchs + (let loop ([mtchs mtchs] + [acc other-matches]) + (cond + [(null? mtchs) acc] + [else + (let* ([mtch (car mtchs)] + [bindings (mtch-bindings mtch)] + [really-matched + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + body-code)]) + (cond + [really-matched + (when (relation-coverage) + (cover-case case-id name (relation-coverage))) + (loop (cdr mtchs) + (map/mt (λ (x) (list name (f x))) really-matched acc))] + [else + (loop (cdr mtchs) acc)]))])) + other-matches))))) name - `side-conditions-rewritten - `lhs-w/extras - (λ (main bindings) - ;; nested term-let's so that the bindings for the variables - ;; show up in the `fresh' side-conditions, the bindings for the variables - ;; show up in the withs, and the withs show up in the 'fresh' side-conditions - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - #,(bind-withs orig-name #'main sides/withs/freshs - #'(make-successful (term to))))))))))) + (λ (lang) (let (test-case-compile-pattern-bindings ...) `lhs-w/extras)) + case-id))))))) (define (process-extras stx orig-name name-table extras) (let ([the-name #f] @@ -751,6 +828,8 @@ [_ (raise-syntax-error orig-name "unknown extra" stx (car extras))])])))) + + ;; table-cons! hash-table sym any -> void ;; extends ht at key by `cons'ing hd onto whatever is alrady bound to key (or the empty list, if nothing is) (define (table-cons! ht key hd) @@ -859,7 +938,7 @@ acc)))])) other-matches))))) (rewrite-proc-name child-make-proc) - (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from) + (λ (lang) (subst lhs-frm-id ((rewrite-proc-lhs child-make-proc) lang) rhs-from)) (rewrite-proc-id child-make-proc))) (define relation-coverage (make-parameter #f)) @@ -884,27 +963,6 @@ (reduction-relation-make-procs relation)) (make-coverage h))) -(define (do-leaf-match name pat w/extras proc) - (let ([case-id (gensym)]) - (make-rewrite-proc - (λ (lang) - (let ([cp (compile-pattern lang pat #t)]) - (λ (main-exp exp f other-matches) - (let ([mtchs (match-pattern cp exp)]) - (if mtchs - (map/mt (λ (mtch) - (let ([really-matched (proc main-exp (mtch-bindings mtch))]) - (and really-matched - (when (relation-coverage) - (cover-case case-id name (relation-coverage))) - (list name (f (successful-result really-matched)))))) - mtchs - other-matches) - other-matches))))) - name - w/extras - case-id))) - (define-syntax (test-match stx) (syntax-case stx () [(_ lang-exp pattern) @@ -986,7 +1044,6 @@ ; ; - (define-syntax-set (define-metafunction define-metafunction/extension define-relation) (define (define-metafunction/proc stx) @@ -1061,15 +1118,42 @@ (tl-side-cond/binds ...)) (parse-extras #'((stuff ...) ...))]) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) - (with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t)) - (syntax->list #'(tl-side-cond/binds ...)))]) + (with-syntax ([(((cp-let-bindings ...) rhs/wheres) ...) + (map (λ (sc/b rhs) + (let-values ([(body-code cp-let-bindings) + (bind-withs + syn-error-name '() + #'lang lang-nts + sc/b 'flatten + #`(list (term #,rhs)))]) + (list cp-let-bindings body-code))) + (syntax->list #'(tl-side-cond/binds ...)) + (syntax->list #'(rhs ...)))] + [(((rg-cp-let-bindings ...) rg-rhs/wheres) ...) + (map (λ (sc/b rhs) + (let-values ([(body-code cp-let-bindings) + (bind-withs + syn-error-name '() + #'lang lang-nts + sc/b 'predicate + #`#t)]) + (list cp-let-bindings body-code))) + (syntax->list #'(tl-side-cond/binds ...)) + (syntax->list #'(rhs ...)))]) (with-syntax ([(side-conditions-rewritten ...) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts syn-error-name #t x)) - (syntax->list (syntax ((side-condition lhs tl-withs) ...))))] + (syntax->list (syntax (lhs ...))))] + [(rg-side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))] [dom-side-conditions-rewritten (and dom-ctcs (rewrite-side-conditions/check-errs @@ -1084,21 +1168,21 @@ #f codom-contract)] [(rhs-fns ...) - (map (λ (lhs rhs bindings) + (map (λ (lhs rhs/where bindings) (let-values ([(names names/ellipses) (extract-names lang-nts syn-error-name #t lhs)]) (with-syntax ([(names ...) names] [(names/ellipses ...) names/ellipses] - [rhs rhs] + [rhs/where rhs/where] [((tl-var tl-exp) ...) bindings]) (syntax (λ (name bindings) (term-let-fn ((name name)) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (term-let ([tl-var (term tl-exp)] ...) - (term rhs))))))))) + rhs/where)))))))) (syntax->list (syntax (lhs ...))) - (syntax->list (syntax (rhs ...))) + (syntax->list (syntax (rhs/wheres ...))) (syntax->list (syntax (tl-bindings ...))))] [(name2 name-predicate) (generate-temporaries (syntax (name name)))] [((side-cond/lw/uq ...) ...) @@ -1123,41 +1207,44 @@ #`(begin (define-values (name2 name-predicate) (let ([sc `(side-conditions-rewritten ...)] - [dsc `dom-side-conditions-rewritten]) - (build-metafunction - lang - sc - (list rhs-fns ...) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) - #''()) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) - #''()) - (λ (f/dom cps rhss) - (make-metafunc-proc - (let ([name (lambda (x) (f/dom x))]) name) - (list (list lhs-for-lw - (list side-cond/lw/uq ...) - (list (cons bind-id/lw bind-pat/lw) ... - (cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ... - (cons where-id/lw where-pat/lw) ...) - rhs/lw) - ...) - lang - #t ;; multi-args? - 'name - cps - rhss - (let ([name (lambda (x) (name-predicate x))]) name) - dsc - sc)) - dsc - `codom-side-conditions-rewritten - 'name - #,relation?))) + [dsc `dom-side-conditions-rewritten] + cp-let-bindings ... ... + rg-cp-let-bindings ... ...) + (let ([rg-sc `(rg-side-conditions-rewritten ...)]) + (build-metafunction + lang + sc + (list rhs-fns ...) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) + #''()) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) + #''()) + (λ (f/dom cps rhss) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x))]) name) + (list (list lhs-for-lw + (list side-cond/lw/uq ...) + (list (cons bind-id/lw bind-pat/lw) ... + (cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ... + (cons where-id/lw where-pat/lw) ...) + rhs/lw) + ...) + lang + #t ;; multi-args? + 'name + cps + rhss + (let ([name (lambda (x) (name-predicate x))]) name) + dsc + rg-sc)) + dsc + `codom-side-conditions-rewritten + 'name + #,relation?)))) (term-define-fn name name2)) 'disappeared-use (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))))] @@ -1317,8 +1404,9 @@ (cdr rhss) (+ num 1))] [relation? - (let ([ans (ormap (λ (mtch) (rhs traced-metafunc (mtch-bindings mtch))) - mtchs)]) + (let ([ans + (ormap (λ (mtch) (ormap values (rhs traced-metafunc (mtch-bindings mtch)))) + mtchs)]) (unless (match-pattern codom-compiled-pattern ans) (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) (cond @@ -1329,19 +1417,34 @@ (loop (cdr patterns) (cdr rhss) (+ num 1))]))] - [(not (null? (cdr mtchs))) - (redex-error name "~a matched ~s ~a different ways" - (if (< num 0) - "a clause from an extended metafunction" - (format "clause ~a" num)) - `(,name ,@exp) - (length mtchs))] [else - (let ([ans (rhs traced-metafunc (mtch-bindings (car mtchs)))]) - (unless (match-pattern codom-compiled-pattern ans) - (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) - (hash-set! cache exp ans) - ans)])))]))] + (let ([anss (apply append + (filter values + (map (λ (mtch) (rhs traced-metafunc (mtch-bindings mtch))) + mtchs)))] + [ht (make-hash)]) + (for-each (λ (ans) (hash-set! ht ans #t)) anss) + (cond + [(null? anss) + (loop (cdr patterns) + (cdr rhss) + (+ num 1))] + [(not (= 1 (hash-count ht))) + (redex-error name "~a matched ~s ~a different ways and returned different results" + (if (< num 0) + "a clause from an extended metafunction" + (format "clause ~a" num)) + `(,name ,@exp) + (length mtchs))] + [else + (let ([ans (car anss)]) + (unless (match-pattern codom-compiled-pattern ans) + (redex-error name + "codomain test failed for ~s, call was ~s" + ans + `(,name ,@exp))) + (hash-set! cache exp ans) + ans)]))])))]))] [else cache-ref])))] [ot (current-trace-print-args)] diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 499b63e387..6a7e93fc9c 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -710,7 +710,7 @@ (define-metafunction empty g : number ... -> (any ...) - [(g number_1 ... 1 number_2 ...) ()]) + [(g number_1 ... 1 number_2 ...) (number_1 ...)]) (define-metafunction empty h : number -> number @@ -796,10 +796,10 @@ (let ([T (reduction-relation L (==> number number - (where num number) - (side-condition (eq? (term num) 4)) - (where numb num) - (side-condition (eq? (term numb) 4))) + (where any_num number) + (side-condition (eq? (term any_num) 4)) + (where any_numb any_num) + (side-condition (eq? (term any_numb) 4))) with [(--> (9 a) b) (==> a b)])]) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index be8da98838..2d627a047f 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -778,7 +778,7 @@ #`(let ([r #,source-stx]) (assert-rel 'redex-check r) (values - (map rewrite-proc-lhs (reduction-relation-make-procs r)) + (map (λ (x) ((rewrite-proc-lhs x) lang)) (reduction-relation-make-procs r)) (reduction-relation-srcs r) (reduction-relation-lang r)))])]) (check-prop-srcs @@ -935,7 +935,8 @@ (assert-rel 'check-reduction-relation rel) (check-prop-srcs (reduction-relation-lang rel) - (map rewrite-proc-lhs (reduction-relation-make-procs rel)) + (map (λ (x) ((rewrite-proc-lhs x) (reduction-relation-lang rel))) + (reduction-relation-make-procs rel)) (reduction-relation-srcs rel) (λ (term _) (property term)) decisions@ diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss index 3bd55be7b4..627e351dc5 100644 --- a/collects/redex/private/test-util.ss +++ b/collects/redex/private/test-util.ss @@ -43,9 +43,10 @@ (define (test/proc run expected line filename) ;(printf "testing line ~s:~s\n" filename line) - (let ([got (run)]) + (let ([got (with-handlers ((exn:fail? values)) (run))]) (set! tests (+ tests 1)) - (unless (matches? got expected) + (unless (and (not (exn? got)) + (matches? got expected)) (set! failures (+ 1 failures)) (fprintf (current-error-port) "test/proc: file ~a line ~a:\n got ~s\nexpected ~s\n\n" diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index e1ee54b582..9c06ea1811 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -303,7 +303,7 @@ ;; match one clause two ways => error (let () (define-metafunction empty-language - [(ll (number_1 ... number_2 ...)) 4]) + [(ll (number_1 ... number_2 ...)) (number_1 ...)]) (test (with-handlers ((exn? (λ (x) 'exn-raised))) (term (ll ())) 'no-exn) @@ -477,8 +477,8 @@ (let () (define-metafunction empty-language [(f variable) - (x x) - (where x (variable variable))]) + (any_x any_x) + (where any_x (variable variable))]) (test (term (f z)) (term ((z z) (z z))))) @@ -504,8 +504,8 @@ (let () (define-metafunction empty-language - [(err number_1 ... number_2 ...) 1]) - (test (term (err)) 1) + [(err number_1 ... number_2 ...) (number_1 ...)]) + (test (term (err)) (term ())) (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) ((λ (x) #t) (λ (x) 'wrong-exn))) (term (err 1 2)) @@ -611,6 +611,35 @@ (term (f 1))) (test (get-output-string sp) "|(f 1)\n|0\n"))) + (let () + (define-language var-lang [(x y z w) variable]) + + ;; this should produce the second case, + ;; since the where clause (should) fail to match + ;; in the first case. + (define-metafunction var-lang + [(f x) + first-case + (where (AnotherAtom y) (Atom x))] + [(f x) + second-case]) + + (test (term (f a)) (term second-case))) + + (let () + + ;; this is an ambiguous function + ;; and should signal an error if it is ever called + ;; with multiple different arguments, but if the + ;; arguments are all the same, it will return + ;; the same result for any parse, and thus should be allowed. + (define-metafunction empty-language + [(f any_x ... any_y any_z ...) + any_y]) + + (test (term (f 1 1 1 1 1)) (term 1))) + + ; ; @@ -1441,8 +1470,8 @@ (test (apply-reduction-relation (reduction-relation empty-language (--> number_1 - y - (where y ,(+ 1 (term number_1))))) + any_y + (where any_y ,(+ 1 (term number_1))))) 3) '(4)) @@ -1451,24 +1480,35 @@ (apply-reduction-relation (reduction-relation empty-language (--> any - z - (where y ,x) - (where x 2) - (where z ,(+ (term y) (term x))))) + any_z + (where any_y ,x) + (where any_x 2) + (where any_z ,(+ (term any_y) (term any_x))))) 'whatever)) '(7)) + ;; tests `where' clauses bind in side-conditions + (test (let ([x 'unk]) + (apply-reduction-relation + (reduction-relation empty-language + (--> any + the-result + (where any_y any) + (side-condition (eq? (term any_y) 'whatever)))) + 'whatever)) + '(the-result)) + ;; test that where clauses bind in side-conditions that follow (let ([save1 #f] [save2 #f]) - (term-let ([y (term outer-y)]) + (term-let ([any_y (term outer-y)]) (test (begin (apply-reduction-relation (reduction-relation empty-language (--> number_1 - y - (side-condition (set! save1 (term y))) - (where y inner-y) - (side-condition (set! save2 (term y))))) + any_y + (side-condition (set! save1 (term any_y))) + (where any_y inner-y) + (side-condition (set! save2 (term any_y))))) 3) (list save1 save2)) (list 'outer-y 'inner-y)))) @@ -1476,11 +1516,26 @@ (test (apply-reduction-relation (reduction-relation empty-language (--> any - y + any_y (fresh x) - (where y x))) + (where any_y x))) 'x) '(x1)) + + (let () + ;; tests where's ability to have redex patterns, not just syntax-case patterns + (define-language var-lang [(x y z w) variable]) + + (define red + (reduction-relation + var-lang + (--> (x ...) + (y ... z ...) + (where (y ... w z ...) (x ...))))) + + (test (apply-reduction-relation red (term (a b c))) + (list (term (a b)) (term (a c)) (term (b c))))) + (let ([r (reduction-relation grammar @@ -1504,7 +1559,7 @@ (->4 a b)])]) ; test that names are properly bound for side-conditions in shortcuts - (let* ([lhs (rewrite-proc-lhs (first (reduction-relation-make-procs r)))] + (let* ([lhs ((rewrite-proc-lhs (first (reduction-relation-make-procs r))) grammar)] [proc (third lhs)] [name (cadadr lhs)] [bind (λ (n) (make-bindings (list (make-bind name n))))]) @@ -1523,7 +1578,7 @@ [else #f])) ; test shortcut in terms of shortcut - (test (match (rewrite-proc-lhs (third (reduction-relation-make-procs r))) + (test (match ((rewrite-proc-lhs (third (reduction-relation-make-procs r))) grammar) [`(((side-condition 5 ,(? procedure?)) 2) 1) #t] [else #f]) #t)) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 4e2ebcf152..633012865b 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -33,8 +33,10 @@ (define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels)) (define (term-node-set-color! term-node r?) (snip/eventspace + term-node (λ () (send (term-node-snip term-node) set-bad r?)))) +(define (term-node-color term-node) (send (term-node-snip term-node) get-bad)) (define (term-node-set-red! term-node r?) (term-node-set-color! term-node (and r? "pink"))) @@ -692,6 +694,7 @@ [hb (box 0)]) (send admin get-view-size wb hb) (send admin needs-update this 0 0 (unbox wb) (unbox hb)))))) + (define/public (get-bad) bad-color) (define names-to-here '()) ;; might have the same parent twice with a different name @@ -886,6 +889,7 @@ term-node-labels term-node-set-red! term-node-set-color! + term-node-color term-node-set-position! term-node-x term-node-y diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 9461f91294..233b64cac1 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -903,8 +903,9 @@ expression, and the pattern variables in the @|ttpattern| are bound in that expression. Raises an exception recognized by @scheme[exn:fail:redex?] if -no clauses match, if one of the clauses matches multiple ways, or -if the contract is violated. +no clauses match, if one of the clauses matches multiple ways +(and that leads to different results for the different matches), +or if the contract is violated. Note that metafunctions are assumed to always return the same results for the same inputs, and their results are cached, unless @@ -1450,6 +1451,12 @@ string. The @scheme[color-database<%>] is used to convert the string to a @scheme[color%] object. } +@defproc[(term-node-color [tn term-node?]) (or/c string? (is-a?/c color%) false/c)]{ + +Returns the current highlighting of the node. See also @scheme[term-node-set-color!]. +} + + @defproc[(term-node-set-red! [tn term-node?] [red? boolean?]) void?]{ Changes the highlighting of the node; if its second argument