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

More patterns that match no terms are now syntax errors

Browse Source 
For example: (any_1 ..._!_1 any_2 ..._!_1 (any_1 any_2) ...)
This commit is contained in:
Robby Findler 2013-11-14 08:33:22 -06:00
parent 5a0ddb3460
commit c2d7e02c70
3 changed files with 100 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -56,18 +56,13 @@
(define last-stx (make-hasheq)) ;; used for syntax error reporting (define last-stx (make-hasheq)) ;; used for syntax error reporting
(define assignments #hasheq()) (define assignments #hasheq())
;; hash[sym -o> (listof (list stx (listof id[mismatch-ellipsis-binders]))) ;; hash[sym -o> (listof stx)]
(define vars-under-mismatch-table (make-hash)) (define var-locs-table (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! vars-under-mismatch-table (hash-set! var-locs-table pat-sym (cons pat-stx (hash-ref var-locs-table pat-sym '())))
(syntax-e pat-stx)
(cons
(list pat-stx under-mismatch-ellipsis)
(hash-ref vars-under-mismatch-table
(syntax-e pat-stx)
'())))
(set! assignments (set! assignments
(if (null? under) (if (null? under)
assignments assignments
@ -77,16 +72,17 @@
[last [last
(unless (equal? (length last) (length under)) (unless (equal? (length last) (length under))
(define stxs (hash-ref last-stx pat-sym)) (define stxs (hash-ref last-stx pat-sym))
(raise-syntax-error what (raise-syntax-error
(format "found ~a under ~a ellips~as in one place and ~a ellips~as in another" what
pat-sym (format "found ~a under ~a ellips~as in one place and ~a ellips~as in another"
(length last) pat-sym
(if (= 1 (length last)) "i" "e") (length last)
(length under) (if (= 1 (length last)) "i" "e")
(if (= 1 (length under)) "i" "e")) (length under)
orig-stx (if (= 1 (length under)) "i" "e"))
(car stxs) orig-stx
(cdr stxs))) (car stxs)
(cdr stxs)))
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)] (foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)]
[else [else
(hash-set! last-contexts pat-sym under) (hash-set! last-contexts pat-sym under)
@ -107,7 +103,8 @@
(let loop ([term orig-stx] (let loop ([term orig-stx]
[under '()] [under '()]
[under-mismatch-ellipsis '()]) [under-mismatch-ellipsis '()])
(syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole cross unquote and) (syntax-case term (side-condition variable-except variable-prefix
hole name in-hole hide-hole cross unquote and)
[(side-condition pre-pat (and)) [(side-condition pre-pat (and))
;; rewriting metafunctions (and possibly other things) that have no where, etc clauses ;; rewriting metafunctions (and possibly other things) that have no where, etc clauses
;; end up with side-conditions that are empty 'and' expressions, so we just toss them here. ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here.
@ -237,7 +234,8 @@
[else [else
(raise-syntax-error (raise-syntax-error
what what
(format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" (format (string-append "before underscore must be either a"
" non-terminal or a built-in pattern, found ~a in ~s")
prefix-sym (syntax-e term)) prefix-sym (syntax-e term))
orig-stx orig-stx
term)])] term)])]
@ -326,7 +324,8 @@
rst-terms) rst-terms)
(append fst-vars rst-vars))] (append fst-vars rst-vars))]
[else [else
(define-values (fst-term fst-vars) (loop (car terms) under under-mismatch-ellipsis)) (define-values (fst-term fst-vars)
(loop (car terms) under under-mismatch-ellipsis))
(define-values (rst-terms rst-vars) (t-loop (cdr terms))) (define-values (rst-terms rst-vars) (t-loop (cdr terms)))
(values (cons fst-term rst-terms) (values (cons fst-term rst-terms)
(append fst-vars rst-vars))]))) (append fst-vars rst-vars))])))
@ -368,10 +367,56 @@
(datum->syntax pat new pat) (datum->syntax pat new pat)
new))] new))]
[_ pat]))) [_ pat])))
;(printf "term ~s\n" (syntax->datum (datum->syntax #'here term))) (define (raise-impossible-pattern-error pat1 pat2)
;(printf "norm ~s\n" (syntax->datum (datum->syntax #'here ellipsis-normalized))) (define (find-pat-var pat)
;(printf "repeat-id-counts ~s\n" repeat-id-counts) (syntax-case pat (name)
[(name id pat)
(syntax-e #'id)]
[_ #f]))
(define pat-var1 (find-pat-var pat1))
(define pat-var2 (find-pat-var pat1))
(cond
[(and pat-var1 pat-var2
(not (equal? pat-var1 pat-var2)))
(define all-ids (append (hash-ref var-locs-table pat-var1 '())
(hash-ref var-locs-table pat-var2 '())))
(raise-syntax-error
what
(format
(string-append "no terms match pattern;\n"
" ~a and ~a are together overly constrained")
pat-var1 pat-var2)
orig-stx
(if (null? all-ids) #f (car all-ids))
(if (null? all-ids) '() (cdr all-ids)))]
[(or pat-var1 pat-var2)
=>
(λ (the-pat-var)
(define all-ids (hash-ref var-locs-table the-pat-var '()))
(raise-syntax-error
what
(format (string-append "no terms match pattern;\n"
" ~a is overly constrained")
the-pat-var)
orig-stx
(if (null? all-ids) #f (car all-ids))
(if (null? all-ids) '() (cdr all-ids))))]
[else
(raise-syntax-error
what
"no terms match pattern"
orig-stx)]))
#|
(printf "term\n") ((dynamic-require 'racket/pretty 'pretty-print)
(syntax->datum (datum->syntax #'here term)))
(printf "norm\n") ((dynamic-require 'racket/pretty 'pretty-print)
(syntax->datum (datum->syntax #'here ellipsis-normalized)))
(printf "repeat-id-counts ~s\n" repeat-id-counts)
|#
;; hash[(list symbol[match-id] symbol[mismatch-id]) -o> syntax[repeat pattern]]
(define both-match-and-mismatch-id (make-hash))
(define ellipsis-normalized/simplified (define ellipsis-normalized/simplified
(let loop ([pat ellipsis-normalized]) (let loop ([pat ellipsis-normalized])
@ -387,6 +432,14 @@
(= 1 (hash-ref repeat-id-counts (syntax-e #'mismatch-name)))) (= 1 (hash-ref repeat-id-counts (syntax-e #'mismatch-name))))
#f #f
#'mismatch-name)) #'mismatch-name))
(when (and (identifier? final-mismatch-repeat-name)
(identifier? final-match-repeat-name))
(define key (list (syntax-e final-mismatch-repeat-name)
(syntax-e final-match-repeat-name)))
(define already-bound (hash-ref both-match-and-mismatch-id key #f))
(when already-bound
(raise-impossible-pattern-error already-bound #'sub-pat))
(hash-set! both-match-and-mismatch-id key #'sub-pat))
#`(repeat #,(loop #'sub-pat) #`(repeat #,(loop #'sub-pat)
#,final-match-repeat-name #,final-match-repeat-name
#,final-mismatch-repeat-name))] #,final-mismatch-repeat-name))]
@ -400,28 +453,6 @@
(filter-duplicates what orig-stx names) (filter-duplicates what orig-stx names)
(for ([(id stx+mismatches) (in-hash vars-under-mismatch-table)])
(define all-ids (map car stx+mismatches))
(define all-mismatch-idss (map cadr stx+mismatches))
(let loop ([all-mismatch-idss all-mismatch-idss])
(cond
[(null? all-mismatch-idss) (void)]
[else
(define id-in-multiple-places/f
(for/or ([mismatch-id (in-list (car all-mismatch-idss))])
(for/or ([other-mismatch-ids (in-list (cdr all-mismatch-idss))])
(and (member mismatch-id other-mismatch-ids)
mismatch-id))))
(when id-in-multiple-places/f
(raise-syntax-error what
(format "~a appears under ~a in multiple places (so this pattern would always fail)"
id
id-in-multiple-places/f)
orig-stx
(car all-ids)
(cdr all-ids)))
(loop (cdr all-mismatch-idss))])))
(let ([without-mismatch-names (filter (λ (x) (not (id/depth-mismatch? x))) names)]) (let ([without-mismatch-names (filter (λ (x) (not (id/depth-mismatch? x))) names)])
(with-syntax ([(name/ellipses ...) (map build-dots without-mismatch-names)] (with-syntax ([(name/ellipses ...) (map build-dots without-mismatch-names)]
[(name ...) (map id/depth-id without-mismatch-names)] [(name ...) (map id/depth-id without-mismatch-names)]
@ -431,7 +462,9 @@
(define-struct id/depth (id depth mismatch?)) (define-struct id/depth (id depth mismatch?))
;; extract-names : syntax syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...])) ;; extract-names : syntax syntax ->
;; (values (listof syntax)
;; (listof syntax[x | (x ...) | ((x ...) ...) | ...]))
;; this function is obsolete and uses of it are suspect. Things should be using ;; this function is obsolete and uses of it are suspect. Things should be using
;; rewrite-side-conditions/check-errs instead ;; rewrite-side-conditions/check-errs instead
(define (extract-names all-nts what bind-names? orig-stx [mode 'rhs-only]) (define (extract-names all-nts what bind-names? orig-stx [mode 'rhs-only])
@ -500,7 +533,12 @@
(and (not (regexp-match #rx"^\\.\\.\\._" str)) (and (not (regexp-match #rx"^\\.\\.\\._" str))
(not (regexp-match #rx"_!_" str)))))) (not (regexp-match #rx"_!_" str))))))
(define (raise-ellipsis-depth-error what one-binder one-depth another-binder another-depth [orig-stx #f]) (define (raise-ellipsis-depth-error what
one-binder
one-depth
another-binder
another-depth
[orig-stx #f])
(raise-syntax-error (raise-syntax-error
what what
(format "found the same binder, ~s, at different depths, ~a and ~a" (format "found the same binder, ~s, at different depths, ~a and ~a"
@ -531,4 +569,3 @@
orig-stx))) orig-stx)))
(not same-id?))) (not same-id?)))
(loop (cdr dups))))]))) (loop (cdr dups))))])))

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

@ -27,7 +27,8 @@
(check-equal? (rsc (1 ..._2) () #t) `((list (repeat 1 #f #f)) () ())) (check-equal? (rsc (1 ..._2) () #t) `((list (repeat 1 #f #f)) () ()))
(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)) () ()))
(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) `((list (repeat 1 #f ..._!_3) (repeat 1 #f ..._!_3)) () ())) (check-equal? (rsc (1 ..._!_3 1 ..._!_3) () #t)
`((list (repeat 1 #f ..._!_3) (repeat 1 #f ..._!_3)) () ()))
(check-equal? (rsc x (x) #t) `((name x (nt x)) (x) (x))) (check-equal? (rsc x (x) #t) `((name x (nt x)) (x) (x)))
(check-equal? (rsc x (x) #f) `((nt x) () ())) (check-equal? (rsc x (x) #f) `((nt x) () ()))
@ -48,8 +49,17 @@
())) ()))
(check-regexp-match (check-regexp-match
#rx"any_1 appears under ..._!_1 in multiple places" #rx"any_1 is overly"
(rsc (any_1 ..._!_1 any_1 ..._!_1) () #f)) (rsc (any_1 ..._!_1 any_1 ..._!_1) () #f))
(check-regexp-match
#rx"any_1 is overly constrained"
(rsc (any_1 ..._!_1 any_2 ..._!_1 (any_1 any_2) ...) () #f))
(check-regexp-match
#rx"any_1 is overly constrained"
(rsc (any_1 ..._!_1 any_2 ..._!_1 any_1 ..._1 any_2 ..._1) () #f))
(check-regexp-match
#rx"any_1 is overly constrained"
(rsc (any_1 ..._!_1 any_2 ..._!_1 (any_1 any_3) ... (any_3 any_2) ...) () #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

3
pkgs/redex-pkgs/redex-test/redex/tests/rg-test.rkt
View File

@ -316,7 +316,6 @@
(b (number_1 ..._!_1 number_1 ..._1)) (b (number_1 ..._!_1 number_1 ..._1))
(c (variable_1 ..._1 number_2 ..._1)) (c (variable_1 ..._1 number_2 ..._1))
(d (z_1 ... z_2 ..._!_1 (z_1 z_2) ...)) (d (z_1 ... z_2 ..._!_1 (z_1 z_2) ...))
(e (n_1 ..._!_1 n_2 ..._!_1 (n_1 n_2) ..._3))
(f (n_1 ..._1 n_2 ..._2 n_2 ..._1)) (f (n_1 ..._1 n_2 ..._2 n_2 ..._1))
(g (z_1 ..._!_1 z_2 ... (z_1 z_2) ...)) (g (z_1 ..._!_1 z_2 ... (z_1 z_2) ...))
(n number) (n number)
@ -334,8 +333,6 @@
null) null)
(test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) (test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
'(4 4 4 4 (4 4) (4 4))) '(4 4 4 4 (4 4) (4 4)))
(test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42))
#rx"generate-term: unable to generate pattern .* in 42")
(test (raised-exn-msg (test (raised-exn-msg
exn:fail:redex:generation-failure? exn:fail:redex:generation-failure?
(parameterize ([generation-decisions (parameterize ([generation-decisions