suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adjust rewrite-side-conditions/check-errs so that it

Browse Source 
returns the ellipses names in addition to the regular names

keeping the names in the pattern and including them in the last
two results

closes PR 14291
This commit is contained in:
Robby Findler 2014-01-14 22:35:15 -06:00
parent a391556faa
commit b5cfb7affe
6 changed files with 166 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/redex-pkgs/redex-lib/redex/private/generate-term.rkt
View File

@ -147,8 +147,10 @@
[res-term-stx #`(#,jf-id #,@args-stx)] [res-term-stx #`(#,jf-id #,@args-stx)]
[property #`(bind-prop [property #`(bind-prop
(λ (bindings) (λ (bindings)
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) #,(bind-pattern-names 'redex-check
#,property)))]) #'(names/ellipses ...)
#'((lookup-binding bindings 'names) ...)
property)))])
(quasisyntax/loc orig-stx (quasisyntax/loc orig-stx
(let ([term-match (λ (generated) (let ([term-match (λ (generated)
(cond [(test-match #,lang res-term-stx generated) => values] (cond [(test-match #,lang res-term-stx generated) => values]
@ -183,9 +185,12 @@
[show (show-message orig-stx)] [show (show-message orig-stx)]
[property #`(bind-prop [property #`(bind-prop
(λ (bindings) (λ (bindings)
(term-let ([lhs-names/ellipses (lookup-binding bindings 'lhs-names)] ... #,(bind-pattern-names 'redex-check
[rhs-names/ellipses (lookup-binding bindings 'rhs-names)] ...) #'(lhs-names/ellipses ...
#,property)))]) rhs-names/ellipses ...)
#'((lookup-binding bindings 'lhs-names) ...
(lookup-binding bindings 'rhs-names) ...)
property)))])
(quasisyntax/loc orig-stx (quasisyntax/loc orig-stx
(let ([term-match (λ (generated) (let ([term-match (λ (generated)
(cond [(test-match #,lang res-term-stx generated) => values] (cond [(test-match #,lang res-term-stx generated) => values]
@ -214,8 +219,10 @@
(parse-redex-check-kw-args kw-args orig-stx form)) (parse-redex-check-kw-args kw-args orig-stx form))
(with-syntax ([property #`(bind-prop (with-syntax ([property #`(bind-prop
(λ (bindings) (λ (bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...) #,(bind-pattern-names 'redex-check
#,property)))]) #'(name/ellipses ...)
#'((lookup-binding bindings 'name) ...)
property)))])
(quasisyntax/loc orig-stx (quasisyntax/loc orig-stx
(let ([att #,attempts-stx] (let ([att #,attempts-stx]
[ret #,retries-stx] [ret #,retries-stx]

18
pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt
View File

@ -154,8 +154,10 @@
(λ (bindings) (λ (bindings)
(let ([x (lookup-binding bindings 'names)] ...) (let ([x (lookup-binding bindings 'names)] ...)
(and binding-constraints ... (and binding-constraints ...
(term-let ([names/ellipses x] ...) #,(bind-pattern-names orig-name
#,rest-body)))))))))] #'(names/ellipses ...)
#'(x ...)
rest-body)))))))))]
[((-side-condition s ...) y ...) [((-side-condition s ...) y ...)
(side-condition-keyword? #'-side-condition) (side-condition-keyword? #'-side-condition)
(if side-condition-unquoted? (if side-condition-unquoted?
@ -239,8 +241,10 @@
(λ (bindings #,(if jf-results-id jf-results-id '_ignored)) (λ (bindings #,(if jf-results-id jf-results-id '_ignored))
(let ([temp (lookup-binding bindings 'output-name)] ...) (let ([temp (lookup-binding bindings 'output-name)] ...)
(and binding-constraint ... (and binding-constraint ...
(term-let ([output-name/ellipsis temp] ...) #,(bind-pattern-names orig-name
#,rest-body))))))))])))) #'(output-name/ellipsis ...)
#'(temp ...)
rest-body))))))))]))))
(define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something) (define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something)
(let ([compiled-pattern (compile-pattern lang output-pattern #t)]) (let ([compiled-pattern (compile-pattern lang output-pattern #t)])
@ -816,8 +820,10 @@
compiled-lhs compiled-lhs
input input
(λ (bnds) (λ (bnds)
(term-let ([names/ellipses (lookup-binding bnds 'names)] ...) #,(bind-pattern-names 'judgment-form
#,body)) #'(names/ellipses ...)
#'((lookup-binding bnds 'names) ...)
body))
#,(if output-contracts #,(if output-contracts
#`(λ (output) #`(λ (output)
(check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode)) (check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode))

45
pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt
View File

@ -47,17 +47,24 @@
(syntax->list (syntax (pattern ...))))] (syntax->list (syntax (pattern ...))))]
[(cp-x ...) (generate-temporaries #'(pattern ...))] [(cp-x ...) (generate-temporaries #'(pattern ...))]
[make-matcher make-matcher]) [make-matcher make-matcher])
#'(begin (with-syntax ([(mtch-procs ...)
(for/list ([names/ellipses (in-list (syntax->list #'((names/ellipses ...) ...)))]
[names (in-list (syntax->list #'((names ...) ...)))]
[rhs (in-list (syntax->list #'(rhs ...)))])
(with-syntax ([(names ...) names])
#`(λ (match)
#,(bind-pattern-names
#'form-name
names/ellipses
#'((lookup-binding (mtch-bindings match) 'names) ...)
rhs))))])
#`(begin
syncheck-expr ... syncheck-expr ...
(make-matcher (make-matcher
'form-name lang 'form-name lang
(list 'pattern ...) (list 'pattern ...)
(list (compile-pattern lang `side-conditions-rewritten #t) ...) (list (compile-pattern lang `side-conditions-rewritten #t) ...)
(list (λ (match) (list mtch-procs ...))))))]))
(term-let/error-name
form-name
([names/ellipses (lookup-binding (mtch-bindings match) 'names)] ...)
rhs)) ...)))))]))
(define-syntax (term-match/single stx) (define-syntax (term-match/single stx)
(term-matcher stx #'term-match/single/proc)) (term-matcher stx #'term-match/single/proc))
@ -684,9 +691,11 @@
'lhs-to-id 'lhs-to-id
`side-conditions-rewritten `side-conditions-rewritten
(λ (bindings rhs-binder) (λ (bindings rhs-binder)
(term-let ([lhs-to-id rhs-binder] (term-let ([lhs-to-id rhs-binder])
[names/ellipses (lookup-binding bindings 'names)] ...) #,(bind-pattern-names 'reduction-relation
(term rhs-to #:lang lang))) #'(names/ellipses ...)
#'((lookup-binding bindings 'names) ...)
#'(term rhs-to #:lang lang))))
#,child-proc #,child-proc
`fresh-rhs-from))) `fresh-rhs-from)))
(get-choices stx orig-name bm #'lang (get-choices stx orig-name bm #'lang
@ -779,10 +788,13 @@
[body-code body-code]) [body-code body-code])
#`(begin #`(begin
lhs-syncheck-expr lhs-syncheck-expr
(build-rewrite-proc/leaf `side-conditions-rewritten (build-rewrite-proc/leaf
`side-conditions-rewritten
(λ (main-exp bindings) (λ (main-exp bindings)
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) #,(bind-pattern-names 'reduction-relation
body-code)) #'(names/ellipses ...)
#'((lookup-binding bindings 'names) ...)
#'body-code))
lhs-source lhs-source
name name
(λ (lang-id2) `lhs-w/extras)))))) (λ (lang-id2) `lhs-w/extras))))))
@ -1085,12 +1097,15 @@
(let ([ans (match-pattern cpat exp)]) (let ([ans (match-pattern cpat exp)])
(and ans (and ans
(map (λ (m) (make-match (sort-bindings (map (λ (m) (make-match (sort-bindings
(filter (λ (x) (memq (bind-name x) binders)) (filter (λ (x) (and (memq (bind-name x) binders)
(not-ellipsis-name (bind-name x))))
(bindings-table (mtch-bindings m)))))) (bindings-table (mtch-bindings m))))))
ans)))))) ans))))))
(if name (if name
(procedure-rename redex-match-proc name) (procedure-rename redex-match-proc name)
redex-match-proc)) redex-match-proc))
(define (not-ellipsis-name x)
(not (regexp-match? #rx"^[.][.][.]" (symbol->string x))))
(define (sort-bindings bnds) (define (sort-bindings bnds)
(sort (sort
@ -1704,6 +1719,10 @@
"cannot use pattern language keyword as a non-terminal name") "cannot use pattern language keyword as a non-terminal name")
(check-each names (λ (x) (regexp-match? #rx"_" (symbol->string (syntax-e x)))) (check-each names (λ (x) (regexp-match? #rx"_" (symbol->string (syntax-e x))))
"cannot use _ in a non-terminal name") "cannot use _ in a non-terminal name")
(check-each names (λ (x) (regexp-match? #rx"^[.][.][.]$" (symbol->string (syntax-e x))))
"cannot name a non-terminal `...'")
(check-each names (λ (x) (regexp-match? #rx"^[.][.][.]_" (symbol->string (syntax-e x))))
"cannot start a non-terminal name with `..._'")
(when (null? prods) (when (null? prods)
(raise-syntax-error #f "expected at least one production to follow" (raise-syntax-error #f "expected at least one production to follow"

51
pkgs/redex-pkgs/redex-lib/redex/private/rewrite-side-conditions.rkt
View File

@ -14,7 +14,8 @@
(rename-out [binds? id-binds?]) (rename-out [binds? id-binds?])
raise-ellipsis-depth-error raise-ellipsis-depth-error
make-language-id make-language-id
language-id-nts) language-id-nts
bind-pattern-names)
(provide (struct-out id/depth)) (provide (struct-out id/depth))
@ -59,6 +60,11 @@
;; hash[sym -o> (listof stx)] ;; hash[sym -o> (listof stx)]
(define var-locs-table (make-hash)) (define var-locs-table (make-hash))
;; hash[sym -o> sym]
;; tells the original names for any given repeat to be replaced after
;; normalization and checking has finished
(define original-repeat-names (make-hash))
(define (record-binder pat-stx under under-mismatch-ellipsis) (define (record-binder pat-stx under under-mismatch-ellipsis)
(define pat-sym (syntax->datum pat-stx)) (define pat-sym (syntax->datum pat-stx))
(hash-set! var-locs-table pat-sym (cons pat-stx (hash-ref var-locs-table pat-sym '()))) (hash-set! var-locs-table pat-sym (cons pat-stx (hash-ref var-locs-table pat-sym '())))
@ -288,24 +294,29 @@
orig-stx orig-stx
(cadr terms) (cadr terms)
(list (caddr terms)))) (list (caddr terms))))
(define ellipsis-sym (syntax-e (cadr terms))) (define ellipsis-pre-sym (syntax-e (cadr terms)))
(define ellipsis-pre-str (symbol->string ellipsis-sym)) (define ellipsis-pre-str (symbol->string ellipsis-pre-sym))
(define mismatch? (regexp-match? #rx"^[.][.][.]_!_" ellipsis-pre-str)) (define mismatch? (regexp-match? #rx"^[.][.][.]_!_" ellipsis-pre-str))
(define ellipsis-str (cond (define-values (ellipsis-str was-named-ellipsis?)
(cond
[mismatch? [mismatch?
(set! ellipsis-number (+ ellipsis-number 1)) (set! ellipsis-number (+ ellipsis-number 1))
(format "..._r~a" ellipsis-number)] (values (format "..._r~a" ellipsis-number) #f)]
[(regexp-match? #rx"^[.][.][.]_r" ellipsis-pre-str) [(regexp-match? #rx"^[.][.][.]_r" ellipsis-pre-str)
(string-append (substring ellipsis-str 0 4) (values (string-append (substring ellipsis-str 0 4)
"r" "r"
(substring ellipsis-str (substring ellipsis-str
4 4
(string-length ellipsis-str)))] (string-length ellipsis-str)))
#t)]
[(regexp-match? #rx"^[.][.][.]_" ellipsis-pre-str) [(regexp-match? #rx"^[.][.][.]_" ellipsis-pre-str)
ellipsis-pre-str] (values ellipsis-pre-str #t)]
[else [else
(set! ellipsis-number (+ ellipsis-number 1)) (set! ellipsis-number (+ ellipsis-number 1))
(format "..._r~a" ellipsis-number)])) (values (format "..._r~a" ellipsis-number) #f)]))
(define ellipsis-sym (string->symbol ellipsis-str))
(when was-named-ellipsis?
(hash-set! original-repeat-names ellipsis-sym ellipsis-pre-sym))
(define ellipsis+name (datum->syntax (define ellipsis+name (datum->syntax
(cadr terms) (cadr terms)
(string->symbol ellipsis-str) (string->symbol ellipsis-str)
@ -318,11 +329,13 @@
(cons (syntax-e (cadr terms)) under-mismatch-ellipsis) (cons (syntax-e (cadr terms)) under-mismatch-ellipsis)
under-mismatch-ellipsis))) under-mismatch-ellipsis)))
(define-values (rst-terms rst-vars) (t-loop (cddr terms))) (define-values (rst-terms rst-vars) (t-loop (cddr terms)))
(values (cons `(repeat ,fst-term (values (cons `(repeat ,fst-term ,ellipsis+name ,(if mismatch? (cadr terms) #f))
,ellipsis+name
,(if mismatch? (cadr terms) #f))
rst-terms) rst-terms)
(append fst-vars rst-vars))] (append fst-vars
(if was-named-ellipsis?
(list (id/depth (cadr terms) (length under) #f))
'())
rst-vars))]
[else [else
(define-values (fst-term fst-vars) (define-values (fst-term fst-vars)
(loop (car terms) under under-mismatch-ellipsis)) (loop (car terms) under under-mismatch-ellipsis))
@ -425,7 +438,7 @@
(let () (let ()
(define final-match-repeat-name (define final-match-repeat-name
(if (= 1 (hash-ref repeat-id-counts (syntax-e #'name))) (if (= 1 (hash-ref repeat-id-counts (syntax-e #'name)))
#f (hash-ref original-repeat-names (syntax-e #'name) #f)
#'name)) #'name))
(define final-mismatch-repeat-name (define final-mismatch-repeat-name
(if (and (syntax-e #'mismatch-name) (if (and (syntax-e #'mismatch-name)
@ -569,3 +582,13 @@
orig-stx))) orig-stx)))
(not same-id?))) (not same-id?)))
(loop (cdr dups))))]))) (loop (cdr dups))))])))
(define (bind-pattern-names err-name names/ellipses vals body)
(with-syntax ([(names/ellipsis ...) names/ellipses]
[(val ...) vals])
#`(term-let/error-name
#,err-name
([names/ellipsis val] ...)
#,body)))

18
pkgs/redex-pkgs/redex-lib/redex/private/term.rkt
View File

@ -168,7 +168,9 @@
(judgment-form-id? #'jf-name)) (judgment-form-id? #'jf-name))
(begin (begin
(unless (not (memq 'O (judgment-form-mode (syntax-local-value #'jf-name)))) (unless (not (memq 'O (judgment-form-mode (syntax-local-value #'jf-name))))
(raise-syntax-error 'term "judgment forms with output mode (\"O\") positions disallowed" arg-stx stx)) (raise-syntax-error 'term
"judgment forms with output mode (\"O\") positions disallowed"
arg-stx stx))
(rewrite-application #'jf-name (syntax/loc stx (arg ...)) depth))] (rewrite-application #'jf-name (syntax/loc stx (arg ...)) depth))]
[f [f
(and (identifier? (syntax f)) (and (identifier? (syntax f))
@ -255,7 +257,9 @@
(define m (regexp-match #rx"^([^_]*)_" (symbol->string id))) (define m (regexp-match #rx"^([^_]*)_" (symbol->string id)))
(when m (when m
(unless (memq (string->symbol (list-ref m 1)) (append pattern-symbols lang-nts)) (unless (memq (string->symbol (list-ref m 1)) (append pattern-symbols lang-nts))
(raise-syntax-error 'term "before underscore must be either a non-terminal or a built-in pattern" arg-stx stx))))) (raise-syntax-error 'term
"before underscore must be either a non-terminal or a built-in pattern"
arg-stx stx)))))
(values (values
(with-syntax ([rewritten (rewrite arg-stx)]) (with-syntax ([rewritten (rewrite arg-stx)])
@ -374,7 +378,13 @@
(define-syntax (term-let/error-name stx) (define-syntax (term-let/error-name stx)
(syntax-case stx () (syntax-case stx ()
[(_ error-name ([x1 rhs1] [x rhs] ...) body1 body2 ...) [(_ error-name ([x1 rhs1] [x rhs] ...) body1 body2 ...)
(let-values ([(orig-names new-names depths new-x1) (let ()
(unless (identifier? #'error-name)
(raise-syntax-error 'term-let/error-name
"expected an identifier as the first argument"
stx
#'error-name))
(define-values (orig-names new-names depths new-x1)
(let loop ([stx #'x1] [depth 0]) (let loop ([stx #'x1] [depth 0])
(define ((combine orig-names new-names depths new-pat) (define ((combine orig-names new-names depths new-pat)
orig-names* new-names* depths* new-pat*) orig-names* new-names* depths* new-pat*)
@ -407,7 +417,7 @@
(λ () (loop #'x depth)) (λ () (loop #'x depth))
combine))] combine))]
[_ [_
(values '() '() '() stx)]))]) (values '() '() '() stx)])))
(with-syntax ([(orig-names ...) orig-names] (with-syntax ([(orig-names ...) orig-names]
[(new-names ...) new-names] [(new-names ...) new-names]
[(depths ...) depths] [(depths ...) depths]

9
pkgs/redex-pkgs/redex-test/redex/tests/rewrite-side-condition-test.rkt
View File

@ -24,8 +24,9 @@
(check-equal? (rsc (1) () #t) `((list 1) () ())) (check-equal? (rsc (1) () #t) `((list 1) () ()))
(check-equal? (rsc (_ _ (name x _)) () #t) `((list any any (name x any)) (x) (x))) (check-equal? (rsc (_ _ (name x _)) () #t) `((list any any (name x any)) (x) (x)))
(check-equal? (rsc (1 ...) () #t) `((list (repeat 1 #f #f)) () ())) (check-equal? (rsc (1 ...) () #t) `((list (repeat 1 #f #f)) () ()))
(check-equal? (rsc (1 ..._2) () #t) `((list (repeat 1 #f #f)) () ())) (check-equal? (rsc (1 ..._2) () #t) `((list (repeat 1 ..._2 #f)) (..._2) (..._2)))
(check-equal? (rsc (1 ..._2 1 ..._2) () #t) `((list (repeat 1 ..._2 #f) (repeat 1 ..._2 #f)) () ())) (check-equal? (rsc (1 ..._2 1 ..._2) () #t)
`((list (repeat 1 ..._2 #f) (repeat 1 ..._2 #f)) (..._2 ..._2) (..._2 ..._2)))
(check-equal? (rsc (1 ..._!_3) () #t) `((list (repeat 1 #f #f)) () ())) (check-equal? (rsc (1 ..._!_3) () #t) `((list (repeat 1 #f #f)) () ()))
(check-equal? (rsc (1 ..._!_3 1 ..._!_3) () #t) (check-equal? (rsc (1 ..._!_3 1 ..._!_3) () #t)
`((list (repeat 1 #f ..._!_3) (repeat 1 #f ..._!_3)) () ())) `((list (repeat 1 #f ..._!_3) (repeat 1 #f ..._!_3)) () ()))
@ -42,7 +43,9 @@
`((list (repeat (list (repeat (name x (nt x)) #f #f)) #f #f)) `((list (repeat (list (repeat (name x (nt x)) #f #f)) #f #f))
(x) (x)
(((x ...) ...)))) (((x ...) ...))))
(check-equal? (rsc (any_1 any_1) (x) #f) `((list (name any_1 any) (name any_1 any))
(any_1 any_1)
(any_1 any_1)))
(check-equal? (rsc (in-hole (hole a #f (hide-hole hole)) (cross x)) '(x) #f) (check-equal? (rsc (in-hole (hole a #f (hide-hole hole)) (cross x)) '(x) #f)
`((in-hole (list hole a #f (hide-hole hole)) (cross x-x)) `((in-hole (list hole a #f (hide-hole hole)) (cross x-x))
() ()