From f1bacffbdc8cf28e15c084eaf985f6a29fdc0b8e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 21 Dec 2011 17:11:15 -0600 Subject: [PATCH] Adjusted rewrite-side-condition/check-errs so that it normalizes the internal redex patterns a bunch: - repeats are turned into wrappers in sequences, - names are all explicit, - non-terminals are wrapped with `nt', - cross patterns always have the hyphens in them. - ellipses names are normalized (so there are no "hidden" name equalities); this also means that repeat patterns can have both a regular name and a mismatch name Also, added a match-a-pattern helper macro that checks to make sure that functions that process patterns don't miss any cases --- collects/redex/private/match-a-pattern.rkt | 131 ++++ collects/redex/private/matcher.rkt | 721 +++++++++-------- .../redex/private/reduction-semantics.rkt | 352 +++++---- .../redex/private/rewrite-side-conditions.rkt | 411 +++++++--- collects/redex/private/rg.rkt | 426 ++++++----- collects/redex/tests/check-syntax-test.rkt | 2 +- collects/redex/tests/matcher-test.rkt | 722 ++++++++++-------- .../tests/rewrite-side-condition-test.rkt | 134 ++++ collects/redex/tests/rg-test.rkt | 134 ++-- collects/redex/tests/run-tests.rkt | 2 + .../judgment-form-definition.rktd | 4 +- .../reduction-relation-definition.rktd | 2 +- collects/redex/tests/test-util.rkt | 4 +- collects/redex/tests/tl-test.rkt | 4 +- 14 files changed, 1823 insertions(+), 1226 deletions(-) create mode 100644 collects/redex/private/match-a-pattern.rkt create mode 100644 collects/redex/tests/rewrite-side-condition-test.rkt diff --git a/collects/redex/private/match-a-pattern.rkt b/collects/redex/private/match-a-pattern.rkt new file mode 100644 index 0000000000..32b06ade70 --- /dev/null +++ b/collects/redex/private/match-a-pattern.rkt @@ -0,0 +1,131 @@ +#lang racket/base +(require racket/match + (for-syntax racket/match + racket/base)) +(provide match-a-pattern) + +#| + +The grammar for the internal patterns is the +contents of the should-be-pats list, where each +'pat' that appears behind an unquote there is +a self-reference in the grammar. + + lpat ::= pat + | `(repeat ,pat ,(or/c symbol? #f) ,(or/c symbol? #f)) + ;; repeat indicates a repetition (ellipsis in the + ;; surface language), where the pattern inside is + ;; what's repeated, the second position is a name + ;; if the ellipsis is named normally and the final + ;; position is a name if the ellipsis has a mismatch + ;; name (more below). + var ::= symbol? + condition ::= (-> bindings? any) ;; any is treated like a boolean + +Also, the `(cross ,nt) pattern alwyas has hypenated non-terminals, ie +(cross e) in the source turns into (cross e-e) after translation (which +means that the other cross non-terminals, e.g. (cross e-v), are not +directly available as redex patterns, but can only be used via the +non-terminals that Redex creates for the cross languages. + +Internal patterns also come with the invariant that there are no +redundant or non-local ellipses names. That is, consider this pattern: + + (any_1 ..._1 any_1 ..._2) + +It might seem like it would turn into something like this: + + (list (repeat (name any_1 any) ..._1 #f) + (repeat (name any_1 any) ..._2 #f)) + +but the _1 and _2 are actually not right, since the x_1 name +will force the two ellipses lengths to be the same. So, this +must turn into this pattern: + + (list (repeat (name any_1 any) ..._1 #f) + (repeat (name any_1 any) ..._1 #f)) + +Similarly, if there are superflous names, they are delete. For +example, this source pattern: + + (any_1 ..._1) + +turns into this: + + (list (repeat (name any_1 any) #f #f)) + +Also, although there cannot be any patterns at the source level +that have both kinds of names, there can be once the ellipses +have been resolved. For example, this: + + (any_1 ..._1 + any_1 ..._!_2 + any_1 ..._1 + any_1 ..._!_2) + +turns into this: + + (list (repeat (name any_1 any) ..._1 #f) + (repeat (name any_1 any) ..._1 ..._!_2) + (repeat (name any_1 any) ..._1 #f) + (repeat (name any_1 any) ..._1 ..._!_2)) + +|# + +(define-syntax (match-a-pattern stx) + (syntax-case stx () + [(_ to-match [pats rhs ...] ...) + (let () + (define should-be-pats + '(`any + `number + `string + `natural + `integer + `real + `variable + `(variable-except ,var ...) + `(variable-prefix ,var) + `variable-not-otherwise-mentioned + `hole + `(nt ,var) + `(name ,var ,pat) + `(mismatch-name ,var ,pat) + `(in-hole ,pat ,pat) ;; context, then contractum + `(hide-hole ,pat) + `(side-condition ,pat ,condition ,srcloc-expr) + `(cross ,var) + `(list ,lpat ...) + (? (compose not pair?)) ;; pattern for literals (numbers, strings, prefabs, etc etc etc) + )) + (for ([pat (in-list (syntax->list #'(pats ...)))]) + (when (null? should-be-pats) + (raise-syntax-error 'match-a-pattern "too many patterns" stx pat)) + (define should-be (car should-be-pats)) + (set! should-be-pats (cdr should-be-pats)) + (define pats-match? + (let loop ([pat (syntax->datum pat)] + [should-be should-be]) + (cond + [(and (null? pat) (null? should-be)) #t] + [(and (pair? pat) (pair? should-be)) + (cond + [(eq? (car should-be) 'unquote) + (eq? (car pat) 'unquote)] + [else + (and (loop (car pat) (car should-be)) + (loop (cdr pat) (cdr should-be)))])] + [else (equal? pat should-be)]))) + (unless pats-match? + (raise-syntax-error 'match-a-pattern + (format "expected pattern ~s" + should-be) + stx + pat))) + (unless (null? should-be-pats) + (raise-syntax-error 'match-a-pattern + (format "did not find pattern ~s" + (car should-be-pats)) + stx)) + #'(match to-match [pats rhs ...] ...))])) + \ No newline at end of file diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt index b63388aae3..5c394534db 100644 --- a/collects/redex/private/matcher.rkt +++ b/collects/redex/private/matcher.rkt @@ -1,21 +1,34 @@ #lang scheme/base +;; optimization ideas: +;; +;; -- jay's idea (bind parsed expressions +;; to structs that indicate what they parsed as +;; (when the parse as non-terminals)) +;; +;; -- when a pattern has no bindings, just use 'and's +;; and 'or's to check for the match (no allocation) +;; +;; -- when a list pattern has only a single repeat, +;; don't search for matches, just count +;; +;; -- when a match is unambiguous (and possibly only when +;; there are no names underneath an ellipsis), +;; pre-allocate the space to store the result (in a vector) + #| Note: the patterns described in the documentation are slightly different than the patterns processed here. -The difference is in the form of the side-condition -expressions. Here they are procedures that accept -binding structures, instead of expressions. The -rewrite-side-conditions/check-errs macro does this -transformation before the pattern compiler is invoked. +See match-a-pattern.rkt for more details |# (require scheme/list scheme/match scheme/contract racket/promise - "underscore-allowed.rkt") + "underscore-allowed.rkt" + "match-a-pattern.rkt") (define-struct compiled-pattern (cp)) @@ -49,8 +62,8 @@ transformation before the pattern compiler is invoked. (define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector (define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector -;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) -(define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below +;; repeat = (make-repeat compiled-pattern (listof rib) (or/c #f symbol?) (or/c #f symbol?)) +(define-struct repeat (pat empty-bindings name mismatch) #:inspector (make-inspector)) ;; inspector for tests below ;; compiled-pattern : exp hole-info -> (union #f (listof mtch)) ;; mtch = (make-mtch bindings sexp[context] (union none sexp[hole])) @@ -131,13 +144,13 @@ transformation before the pattern compiler is invoked. [non-list-nt-table (build-non-list-nt-label lang)] [list-nt-table (build-list-nt-label lang)] [do-compilation - (lambda (ht list-ht lang prefix-cross?) + (lambda (ht list-ht lang) (for-each (lambda (nt) (for-each (lambda (rhs) (let-values ([(compiled-pattern has-hole?) - (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)]) + (compile-pattern/cross? clang (rhs-pattern rhs) #f)]) (let ([add-to-ht (lambda (ht) (hash-set! @@ -176,9 +189,9 @@ transformation before the pattern compiler is invoked. (hash-set! across-ht (nt-name nt) null) (hash-set! across-list-ht (nt-name nt) null)) compatible-context-language) - (do-compilation across-ht across-list-ht compatible-context-language #f) + (do-compilation across-ht across-list-ht compatible-context-language) compatible-context-language))) - (do-compilation clang-ht clang-list-ht lang #t) + (do-compilation clang-ht clang-list-ht lang) (struct-copy compiled-lang clang [delayed-cclang compatible-context-language]))) ;; extract-literals : (listof nt) -> (listof symbol) @@ -195,7 +208,7 @@ transformation before the pattern compiler is invoked. ;; inserts the literals mentioned in pat into ht (define (extract-literals/pat nts pat ht) (let loop ([pat pat]) - (match pat + (match-a-pattern pat [`any (void)] [`number (void)] [`string (void)] @@ -207,12 +220,9 @@ transformation before the pattern compiler is invoked. [`(variable-prefix ,s) (void)] [`variable-not-otherwise-mentioned (void)] [`hole (void)] - [(? symbol? s) - (unless (regexp-match #rx"_" (symbol->string s)) - (unless (regexp-match #rx"^\\.\\.\\." (symbol->string s)) - (unless (memq s nts) - (hash-set! ht s #t))))] + [`(nt ,id) (void)] [`(name ,name ,pat) (loop pat)] + [`(mismatch-name ,name ,pat) (loop pat)] [`(in-hole ,p1 ,p2) (loop p1) (loop p2)] @@ -220,11 +230,19 @@ transformation before the pattern compiler is invoked. [`(side-condition ,p ,g ,e) (loop p)] [`(cross ,s) (void)] - [_ - (let l-loop ([l-pat pat]) - (when (pair? l-pat) - (loop (car l-pat)) - (l-loop (cdr l-pat))))]))) + [`(list ,sub-pats ...) + (for ([sub-pat (in-list sub-pats)]) + (match sub-pat + [`(repeat ,pat ,name ,mismatch) + (loop pat)] + [else + (loop sub-pat)]))] + [(? (compose not pair?)) + (when (symbol? pat) + (unless (regexp-match #rx"_" (symbol->string pat)) + (unless (regexp-match #rx"^\\.\\.\\." (symbol->string pat)) + (unless (memq pat nts) + (hash-set! ht pat #t)))))]))) ; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean] ; produces a map of nonterminal -> whether that nonterminal could produce a hole @@ -232,66 +250,70 @@ transformation before the pattern compiler is invoked. (build-nt-property lang (lambda (pattern recur) - (match pattern + (match-a-pattern pattern [`any #f] [`number #f] [`string #f] - [`variable #f] [`natural #f] [`integer #f] [`real #f] + [`variable #f] [`(variable-except ,vars ...) #f] [`(variable-prefix ,var) #f] [`variable-not-otherwise-mentioned #f] [`hole #t] - [(? string?) #f] - [(? symbol?) - ;; cannot be a non-terminal, otherwise this function isn't called - #f] + [`(nt ,id) + (error 'build-has-hole-nt "should not get here")] [`(name ,name ,pat) (recur pat)] + [`(mismatch-name ,name ,pat) + (recur pat)] [`(in-hole ,context ,contractum) (recur contractum)] [`(hide-hole ,arg) #f] [`(side-condition ,pat ,condition ,expr) (recur pat)] - [(? list?) - (ormap recur pattern)] - [else #f])) + [`(cross ,nt) #f] + [`(list ,pats ...) + (for/or ([pat (in-list pats)]) + (match pat + [`(repeat ,pat ,name ,mismatch?) (recur pat)] + [_ (recur pat)]))] + [(? (compose not pair?)) #f])) #t (lambda (lst) (ormap values lst)))) ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean ;; -> hash[symbol[nt] -> boolean] (define (build-nt-property lang test-rhs conservative-answer combine-rhss) - (let ([ht (make-hasheq)] - [rhs-ht (make-hasheq)]) - (for-each - (lambda (nt) - (hash-set! rhs-ht (nt-name nt) (nt-rhs nt)) - (hash-set! ht (nt-name nt) 'unknown)) - lang) - (let () - (define (check-nt nt-sym) - (let ([current (hash-ref ht nt-sym)]) - (case current - [(unknown) - (hash-set! ht nt-sym 'computing) - (let ([answer (combine-rhss - (map (lambda (x) (check-rhs (rhs-pattern x))) - (hash-ref rhs-ht nt-sym)))]) - (hash-set! ht nt-sym answer) - answer)] - [(computing) conservative-answer] - [else current]))) - (define (check-rhs rhs) - (cond - [(hash-maps? ht rhs) - (check-nt rhs)] - [else (test-rhs rhs check-rhs)])) - (for-each (lambda (nt) (check-nt (nt-name nt))) - lang) - ht))) + (define ht (make-hasheq)) + (define rhs-ht (make-hasheq)) + (for ([nt (in-list lang)]) + (hash-set! rhs-ht (nt-name nt) (nt-rhs nt)) + (hash-set! ht (nt-name nt) 'unknown)) + (define (check-nt nt-sym) + (let ([current (hash-ref ht nt-sym)]) + (case current + [(unknown) + (hash-set! ht nt-sym 'computing) + (let ([answer (combine-rhss + (map (lambda (x) (check-rhs (rhs-pattern x))) + (hash-ref rhs-ht nt-sym)))]) + (hash-set! ht nt-sym answer) + answer)] + [(computing) conservative-answer] + [else current]))) + (define (check-rhs rhs) + (match rhs + [`(nt ,nt) + (cond + [(hash-maps? ht nt) + (check-nt nt)] + [else (test-rhs rhs check-rhs)])] + [_ (test-rhs rhs check-rhs)])) + (for ([nt (in-list lang)]) + (check-nt (nt-name nt))) + ht) ;; build-compatible-context-language : lang -> lang (define (build-compatible-context-language clang-ht lang) @@ -383,7 +405,7 @@ transformation before the pattern compiler is invoked. (let loop ([pattern pattern]) (define (untouched-pattern _) (values pattern #f)) - (match pattern + (match-a-pattern pattern [`any untouched-pattern] [`number untouched-pattern] [`string untouched-pattern] @@ -395,16 +417,15 @@ transformation before the pattern compiler is invoked. [`(variable-prefix ,var) untouched-pattern] [`variable-not-otherwise-mentioned untouched-pattern] [`hole untouched-pattern] - [(? string?) untouched-pattern] - [(? symbol?) + [`(nt ,name) (cond - [(hash-ref clang-ht pattern #f) + [(hash-ref clang-ht name #f) (set! count (+ count 1)) (lambda (l) (let ([fst (car (unbox l))]) (set-box! l (cdr (unbox l))) (if fst - (values `(cross ,(symbol-append prefix '- pattern)) #t) + (values `(cross ,(symbol-append prefix '- name)) #t) (values pattern #f))))] [else untouched-pattern])] [`(name ,name ,pat) @@ -412,6 +433,11 @@ transformation before the pattern compiler is invoked. (lambda (l) (let-values ([(p h?) (patf l)]) (values `(name ,name ,p) h?))))] + [`(mismatch-name ,name ,pat) + (let ([patf (loop pat)]) + (lambda (l) + (let-values ([(p h?) (patf l)]) + (values `(mismatch-name ,name ,p) h?))))] [`(in-hole ,context ,contractum) (let ([match-context (loop context)] [match-contractum (loop contractum)]) @@ -431,15 +457,15 @@ transformation before the pattern compiler is invoked. (lambda (l) (let-values ([(p h?) (patf l)]) (values `(side-condition ,p ,condition ,expr) h?))))] - [(? list?) + [`(cross ,arg) untouched-pattern] + [`(list ,pats ...) (define pre-cross - (let l-loop ([ps pattern]) - (match ps - ['() '()] - [(list-rest p '... ps*) - (cons (list (loop p) p) (l-loop ps*))] - [(cons p ps*) - (cons (list (loop p) #f) (l-loop ps*))]))) + (for/list ([sub-pat (in-list pats)]) + (match sub-pat + [`(repeat ,pat ,name ,mismatch) + (list (loop pat) sub-pat)] + [else + (list (loop sub-pat) #f)]))) (λ (l) (define any-cross? #f) (define post-cross @@ -450,22 +476,28 @@ transformation before the pattern compiler is invoked. (list p h? r?))]) pre-cross)) (define (hide p) - (if any-cross? `(hide-hole ,p) p)) + (if any-cross? + (match p + [`(repeat ,p ,name ,mismatch?) + `(repeat (hide-hole ,p) ,name ,mismatch?)] + [_ + `(hide-hole ,p)]) + p)) (values - (foldr (λ (post tail) - (match post - [(list p* #t (and (not #f) p)) - `(,(hide p) ... ,p* ,(hide p) ... . ,tail)] - [(list p #f (not #f)) - `(,(hide p) ... . ,tail)] - [(list p* #t #f) - `(,p* . ,tail)] - [(list p #f #f) - `(,(hide p) . ,tail)])) - '() - post-cross) + `(list ,@(foldr (λ (post tail) + (match post + [(list p* #t (and (not #f) p)) + `(,(hide p) ,p* ,(hide p) . ,tail)] + [(list p #f (not #f)) + `((repeat ,(hide p) #f #f) . ,tail)] + [(list p* #t #f) + `(,p* . ,tail)] + [(list p #f #f) + `(,(hide p) . ,tail)])) + '() + post-cross)) any-cross?))] - [else untouched-pattern]))) + [(? (compose not pair?)) untouched-pattern]))) (values (λ (l) (let-values ([(p _) (maker l)]) p)) count))) @@ -484,39 +516,35 @@ transformation before the pattern compiler is invoked. (let loop ([pattern pattern]) (may-be-list-pattern?/internal pattern - (lambda (sym) - (hash-ref list-nt-table (symbol->nt sym) #t)) + (lambda (nt) + (hash-ref list-nt-table nt #t)) loop))) -(define (may-be-list-pattern?/internal pattern handle-symbol recur) - (match pattern +(define (may-be-list-pattern?/internal pattern handle-nt recur) + (match-a-pattern pattern [`any #t] [`number #f] [`string #f] - [`variable #f] [`natural #f] [`integer #f] [`real #f] + [`variable #f] [`(variable-except ,vars ...) #f] - [`variable-not-otherwise-mentioned #f] [`(variable-prefix ,var) #f] - [`hole #t] - [(? string?) #f] - [(? symbol?) - (handle-symbol pattern)] - [`(name ,name ,pat) - (recur pat)] + [`variable-not-otherwise-mentioned #f] + [`hole #t] + [`(nt ,id) (handle-nt id)] + [`(name ,id ,pat) (recur pat)] + [`(mismatch-name ,id ,pat) (recur pat)] [`(in-hole ,context ,contractum) (recur context)] [`(hide-hole ,p) (recur p)] [`(side-condition ,pat ,condition ,expr) (recur pat)] - [(? list?) - #t] - [else - ;; is this right?! - (or (null? pattern) (pair? pattern))])) + [`(cross ,nt) #t] + [`(list ,pats ...) #t] + [(? (compose not pair?)) #f])) ;; build-non-list-nt-label : lang -> hash[symbol -o> boolean] @@ -534,38 +562,37 @@ transformation before the pattern compiler is invoked. (let loop ([pattern pattern]) (may-be-non-list-pattern?/internal pattern - (lambda (sym) - (hash-ref non-list-nt-table (symbol->nt sym) #t)) + (lambda (nt) + (hash-ref non-list-nt-table nt #t)) loop))) -(define (may-be-non-list-pattern?/internal pattern handle-sym recur) - (match pattern +(define (may-be-non-list-pattern?/internal pattern handle-nt recur) + (match-a-pattern pattern [`any #t] [`number #t] [`string #t] - [`variable #t] [`natural #t] [`integer #t] [`real #t] + [`variable #t] [`(variable-except ,vars ...) #t] - [`variable-not-otherwise-mentioned #t] [`(variable-prefix ,prefix) #t] + [`variable-not-otherwise-mentioned #t] [`hole #t] - [(? string?) #t] - [(? symbol?) (handle-sym pattern)] + [`(nt ,nt) (handle-nt nt)] [`(name ,name ,pat) (recur pat)] + [`(mismatch-name ,name ,pat) + (recur pat)] [`(in-hole ,context ,contractum) (recur context)] [`(hide-hole ,p) (recur p)] [`(side-condition ,pat ,condition ,expr) (recur pat)] - [(? list?) - #f] - [else - ;; is this right?! - (not (or (null? pattern) (pair? pattern)))])) + [`(cross ,nt) #t] + [`(list ,pats ...) #f] + [(? (compose not pair?)) #t])) ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) (define (match-pattern compiled-pattern exp) @@ -632,15 +659,15 @@ transformation before the pattern compiler is invoked. ;; compile-pattern : compiled-lang pattern boolean -> compiled-pattern (define (compile-pattern clang pattern bind-names?) - (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) + (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern bind-names?)]) (make-compiled-pattern pattern))) ;; name-to-key/binding : hash[symbol -o> key-wrap] (define name-to-key/binding (make-hasheq)) (define-struct key-wrap (sym) #:inspector (make-inspector)) -;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) -(define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) +;; compile-pattern/cross? : compiled-lang pattern boolean -> (values compiled-pattern boolean) +(define (compile-pattern/cross? clang pattern bind-names?) (define clang-ht (compiled-lang-ht clang)) (define clang-list-ht (compiled-lang-list-ht clang)) (define has-hole-ht (compiled-lang-has-hole-ht clang)) @@ -664,9 +691,14 @@ transformation before the pattern compiler is invoked. (apply values compiled-cache)]))) (define (true-compile-pattern pattern) - (match pattern - [(? (lambda (x) (eq? x '....))) - (error 'compile-language "the pattern .... can only be used in extend-language")] + (match-a-pattern pattern + [`any (simple-match (λ (x) #t))] + [`number (simple-match number?)] + [`string (simple-match string?)] + [`natural (simple-match exact-nonnegative-integer?)] + [`integer (simple-match exact-integer?)] + [`real (simple-match real?)] + [`variable (simple-match symbol?)] [`(variable-except ,vars ...) (values (lambda (exp hole-info) @@ -689,54 +721,28 @@ transformation before the pattern compiler is invoked. (build-flat-context exp) none))))))) #f)] + [`variable-not-otherwise-mentioned + (let ([literals (compiled-lang-literals clang)]) + (simple-match + (λ (exp) + (and (symbol? exp) + (not (memq exp literals))))))] [`hole (values match-hole #t)] - [(? string?) + [`(nt ,nt) (values (lambda (exp hole-info) - (and (string? exp) - (string=? exp pattern) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)] - [(? symbol?) - (cond - [(has-underscore? pattern) - (let*-values ([(binder before-underscore) - (let ([before (split-underscore pattern)]) - (values pattern before))] - [(match-raw-name has-hole?) - (compile-id-pattern before-underscore)]) - (values - (match-named-pat binder match-raw-name) - has-hole?))] - [else - (let-values ([(match-raw-name has-hole?) (compile-id-pattern pattern)]) - (values (if (non-underscore-binder? pattern) - (match-named-pat pattern match-raw-name) - match-raw-name) - has-hole?))])] - [`(cross ,(? symbol? pre-id)) - (define across-ht (compiled-lang-across-ht clang)) - (define across-list-ht (compiled-lang-across-list-ht clang)) - (define id (if prefix-cross? - (symbol-append pre-id '- pre-id) - pre-id)) - (cond - [(hash-maps? across-ht id) - (values - (lambda (exp hole-info) - (match-nt (hash-ref across-list-ht id) - (hash-ref across-ht id) - id exp hole-info)) - #t)] - [else - (error 'compile-pattern "unknown cross reference ~a" id)])] - + (match-nt (hash-ref clang-list-ht nt) + (hash-ref clang-ht nt) + nt exp hole-info)) + (hash-ref has-hole-ht nt))] [`(name ,name ,pat) (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) - (values (match-named-pat name match-pat) + (values (match-named-pat name match-pat #f) + has-hole?))] + [`(mismatch-name ,name ,pat) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) + (values (match-named-pat name match-pat #t) has-hole?))] [`(in-hole ,context ,contractum) (let-values ([(match-context ctxt-has-hole?) (compile-pattern/default-cache context)] @@ -753,7 +759,6 @@ transformation before the pattern compiler is invoked. (map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none)) matches)))) #f))] - [`(side-condition ,pat ,condition ,expr) (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) (values @@ -766,76 +771,97 @@ transformation before the pattern compiler is invoked. #f filtered))))) has-hole?))] - [(? list?) - (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern compile-pattern/default-cache)]) - (let ([count (and (not (ormap repeat? rewritten)) - (length rewritten))]) + [`(cross ,(? symbol? id)) + (define across-ht (compiled-lang-across-ht clang)) + (define across-list-ht (compiled-lang-across-list-ht clang)) + (cond + [(hash-maps? across-ht id) + (values + (lambda (exp hole-info) + (match-nt (hash-ref across-list-ht id) + (hash-ref across-ht id) + id exp hole-info)) + #t)] + [else + (error 'compile-pattern "unknown cross reference ~a" id)])] + [`(list ,pats ...) + (let-values ([(rewritten has-hole?) (rewrite-ellipses pats compile-pattern/default-cache)]) + (let ([repeats (length (filter repeat? rewritten))] + [non-repeats (length (filter (λ (x) (not (repeat? x))) rewritten))]) (values - (lambda (exp hole-info) - (cond - [(list? exp) - ;; shortcircuit: if the list isn't the right length, give up immediately. - (if (and count - (not (= (length exp) count))) - #f - (match-list rewritten exp hole-info))] - [else #f])) + (cond + [(= 0 repeats) + (lambda (exp hole-info) + (cond + [(list? exp) + ;; shortcircuit: if the list isn't the right length, give up immediately. + (if (= (length exp) non-repeats) + (match-list rewritten exp hole-info) + #f)] + [else #f]))] + [else + (lambda (exp hole-info) + (cond + [(list? exp) + ;; shortcircuit: if the list doesn't have the right number of + ;; fixed parts, give up immediately + (if (>= (length exp) non-repeats) + (match-list rewritten exp hole-info) + #f)] + [else #f]))]) has-hole?)))] - ;; an already comiled pattern - [(? compiled-pattern?) - ;; return #t here as a failsafe; no way to check better. - (values (compiled-pattern-cp pattern) - #t)] - - [else - (values - (lambda (exp hole-info) - (and (equal? pattern exp) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)])) + [(? (compose not pair?)) + (cond + [(compiled-pattern? pattern) ;; can this really happen anymore?! + (values (compiled-pattern-cp pattern) + ;; return #t here as a failsafe; no way to check better. + #t)] + [(eq? pattern '....) + ;; this should probably be checked at compile time, not here + (error 'compile-language "the pattern .... can only be used in extend-language")] + [else + (values + (lambda (exp hole-info) + (and (equal? pattern exp) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)])])) + + (define (has-name? pattern) + (match-a-pattern + pattern + [`any #f] + [`number #f] + [`string #f] + [`natural #f] + [`integer #f] + [`real #f] + [`variable #f] + [`(variable-except ,vars ...) #f] + [`(variable-prefix ,vars) #f] + [`variable-not-otherwise-mentioned #f] + [`hole #f] + [`(nt ,nt) #f] + [`(name ,name ,pat) #t] + [`(mismatch-name ,name ,pat) #t] + [`(in-hole ,context ,contractum) (or (has-name? context) (has-name? contractum))] + [`(hide-hole ,p) (has-name? p)] + [`(side-condition ,pat ,test ,expr) (has-name? pat)] + [`(cross ,id) #f] + [`(list ,pats ...) + (for/or ([p (in-list pats)]) + (cond + [(repeat? p) (has-name? (repeat-pat p))] + [else (has-name? p)]))] + [(? (compose not pair?)) #f])) (define (non-underscore-binder? pattern) (and bind-names? (or (hash-maps? clang-ht pattern) (memq pattern underscore-allowed)))) - ;; compile-id-pattern : symbol[with-out-underscore] -> (values boolean) - (define (compile-id-pattern pat) - (match pat - [`any (simple-match (λ (x) #t))] - [`number (simple-match number?)] - [`string (simple-match string?)] - [`variable (simple-match symbol?)] - [`variable-not-otherwise-mentioned - (let ([literals (compiled-lang-literals clang)]) - (simple-match - (λ (exp) - (and (symbol? exp) - (not (memq exp literals))))))] - [`natural (simple-match (λ (x) (and (integer? x) (exact? x) (not (negative? x)))))] - [`integer (simple-match (λ (x) (and (integer? x) (exact? x))))] - [`real (simple-match real?)] - [(? is-non-terminal?) - (values - (lambda (exp hole-info) - (match-nt (hash-ref clang-list-ht pat) - (hash-ref clang-ht pat) - pat exp hole-info)) - (hash-ref has-hole-ht pat))] - [else - (values - (lambda (exp hole-info) - (and (eq? exp pat) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)])) - - (define (is-non-terminal? sym) (hash-maps? clang-ht sym)) - ;; simple-match : (any -> bool) -> (values boolean) ;; does a match based on a built-in Scheme predicate (define (simple-match pred) @@ -850,48 +876,24 @@ transformation before the pattern compiler is invoked. (compile-pattern/default-cache pattern)) ;; match-named-pat : symbol -> -(define (match-named-pat name match-pat) - (let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))]) - (lambda (exp hole-info) - (let ([matches (match-pat exp hole-info)]) - (and matches - (map (lambda (match) - (make-mtch - (make-bindings (cons (if mismatch-bind? - (make-mismatch-bind name (mtch-context match)) - (make-bind name (mtch-context match))) - (bindings-table (mtch-bindings match)))) - (mtch-context match) - (mtch-hole match))) - matches)))))) - -;; split-underscore : symbol -> symbol -;; returns the text before the underscore in a symbol (as a symbol) -;; raise an error if there is more than one underscore in the input -(define (split-underscore sym) - (let ([str (symbol->string sym)]) - (cond - [(regexp-match #rx"^([^_]*)_[^_]*$" str) - => - (λ (m) (string->symbol (cadr m)))] - [(regexp-match #rx"^([^_]*)_!_[^_]*$" str) - => - (λ (m) (string->symbol (cadr m)))] - [else - (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)]))) +(define (match-named-pat name match-pat mismatch-bind?) + (lambda (exp hole-info) + (let ([matches (match-pat exp hole-info)]) + (and matches + (map (lambda (match) + (make-mtch + (make-bindings (cons (if mismatch-bind? + (make-mismatch-bind name (mtch-context match)) + (make-bind name (mtch-context match))) + (bindings-table (mtch-bindings match)))) + (mtch-context match) + (mtch-hole match))) + matches))))) ;; has-underscore? : symbol -> boolean (define (has-underscore? sym) (memq #\_ (string->list (symbol->string sym)))) -;; symbol->nt : symbol -> symbol -;; strips the trailing underscore from a symbol, if one is there. -(define (symbol->nt sym) - (cond - [(has-underscore? sym) - (split-underscore sym)] - [else sym])) - (define (memoize f needs-all-args?) (if needs-all-args? (memoize2 f) @@ -1229,7 +1231,7 @@ transformation before the pattern compiler is invoked. (cons (let/ec k (let ([mt-fail (lambda () (k null))]) (map (lambda (pat-ele) - (cons (add-ellipses-index (list r-mt) (repeat-suffix fst-pat) (repeat-mismatch? fst-pat) 0) + (cons (add-ellipses-index (list r-mt) (repeat-name fst-pat) (repeat-mismatch fst-pat) 0) pat-ele)) (loop (cdr patterns) exp mt-fail)))) (let r-loop ([exp exp] @@ -1246,8 +1248,8 @@ transformation before the pattern compiler is invoked. [reversed (add-ellipses-index (reverse-multiples combined-matches) - (repeat-suffix fst-pat) - (repeat-mismatch? fst-pat) + (repeat-name fst-pat) + (repeat-mismatch fst-pat) index)]) (cons (let/ec fail-k @@ -1282,17 +1284,19 @@ transformation before the pattern compiler is invoked. (list null) (fail))])))) -;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch) -(define (add-ellipses-index mtchs key mismatch-bind? i) - (if key - (let ([rib (if mismatch-bind? - (make-mismatch-bind key i) - (make-bind key i))]) - (map (λ (mtch) (make-mtch (make-bindings (cons rib (bindings-table (mtch-bindings mtch)))) - (mtch-context mtch) - (mtch-hole mtch))) - mtchs)) - mtchs)) +;; add-ellipses-index : (listof mtch) (or/c sym #f) (or/c sym #f) number -> (listof mtch) +(define (add-ellipses-index mtchs name mismatch-name i) + (let* ([ribs '()] + [ribs (if name + (cons (make-bind name i) ribs) + ribs)] + [ribs (if mismatch-name + (cons (make-mismatch-bind mismatch-name i) ribs) + ribs)]) + (map (λ (mtch) (make-mtch (make-bindings (append ribs (bindings-table (mtch-bindings mtch)))) + (mtch-context mtch) + (mtch-hole mtch))) + mtchs))) ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists]) (define (collapse-single-multiples bindingss multiple-bindingss) @@ -1311,7 +1315,7 @@ transformation before the pattern compiler is invoked. (make-mismatch-bind name (cons sing-exp mult-exp))] [else (error 'collapse-single-multiples - "internal error: expected matches' bindings in same order; got ~e ~e" + "internal error: expected matches' bindings in same order; got\n ~e\n ~e" single-bindings multiple-bindings)]) (bindings-table single-bindings) @@ -1354,24 +1358,37 @@ transformation before the pattern compiler is invoked. ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info ;; -> (union #f (listof bindings)) (define (match-nt list-rhs non-list-rhs nt term hole-info) - (let loop ([rhss (if (or (null? term) (pair? term)) - list-rhs - non-list-rhs)] - [ht #f]) - (cond - [(null? rhss) - (if ht - (hash-map ht (λ (k v) k)) - #f)] - [else - (let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) - (cond - [mth - (let ([ht (or ht (make-hash))]) - (for-each (λ (x) (hash-set! ht x #t)) mth) - (loop (cdr rhss) ht))] - [else - (loop (cdr rhss) ht)]))]))) + (if hole-info + + (let loop ([rhss (if (or (null? term) (pair? term)) + list-rhs + non-list-rhs)] + [ht #f]) + (cond + [(null? rhss) + (if ht + (hash-map ht (λ (k v) k)) + #f)] + [else + (let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) + (cond + [mth + (let ([ht (or ht (make-hash))]) + (for-each (λ (x) (hash-set! ht x #t)) mth) + (loop (cdr rhss) ht))] + [else + (loop (cdr rhss) ht)]))])) + + ;; if we're not doing a decomposition, we just need + ;; to find the first match, not all of the matches + (let loop ([rhss (if (or (null? term) (pair? term)) + list-rhs + non-list-rhs)]) + (cond + [(null? rhss) #f] + [else + (or (remove-bindings/filter ((car rhss) term hole-info)) + (loop (cdr rhss)))])))) ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) (define (remove-bindings/filter matches) @@ -1384,43 +1401,28 @@ transformation before the pattern compiler is invoked. (mtch-hole match))) matches))))) -;; rewrite-ellipses : (symbol -> boolean) -;; (listof pattern) +;; rewrite-ellipses : (listof l-pat) ;; (pattern -> (values compiled-pattern boolean)) ;; -> (values (listof (union repeat compiled-pattern)) boolean) ;; moves the ellipses out of the list and produces repeat structures -(define (rewrite-ellipses non-underscore-binder? pattern compile) - (let loop ([exp-eles pattern] - [fst dummy]) - (cond - [(null? exp-eles) - (if (eq? fst dummy) - (values empty #f) - (let-values ([(compiled has-hole?) (compile fst)]) - (values (list compiled) has-hole?)))] - [else - (let ([exp-ele (car exp-eles)]) - (cond - [(or (eq? '... exp-ele) - (prefixed-with? "..._" exp-ele)) - (when (eq? fst dummy) - (error 'match-pattern "bad ellipses placement: ~s" pattern)) - (let-values ([(compiled has-hole?) (compile fst)] - [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)]) - (let ([underscore-key (if (eq? exp-ele '...) #f exp-ele)] - [mismatch? (and (regexp-match #rx"_!_" (symbol->string exp-ele)) #t)]) - (values - (cons (make-repeat compiled (extract-empty-bindings non-underscore-binder? fst) underscore-key mismatch?) - rest) - (or has-hole? rest-has-hole?))))] - [(eq? fst dummy) - (loop (cdr exp-eles) exp-ele)] - [else - (let-values ([(compiled has-hole?) (compile fst)] - [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)]) - (values - (cons compiled rest) - (or has-hole? rest-has-hole?)))]))]))) +(define (rewrite-ellipses pattern compile) + (let loop ([exp-eles pattern]) + (match exp-eles + [`() (values empty #f)] + [(cons `(repeat ,pat ,name ,mismatch-name) rst) + (define-values (fst-compiled fst-has-hole?) (compile pat)) + (define-values (rst-compiled rst-has-hole?) (loop rst)) + (values (cons (make-repeat fst-compiled + (extract-empty-bindings pat) + name + mismatch-name) + rst-compiled) + (or fst-has-hole? rst-has-hole?))] + [(cons pat rst) + (define-values (fst-compiled fst-has-hole?) (compile pat)) + (define-values (rst-compiled rst-has-hole?) (loop rst)) + (values (cons fst-compiled rst-compiled) + (or fst-has-hole? rst-has-hole?))]))) (define (prefixed-with? prefix exp) (and (symbol? exp) @@ -1432,34 +1434,34 @@ transformation before the pattern compiler is invoked. (define dummy (box 0)) -;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib) -(define (extract-empty-bindings non-underscore-binder? pattern) +;; extract-empty-bindings : pattern -> (listof rib) +(define (extract-empty-bindings pattern) (let loop ([pattern pattern] [ribs null]) - (match pattern + (match-a-pattern pattern + [`any ribs] + [`number ribs] + [`string ribs] + [`natural ribs] + [`integer ribs] + [`real ribs] + [`variable ribs] [`(variable-except ,vars ...) ribs] [`(variable-prefix ,vars) ribs] [`variable-not-otherwise-mentioned ribs] [`hole ribs] - [(? symbol?) - (cond - [(regexp-match #rx"_!_" (symbol->string pattern)) - (cons (make-mismatch-bind pattern '()) ribs)] - [(or (has-underscore? pattern) - (non-underscore-binder? pattern)) - (cons (make-bind pattern '()) ribs)] - [else ribs])] - [`(name ,name ,pat) - (cons (if (regexp-match #rx"_!_" (symbol->string name)) - (make-mismatch-bind name '()) - (make-bind name '())) - (loop pat ribs))] + [`(nt ,nt) ribs] + [`(name ,name ,pat) + (cons (make-bind name '()) (loop pat ribs))] + [`(mismatch-name ,name ,pat) + (cons (make-mismatch-bind name '()) (loop pat ribs))] [`(in-hole ,context ,contractum) (loop contractum (loop context ribs))] [`(hide-hole ,p) (loop p ribs)] [`(side-condition ,pat ,test ,expr) (loop pat ribs)] - [(? list?) - (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern (lambda (x) (values x #f)))]) + [`(cross ,id) ribs] + [`(list ,pats ...) + (let-values ([(rewritten has-hole?) (rewrite-ellipses pats (lambda (x) (values x #f)))]) (let i-loop ([r-exps rewritten] [ribs ribs]) (cond @@ -1467,18 +1469,18 @@ transformation before the pattern compiler is invoked. [else (let ([r-exp (car r-exps)]) (cond [(repeat? r-exp) - (append (if (repeat-suffix r-exp) - (list ((if (repeat-mismatch? r-exp) - make-mismatch-bind - make-bind) - (repeat-suffix r-exp) - '())) - null) + (define bindings (if (repeat-mismatch r-exp) + (list (make-mismatch-bind (repeat-mismatch r-exp) '())) + '())) + (define bindings2 (if (repeat-name r-exp) + (cons (make-bind (repeat-name r-exp) '()) bindings) + bindings)) + (append bindings2 (repeat-empty-bindings r-exp) (i-loop (cdr r-exps) ribs))] [else (loop (car r-exps) (i-loop (cdr r-exps) ribs))]))])))] - [else ribs]))) + [(? (compose not pair?)) ribs]))) ;; combine-matches : (listof (listof mtch)) -> (listof mtch) ;; input is the list of bindings corresonding to a piecewise match @@ -1605,10 +1607,7 @@ transformation before the pattern compiler is invoked. (bind? (any/c . -> . boolean?)) (bind-name (bind? . -> . symbol?)) (bind-exp (bind? . -> . any/c)) - (compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?)) - (symbol->nt (symbol? . -> . symbol?)) - (has-underscore? (symbol? . -> . boolean?)) - (split-underscore (symbol? . -> . symbol?))) + (compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?))) (provide compiled-pattern? print-stats) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index ac3fa7a6e2..cb03b86740 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -52,12 +52,7 @@ (unless (identifier? #'lang) (raise-syntax-error (syntax-e #'form-name) "expected an identifier in the language position" orig-stx #'lang)) (let ([lang-nts (language-id-nts #'lang (syntax-e #'form-name))]) - (with-syntax ([(((names ...) (names/ellipses ...)) ...) - (map (λ (x) (call-with-values - (λ () (extract-names lang-nts (syntax-e #'form-name) #t x)) - list)) - (syntax->list (syntax (pattern ...))))] - [(side-conditions-rewritten ...) + (with-syntax ([((side-conditions-rewritten (names ...) (names/ellipses ...)) ...) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts (syntax-e #'form-name) #t x)) (syntax->list (syntax (pattern ...))))] [(cp-x ...) (generate-temporaries #'(pattern ...))] @@ -158,7 +153,7 @@ (syntax-case stx () [(_ red lang nt) (identifier? (syntax nt)) - (with-syntax ([side-conditions-rewritten + (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs (language-id-nts #'lang 'compatible-closure) 'compatible-closure #t @@ -170,7 +165,7 @@ (define-syntax (context-closure stx) (syntax-case stx () [(_ red lang pattern) - (with-syntax ([side-conditions-rewritten + (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs (language-id-nts #'lang 'context-closure) 'context-closure #t @@ -291,8 +286,8 @@ (syntax-case stx () [(s (... ...)) (let ([r (id/depth #'s)]) - (make-id/depth (id/depth-id r) (add1 (id/depth-depth r))))] - [s (make-id/depth #'s 0)])) + (make-id/depth (id/depth-id r) (add1 (id/depth-depth r)) (id/depth-mismatch? r)))] + [s (make-id/depth #'s 0 #f)])) (define temporaries (generate-temporaries names)) (values (for/fold ([cs '()]) @@ -332,37 +327,33 @@ [() body] [((-where x e) y ...) (where-keyword? #'-where) - (let-values ([(names names/ellipses) (extract-names lang-nts 'reduction-relation #t #'x)]) - (define-values (binding-constraints temporaries env+) - (generate-binding-constraints names names/ellipses env orig-name)) - (with-syntax ([(binding-constraints ...) binding-constraints] - [side-conditions-rewritten (rewrite-side-conditions/check-errs - lang-nts - 'reduction-relation - #f - #'x)] - [(names ...) names] - [(names/ellipses ...) names/ellipses] - [(x ...) temporaries]) - (let ([rest-body (loop #'(y ...) #`(list x ... #,to-not-be-in) env+)]) - #`(let* ([mtchs (match-pattern (compile-pattern #,lang `side-conditions-rewritten #t) (term e))] - [result (λ (mtch) - (let ([bindings (mtch-bindings mtch)]) - (let ([x (lookup-binding bindings 'names)] ...) - (and binding-constraints ... - (term-let ([names/ellipses x] ...) - #,rest-body)))))]) - (if mtchs - #, - (case where-mode - [(flatten) - #`(for/fold ([r '()]) ([m mtchs]) - (let ([s (result m)]) - (if s (append s r) r)))] - [(predicate) - #`(ormap result mtchs)] - [else (error 'unknown-where-mode "~s" where-mode)]) - #f)))))] + (let () + (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) + (rewrite-side-conditions/check-errs + lang-nts + 'reduction-relation + #t + #'x)]) + (define-values (binding-constraints temporaries env+) + (generate-binding-constraints (syntax->list #'(names ...)) + (syntax->list #'(names/ellipses ...)) + env + orig-name)) + (with-syntax ([(binding-constraints ...) binding-constraints] + [(x ...) temporaries]) + (define rest-body (loop #'(y ...) #`(list x ... #,to-not-be-in) env+)) + #`(#,(case where-mode + [(flatten) + #'combine-where-results/flatten] + [(predicate) + #'combine-where-results/predicate] + [else (error 'unknown-where-mode "~s" where-mode)]) + (match-pattern (compile-pattern #,lang `side-conditions-rewritten #t) (term e)) + (λ (bindings) + (let ([x (lookup-binding bindings 'names)] ...) + (and binding-constraints ... + (term-let ([names/ellipses x] ...) + #,rest-body))))))))] [((-side-condition s ...) y ...) (or (free-identifier=? #'-side-condition #'side-condition) (free-identifier=? #'-side-condition #'side-condition/hidden)) @@ -410,10 +401,12 @@ (let ([ellipsis (syntax/loc premise (... ...))]) (values #`(#,in #,ellipsis) #`(#,out #,ellipsis))) (values in out)))] - [(output-pattern) - (rewrite-side-conditions/check-errs lang-nts orig-name #t output-pre-pattern)] - [(output-names output-names/ellipses) - (extract-names lang-nts orig-name #t output-pre-pattern)] + [(output-pattern output-names output-names/ellipses) + (with-syntax ([(output names names/ellipses) + (rewrite-side-conditions/check-errs lang-nts orig-name #t output-pre-pattern)]) + (values #'output + (syntax->list #'names) + (syntax->list #'names/ellipses)))] [(binding-constraints temporaries env+) (generate-binding-constraints output-names output-names/ellipses env orig-name)] [(rest-body) (loop rest-clauses #`(list judgment-output #,to-not-be-in) env+)] @@ -446,6 +439,17 @@ outputs))) outputs)))))])))) +(define (combine-where-results/flatten mtchs result) + (and mtchs + (for/fold ([r '()]) ([m mtchs]) + (let ([s (result (mtch-bindings m))]) + (if s (append s r) r))))) + +(define (combine-where-results/predicate mtchs result) + (and mtchs + (for/or ([mtch mtchs]) + (result (mtch-bindings mtch))))) + (define (repeated-premise-outputs inputs premise) (if (null? inputs) '(()) @@ -815,7 +819,7 @@ (map car (sort (hash-map name-table (λ (k v) (list k (list-ref v 1)))) < #:key cadr)))] [lws lws] - [domain-pattern-side-conditions-rewritten + [(domain-pattern-side-conditions-rewritten (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs lang-nts orig-name @@ -868,31 +872,30 @@ (let* ([lang-nts (language-id-nts lang-id orig-name)] [rewrite-side-conds (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))]) - (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t (syntax rhs-from))]) - (with-syntax ([(names ...) names] - [(names/ellipses ...) names/ellipses] - [side-conditions-rewritten (rewrite-side-conds - (rewrite-node-pat (syntax-e (syntax lhs-frm-id)) - (syntax rhs-from)))] - [fresh-rhs-from (rewrite-side-conds - (freshen-names #'rhs-from #'lhs-frm-id lang-nts orig-name))] - [lang lang]) - (map - (λ (child-proc) - #`(do-node-match - 'lhs-frm-id - 'lhs-to-id - `side-conditions-rewritten - (λ (bindings rhs-binder) - (term-let ([lhs-to-id rhs-binder] - [names/ellipses (lookup-binding bindings 'names)] ...) - (term rhs-to))) - #,child-proc - `fresh-rhs-from)) - (get-choices stx orig-name bm #'lang - (syntax lhs-arrow) - name-table lang-id - allow-zero-rules?)))))])) + (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) + (rewrite-side-conds + (rewrite-node-pat (syntax-e (syntax lhs-frm-id)) + (syntax rhs-from)))] + [(fresh-rhs-from (fresh-names ...) (fresh-names/ellipses ...)) + (rewrite-side-conds + (freshen-names #'rhs-from #'lhs-frm-id lang-nts orig-name))] + [lang lang]) + (map + (λ (child-proc) + #`(do-node-match + 'lhs-frm-id + 'lhs-to-id + `side-conditions-rewritten + (λ (bindings rhs-binder) + (term-let ([lhs-to-id rhs-binder] + [names/ellipses (lookup-binding bindings 'names)] ...) + (term rhs-to))) + #,child-proc + `fresh-rhs-from)) + (get-choices stx orig-name bm #'lang + (syntax lhs-arrow) + name-table lang-id + allow-zero-rules?))))])) (define (rewrite-node-pat id term) (let loop ([t term]) (syntax-case t (side-condition) @@ -936,37 +939,37 @@ (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 computed-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)] - [(body-code) - (bind-withs orig-name - #'main-exp - lang - lang-nts - sides/withs/freshs - 'flatten - #`(list (cons #,(or computed-name #'none) - (term #,to))) - names names/ellipses)] - [(test-case-body-code) - ;; this contains some redundant code - (bind-withs orig-name - #'#t - #'lang-id2 - lang-nts - sides/withs/freshs - 'predicate - #'#t - names names/ellipses)]) - (with-syntax ([side-conditions-rewritten (rw-sc from)] - [lhs-w/extras (rw-sc #`(side-condition #,from #,test-case-body-code))] + (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) (rw-sc from)]) + (define body-code + (bind-withs orig-name + #'main-exp + lang + lang-nts + sides/withs/freshs + 'flatten + #`(list (cons #,(or computed-name #'none) + (term #,to))) + (syntax->list #'(names ...)) + (syntax->list #'(names/ellipses ...)))) + (define test-case-body-code + ;; this contains some redundant code + (bind-withs orig-name + #'#t + #'lang-id2 + lang-nts + sides/withs/freshs + 'predicate + #'#t + (syntax->list #'(names ...)) + (syntax->list #'(names/ellipses ...)))) + (with-syntax ([(lhs-w/extras (w/extras-names ...) (w/extras-names/ellipses ...)) + (rw-sc #`(side-condition #,from #,test-case-body-code))] [lhs-source (format "~a:~a:~a" (syntax-source from) (syntax-line from) (syntax-column from))] [name name] [lang lang] - [(names ...) names] - [(names/ellipses ...) names/ellipses] [body-code body-code]) #` (build-rewrite-proc/leaf `side-conditions-rewritten @@ -1263,13 +1266,13 @@ [(form-name lang-exp pattern) (identifier? #'lang-exp) (let*-values ([(what) (syntax-e #'form-name)] - [(nts) (language-id-nts #'lang-exp what)] - [(ids/depths _) (extract-names nts what #t #'pattern)]) - (with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs nts what #t #'pattern)] - [binders (map syntax-e ids/depths)] - [name (syntax-local-infer-name stx)]) - (syntax - (do-test-match lang-exp `side-condition-rewritten 'binders 'name))))] + [(nts) (language-id-nts #'lang-exp what)]) + (with-syntax ([(side-condition-rewritten (vars ...) (ids/depths ...)) + (rewrite-side-conditions/check-errs nts what #t #'pattern)]) + (with-syntax ([binders (map syntax-e (syntax->list #'(ids/depths ...)))] + [name (syntax-local-infer-name stx)]) + (syntax + (do-test-match lang-exp `side-condition-rewritten 'binders 'name)))))] [(form-name lang-exp pattern expression) (identifier? #'lang-exp) (syntax @@ -1464,7 +1467,7 @@ [codom-contracts (syntax-e #'codom-contracts)] [pats (syntax-e #'pats)] [relation? (syntax-e #'relation?)] - [syn-error-name (syntax-e #'syn-err-name)]) + [syn-error-name (syntax-e #'syn-error-name)]) (define lang-nts (definition-nts #'lang #'orig-stx syn-error-name)) (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] @@ -1477,8 +1480,13 @@ #'((raw-rhses ...) ...))] [(lhs ...) #'((lhs-clauses ...) ...)]) (parse-extras #'((stuff ...) ...)) - (let-values ([(lhs-namess lhs-namess/ellipsess) - (lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) + (with-syntax ([((side-conditions-rewritten lhs-names lhs-namess/ellipses) ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax (lhs ...))))]) (with-syntax ([(rhs/wheres ...) (map (λ (sc/b rhs names names/ellipses) (bind-withs @@ -1486,10 +1494,12 @@ #'effective-lang lang-nts sc/b 'flatten #`(list (term #,rhs)) - names names/ellipses)) + (syntax->list names) + (syntax->list names/ellipses))) (syntax->list #'((stuff ...) ...)) (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)] + (syntax->list #'(lhs-names ...)) + (syntax->list #'(lhs-namess/ellipses ...)))] [(rg-rhs/wheres ...) (map (λ (sc/b rhs names names/ellipses) (bind-withs @@ -1497,18 +1507,13 @@ #'effective-lang lang-nts sc/b 'predicate #`#t - names names/ellipses)) + (syntax->list names) + (syntax->list names/ellipses))) (syntax->list #'((stuff ...) ...)) (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)]) - (with-syntax ([(side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #t - x)) - (syntax->list (syntax (lhs ...))))] - [(rg-side-conditions-rewritten ...) + (syntax->list #'(lhs-names ...)) + (syntax->list #'(lhs-namess/ellipses ...)))]) + (with-syntax ([((rg-side-conditions-rewritten rg-names rg-names/ellipses ...) ...) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts syn-error-name @@ -1522,14 +1527,15 @@ (syntax-line lhs) (syntax-column lhs))) pats)] - [dom-side-conditions-rewritten - (and dom-ctcs - (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #f - dom-ctcs))] - [(codom-side-conditions-rewritten ...) + [(dom-side-conditions-rewritten dom-names dom-names/ellipses) + (if dom-ctcs + (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #f + dom-ctcs) + #'(any () ()))] + [((codom-side-conditions-rewritten codom-names codom-names/ellipses) ...) (map (λ (codom-contract) (rewrite-side-conditions/check-errs lang-nts @@ -1547,7 +1553,8 @@ (term-let-fn ((name name)) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) rhs/where)))))) - lhs-namess lhs-namess/ellipsess + (syntax->list #'(lhs-names ...)) + (syntax->list #'(lhs-namess/ellipses ...)) (syntax->list (syntax (rhs/wheres ...))))]) (syntax-property (prune-syntax @@ -1587,7 +1594,7 @@ dsc (append cases parent-cases) #,relation?)) - dsc + #,(if dom-ctcs #'dsc #f) `(codom-side-conditions-rewritten ...) 'name #,relation?)))) @@ -1680,17 +1687,6 @@ (raise-syntax-error #f "mode and contract specify different numbers of positions" full-def))) -(define-for-syntax (lhss-bound-names lhss nts syn-error-name) - (let loop ([lhss lhss]) - (if (null? lhss) - (values null null) - (let-values ([(namess namess/ellipsess) - (loop (cdr lhss))] - [(names names/ellipses) - (extract-names nts syn-error-name #t (car lhss))]) - (values (cons names namess) - (cons names/ellipses namess/ellipsess)))))) - (define-for-syntax (defined-name declared-names clauses orig-stx) (with-syntax ([(((used-names _ ...) _ ...) ...) clauses]) (define-values (the-name other-names) @@ -1892,26 +1888,30 @@ (syntax-case clause () [((_ . conc-pats) . prems) (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) - (define-values (input-names input-names/ellipses) - (extract-names nts syn-error-name #t input-pats)) (define ((rewrite-pattern binds?) pat) (rewrite-side-conditions/check-errs nts syn-error-name binds? pat)) - (define (contracts-compilation ctcs) - (and ctcs #`(map (λ (p) (compile-pattern #,lang p #f)) `#,ctcs))) - (define-values (input-contracts output-contracts) - (syntax-case contracts () - [#f (values #f #f)] - [(p ...) - (let-values ([(ins outs) (split-by-mode (syntax->list #'(p ...)) mode)]) - (values (map (rewrite-pattern #f) ins) - (map (rewrite-pattern #f) outs)))])) - (define lhs (map (rewrite-pattern #t) input-pats)) - (define body - (bind-withs syn-error-name '() lang nts (syntax->list #'prems) - 'flatten #`(list (term (#,@output-pats))) input-names input-names/ellipses)) - (with-syntax ([(names ...) input-names] - [(names/ellipses ...) input-names/ellipses]) - #`(let ([compiled-lhs (compile-pattern #,lang `#,lhs #t)] + (with-syntax ([(lhs (names ...) (names/ellipses ...)) ((rewrite-pattern #t) input-pats)]) + (define (contracts-compilation ctcs) + (and ctcs + (with-syntax ([(ctc ...) ctcs]) + #`(list (compile-pattern #,lang `ctc #f) ...)))) + (define-values (input-contracts output-contracts) + (syntax-case contracts () + [#f (values #f #f)] + [(p ...) + (let-values ([(ins outs) (split-by-mode (syntax->list #'(p ...)) mode)]) + (with-syntax ([((in-pat in-names in-names/ellipses) ...) + (map (rewrite-pattern #f) ins)] + [((out-pat out-names out-names/ellipses) ...) + (map (rewrite-pattern #f) outs)]) + (values #'(in-pat ...) + #'(out-pat ...))))])) + (define body + (bind-withs syn-error-name '() lang nts (syntax->list #'prems) + 'flatten #`(list (term (#,@output-pats))) + (syntax->list #'(names ...)) + (syntax->list #'(names/ellipses ...)))) + #`(let ([compiled-lhs (compile-pattern #,lang `lhs #t)] [compiled-input-ctcs #,(contracts-compilation input-contracts)] [compiled-output-ctcs #,(contracts-compilation output-contracts)]) (λ (input) @@ -2392,7 +2392,7 @@ (prune-syntax (let () (let ([all-names (syntax->list #'(all-names ...))]) - (with-syntax ([((r-rhs ...) ...) + (with-syntax ([(((r-rhs r-names r-names/ellipses) ...) ...) (map (lambda (rhss) (map (lambda (rhs) (rewrite-side-conditions/check-errs @@ -2450,7 +2450,7 @@ (begin (void) refs ...)) (compile-language (list (list '(uniform-names ...) rhs/lw ...) ...) (list (make-nt 'first-names (list (make-rhs `r-rhs) ...)) ... - (make-nt 'new-name (list (make-rhs 'orig-name))) ...) + (make-nt 'new-name (list (make-rhs '(nt orig-name)))) ...) '((uniform-names ...) ...)))))))))])) (define-syntax (define-extended-language stx) @@ -2483,31 +2483,21 @@ (define-syntax (extend-language stx) (syntax-case stx () [(_ lang (all-names ...) (name rhs ...) ...) - (with-syntax ([((r-rhs ...) ...) (map (lambda (rhss) (map (λ (x) (rewrite-side-conditions/check-errs - (append (language-id-nts #'lang 'define-extended-language) - (map syntax-e - (syntax->list #'(all-names ...)))) - 'define-extended-language - #f - x)) - (syntax->list rhss))) - (syntax->list (syntax ((rhs ...) ...))))] + (with-syntax ([(((r-rhs r-names r-names/ellipses) ...) ...) + (map (lambda (rhss) (map (λ (x) (rewrite-side-conditions/check-errs + (append (language-id-nts #'lang 'define-extended-language) + (map syntax-e + (syntax->list #'(all-names ...)))) + 'define-extended-language + #f + x)) + (syntax->list rhss))) + (syntax->list (syntax ((rhs ...) ...))))] [((rhs/lw ...) ...) (map (lambda (rhss) (map to-lw/proc (syntax->list rhss))) (syntax->list (syntax ((rhs ...) ...))))] [((uniform-names ...) ...) (map (λ (x) (if (identifier? x) (list x) x)) - (syntax->list (syntax (name ...))))] - - [((new-name orig-name) ...) - (apply - append - (map (λ (name-stx) - (if (identifier? name-stx) - '() - (let ([l (syntax->list name-stx)]) - (map (λ (x) (list x (car l))) - (cdr l))))) - (syntax->list #'(name ...))))]) + (syntax->list (syntax (name ...))))]) (syntax/loc stx (do-extend-language lang (list (make-nt '(uniform-names ...) (list (make-rhs `r-rhs) ...)) ...) @@ -2587,7 +2577,7 @@ (for-each (λ (shortcut-name) (hash-set! new-ht shortcut-name - (make-nt shortcut-name (list (make-rhs (car names)))))) + (make-nt shortcut-name (list (make-rhs `(nt ,(car names))))))) (cdr names))))) new-nts) diff --git a/collects/redex/private/rewrite-side-conditions.rkt b/collects/redex/private/rewrite-side-conditions.rkt index 47d2452d14..4fa54b4f58 100644 --- a/collects/redex/private/rewrite-side-conditions.rkt +++ b/collects/redex/private/rewrite-side-conditions.rkt @@ -1,7 +1,9 @@ -(module rewrite-side-conditions scheme +#lang racket/base + (require mzlib/list "underscore-allowed.rkt") - (require (for-template + (require "term.rkt" + (for-template mzscheme "term.rkt" "matcher.rkt")) @@ -36,91 +38,310 @@ stx)) (define (expected-arguments name stx) (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) - (define ((expect-identifier src) stx) + (define (expect-identifier src stx) (unless (identifier? stx) (raise-syntax-error what "expected an identifier" src stx))) - ;; call this and discard the result to ensure that all names are at the right ellipsis depths. - (extract-names all-nts what bind-names? orig-stx) + ; union-find w/o balancing or path compression (at least for now) + (define (union e f sets) + (hash-set sets (find f sets) (find e sets))) + (define (find e sets) + (let recur ([chd e] [par (hash-ref sets e #f)]) + (if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd))) - (let loop ([term orig-stx]) - (syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole cross unquote and) - [(side-condition pre-pat (and)) - ;; 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. - (loop #'pre-pat)] - [(side-condition pre-pat exp) - (with-syntax ([pat (loop (syntax pre-pat))]) - (let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))]) - (with-syntax ([(name ...) names] - [(name/ellipses ...) names/ellipses] + (define last-contexts (make-hasheq)) + (define assignments #hasheq()) + (define (record-binder pat-stx under) + (define pat-sym (syntax->datum pat-stx)) + (set! assignments + (if (null? under) + assignments + (let ([last (hash-ref last-contexts pat-sym #f)]) + (if last + (foldl (λ (cur last asgns) (union cur last asgns)) assignments under last) + (begin + (hash-set! last-contexts pat-sym under) + assignments)))))) + + (define ellipsis-number 0) + + (define-values (term names) + (let loop ([term orig-stx] + [under '()]) + (syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole cross unquote and) + [(side-condition pre-pat (and)) + ;; 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. + (loop #'pre-pat under)] + [(side-condition pre-pat exp) + (let () + (define-values (pre-term pre-vars) (loop #'pre-pat under)) + (define names/ellipses (map build-dots pre-vars)) + (with-syntax ([pre-term pre-term] + [((name name/ellipses) ...) + (filter + values + (map (λ (id name/ellipses) + (if (id/depth-mismatch? id) + #f + (list (id/depth-id id) + name/ellipses))) + pre-vars + names/ellipses))] [src-loc (parameterize ([print-syntax-width 0]) (format "~s" #'exp))]) - (syntax/loc term - (side-condition - pat - ,(lambda (bindings) - (term-let - ([name/ellipses (lookup-binding bindings 'name)] ...) - exp)) - ; For use in error messages. - src-loc)))))] - [(side-condition a ...) (expected-exact 'side-condition 2 term)] - [side-condition (expected-arguments 'side-condition term)] - [(variable-except a ...) - (for-each (expect-identifier term) (syntax->list #'(a ...))) - term] - [variable-except (expected-arguments 'variable-except term)] - [(variable-prefix a) - ((expect-identifier term) #'a) - term] - [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] - [variable-prefix (expected-arguments 'variable-prefix term)] - [hole term] - [(name x y) #`(name x #,(loop #'y))] - [(name x ...) (expected-exact 'name 2 term)] - [name (expected-arguments 'name term)] - [(in-hole a b) #`(in-hole #,(loop #'a) #,(loop #'b))] - [(in-hole a ...) (expected-exact 'in-hole 2 term)] - [in-hole (expected-arguments 'in-hole term)] - [(hide-hole a) #`(hide-hole #,(loop #'a))] - [(hide-hole a ...) (expected-exact 'hide-hole 1 term)] - [hide-hole (expected-arguments 'hide-hole term)] - [(cross a) - ((expect-identifier term) #'a) - term] - [(cross a ...) (expected-exact 'cross 1 term)] - [cross (expected-arguments 'cross term)] - [(unquote . _) - (raise-syntax-error what "unquote disallowed in patterns" orig-stx term)] - [_ - (identifier? term) - (match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term))) - [(list _ (app string->symbol s)) - (if (or (memq s (cons '... underscore-allowed)) - (memq s all-nts)) - term - (raise-syntax-error - what - (format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" - s (syntax-e term)) - orig-stx - term))] - [_ term])] - [(terms ...) - (map loop (syntax->list (syntax (terms ...))))] - [else - (when (pair? (syntax-e term)) - (let loop ([term term]) + (values (syntax/loc term + (side-condition + pre-term + ,(lambda (bindings) + (term-let + ([name/ellipses (lookup-binding bindings 'name)] ...) + exp)) + ; For use in error messages. + src-loc)) + pre-vars)))] + [(side-condition a ...) (expected-exact 'side-condition 2 term)] + [side-condition (expected-arguments 'side-condition term)] + [(variable-except a ...) + (begin + (for ([a (in-list (syntax->list #'(a ...)))]) + (expect-identifier term a)) + (values term '()))] + [variable-except (expected-arguments 'variable-except term)] + [(variable-prefix a) + (begin + (expect-identifier term #'a) + (values term '()))] + [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] + [variable-prefix (expected-arguments 'variable-prefix term)] + [hole (values term '())] + [(name x y) + (let () + (define-values (sub-term sub-vars) (loop #'y under)) + (record-binder #'x under) + (values #`(name x #,sub-term) + (cons (make-id/depth #'x (length under) #f) + sub-vars)))] + [(name x ...) (expected-exact 'name 2 term)] + [name (expected-arguments 'name term)] + [(in-hole a b) + (let () + (define-values (a-term a-vars) (loop #'a under)) + (define-values (b-term b-vars) (loop #'b under)) + (values #`(in-hole #,a-term #,b-term) + (append a-vars b-vars)))] + [(in-hole a ...) (expected-exact 'in-hole 2 term)] + [in-hole (expected-arguments 'in-hole term)] + [(hide-hole a) + (let () + (define-values (sub-term vars) (loop #'a under)) + (values #`(hide-hole #,sub-term) vars))] + [(hide-hole a ...) (expected-exact 'hide-hole 1 term)] + [hide-hole (expected-arguments 'hide-hole term)] + [(cross a) + (let () + (expect-identifier term #'a) + (define a-str (symbol->string (syntax-e #'a))) + (values #`(cross #,(string->symbol (format "~a-~a" a-str a-str))) + '()))] + [(cross a ...) (expected-exact 'cross 1 term)] + [cross (expected-arguments 'cross term)] + [(unquote . _) + (raise-syntax-error what "unquote disallowed in patterns" orig-stx term)] + [_ + (identifier? term) + (let () + (define m (regexp-match #rx"^([^_]*)_(.*)$" (symbol->string (syntax-e term)))) (cond - [(syntax? term) (loop (syntax-e term))] - [(pair? term) (loop (cdr term))] - [(null? term) (void)] - [#t - (raise-syntax-error what "dotted pairs not supported in patterns" orig-stx term)]))) - term]))) + [m + (define prefix (list-ref m 1)) + (define suffix (list-ref m 2)) + (define suffix-sym (string->symbol suffix)) + (define prefix-sym (string->symbol prefix)) + (define prefix-stx (datum->syntax term prefix-sym)) + (define mismatch? (regexp-match? #rx"^!_" suffix)) + (cond + [(eq? prefix-sym '...) + (raise-syntax-error + what + "found an ellipsis outside of a sequence" + orig-stx + term)] + [(memq prefix-sym all-nts) + (record-binder term under) + (values (if mismatch? + `(mismatch-name ,term (nt ,prefix-stx)) + `(name ,term (nt ,prefix-stx))) + (list (make-id/depth term (length under) mismatch?)))] + [(memq prefix-sym underscore-allowed) + (record-binder term under) + (values (if mismatch? + `(mismatch-name ,term ,prefix-stx) + `(name ,term ,prefix-stx)) + (list (make-id/depth term (length under) mismatch?)))] + [else + (raise-syntax-error + what + (format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" + suffix-sym (syntax-e term)) + orig-stx + term)])] + [(eq? (syntax-e term) '...) + (raise-syntax-error + what + "found an ellipsis outside of a sequence" + orig-stx + term)] + [(memq (syntax-e term) all-nts) + (cond + [bind-names? + (record-binder term under) + (values `(name ,term (nt ,term)) (list (make-id/depth term (length under) #f)))] + [else + (values `(nt ,term) '())])] + [(memq (syntax-e term) underscore-allowed) + (cond + [bind-names? + (record-binder #'term under) + (values `(name ,term ,term) (list (make-id/depth term (length under) #f)))] + [else + (values term '())])] + [else + (values term '())]))] + [(terms ...) + (let () + (define terms-lst (syntax->list #'(terms ...))) + (define (is-ellipsis? term) + (and (identifier? term) + (regexp-match? #rx"^[.][.][.]" (symbol->string (syntax-e term))))) + (when (and (pair? terms-lst) (is-ellipsis? (car terms-lst))) + (raise-syntax-error what + "ellipsis should not appear in the first position of a sequence" + orig-stx + term)) + (define-values (updated-terms vars) + (let t-loop ([terms terms-lst]) + (cond + [(null? terms) (values '() '())] + [(null? (cdr terms)) + (define-values (term vars) (loop (car terms) under)) + (values (list term) vars)] + [(is-ellipsis? (cadr terms)) + (when (and (pair? (cddr terms)) + (is-ellipsis? (caddr terms))) + (raise-syntax-error what + "two ellipses should not appear in a row" + orig-stx + (cadr terms) + (list (caddr terms)))) + (define ellipsis-sym (syntax-e (cadr terms))) + (define ellipsis-pre-str (symbol->string ellipsis-sym)) + (define mismatch? (regexp-match? #rx"^[.][.][.]_!_" ellipsis-pre-str)) + (define ellipsis-str (cond + [mismatch? + (set! ellipsis-number (+ ellipsis-number 1)) + (format "..._r~a" ellipsis-number)] + [(regexp-match? #rx"^[.][.][.]_r" ellipsis-pre-str) + (string-append (substring ellipsis-str 0 4) + "r" + (substring ellipsis-str + 4 + (string-length ellipsis-str)))] + [(regexp-match? #rx"^[.][.][.]_" ellipsis-pre-str) + ellipsis-pre-str] + [else + (set! ellipsis-number (+ ellipsis-number 1)) + (format "..._r~a" ellipsis-number)])) + (define ellipsis+name (datum->syntax + (cadr terms) + (string->symbol ellipsis-str) + (cadr terms))) + (record-binder ellipsis+name under) + (define-values (fst-term fst-vars) + (loop (car terms) (cons (syntax-e ellipsis+name) under))) + (define-values (rst-terms rst-vars) (t-loop (cddr terms))) + (values (cons `(repeat ,fst-term + ,ellipsis+name + ,(if mismatch? (cadr terms) #f)) + rst-terms) + (append fst-vars rst-vars))] + [else + (define-values (fst-term fst-vars) (loop (car terms) under)) + (define-values (rst-terms rst-vars) (t-loop (cdr terms))) + (values (cons fst-term rst-terms) + (append fst-vars rst-vars))]))) + (values `(list ,@updated-terms) vars))] + [else + (when (pair? (syntax-e term)) + (let loop ([term term]) + (cond + [(syntax? term) (loop (syntax-e term))] + [(pair? term) (loop (cdr term))] + [(null? term) (void)] + [#t + (raise-syntax-error what "dotted pairs not supported in patterns" orig-stx term)]))) + (values term '())]))) + + (define closed-table + (make-immutable-hasheq (hash-map assignments (λ (cls _) (cons cls (find cls assignments)))))) + + (define repeat-id-counts (make-hash)) + + (define ellipsis-normalized + (let loop ([pat term]) + (syntax-case pat (repeat) + [(repeat sub-pat name mismatch-name) + (let () + (define mapped-name (hash-ref closed-table (syntax-e #'name) #f)) + (define new-name (if mapped-name + mapped-name + (syntax-e #'name))) + (hash-set! repeat-id-counts new-name (+ 1 (hash-ref repeat-id-counts new-name 0))) + (let ([id (syntax-e #'mismatch-name)]) + (when id + (hash-set! repeat-id-counts id (+ 1 (hash-ref repeat-id-counts id 0))))) + #`(repeat #,(loop #'sub-pat) #,new-name mismatch-name))] + [(a ...) + (let () + (define new (map loop (syntax->list #'(a ...)))) + (if (syntax? pat) + (datum->syntax pat new pat) + new))] + [_ pat]))) + + ;(printf "term ~s\n" (syntax->datum (datum->syntax #'here term))) + ;(printf "norm ~s\n" (syntax->datum (datum->syntax #'here ellipsis-normalized))) + ;(printf "repeat-id-counts ~s\n" repeat-id-counts) + + (define ellipsis-normalized/simplified + (let loop ([pat ellipsis-normalized]) + (syntax-case pat (repeat) + [(repeat sub-pat name mismatch-name) + (let () + #`(repeat #,(loop #'sub-pat) + #,(if (= 1 (hash-ref repeat-id-counts (syntax-e #'name))) + #f + #'name) + #,(if (and (syntax-e #'mismatch-name) + (= 1 (hash-ref repeat-id-counts (syntax-e #'mismatch-name)))) + #f + #'mismatch-name)))] + [(a ...) + (let () + (define new (map loop (syntax->list #'(a ...)))) + (if (syntax? pat) + (datum->syntax pat new pat) + new))] + [_ pat]))) + + (filter-duplicates what orig-stx names) + (let ([without-mismatch-names (filter (λ (x) (not (id/depth-mismatch? x))) names)]) + (with-syntax ([(name/ellipses ...) (map build-dots without-mismatch-names)] + [(name ...) (map id/depth-id without-mismatch-names)] + [term ellipsis-normalized/simplified]) + #'(term (name ...) (name/ellipses ...))))) - (define-struct id/depth (id depth)) + (define-struct id/depth (id depth mismatch?)) ;; extract-names : syntax syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...])) (define (extract-names all-nts what bind-names? orig-stx [mode 'rhs-only]) @@ -128,11 +349,11 @@ (let loop ([stx orig-stx] [names null] [depth 0]) - (syntax-case stx (name in-hole side-condition cross) + (syntax-case stx (name in-hole side-condition cross nt) [(name sym pat) (identifier? (syntax sym)) (loop (syntax pat) - (cons (make-id/depth (syntax sym) depth) names) + (cons (make-id/depth (syntax sym) depth #f) names) depth)] [(in-hole pat1 pat2) (loop (syntax pat1) @@ -163,7 +384,7 @@ [(rhs-only) binds-in-right-hand-side?] [(binds-anywhere) binds?]) all-nts bind-names? (syntax x))) - (cons (make-id/depth (syntax x) depth) names)] + (cons (make-id/depth (syntax x) depth #f) names)] [else names]))] [no-dups (filter-duplicates what orig-stx dups)]) (values (map id/depth-id no-dups) @@ -189,16 +410,16 @@ (and (not (regexp-match #rx"^\\.\\.\\._" str)) (not (regexp-match #rx"_!_" str)))))) - (define (raise-ellipsis-depth-error what one-binder one-depth another-binder another-depth) - (raise - (make-exn:fail:syntax - (format "~a: found the same binder, ~s, at different depths, ~a and ~a" - what - (syntax->datum one-binder) - one-depth - another-depth) - (current-continuation-marks) - (list one-binder another-binder)))) + (define (raise-ellipsis-depth-error what one-binder one-depth another-binder another-depth [orig-stx #f]) + (raise-syntax-error + what + (format "found the same binder, ~s, at different depths, ~a and ~a" + (syntax->datum one-binder) + one-depth + another-depth) + orig-stx + another-binder + (list one-binder))) (define (filter-duplicates what orig-stx dups) (let loop ([dups dups]) @@ -216,6 +437,8 @@ (raise-ellipsis-depth-error what (id/depth-id x) (id/depth-depth x) - (id/depth-id (car dups)) (id/depth-depth (car dups))))) + (id/depth-id (car dups)) (id/depth-depth (car dups)) + orig-stx))) (not same-id?))) - (loop (cdr dups))))])))) + (loop (cdr dups))))]))) + diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index 0d7c740332..1de054c9d2 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -6,6 +6,7 @@ "term.rkt" "error.rkt" "struct.rkt" + "match-a-pattern.rkt" (for-syntax racket/base "rewrite-side-conditions.rkt" "term-fn.rkt" @@ -159,8 +160,9 @@ (define-struct rg-lang (non-cross delayed-cross base-cases)) (define (rg-lang-cross x) (force (rg-lang-delayed-cross x))) (define (prepare-lang lang) - (let ([parsed (parse-language lang)]) - (values parsed (map symbol->string (compiled-lang-literals lang)) (find-base-cases parsed)))) + (values lang + (map symbol->string (compiled-lang-literals lang)) + (find-base-cases lang))) (define-struct (exn:fail:redex:generation-failure exn:fail:redex) ()) (define (raise-gen-fail who what attempts) @@ -198,7 +200,7 @@ [size init-sz] [attempt init-att]) (if (zero? remaining) - (raise-gen-fail what (format "pattern ~a" name) retries) + (raise-gen-fail what (format "pattern ~s" name) retries) (let-values ([(term env) (gen size attempt)]) (if (pred term env) (values term env) @@ -210,13 +212,16 @@ pre-threshold-incr)))))))) (define (generate/prior name env gen) + ;(printf "generate/prior ~s ~s ~s\n" name env gen) (let* ([none (gensym)] [prior (hash-ref env name none)]) (if (eq? prior none) (let-values ([(term env) (gen)]) + ;(printf "generated ~s for ~s\n" term name) (values term (hash-set env name term))) (values prior env)))) + (define (generate-sequence gen env vars length) (define (split-environment env) (foldl (λ (var seq-envs) @@ -252,7 +257,7 @@ vals)))) (for/and ([(name val) env]) (or (not (mismatch? name)) - (let ([prior (get-group (mismatch-group name))]) + (let ([prior (get-group (mismatch-var name))]) (and (not (hash-ref prior val #f)) (hash-set! prior val #t)))))) @@ -261,8 +266,8 @@ (define (bindings env) (make-bindings (for/fold ([bindings null]) ([(key val) env]) - (if (binder? key) - (cons (make-bind (binder-name key) val) bindings) + (if (symbol? key) + (cons (make-bind key val) bindings) bindings)))) (define-values (langp lits lang-bases) (prepare-lang lang)) @@ -270,6 +275,73 @@ (define lit-syms (compiled-lang-literals lang)) (define (compile pat any?) + + (define vars-table (make-hash)) + (define (find-vars pat) (hash-ref vars-table pat '())) + (define mismatch-id 0) + (define-values (rewritten-pat vars) + (let loop ([pat pat]) + (define (add/ret pat vars) + (hash-set! vars-table pat vars) + (values pat vars)) + (define (build-mismatch var) + (set! mismatch-id (+ mismatch-id 1)) + (make-mismatch mismatch-id var)) + (match-a-pattern pat + [`any (values pat '())] + [`number (values pat '())] + [`string (values pat '())] + [`natural (values pat '())] + [`integer (values pat '())] + [`real (values pat '())] + [`variable (values pat '())] + [`(variable-except ,vars ...) (values pat '())] + [`(variable-prefix ,var) (values pat '())] + [`variable-not-otherwise-mentioned (values pat '())] + [`hole (values pat '())] + [`(nt ,x) (values pat '())] + [`(name ,name ,p) + (define-values (p-rewritten p-names) (loop p)) + (add/ret `(name ,name ,p-rewritten) (cons name p-names))] + [`(mismatch-name ,name ,p) + (define mm (build-mismatch name)) + (define-values (p-rewritten p-names) (loop p)) + (add/ret `(mismatch-name ,mm ,p-rewritten) + (cons mm p-names))] + [`(in-hole ,p1 ,p2) + (define-values (p1-rewritten p1-names) (loop p1)) + (define-values (p2-rewritten p2-names) (loop p2)) + (add/ret `(in-hole ,p1-rewritten ,p2-rewritten) + (append p1-names p2-names))] + [`(hide-hole ,p) + (define-values (p-rewritten p-names) (loop p)) + (add/ret `(hide-hole ,p-rewritten) p-names)] + [`(side-condition ,p ,e ,e2) + (define-values (p-rewritten p-names) (loop p)) + (add/ret `(side-condition ,p-rewritten ,e ,e2) p-names)] + [`(cross ,var) (values pat '())] + [`(list ,lpats ...) + (define-values (lpats-rewritten vars) + (for/fold ([ps-rewritten '()] + [vars '()]) + ([lpat (in-list lpats)]) + (match lpat + [`(repeat ,p ,name ,mismatch-name) + (define l1 (if name (list name) '())) + (define mm (and mismatch-name + (build-mismatch mismatch-name))) + (define l2 (if mm (cons mm l1) l1)) + (define-values (p-rewritten p-vars) (loop p)) + (values (cons `(repeat ,p-rewritten ,name ,mm) ps-rewritten) + (append l2 p-vars vars))] + [_ + (define-values (p-rewritten p-vars) (loop lpat)) + (values (cons p-rewritten ps-rewritten) + (append p-vars vars))]))) + (add/ret `(list ,@(reverse lpats-rewritten)) + vars)] + [(? (compose not pair?)) (values pat '())]))) + (let* ([nt? (is-nt? (if any? sexpp langp))] [mismatches? #f] [generator @@ -291,12 +363,19 @@ ; (W hole ; ; extra parens to avoid matcher loop ; (in-hole (W_1) (+ natural hole)))) - (let recur ([pat pat]) - (match pat + (let recur ([pat rewritten-pat]) + (match-a-pattern pat + [`any + (λ (r s a e f) + (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] + [(term) (gen-nt lang nt #f r s a the-not-hole)]) + (values term e)))] [`number (generator/attempts (λ (a) ((next-number-decision) a)))] + [`string (generator/attempts (λ (a) ((next-string-decision) lits a)))] [`natural (generator/attempts (λ (a) ((next-natural-decision) a)))] [`integer (generator/attempts (λ (a) ((next-integer-decision) a)))] [`real (generator/attempts (λ (a) ((next-real-decision) a)))] + [`variable (generator/attempts (λ (a) ((next-variable-decision) lits a)))] [`(variable-except ,vars ...) (let ([g (recur 'variable)]) (λ (r s a e f) @@ -304,14 +383,6 @@ (λ (s a) (g r s a e f)) (λ (var _) (not (memq var vars))) s a r)))] - [`variable (generator/attempts (λ (a) ((next-variable-decision) lits a)))] - [`variable-not-otherwise-mentioned - (let ([g (recur 'variable)]) - (λ (r s a e f) - (generate/pred pat - (λ (s a) (g r s a e f)) - (λ (var _) (not (memq var lit-syms))) - s a r)))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) @@ -319,20 +390,27 @@ (λ (r s a e f) (let-values ([(t e) (g r s a e f)]) (values (symbol-append prefix t) e))))] - [`string (generator/attempts (λ (a) ((next-string-decision) lits a)))] - [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) - (let ([g (recur pat)]) + [`variable-not-otherwise-mentioned + (let ([g (recur 'variable)]) (λ (r s a e f) - (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) + (generate/pred pat (λ (s a) (g r s a e f)) - (λ (_ env) (condition (bindings env))) + (λ (var _) (not (memq var lit-syms))) s a r)))] - [`(name ,(? symbol? id) ,p) + [`hole (λ (r s a e f) (values f e))] + [`(nt ,nt-id) + (λ (r s a e f) + (values (gen-nt (if any? sexpc langc) nt-id #f r s a f) e))] + [`(name ,id ,p) (let ([g (recur p)]) (λ (r s a e f) - (let-values ([(t env) (g r s a e f)]) - (values t (hash-set env (make-binder id) t)))))] - [`hole (λ (r s a e f) (values f e))] + (generate/prior id e (λ () (g r s a e f)))))] + [`(mismatch-name ,id ,pat) + (let ([g (recur pat)]) + (set! mismatches? #t) + (λ (r s a e f) + (let-values ([(t e) (g r s a e f)]) + (values t (hash-set e id t)))))] [`(in-hole ,context ,filler) (let ([c-context (recur context)] [c-filler (recur filler)]) @@ -344,54 +422,50 @@ (let ([g (recur pattern)]) (λ (r s a e f) (g r s a e the-not-hole)))] - [`any + [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) + (let ([g (recur pat)]) + (λ (r s a e f) + (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) + (λ (s a) (g r s a e f)) + (λ (_ env) (condition (bindings env))) + s a r)))] + [`(cross ,(? symbol? p)) (λ (r s a e f) - (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] - [(term) (gen-nt lang nt #f r s a the-not-hole)]) - (values term e)))] - [(or (? symbol? (? nt? p)) `(cross ,(? symbol? p))) - (let ([cross? (not (symbol? pat))]) - (λ (r s a e f) - (values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))] - [(? binder?) - (let ([g (recur (binder-pattern pat))]) - (λ (r s a e f) - (generate/prior pat e (λ () (g r s a e f)))))] - [(? mismatch?) - (let ([g (recur (mismatch-pattern pat))]) - (set! mismatches? #t) - (λ (r s a e f) - (let-values ([(t e) (g r s a e f)]) - (values t (hash-set e pat t)))))] - [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) - (λ (r s a e f) (values pat e))] - [(list-rest (struct ellipsis (name sub-pat class vars)) rest) - (let ([elemg (recur sub-pat)] - [tailg (recur rest)]) - (when (mismatch? name) - (set! mismatches? #t)) - (λ (r s a e f) - (let*-values ([(len) - (let ([prior (hash-ref e class #f)]) - (if prior - prior - (if (zero? s) 0 ((next-sequence-decision) s))))] - [(seq env) - (generate-sequence (λ (e) (elemg r s a e f)) e vars len)] - [(tail env) - (let ([e (hash-set (hash-set env class len) name len)]) - (tailg r s a e f))]) - (values (append seq tail) env))))] - [(list-rest hdp tlp) - (let ([hdg (recur hdp)] - [tlg (recur tlp)]) - (λ (r s a e f) - (let*-values - ([(hd env) (hdg r s a e f)] - [(tl env) (tlg r s a env f)]) - (values (cons hd tl) env))))] - [else - (error what "unknown pattern ~s\n" pat)]))]) + (values (gen-nt (if any? sexpc langc) p #t r s a f) e))] + + [`(list ,in-lpats ...) + (let loop ([lpats in-lpats]) + (match lpats + [`() (λ (r s a e f) (values '() e))] + [(cons `(repeat ,sub-pat ,name ,mismatch-name) rst) + (let ([elemg (recur sub-pat)] + [tailg (loop rst)] + [vars (find-vars sub-pat)]) + (when mismatch-name + (set! mismatches? #t)) + (λ (r s a env0 f) + (define len + (let ([prior (and name (hash-ref env0 name #f))]) + (if prior + prior + (if (zero? s) 0 ((next-sequence-decision) s))))) + (let*-values ([(seq env) (generate-sequence (λ (e) (elemg r s a e f)) env0 vars len)] + [(env) (if name (hash-set env name len) env)] + [(env) (if mismatch-name + (hash-set env mismatch-name len) + env)] + [(tail env) (tailg r s a env f)]) + (values (append seq tail) env))))] + [(cons hdp tlp) + (let ([hdg (recur hdp)] + [tlg (loop tlp)]) + (λ (r s a env f) + (let*-values + ([(hd env) (hdg r s a env f)] + [(tl env) (tlg r s a env f)]) + (values (cons hd tl) env))))]))] + [(? (compose not pair?)) + (λ (r s a e f) (values pat e))]))]) (if mismatches? (λ (r s a e f) (let ([g (λ (s a) (generator r s a e f))] @@ -413,7 +487,7 @@ (define sexpc (compile-language sexpp sexp-bases #t)) (define (compile-pattern pat) (compile pat #f)) (λ (pat) - (define g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))) + (define g (compile-pattern pat)) (λ (size attempt retries) (define-values (t e) (g retries size attempt empty-env the-hole)) (values (let replace-the-not-hole ([t t]) @@ -450,27 +524,34 @@ (define (rhs->nts pat) (let ([nts '()]) (let loop ([pat pat]) - (match pat - [(? binder?) - (set! nts (cons (cons #f (binder-pattern pat)) nts))] - [(? mismatch?) - (set! nts (cons (cons #f (mismatch-pattern pat)) nts))] - [(? symbol?) - (when ((is-nt? lang) pat) - (set! nts (cons (cons #f pat) nts)))] - [`(cross ,(? symbol? x-nt)) + (match-a-pattern pat + [`any (void)] + [`number (void)] + [`string (void)] + [`natural (void)] + [`integer (void)] + [`real (void)] + [`variable (void)] + [`(variable-except ,vars ...) (void)] + [`(variable-prefix ,var) (void)] + [`variable-not-otherwise-mentioned (void)] + [`hole (void)] + [`(nt ,var) (set! nts (cons (cons #f var) nts))] + [`(name ,n ,p) (loop p)] + [`(mismatch-name ,n ,p) (loop p)] + [`(in-hole ,p1 ,p2) (loop p1) (loop p2)] + [`(hide-hole ,p) (loop p)] + [`(side-condition ,p ,exp ,info) (loop p)] + [`(cross ,x-nt) (set! nts (cons (cons #t x-nt) nts))] - [`(variable-except ,s ...) (void)] - [`(variable-prefix ,p) (void)] - [`(name ,_ ,p) (loop p)] - [`() (void)] - [(struct ellipsis (_ p _ _)) - (loop p)] - [`(,a . ,b) - (loop a) - (loop b)] - [_ (void)])) - nts)) + [`(list ,lpats ...) + (for ([lpat (in-list lpats)]) + (match lpat + [`(repeat ,p ,name ,mismatch?) + (loop p)] + [_ (loop lpat)]))] + [(? (compose not pair?)) (void)])) + nts)) ;; build-table : (listof nt) -> hash (define (build-table nts) @@ -547,15 +628,11 @@ (let ([match (regexp-match rx (symbol->string x))]) (and match (cadr match) (string->symbol (cadr match)))))) -(define-struct class (id) #:inspector (make-inspector)) +(define-struct class (id) #:transparent) -(define-struct mismatch (id group) #:inspector (make-inspector)) -(define mismatch-pattern - (match-lambda - [(struct mismatch (_ name)) - ((symbol-match mismatch-nt-rx) name)])) +(define-struct mismatch (id var) #:transparent) -(define-struct binder (name) #:inspector (make-inspector)) +(define-struct binder (name) #:transparent) (define binder-pattern (match-lambda [(struct binder (name)) @@ -574,76 +651,13 @@ ;; and after generating an ellipsis (define-struct ellipsis (name pattern class vars) #:inspector (make-inspector)) -;; parse-pattern : pattern compiled-lang (or/c 'cross 'top-level 'grammar) -> parsed-pattern -;; Turns "pat ...", "pat ..._id", and "pat ..._!_id" into ellipsis structs, -;; "nt_!_id" into mismatch structs, "nt_id" into binder structs, and -;; "nt/underscore-allowed" in top-level patterns into binder structs. -(define (parse-pattern pattern lang mode) - (define (recur pat vars) - (match pat - [(or (app (symbol-match named-nt-rx) (or (? (is-nt? lang)) (? built-in?))) - (and (? (λ (_) (eq? mode 'top-level))) (or (? (is-nt? lang)) (? built-in?)))) - (let ([b (make-binder pat)]) - (values b (cons b vars)))] - [(app (symbol-match mismatch-nt-rx) (or (? (is-nt? lang)) (? built-in?))) - (let ([mismatch (make-mismatch (gensym) pat)]) - (values mismatch (cons mismatch vars)))] - [`(name ,name ,sub-pat) - (let-values ([(parsed vars) (recur sub-pat vars)]) - (values `(name ,name ,parsed) (cons (make-binder name) vars)))] - [(list-rest sub-pat (and (? symbol?) (app symbol->string (regexp named-ellipsis-rx)) name) rest) - (let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)] - [(seq) (make-ellipsis name sub-pat-parsed (make-class name) sub-pat-vars)] - [(vars) (append (list* name (make-class name) sub-pat-vars) vars)] - [(rest-parsed vars) (recur rest vars)]) - (values (cons seq rest-parsed) vars))] - [(list-rest sub-pat '... rest) - (let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)] - [(class) (make-class (gensym))] - [(seq) (make-ellipsis '... sub-pat-parsed class sub-pat-vars)] - [(rest-parsed vars) (recur rest (cons class (append sub-pat-vars vars)))]) - (values (cons seq rest-parsed) vars))] - [(list-rest sub-pat (and (? symbol?) (app symbol->string (regexp mismatch-ellipsis-rx)) name) rest) - (let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)] - [(mismatch) (make-mismatch (gensym) name)] - [(class) (make-class (gensym))] - [(seq) (make-ellipsis mismatch sub-pat-parsed class sub-pat-vars)] - [(vars) (append (list* class mismatch sub-pat-vars) vars)] - [(rest-parsed vars) (recur rest vars)]) - (values (cons seq rest-parsed) vars))] - [(and (? (λ (_) (not (eq? mode 'cross)))) `(cross ,(and (? (is-nt? lang)) nt))) - (let ([nt-str (symbol->string nt)]) - (values `(cross ,(string->symbol (string-append nt-str "-" nt-str))) vars))] - [`(side-condition ,pat ,guard ,guard-src-loc) - (let-values ([(parsed vars) (recur pat vars)]) - (values `(side-condition ,parsed ,guard ,guard-src-loc) vars))] - [(cons first rest) - (let-values ([(first-parsed vars) (recur first vars)]) - (let-values ([(rest-parsed vars) (recur rest vars)]) - (values (cons first-parsed rest-parsed) vars)))] - [_ (values pat vars)])) - (let-values ([(parsed _) (recur pattern null)]) - parsed)) - -;; parse-language: compiled-lang -> compiled-lang -(define (parse-language lang) - (define ((parse-nt mode) nt) - (make-nt (nt-name nt) (map (parse-rhs mode) (nt-rhs nt)))) - (define ((parse-rhs mode) rhs) - (make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode)))) - - (struct-copy - compiled-lang lang - [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))] - [delayed-cclang (delay (map (parse-nt 'cross) (compiled-lang-cclang lang)))])) - ;; unparse-pattern: parsed-pattern -> pattern (define unparse-pattern (match-lambda [(struct binder (name)) name] - [(struct mismatch (_ group)) group] + [(struct mismatch (id var)) var] [(list-rest (struct ellipsis (name sub-pat _ _)) rest) - (let ([ellipsis (if (mismatch? name) (mismatch-group name) name)]) + (let ([ellipsis (if (mismatch? name) (mismatch-var name) name)]) (list* (unparse-pattern sub-pat) ellipsis (unparse-pattern rest)))] [(cons first rest) (cons (unparse-pattern first) (unparse-pattern rest))] @@ -659,31 +673,54 @@ (if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd))) (let* ([last-contexts (make-hasheq)] + [assignments #hasheq()] [record-binder - (λ (pat under assignments) - (if (null? under) - assignments - (let ([last (hash-ref last-contexts pat #f)]) - (if last - (foldl (λ (cur last asgns) (union cur last asgns)) assignments under last) - (begin - (hash-set! last-contexts pat under) - assignments)))))] - [assignments - (let recur ([pat pattern] [under null] [assignments #hasheq()]) - (match pat - ;; `(name ,id ,sub-pat) not considered, since bindings introduced - ;; by name must be unique. - [(struct binder (name)) - (record-binder name under assignments)] - [(struct ellipsis (name sub-pat (struct class (cls)) _)) - (recur sub-pat (cons cls under) - (if (and (symbol? name) (regexp-match named-ellipsis-rx (symbol->string name))) - (record-binder name under assignments) - assignments))] - [(? list?) - (foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)] - [_ assignments]))]) + (λ (pat under) + (set! assignments + (if (null? under) + assignments + (let ([last (hash-ref last-contexts pat #f)]) + (if last + (foldl (λ (cur last asgns) (union cur last asgns)) assignments under last) + (begin + (hash-set! last-contexts pat under) + assignments))))))]) + (let recur ([pat pattern] [under null]) + (match-a-pattern pat + [`any assignments] + [`number assignments] + [`string assignments] + [`natural assignments] + [`integer assignments] + [`real assignments] + [`variable assignments] + [`(variable-except ,vars ...) assignments] + [`(variable-prefix ,var) assignments] + [`variable-not-otherwise-mentioned assignments] + [`hole assignments] + [`(nt ,var) assignments] + [`(name ,var ,pat) + (record-binder var under) + (recur pat under)] + [`(mismatch-name ,var ,pat) + (recur pat under)] + [`(in-hole ,p1 ,p2) + (recur p2 under) + (recur p1 under)] + [`(hide-hole ,p) + (recur p under)] + [`(side-condition ,p ,exp ,srcloc) + (recur p under)] + [`(cross ,nt) assignments] + [`(list ,lpats ...) + (for ([lpat (in-list lpats)]) + (match lpat + [`(repeat ,p ,name ,mismatch?) + (record-binder name under) + (recur p (cons (or name (gensym)) under))] + [else (recur lpat under)])) + assignments] + [(? (compose not pair?)) assignments])) (make-immutable-hasheq (hash-map assignments (λ (cls _) (cons cls (find cls assignments))))))) (define (reassign-classes pattern) @@ -691,6 +728,11 @@ [rewrite (λ (c) (make-class (hash-ref reassignments (class-id c) (class-id c))))]) (let recur ([pat pattern]) (match pat + #; + [`(repeat ,sub-pat ,name ,mismatch?) + `(repeat ,(recur sub-pat) + ,(rewrite name) + ,mismatch?)] [(struct ellipsis (name sub-pat class vars)) (make-ellipsis name (recur sub-pat) (rewrite class) (map (λ (v) (if (class? v) (rewrite v) v)) vars))] @@ -710,7 +752,7 @@ (if m m (raise-syntax-error #f "not a metafunction" stx name)))) (define-for-syntax (term-generator lang pat what) - (with-syntax ([pattern + (with-syntax ([(pattern (vars ...) (vars/ellipses ...)) (rewrite-side-conditions/check-errs (language-id-nts lang what) what #t pat)]) @@ -1067,8 +1109,8 @@ (provide pick-from-list pick-sequence-length pick-nts pick-char pick-var pick-string pick-any pick-number pick-natural pick-integer pick-real - parse-pattern unparse-pattern - parse-language prepare-lang + unparse-pattern + prepare-lang class-reassignments reassign-classes default-retries proportion-at-size retry-threshold proportion-before-threshold post-threshold-incr diff --git a/collects/redex/tests/check-syntax-test.rkt b/collects/redex/tests/check-syntax-test.rkt index b173b35173..b5b93b787d 100644 --- a/collects/redex/tests/check-syntax-test.rkt +++ b/collects/redex/tests/check-syntax-test.rkt @@ -171,7 +171,7 @@ (test (send annotations collected-rename-class def-name) (expected-rename-class (list def-name use-name))) - (test (send annotations collected-rename-class def-name) + (test (send annotations collected-rename-class use-name) (expected-rename-class (list def-name use-name)))) (print-tests-passed 'check-syntax-test.rkt) \ No newline at end of file diff --git a/collects/redex/tests/matcher-test.rkt b/collects/redex/tests/matcher-test.rkt index 042d74550b..21d1dc6a48 100644 --- a/collects/redex/tests/matcher-test.rkt +++ b/collects/redex/tests/matcher-test.rkt @@ -1,26 +1,29 @@ -(module matcher-test mzscheme - (require "../private/matcher.rkt" - (only "test-util.rkt" equal/bindings?) - mzlib/list) +#lang racket/base + +(require "../private/matcher.rkt" + (only-in "test-util.rkt" equal/bindings?) + (for-syntax racket/base) + racket/list) + +(error-print-width 500) - (error-print-width 500) +(define (make-test-mtch a b c) (make-mtch a (build-flat-context b) c)) - (define (make-test-mtch a b c) (make-mtch a (build-flat-context b) c)) - - (define (test) +(define (test) + (let-syntax ([this-line (λ (stx) (datum->syntax #'here (syntax-line stx)))]) (print-struct #t) - (test-empty 'any 1 (list (make-test-mtch (make-bindings (list (make-bind 'any 1))) 1 none))) - (test-empty 'any 'true (list (make-test-mtch (make-bindings (list (make-bind 'any 'true))) 'true none))) - (test-empty 'any "a" (list (make-test-mtch (make-bindings (list (make-bind 'any "a"))) "a" none))) - (test-empty 'any '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any '(a b)))) '(a b) none))) - (test-empty 'any #t (list (make-test-mtch (make-bindings (list (make-bind 'any #t))) #t none))) + (test-empty '(name any any) 1 (list (make-test-mtch (make-bindings (list (make-bind 'any 1))) 1 none))) + (test-empty '(name any any) 'true (list (make-test-mtch (make-bindings (list (make-bind 'any 'true))) 'true none))) + (test-empty '(name any any) "a" (list (make-test-mtch (make-bindings (list (make-bind 'any "a"))) "a" none))) + (test-empty '(name any any) '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any '(a b)))) '(a b) none))) + (test-empty '(name any any) #t (list (make-test-mtch (make-bindings (list (make-bind 'any #t))) #t none))) (test-empty 1 1 (list (make-test-mtch (make-bindings null) 1 none))) (test-empty 1 '() #f) (test-empty 99999999999999999999999999999999999999999999999 99999999999999999999999999999999999999999999999 (list (make-test-mtch (make-bindings null) - 99999999999999999999999999999999999999999999999 - none))) + 99999999999999999999999999999999999999999999999 + none))) (test-empty 99999999999999999999999999999999999999999999999 '() #f) @@ -33,31 +36,34 @@ (test-empty "a" "a" (list (make-test-mtch (make-bindings null) "a" none))) (test-empty #s(x 1) #s(x 1) (list (make-test-mtch (make-bindings null) #s(x 1) none))) (test-empty #s(x 1) #s(x 2) #f) - (test-empty 'number 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none))) + (test-empty '(name number number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none))) (test-empty 'number 'x #f) (test-empty 'number '() #f) - (test-empty 'natural 1 (list (make-test-mtch (make-bindings (list (make-bind 'natural 1))) 1 none))) + (test-empty '(name natural natural) 1 (list (make-test-mtch (make-bindings (list (make-bind 'natural 1))) 1 none))) (test-empty 'natural 'x #f) (test-empty 'natural '() #f) (test-empty 'natural -1 #f) (test-empty 'natural 1.0 #f) - (test-empty 'integer -1 (list (make-test-mtch (make-bindings (list (make-bind 'integer -1))) -1 none))) + (test-empty '(name integer integer) -1 (list (make-test-mtch (make-bindings (list (make-bind 'integer -1))) -1 none))) (test-empty 'integer 'x #f) (test-empty 'integer '() #f) (test-empty 'integer 1.0 #f) - (test-empty 'real 1.1 (list (make-test-mtch (make-bindings (list (make-bind 'real 1.1))) 1.1 none))) + (test-empty '(name real real) 1.1 (list (make-test-mtch (make-bindings (list (make-bind 'real 1.1))) 1.1 none))) (test-empty 'real 'x #f) (test-empty 'real '() #f) (test-empty 'real 2+3i #f) - (test-empty 'string "a" (list (make-test-mtch (make-bindings (list (make-bind 'string "a"))) "a" none))) + (test-empty '(name string string) "a" (list (make-test-mtch (make-bindings (list (make-bind 'string "a"))) "a" none))) (test-empty 'string 1 #f) (test-empty 'string '() #f) - (test-empty 'variable 'x (list (make-test-mtch (make-bindings (list (make-bind 'variable 'x))) 'x none))) + (test-empty '(name variable variable) 'x (list (make-test-mtch (make-bindings (list (make-bind 'variable 'x))) 'x none))) (test-empty 'variable 1 #f) (test-empty '(variable-except x) 1 #f) (test-empty '(variable-except x) 'x #f) (test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none))) - (test-lang 'x 'y (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none)) + (test-lang (this-line) + '(name x (nt x)) + 'y + (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none)) (list (make-nt 'x (list (make-rhs '(variable-except x)))))) (test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none))) (test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none))) @@ -65,183 +71,229 @@ (test-empty '(variable-prefix x:) '() #f) (test-empty 'hole 1 #f) - (test-empty `hole + (test-empty 'hole the-hole (list (make-test-mtch (make-bindings (list)) the-hole none))) - (test-empty '(in-hole (hole 2) 1) + (test-empty '(in-hole (list hole 2) 1) '(1 2) (list (make-test-mtch (make-bindings (list)) `(1 2) none))) - (test-empty '(in-hole (name E_1 ((hide-hole hole) hole)) x) + (test-empty '(in-hole (name E_1 (list (hide-hole hole) hole)) x) `(,the-hole x) (list (make-test-mtch (make-bindings (list (make-bind 'E_1 `(,the-not-hole ,the-hole)))) `(,the-hole x) none))) - + (test-empty '(name x (name number number)) 1 (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) 1 none))) + (test-empty '(name number_x number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'number_x 1))) 1 none))) + (test-empty '(name string_y string) "b" (list (make-test-mtch (make-bindings (list (make-bind 'string_y "b"))) "b" none))) + (test-empty '(name any_z any) '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any_z '(a b)))) '(a b) none))) - (test-empty '(name x number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) 1 none))) - (test-empty 'number_x 1 (list (make-test-mtch (make-bindings (list (make-bind 'number_x 1))) 1 none))) - (test-empty 'string_y "b" (list (make-test-mtch (make-bindings (list (make-bind 'string_y "b"))) "b" none))) - (test-empty 'any_z '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any_z '(a b)))) '(a b) none))) - - (test-empty '(name x_!_1 number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none))) - (test-empty '((name x_!_1 number) (name x_!_1 number)) '(1 1) #f) - (test-empty '((name x_!_1 number_a) (name x_!_1 number_b)) '(1 2) + (test-empty '(mismatch-name x_!_1 (name number number)) 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none))) + (test-empty '(list (mismatch-name x_!_1 (name number number)) (mismatch-name x_!_1 number)) '(1 1) #f) + (test-empty '(list (mismatch-name x_!_1 (name number_a number)) (mismatch-name x_!_1 (name number_b number))) '(1 2) (list (make-test-mtch (make-bindings (list (make-bind 'number_a 1) (make-bind 'number_b 2))) '(1 2) none))) - (test-empty '(number_!_1 number_!_1) '(1 1) #f) - (test-empty '(number_!_1 number_!_1) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none))) - (test-empty '(number_!_1 ...) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none))) - (test-empty '(number_!_1 ...) '(1 2 3 4 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 4 5) none))) - (test-empty '(number_!_1 ...) '(1 2 3 1 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 1 5) none))) - (test-empty '((number_!_1 ...) (number_!_1 ...)) + (test-empty '(list (mismatch-name number_!_1 number) (mismatch-name number_!_1 number)) '(1 1) #f) + (test-empty '(list (mismatch-name number_!_1 number) (mismatch-name number_!_1 number)) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none))) + (test-empty '(list (repeat (mismatch-name number_!_1 number) #f #f)) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none))) + (test-empty '(list (repeat (mismatch-name number_!_1 number) #f #f)) '(1 2 3 4 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 4 5) none))) + (test-empty '(list (repeat (mismatch-name number_!_1 number) #f #f)) '(1 2 3 1 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 1 5) none))) + (test-empty '(list (list (repeat (mismatch-name number_!_1 number) #f #f)) (list (repeat number_!_1 #f #f))) '((1 2 3 1 5) (1 2 3 1 5)) #f) - (test-empty '((number_!_1 ...) (number_!_1 ...)) + (test-empty '(list (list (repeat (mismatch-name number_!_1 number) #f #f)) + (list (repeat (mismatch-name number_!_1 number) #f #f))) '((17 2 3 1 5) (1 2 3 1 5)) (list (make-test-mtch (make-bindings (list)) '((17 2 3 1 5) (1 2 3 1 5)) none))) - (test-empty '((number_!_1 number_!_1) ... number_!_1 ...) '((1 1) (2 2) 1 3) #f) - (test-empty '((number_!_1 number_!_1) ... number_!_1 ...) '((1 1) (2 3) 1 2) #f) - (test-empty '((number_!_1 number_!_1) ... number_!_1 ...) + (test-empty '(list (repeat (list (mismatch-name number_!_1 number) (mismatch-name number_!_1 number)) #f #f) + (repeat (mismatch-name number_!_1 number) #f #f)) + '((1 1) (2 2) 1 3) + #f) + (test-empty '(list (repeat (list (mismatch-name number_!_1 number) (mismatch-name number_!_1 number)) #f #f) + (repeat (mismatch-name number_!_1 number) #f #f)) + '((1 1) (2 3) 1 2) + #f) + (test-empty '(list (repeat (list (mismatch-name number_!_1 number) (mismatch-name number_!_1 number)) #f #f) + (repeat (mismatch-name number_!_1 number) #f #f)) '((1 1) (2 3) 1 4) (list (make-test-mtch (make-bindings (list)) '((1 1) (2 3) 1 4) none))) + (test-empty '(list (repeat (name x_1 1) ..._1 ..._!_1) + (repeat (name x_1 1) ..._1 #f) + (repeat (name x_2 2) ..._2 ..._!_1) + (repeat (name x_2 2) ..._2 #f)) + '(1 1 2 2) + #f) + (test-empty '(list (repeat (name x_1 1) ..._1 ..._!_1) + (repeat (name x_1 1) ..._1 #f) + (repeat (name x_2 2) ..._2 ..._!_1) + (repeat (name x_2 2) ..._2 #f)) + '(1 1 2 2 2) + #f) + (test-empty '(list (repeat (name x_1 1) ..._1 ..._!_1) + (repeat (name x_1 1) ..._1 #f) + (repeat (name x_2 2) ..._2 ..._!_1) + (repeat (name x_2 2) ..._2 #f)) + '(1 1 1 2 2) + #f) + (test-empty '(list (repeat (name x_1 1) ..._1 ..._!_1) + (repeat (name x_1 1) ..._1 #f) + (repeat (name x_2 2) ..._2 ..._!_1) + (repeat (name x_2 2) ..._2 #f)) + '(1 1 1 1 2 2) + (list (make-mtch (make-bindings (list (make-bind 'x_1 '(1 1)) + (make-bind 'x_2 '(2)) + (make-bind '..._2 1) + (make-bind '..._1 2))) + '(1 1 1 1 2 2) + none))) + (test-ellipses '(a) '(a)) - (test-ellipses '(a ...) `(,(make-repeat 'a '() #f #f))) - (test-ellipses '((a ...) ...) `(,(make-repeat '(a ...) '() #f #f))) - (test-ellipses '(a ... b c ...) `(,(make-repeat 'a '() #f #f) b ,(make-repeat 'c '() #f #f))) - (test-ellipses '((name x a) ...) `(,(make-repeat '(name x a) (list (make-bind 'x '())) #f #f))) - (test-ellipses '((name x (a ...)) ...) - `(,(make-repeat '(name x (a ...)) (list (make-bind 'x '())) #f #f))) - (test-ellipses '(((name x a) ...) ...) - `(,(make-repeat '((name x a) ...) (list (make-bind 'x '())) #f #f))) - (test-ellipses '((1 (name x a)) ...) - `(,(make-repeat '(1 (name x a)) (list (make-bind 'x '())) #f #f))) - (test-ellipses '((any (name x a)) ...) - `(,(make-repeat '(any (name x a)) (list (make-bind 'any '()) - (make-bind 'x '())) + (test-ellipses '((repeat a #f #f)) `(,(make-repeat 'a '() #f #f))) + (test-ellipses '((repeat (list (repeat a #f #f)) #f #f)) `(,(make-repeat '(list (repeat a #f #f)) '() #f #f))) + (test-ellipses '((repeat a #f #f) b (repeat c #f #f)) `(,(make-repeat 'a '() #f #f) b ,(make-repeat 'c '() #f #f))) + (test-ellipses '((repeat (name x a) #f #f)) `(,(make-repeat '(name x a) (list (make-bind 'x '())) #f #f))) + (test-ellipses '((repeat (name x (list (repeat a #f #f))) #f #f)) + `(,(make-repeat '(name x (list (repeat a #f #f))) (list (make-bind 'x '())) #f #f))) + (test-ellipses '((repeat (list (repeat (name x a) #f #f)) #f #f)) + `(,(make-repeat '(list (repeat (name x a) #f #f)) (list (make-bind 'x '())) #f #f))) + (test-ellipses '((repeat (list 1 (name x a)) #f #f)) + `(,(make-repeat '(list 1 (name x a)) (list (make-bind 'x '())) #f #f))) + (test-ellipses '((repeat (list (name any any) (name x a)) #f #f)) + `(,(make-repeat '(list (name any any) (name x a)) + (list (make-bind 'any '()) + (make-bind 'x '())) + #f #f))) + (test-ellipses '((repeat (list (name number number) (name x a)) #f #f)) + `(,(make-repeat '(list (name number number) (name x a)) + (list (make-bind 'number '()) + (make-bind 'x '())) #f #f))) - (test-ellipses '((number (name x a)) ...) - `(,(make-repeat '(number (name x a)) (list (make-bind 'number '()) - (make-bind 'x '())) - #f #f))) - (test-ellipses '((variable (name x a)) ...) - `(,(make-repeat '(variable (name x a)) (list (make-bind 'variable '()) - (make-bind 'x '())) - #f #f))) - (test-ellipses '(((name x a) (name y b)) ...) - `(,(make-repeat '((name x a) (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f))) - (test-ellipses '((name x (name y b)) ...) + (test-ellipses '((repeat (list (name variable variable) (name x a)) #f #f)) + `(,(make-repeat '(list (name variable variable) (name x a)) + (list (make-bind 'variable '()) + (make-bind 'x '())) + #f #f))) + (test-ellipses '((repeat (list (name x a) (name y b)) #f #f)) + `(,(make-repeat '(list (name x a) (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f))) + + (test-ellipses '((repeat (name x (name y b)) #f #f)) `(,(make-repeat '(name x (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f))) - (test-ellipses '((in-hole (name x a) (name y b)) ...) + (test-ellipses '((repeat (in-hole (name x a) (name y b)) #f #f)) `(,(make-repeat '(in-hole (name x a) (name y b)) - (list (make-bind 'y '()) (make-bind 'x '())) #f #f))) + (list (make-bind 'y '()) (make-bind 'x '())) + #f #f))) - (test-ellipses '(a ..._1) + (test-ellipses '((repeat a ..._1 #f)) `(,(make-repeat 'a (list) '..._1 #f))) - (test-ellipses '(a ..._!_1) - `(,(make-repeat 'a (list) '..._!_1 #t))) + (test-ellipses '((repeat a #f ..._!_1)) + `(,(make-repeat 'a (list) #f '..._!_1))) - (test-empty '() '() (list (make-test-mtch (make-bindings null) '() none))) - (test-empty '(a) '(a) (list (make-test-mtch (make-bindings null) '(a) none))) - (test-empty '(a) '(b) #f) - (test-empty '(a b) '(a b) (list (make-test-mtch (make-bindings null) '(a b) none))) - (test-empty '(a b) '(a c) #f) - (test-empty '() 1 #f) - (test-empty '(#f x) '(#f x) (list (make-test-mtch (make-bindings null) '(#f x) none))) - (test-empty '(#f (name y any)) '(#f) #f) - (test-empty '(in-hole (z hole) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none))) - (test-empty '(in-hole (z hole) (in-hole (x hole) a)) + (test-empty '(list) '() (list (make-test-mtch (make-bindings null) '() none))) + (test-empty '(list a) '(a) (list (make-test-mtch (make-bindings null) '(a) none))) + (test-empty '(list a) '(b) #f) + (test-empty '(list a b) '(a b) (list (make-test-mtch (make-bindings null) '(a b) none))) + (test-empty '(list a b) '(a c) #f) + (test-empty '(list) 1 #f) + (test-empty '(list #f x) '(#f x) (list (make-test-mtch (make-bindings null) '(#f x) none))) + (test-empty '(list #f (name y any)) '(#f) #f) + (test-empty '(in-hole (list z hole) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none))) + (test-empty '(in-hole (list z hole) (in-hole (list x hole) a)) '(z (x a)) (list (make-test-mtch (make-bindings (list)) '(z (x a)) none))) - (run-test/cmp 'in-hole-zero-holes + (run-test/cmp (this-line) + 'in-hole-zero-holes (with-handlers ([exn:fail? (λ (e) (regexp-match #rx"zero holes" (exn-message e)))]) - (test-empty '(in-hole (1 2) 2) '(1 2) 'never-gets-here) + (test-empty '(in-hole (list 1 2) 2) '(1 2) 'never-gets-here) 'should-have-raised-an-exception) '("zero holes") equal?) - (test-empty '(in-hole (in-hole (x hole) hole) y) + (test-empty '(in-hole (in-hole (list x hole) hole) y) '(x y) (list (make-test-mtch (make-bindings (list)) '(x y) none))) - (test-empty '(number number) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) '(1 1) none))) - (test-empty '((name x number) (name x number)) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) '(1 1) none))) - (test-empty '((name x number_q) (name x number_r)) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'x 1) - (make-bind 'number_q 1) - (make-bind 'number_r 1))) - '(1 1) - none))) - (test-empty '(number number) '(1 2) #f) - (test-empty '((name x number) (name x number)) '(1 2) #f) - (test-empty '((name x number_q) (name x number_r)) '(1 2) #f) + (test-empty '(list (name number number) (name number number)) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) '(1 1) none))) + (test-empty '(list (name x (name number number)) (name x (name number number))) + '(1 1) + (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) '(1 1) none))) + (test-empty '(list (name x (name number_q number)) (name x (name number_r number))) + '(1 1) + (list (make-test-mtch (make-bindings (list (make-bind 'x 1) + (make-bind 'number_q 1) + (make-bind 'number_r 1))) + '(1 1) + none))) + (test-empty '(list (name number number) (name number number)) '(1 2) #f) + (test-empty '(list (name x number) (name x number)) '(1 2) #f) + (test-empty '(list (name x number_q) (name x number_r)) '(1 2) #f) - (test-empty '(a ...) '() (list (make-test-mtch (make-bindings empty) '() none))) - (test-empty '(a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none))) - (test-empty '(a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none))) - (test-empty '((name x a) ...) '() (list (make-test-mtch (make-bindings (list (make-bind 'x '()))) '() none))) - (test-empty '((name x a) ...) '(a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a)))) '(a) none))) - (test-empty '((name x a) ...) '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a a)))) '(a a) none))) - (test-empty '(hole ...) '() (list (make-test-mtch (make-bindings empty) '() none))) + (test-empty '(list (repeat a #f #f)) '() (list (make-test-mtch (make-bindings empty) '() none))) + (test-empty '(list (repeat a #f #f)) '(a) (list (make-test-mtch (make-bindings empty) '(a) none))) + (test-empty '(list (repeat a #f #f)) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none))) + (test-empty '(list (repeat (name x a) #f #f)) '() (list (make-test-mtch (make-bindings (list (make-bind 'x '()))) '() none))) + (test-empty '(list (repeat (name x a) #f #f)) '(a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a)))) '(a) none))) + (test-empty '(list (repeat (name x a) #f #f)) '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a a)))) '(a a) none))) + (test-empty '(list (repeat hole #f #f)) '() (list (make-test-mtch (make-bindings empty) '() none))) - (test-empty '(b ... a ...) '() (list (make-test-mtch (make-bindings empty) '() none))) - (test-empty '(b ... a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none))) - (test-empty '(b ... a ...) '(b) (list (make-test-mtch (make-bindings empty) '(b) none))) - (test-empty '(b ... a ...) '(b a) (list (make-test-mtch (make-bindings empty) '(b a) none))) - (test-empty '(b ... a ...) '(b b a a) (list (make-test-mtch (make-bindings empty) '(b b a a) none))) - (test-empty '(b ... a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none))) - (test-empty '(b ... a ...) '(b b) (list (make-test-mtch (make-bindings empty) '(b b) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '() (list (make-test-mtch (make-bindings empty) '() none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(a) (list (make-test-mtch (make-bindings empty) '(a) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(b) (list (make-test-mtch (make-bindings empty) '(b) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(b a) (list (make-test-mtch (make-bindings empty) '(b a) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(b b a a) (list (make-test-mtch (make-bindings empty) '(b b a a) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none))) + (test-empty '(list (repeat b #f #f) (repeat a #f #f)) '(b b) (list (make-test-mtch (make-bindings empty) '(b b) none))) - (test-empty '(a ..._1 a ..._2) + (test-empty '(list (repeat a ..._1 #f) (repeat a ..._2 #f)) '(a) (list (make-test-mtch (make-bindings (list (make-bind '..._1 1) (make-bind '..._2 0))) '(a) none) (make-test-mtch (make-bindings (list (make-bind '..._1 0) (make-bind '..._2 1))) '(a) none))) - (test-empty '(a ..._1 a ..._1) '(a) #f) - (test-empty '(a ..._1 a ..._1) + (test-empty '(list (repeat a ..._1 #f) (repeat a ..._1 #f)) '(a) #f) + (test-empty '(list (repeat a ..._1 #f) (repeat a ..._1 #f)) '(a a) (list (make-test-mtch (make-bindings (list (make-bind '..._1 1))) '(a a) none))) - (test-empty '((a ..._1 a ..._1) ...) + (test-empty '(list (repeat (list (repeat a ..._1 #f) (repeat a ..._1 #f)) #f #f)) '((a a a a)) (list (make-test-mtch (make-bindings (list (make-bind '..._1 '(2)))) '((a a a a)) none))) - (test-empty '((a ..._!_1 a ..._!_1) ...) + (test-empty '(list (repeat (list (repeat a #f ..._!_1) (repeat a #f ..._!_1)) #f #f)) '((a a a a)) (list (make-test-mtch (make-bindings '()) '((a a a a)) none) (make-test-mtch (make-bindings '()) '((a a a a)) none) (make-test-mtch (make-bindings '()) '((a a a a)) none) (make-test-mtch (make-bindings '()) '((a a a a)) none))) - (test-empty '((name x a) ..._!_1 (name y a) ..._!_1) + (test-empty '(list (repeat (name x a) #f ..._!_1) (repeat (name y a) #f ..._!_1)) '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '(a a)))) '(a a) none) (make-test-mtch (make-bindings (list (make-bind 'x '(a a)) (make-bind 'y '()))) '(a a) none))) - (test-empty '((name y b) ... (name x a) ...) '() + (test-empty '(list (repeat (name y b) #f #f) (repeat (name x a) #f #f)) '() (list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '()))) '() none))) - (test-empty '((name y b) ... (name x a) ...) '(a) + (test-empty '(list (repeat (name y b) #f #f) (repeat (name x a) #f #f)) '(a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a)) (make-bind 'y '()))) '(a) none))) - (test-empty '((name y b) ... (name x a) ...) '(b) + (test-empty '(list (repeat (name y b) #f #f) (repeat (name x a) #f #f)) '(b) (list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '(b)))) '(b) none))) - (test-empty '((name y b) ... (name x a) ...) '(b b a a) + (test-empty '(list (repeat (name y b) #f #f) (repeat (name x a) #f #f)) '(b b a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a a)) (make-bind 'y '(b b)))) '(b b a a) none))) - (test-empty '((name y a) ... (name x a) ...) '(a) + (test-empty '(list (repeat (name y a) #f #f) (repeat (name x a) #f #f)) '(a) (list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '(a)))) '(a) @@ -250,7 +302,7 @@ (make-bind 'y '()))) '(a) none))) - (test-empty '((name y a) ... (name x a) ...) '(a a) + (test-empty '(list (repeat (name y a) #f #f) (repeat (name x a) #f #f)) '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '(a a)))) '(a a) @@ -264,27 +316,37 @@ '(a a) none))) - (test-ab '(bb_y ... aa_x ...) '() + (test-ab (this-line) + '(list (repeat (name bb_y (nt bb)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '() (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) (make-bind 'bb_y '()))) '() none))) - (test-ab '(bb_y ... aa_x ...) '(a) + (test-ab (this-line) + '(list (repeat (name bb_y (nt bb)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '(a) (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a)) (make-bind 'bb_y '()))) '(a) none))) - (test-ab '(bb_y ... aa_x ...) '(b) + (test-ab (this-line) + '(list (repeat (name bb_y (nt bb)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '(b) (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) (make-bind 'bb_y '(b)))) '(b) none))) - (test-ab '(bb_y ... aa_x ...) '(b b a a) + (test-ab (this-line) + '(list (repeat (name bb_y (nt bb)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '(b b a a) (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a a)) (make-bind 'bb_y '(b b)))) '(b b a a) none))) - (test-ab '(aa_y ... aa_x ...) '(a) + (test-ab (this-line) + '(list (repeat (name aa_y (nt aa)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '(a) (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) (make-bind 'aa_y '(a)))) '(a) @@ -293,7 +355,9 @@ (make-bind 'aa_y '()))) '(a) none))) - (test-ab '(aa_y ... aa_x ...) '(a a) + (test-ab (this-line) + '(list (repeat (name aa_y (nt aa)) #f #f) (repeat (name aa_x (nt aa)) #f #f)) + '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) (make-bind 'aa_y '(a a)))) '(a a) @@ -307,19 +371,27 @@ '(a a) none))) - (test-empty '((name x number) ...) '(1 2) (list (make-test-mtch (make-bindings (list (make-bind 'x '(1 2)) (make-bind 'number '(1 2)))) '(1 2) none))) + (test-empty '(list (repeat (name x (name number number)) #f #f)) + '(1 2) + (list (make-test-mtch (make-bindings (list (make-bind 'x '(1 2)) (make-bind 'number '(1 2)))) '(1 2) none))) - (test-empty '(a ...) '(b) #f) - (test-empty '(a ... b ...) '(c) #f) - (test-empty '(a ... b) '(b c) #f) - (test-empty '(a ... b) '(a b c) #f) + (test-empty '(list (repeat a #f #f)) '(b) #f) + (test-empty '(list (repeat a #f #f) (repeat b #f #f)) '(c) #f) + (test-empty '(list (repeat a #f #f) b) '(b c) #f) + (test-empty '(list (repeat a #f #f) b) '(a b c) #f) - (test-lang '(n n ...) '((1 1) 1 1) (list (make-mtch (make-bindings (list (make-bind 'n '(1 1)))) '((1 1) 1 1) none)) + (test-lang (this-line) + '(list (name n (nt n)) (repeat (name n (nt n)) #f #f)) + '((1 1) 1 1) + (list (make-mtch (make-bindings (list (make-bind 'n '(1 1)))) '((1 1) 1 1) none)) (list (make-nt 'n (list (make-rhs 'any) (make-rhs 'number))))) - (test-lang '(n (n ...)) '((1 1) (1 1)) (list (make-mtch (make-bindings (list (make-bind 'n '(1 1)))) '((1 1) (1 1)) none)) + (test-lang (this-line) + '(list (name n (nt n)) (list (repeat (name n (nt n)) #f #f))) + '((1 1) (1 1)) + (list (make-mtch (make-bindings (list (make-bind 'n '(1 1)))) '((1 1) (1 1)) none)) (list (make-nt 'n (list (make-rhs 'any) (make-rhs 'number))))) - (test-empty '((name x any) - ((name x number) ...)) + (test-empty '(list (name x (name any any)) + (list (repeat (name x (name number number)) #f #f))) '((1 1) (1 1)) (list (make-test-mtch (make-bindings (list (make-bind 'x '(1 1)) (make-bind 'any '(1 1)) @@ -327,14 +399,15 @@ '((1 1) (1 1)) none))) - (test-empty '((variable_1 variable_1) ...) + (test-empty '(list (repeat (list variable_1 variable_1) #f #f)) '((x y)) #f) - - (test-empty '(number ...) '() + (test-empty '(list (repeat (name number number) #f #f)) '() (list (make-test-mtch (make-bindings (list (make-bind 'number '()))) '() none))) - (test-ab '(aa ...) '() + (test-ab (this-line) + '(list (repeat (name aa aa) #f #f)) + '() (list (make-test-mtch (make-bindings (list (make-bind 'aa '()))) '() none))) @@ -342,27 +415,27 @@ (test-empty '(hide-hole a) 'b #f) (test-empty '(hide-hole a) 'a (list (make-test-mtch (make-bindings '()) 'a none))) (test-empty '(hide-hole a) '(block-in-hole a) #f) - (test-empty '(in-hole (x (hide-hole hole)) 1) '(x 1) #f) - (test-empty '(in-hole (x hole) 1) '(x 1) (list (make-test-mtch (make-bindings '()) '(x 1) none))) - (test-empty '(in-hole ((hole #f) (hide-hole hole)) junk) + (test-empty '(in-hole (list x (hide-hole hole)) 1) '(x 1) #f) + (test-empty '(in-hole (list x hole) 1) '(x 1) (list (make-test-mtch (make-bindings '()) '(x 1) none))) + (test-empty '(in-hole (list hole (hide-hole hole)) junk) '(junk junk2) #f) - (test-xab 'lsts '() (list (make-test-mtch (make-bindings (list (make-bind 'lsts '()))) '() none))) - (test-xab 'lsts '(x) (list (make-test-mtch (make-bindings (list (make-bind 'lsts '(x)))) '(x) none))) - (test-xab 'lsts 'x (list (make-test-mtch (make-bindings (list (make-bind 'lsts 'x))) 'x none))) - (test-xab 'lsts #f (list (make-test-mtch (make-bindings (list (make-bind 'lsts #f))) #f none))) - (test-xab 'split-out '1 (list (make-test-mtch (make-bindings (list (make-bind 'split-out 1))) '1 none))) + (test-xab '(name lsts (nt lsts)) '() (list (make-test-mtch (make-bindings (list (make-bind 'lsts '()))) '() none))) + (test-xab '(name lsts (nt lsts)) '(x) (list (make-test-mtch (make-bindings (list (make-bind 'lsts '(x)))) '(x) none))) + (test-xab '(name lsts (nt lsts)) 'x (list (make-test-mtch (make-bindings (list (make-bind 'lsts 'x))) 'x none))) + (test-xab '(name lsts (nt lsts)) #f (list (make-test-mtch (make-bindings (list (make-bind 'lsts #f))) #f none))) + (test-xab '(name split-out (nt split-out)) '1 (list (make-test-mtch (make-bindings (list (make-bind 'split-out 1))) '1 none))) - (test-xab 'exp 1 (list (make-test-mtch (make-bindings (list (make-bind 'exp 1))) 1 none))) - (test-xab 'exp '(+ 1 2) (list (make-test-mtch (make-bindings (list (make-bind 'exp '(+ 1 2)))) '(+ 1 2) none))) - (test-xab '(in-hole ctxt any) + (test-xab '(name exp (nt exp)) 1 (list (make-test-mtch (make-bindings (list (make-bind 'exp 1))) 1 none))) + (test-xab '(name exp (nt exp)) '(+ 1 2) (list (make-test-mtch (make-bindings (list (make-bind 'exp '(+ 1 2)))) '(+ 1 2) none))) + (test-xab '(in-hole (name ctxt (nt ctxt)) (name any any)) '1 (list (make-test-mtch (make-bindings (list (make-bind 'ctxt the-hole) (make-bind 'any 1))) 1 none))) - (test-xab '(in-hole ctxt (name x any)) + (test-xab '(in-hole (name ctxt (nt ctxt)) (name x (name any any))) '1 (list (make-test-mtch (make-bindings (list (make-bind 'ctxt the-hole) (make-bind 'x 1) (make-bind 'any 1))) 1 none))) - (test-xab '(in-hole (name c ctxt) (name x any)) + (test-xab '(in-hole (name c (name ctxt (nt ctxt))) (name x (name any any))) '(+ 1 2) (list (make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context the-hole)) (make-bind 'c (build-context the-hole)) @@ -379,7 +452,7 @@ (make-bind 'x 2) (make-bind 'any 2))) '(+ 1 2) none))) - (test-xab '(in-hole (name c ctxt) (name i (+ number_1 number_2))) + (test-xab '(in-hole (name c (name ctxt (nt ctxt))) (name i (list + (name number_1 number) (name number_2 number)))) '(+ (+ 1 2) (+ 3 4)) (list (make-test-mtch (make-bindings (list (make-bind 'i '(+ 1 2)) @@ -397,29 +470,29 @@ '(+ (+ 1 2) (+ 3 4)) none))) - (test-empty '(in-hole ((z hole)) (name x any)) + (test-empty '(in-hole (list (list z hole)) (name x (name any any))) '((z a)) (list (make-test-mtch (make-bindings (list (make-bind 'x 'a) (make-bind 'any 'a))) '((z a)) none))) - (test-empty '(in-hole (name c (z ... hole z ...)) any) + (test-empty '(in-hole (name c (list (repeat z #f #f) hole (repeat z #f #f))) (name any any)) '(z z) (list (make-test-mtch (make-bindings (list (make-bind 'c `(z ,the-hole)) (make-bind 'any 'z))) '(z z) none) (make-test-mtch (make-bindings (list (make-bind 'c `(,the-hole z)) (make-bind 'any 'z))) '(z z) none))) - (test-empty '(in-hole (name c (z ... hole z ...)) any) + (test-empty '(in-hole (name c (list (repeat z #f #f) hole (repeat z #f #f))) (name any any)) '(z z z) (list (make-test-mtch (make-bindings (list (make-bind 'c `(z z ,the-hole)) (make-bind 'any 'z))) '(z z z) none) (make-test-mtch (make-bindings (list (make-bind 'c `(z ,the-hole z)) (make-bind 'any 'z))) '(z z z) none) (make-test-mtch (make-bindings (list (make-bind 'c `(,the-hole z z)) (make-bind 'any 'z))) '(z z z) none))) - (test-empty '(z (in-hole (name c (z hole)) a)) + (test-empty '(list z (in-hole (name c (list z hole)) a)) '(z (z a)) (list (make-test-mtch (make-bindings (list (make-bind 'c `(z ,the-hole)))) '(z (z a)) none))) - (test-empty '(a (in-hole (name c1 (b (in-hole (name c2 (c hole)) d) hole)) e)) + (test-empty '(list a (in-hole (name c1 (list b (in-hole (name c2 (list c hole)) d) hole)) e)) '(a (b (c d) e)) (list (make-test-mtch (make-bindings (list (make-bind 'c2 `(c ,the-hole)) @@ -431,7 +504,7 @@ 'a (list (make-test-mtch (make-bindings (list)) 'a none))) - (test-empty '(a (b (in-hole (name c1 (in-hole (name c2 (c hole)) (d hole))) e))) + (test-empty '(list a (list b (in-hole (name c1 (in-hole (name c2 (list c hole)) (list d hole))) e))) '(a (b (c (d e)))) (list (make-test-mtch (make-bindings (list (make-bind 'c1 `(c (d ,the-hole))) @@ -439,21 +512,21 @@ '(a (b (c (d e)))) none))) - (test-empty `(+ 1 (side-condition any ,(lambda (bindings) #t) #t)) + (test-empty `(list + 1 (side-condition (name any any) ,(lambda (bindings) #t) #t)) '(+ 1 b) (list (make-test-mtch (make-bindings (list (make-bind 'any 'b))) '(+ 1 b) none))) - (test-empty `(+ 1 (side-condition any ,(lambda (bindings) #f) #f)) + (test-empty `(list + 1 (side-condition (name any any) ,(lambda (bindings) #f) #f)) '(+ 1 b) #f) - (test-empty `(+ 1 (side-condition b ,(lambda (bindings) #t) #t)) + (test-empty `(list + 1 (side-condition b ,(lambda (bindings) #t) #t)) '(+ 1 b) (list (make-test-mtch (make-bindings '()) '(+ 1 b) none))) - (test-empty `(+ 1 (side-condition a ,(lambda (bindings) #t)) #t) + (test-empty `(list + 1 (side-condition a ,(lambda (bindings) #t) #t) #t) '(+ 1 b) #f) - (test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a)) + (test-empty `(side-condition (name x (name any any)) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) side-condition-srcloc) 'a (list (make-test-mtch (make-bindings (list (make-bind 'x 'a) @@ -461,7 +534,8 @@ 'a none))) - (test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a))) + (test-empty `(list + 1 (side-condition (name x (name any any)) + ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) side-condition-srcloc)) '(+ 1 a) (list (make-test-mtch (make-bindings (list (make-bind 'x 'a) @@ -473,158 +547,163 @@ 'b #f) - (test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a))) + (test-empty `(list + 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a))) '(+ 1 b) #f) - (test-empty `(side-condition ((any_1 ..._a) (any_2 ..._a)) + (test-empty `(side-condition (list (list (repeat any_1 ..._a #f)) (list (repeat any_2 ..._a #f))) ,(lambda (bindings) (error 'should-not-be-called)) (error 'should-not-be-called)) '((1 2 3) (4 5)) #f) - (test-xab 'exp_1 + (test-xab '(name exp_1 (nt exp)) '(+ 1 2) (list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)))) '(+ 1 2) none))) - (test-xab '(exp_1 exp_2) + (test-xab '(list (name exp_1 (nt exp)) (name exp_2 (nt exp))) '((+ 1 2) (+ 3 4)) (list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)) (make-bind 'exp_2 '(+ 3 4)))) '((+ 1 2) (+ 3 4)) none))) - (test-xab '(exp_1 exp_1) + (test-xab '(list (name exp_1 (nt exp)) (name exp_1 (nt exp))) '((+ 1 2) (+ 3 4)) #f) - (test-xab 'nesting-names + (test-xab '(name nesting-names (nt nesting-names)) 'b (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names 'b))) 'b none))) - (test-xab 'nesting-names + (test-xab '(name nesting-names (nt nesting-names)) '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a b)))) '(a b) none))) - (test-xab 'nesting-names + (test-xab '(name nesting-names (nt nesting-names)) '(a (a b)) (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a (a b))))) '(a (a b)) none))) - (test-xab '((name x a) nesting-names) + (test-xab '(list (name x a) (name nesting-names (nt nesting-names))) '(a (a (a b))) (list (make-test-mtch (make-bindings (list (make-bind 'x 'a) (make-bind 'nesting-names '(a (a b))))) '(a (a (a b))) none))) - (test-xab 'nesting-names + (test-xab '(name nesting-names (nt nesting-names)) '(a (a (a (a b)))) (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a (a (a (a b))))))) '(a (a (a (a b)))) none))) - (test-xab 'same-in-nt + (test-xab '(name same-in-nt (nt same-in-nt)) '(x x) (list (make-test-mtch (make-bindings (list (make-bind 'same-in-nt '(x x)))) '(x x) none))) - (test-xab 'same-in-nt + (test-xab '(name same-in-nt (nt same-in-nt)) '(x y) #f) - (test-xab '(in-hole (cross forever-list) 1) + (test-xab '(in-hole (cross forever-list-forever-list) 1) '(a b c) #f) - (test-xab '(in-hole (cross forever-list) 1) + (test-xab '(in-hole (cross forever-list-forever-list) 1) '(1 x x) (list (make-test-mtch (make-bindings '()) '(1 x x) none))) - (test-xab '(in-hole (cross forever-list) 1) + (test-xab '(in-hole (cross forever-list-forever-list) 1) '(x 1 x) (list (make-test-mtch (make-bindings '()) '(x 1 x) none))) - (test-xab '(in-hole (cross simple) g) + (test-xab '(in-hole (cross simple-simple) g) 'g (list (make-mtch (make-bindings (list)) 'g none))) - (test-xab 'var '+ #f) - (test-xab 'var 'anunusedvariable (list (make-mtch (make-bindings (list (make-bind 'var 'anunusedvariable))) 'anunusedvariable none))) - (test-xab 'var 'exp (list (make-mtch (make-bindings (list (make-bind 'var 'exp))) 'exp none))) - (test-xab 'var 'exp_x (list (make-mtch (make-bindings (list (make-bind 'var 'exp_x))) 'exp_x none))) + (test-xab '(name var (nt var)) '+ #f) + (test-xab '(name var (nt var)) 'anunusedvariable (list (make-mtch (make-bindings (list (make-bind 'var 'anunusedvariable))) 'anunusedvariable none))) + (test-xab '(name var (nt var)) 'exp (list (make-mtch (make-bindings (list (make-bind 'var 'exp))) 'exp none))) + (test-xab '(name var (nt var)) 'exp_x (list (make-mtch (make-bindings (list (make-bind 'var 'exp_x))) 'exp_x none))) - (test-xab 'underscore '(+ 1 2) (list (make-mtch (make-bindings (list (make-bind 'underscore '(+ 1 2)))) '(+ 1 2) none))) - (test-xab 'underscore '2 (list (make-mtch (make-bindings (list (make-bind 'underscore 2))) 2 none))) + (test-xab '(name underscore (nt underscore)) '(+ 1 2) (list (make-mtch (make-bindings (list (make-bind 'underscore '(+ 1 2)))) '(+ 1 2) none))) + (test-xab '(name underscore (nt underscore)) '2 (list (make-mtch (make-bindings (list (make-bind 'underscore 2))) 2 none))) (run-test + (this-line) 'compatible-context-language1 (build-compatible-context-language (mk-hasheq '((exp . ()) (ctxt . ()))) (list (make-nt 'exp - (list (make-rhs '(+ exp exp)) + (list (make-rhs '(list + (nt exp) (nt exp))) (make-rhs 'number))) (make-nt 'ctxt - (list (make-rhs '(+ ctxt exp)) - (make-rhs '(+ exp ctxt)) + (list (make-rhs '(list + (nt ctxt) (nt exp))) + (make-rhs '(list + (nt exp) (nt ctxt))) (make-rhs 'hole))))) (list (make-nt 'ctxt-ctxt (list (make-rhs 'hole) - (make-rhs `((hide-hole +) (cross ctxt-ctxt) (hide-hole exp))) - (make-rhs `((hide-hole +) (hide-hole ctxt) (cross ctxt-exp))) - (make-rhs `((hide-hole +) (cross ctxt-exp) (hide-hole ctxt))) - (make-rhs `((hide-hole +) (hide-hole exp) (cross ctxt-ctxt))))) + (make-rhs `(list (hide-hole +) (cross ctxt-ctxt) (hide-hole (nt exp)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt ctxt)) (cross ctxt-exp))) + (make-rhs `(list (hide-hole +) (cross ctxt-exp) (hide-hole (nt ctxt)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt exp)) (cross ctxt-ctxt))))) (make-nt 'ctxt-exp - (list (make-rhs `((hide-hole +) (cross ctxt-exp) (hide-hole exp))) - (make-rhs `((hide-hole +) (hide-hole exp) (cross ctxt-exp))))) + (list (make-rhs `(list (hide-hole +) (cross ctxt-exp) (hide-hole (nt exp)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt exp)) (cross ctxt-exp))))) (make-nt 'exp-ctxt - (list (make-rhs `((hide-hole +) (cross exp-ctxt) (hide-hole exp))) - (make-rhs `((hide-hole +) (hide-hole ctxt) (cross exp-exp))) - (make-rhs `((hide-hole +) (cross exp-exp) (hide-hole ctxt))) - (make-rhs `((hide-hole +) (hide-hole exp) (cross exp-ctxt))))) + (list (make-rhs `(list (hide-hole +) (cross exp-ctxt) (hide-hole (nt exp)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt ctxt)) (cross exp-exp))) + (make-rhs `(list (hide-hole +) (cross exp-exp) (hide-hole (nt ctxt)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt exp)) (cross exp-ctxt))))) (make-nt 'exp-exp (list (make-rhs 'hole) - (make-rhs `((hide-hole +) (cross exp-exp) (hide-hole exp))) - (make-rhs `((hide-hole +) (hide-hole exp) (cross exp-exp))))))) + (make-rhs `(list (hide-hole +) (cross exp-exp) (hide-hole (nt exp)))) + (make-rhs `(list (hide-hole +) (hide-hole (nt exp)) (cross exp-exp))))))) (run-test + (this-line) 'compatible-context-language2 (build-compatible-context-language (mk-hasheq '((m . ()) (v . ()))) - (list (make-nt 'm (list (make-rhs '(m m)) (make-rhs '(+ m m)) (make-rhs 'v))) - (make-nt 'v (list (make-rhs 'number) (make-rhs '(lambda (x) m)))))) + (list (make-nt 'm (list (make-rhs '(list (nt m) (nt m))) (make-rhs '(list + (nt m) (nt m))) (make-rhs '(nt v)))) + (make-nt 'v (list (make-rhs 'number) (make-rhs '(list lambda (list x) (nt m))))))) (list - (make-nt 'v-v (list (make-rhs 'hole) (make-rhs '((hide-hole lambda) (hide-hole (x)) (cross v-m))))) + (make-nt 'v-v (list (make-rhs 'hole) (make-rhs '(list (hide-hole lambda) (hide-hole (list x)) (cross v-m))))) (make-nt 'v-m (list - (make-rhs '((cross v-m) (hide-hole m))) - (make-rhs '((hide-hole m) (cross v-m))) - (make-rhs '((hide-hole +) (cross v-m) (hide-hole m))) - (make-rhs '((hide-hole +) (hide-hole m) (cross v-m))) + (make-rhs '(list (cross v-m) (hide-hole (nt m)))) + (make-rhs '(list (hide-hole (nt m)) (cross v-m))) + (make-rhs '(list (hide-hole +) (cross v-m) (hide-hole (nt m)))) + (make-rhs '(list (hide-hole +) (hide-hole (nt m)) (cross v-m))) (make-rhs '(cross v-v)))) - (make-nt 'm-v (list (make-rhs '((hide-hole lambda) (hide-hole (x)) (cross m-m))))) + (make-nt 'm-v (list (make-rhs '(list (hide-hole lambda) (hide-hole (list x)) (cross m-m))))) (make-nt 'm-m (list (make-rhs 'hole) - (make-rhs '((cross m-m) (hide-hole m))) - (make-rhs '((hide-hole m) (cross m-m))) - (make-rhs '((hide-hole +) (cross m-m) (hide-hole m))) - (make-rhs '((hide-hole +) (hide-hole m) (cross m-m))) + (make-rhs '(list (cross m-m) (hide-hole (nt m)))) + (make-rhs '(list (hide-hole (nt m)) (cross m-m))) + (make-rhs '(list (hide-hole +) (cross m-m) (hide-hole (nt m)))) + (make-rhs '(list (hide-hole +) (hide-hole (nt m)) (cross m-m))) (make-rhs '(cross m-v)))))) (run-test + (this-line) 'compatible-context-language3 (build-compatible-context-language (mk-hasheq '((m . ()) (seven . ()))) - (list (make-nt 'm (list (make-rhs '(m seven m)) (make-rhs 'number))) + (list (make-nt 'm (list (make-rhs '(list (nt m) (nt seven) (nt m))) + (make-rhs 'number))) (make-nt 'seven (list (make-rhs 7))))) `(,(make-nt 'm-m `(,(make-rhs 'hole) - ,(make-rhs `((cross m-m) (hide-hole seven) (hide-hole m))) - ,(make-rhs `((hide-hole m) (hide-hole seven) (cross m-m))))) + ,(make-rhs `(list (cross m-m) (hide-hole (nt seven)) (hide-hole (nt m)))) + ,(make-rhs `(list (hide-hole (nt m)) (hide-hole (nt seven)) (cross m-m))))) ,(make-nt 'seven-m - `(,(make-rhs `((cross seven-m) (hide-hole seven) (hide-hole m))) - ,(make-rhs `((hide-hole m) (cross seven-seven) (hide-hole m))) - ,(make-rhs `((hide-hole m) (hide-hole seven) (cross seven-m))))) + `(,(make-rhs `(list (cross seven-m) (hide-hole (nt seven)) (hide-hole (nt m)))) + ,(make-rhs `(list (hide-hole (nt m)) (cross seven-seven) (hide-hole (nt m)))) + ,(make-rhs `(list (hide-hole (nt m)) (hide-hole (nt seven)) (cross seven-m))))) ,(make-nt 'seven-seven `(,(make-rhs 'hole))))) (run-test + (this-line) 'compatible-context-language4 (build-compatible-context-language (mk-hasheq '((a . ()) (b . ()) (c . ()))) - (list (make-nt 'a (list (make-rhs 'b))) - (make-nt 'b (list (make-rhs 'c))) + (list (make-nt 'a (list (make-rhs '(nt b)))) + (make-nt 'b (list (make-rhs '(nt c)))) (make-nt 'c (list (make-rhs 3))))) (list (make-nt 'c-c (list (make-rhs 'hole))) (make-nt 'c-b (list (make-rhs '(cross c-c)))) @@ -633,49 +712,63 @@ (make-nt 'b-a (list (make-rhs '(cross b-b)))) (make-nt 'a-a (list (make-rhs 'hole))))) - #; - (test-xab '(in-hole (cross exp) (+ number number)) - '(+ (+ 1 2) 3) - (list (make-bindings (list (make-bind 'hole (make-hole-binding (list '+ 1 2) (list 'cdr 'car) #f)))))) + (run-test + (this-line) + 'compatible-context-language5 + (build-compatible-context-language + (mk-hasheq '((a . ()) (b . ()) (c . ()))) + (list (make-nt 'a (list (make-rhs '1) (make-rhs '2) (make-rhs '3))) + (make-nt 'b (list (make-rhs '(nt a)) + (make-rhs '(list (name a_1 (nt a)) (mismatch-name b_!_1 (nt b)))))))) + (list (make-nt 'a-a (list (make-rhs 'hole))) + (make-nt 'a-b (list (make-rhs '(cross a-a)) + (make-rhs '(list (name a_1 (cross a-a)) (hide-hole (mismatch-name b_!_1 (nt b))))) + (make-rhs '(list (hide-hole (name a_1 (nt a))) (mismatch-name b_!_1 (cross a-b)))))) + (make-nt 'b-b (list (make-rhs 'hole) + (make-rhs '(list (hide-hole (name a_1 (nt a))) (mismatch-name b_!_1 (cross b-b)))))))) - (run-test/cmp 'split-underscore1 (split-underscore 'a_1) 'a eq?) - (run-test/cmp 'split-underscore2 (split-underscore 'a_!_1) 'a eq?) - (run-test/cmp 'split-underscore3 - (with-handlers ([exn:fail? (λ (e) (cadr (regexp-match #rx"^([^:]+):" (exn-message e))))]) - (split-underscore 'a_b_1)) - "compile-pattern" - equal?) - - (test-ellipsis-binding '((number_1 number_2) ...) '() '((1 2))) - (test-ellipsis-binding '((name x number_1) ...) '() '(1 2)) - (test-ellipsis-binding '(((number_1 ...) (number_2 ...)) ...) '() '(((1) (2)))) - (test-ellipsis-binding '(number ... variable) '() '(1 x)) - (test-ellipsis-binding '((in-hole H_1 number_1) ...) '((H hole)) '(1 2)) + (test-ellipsis-binding '(list (repeat (list (name number_1 number) (name number_2 number)) #f #f)) '() '((1 2))) + (test-ellipsis-binding '(list (repeat (name x (name number_1 number)) #f #f)) '() '(1 2)) + (test-ellipsis-binding '(list (repeat (list (list (repeat (name number_1 number) #f #f)) + (list (repeat (name number_2 number) #f #f))) + #f + #f)) + '() + '(((1) (2)))) + (test-ellipsis-binding '(list (repeat number #f #f) variable) '() '(1 x)) + (test-ellipsis-binding '(list (repeat (in-hole (name H_1 (nt H)) (name number_1 number)) #f #f)) '((H hole)) '(1 2)) (cond [(= failures 0) (printf "matcher-test.rkt: all ~a tests passed.\n" test-count)] [else - (printf "matcher-test.rkt: ~a test~a failed.\n" - failures - (if (= failures 1) - "" - "s"))])) + (eprintf "matcher-test.rkt: ~a test~a failed.\n" + failures + (if (= failures 1) + "" + "s"))]))) - ;; mk-hasheq : (listof (cons sym any)) -> hash-table + ;; mk-hasheq : (listof (cons sym any)) -> hash ;; builds a hash table that has the bindings in assoc-list (define (mk-hasheq assoc-list) - (let ([ht (make-hash-table)]) + (let ([ht (make-hash)]) (for-each (lambda (a) - (hash-table-put! ht (car a) (cdr a))) + (hash-set! ht (car a) (cdr a))) assoc-list) ht)) ;; test-empty : sexp[pattern] sexp[term] answer -> void ;; returns #t if pat matching exp with the empty language produces ans. - (define (test-empty pat exp ans) + (define-syntax (test-empty stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([line (syntax-line stx)]) + #'(test-empty/proc line . args))])) + + (define (test-empty/proc line pat exp ans) (run-match-test + line `(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used '() '()) ',pat #t) ',exp) (match-pattern (compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t) @@ -688,9 +781,10 @@ ;; test-lang : sexp[pattern] sexp[term] answer (list/c nt) -> void ;; returns #t if pat matching exp with the language defined by the given nts - (define (test-lang pat exp ans nts) + (define (test-lang line pat exp ans nts) (let ([nt-map (make-nt-map nts)]) (run-match-test + line `(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used ',nts ',nt-map) ',pat #t) ',exp) (match-pattern (compile-pattern (compile-language 'pict-stuff-not-used nts nt-map) pat #t) @@ -700,50 +794,58 @@ (define xab-lang #f) ;; test-xab : sexp[pattern] sexp[term] answer -> void ;; returns #t if pat matching exp with a simple language produces ans. - (define (test-xab pat exp ans) + + (define-syntax (test-xab stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([line (syntax-line stx)]) + #'(test-xab/proc line . args))])) + + (define (test-xab/proc line pat exp ans) (unless xab-lang (let ([nts (list (make-nt 'exp - (list (make-rhs '(+ exp exp)) + (list (make-rhs '(list + (nt exp) (nt exp))) (make-rhs 'number))) (make-nt 'ctxt - (list (make-rhs '(+ ctxt exp)) - (make-rhs '(+ exp ctxt)) + (list (make-rhs '(list + (nt ctxt) (nt exp))) + (make-rhs '(list + (nt exp) (nt ctxt))) (make-rhs 'hole))) (make-nt 'ec-one - (list (make-rhs '(+ (hole xx) exp)) - (make-rhs '(+ exp (hole xx))))) + (list (make-rhs '(list + hole (nt exp))) + (make-rhs '(list + (nt exp) hole)))) - (make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any))))) + (make-nt 'same-in-nt (list (make-rhs '(list (name x any) (name x any))))) - (make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...)) + (make-nt 'forever-list (list (make-rhs '(list (nt forever-list) (repeat (nt forever-list) #f #f))) (make-rhs 'x))) (make-nt 'lsts - (list (make-rhs '()) - (make-rhs '(x)) + (list (make-rhs '(list)) + (make-rhs '(list x)) (make-rhs 'x) (make-rhs '#f))) (make-nt 'split-out - (list (make-rhs 'split-out2))) + (list (make-rhs '(nt split-out2)))) (make-nt 'split-out2 (list (make-rhs 'number))) (make-nt 'simple (list (make-rhs 'simple-rhs))) (make-nt 'nesting-names - (list (make-rhs '(a (name x nesting-names))) + (list (make-rhs '(list a (name x (nt nesting-names)))) (make-rhs 'b))) (make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned))) - (make-nt 'underscore (list (make-rhs 'exp_1))) + (make-nt 'underscore (list (make-rhs '(name exp_1 (nt exp))))) )]) (set! xab-lang (compile-language 'pict-stuff-not-used nts (map (λ (x) (list (nt-name x))) nts))))) (run-match-test + line `(match-pattern (compile-pattern xab-lang ',pat #t) ',exp) (match-pattern (compile-pattern xab-lang pat #t) exp) ans)) @@ -751,7 +853,7 @@ (define ab-lang #f) ;; test-xab : sexp[pattern] sexp[term] answer -> void ;; returns #t if pat matching exp with a simple language produces ans. - (define (test-ab pat exp ans) + (define (test-ab line pat exp ans) (unless ab-lang (set! ab-lang (compile-language @@ -762,76 +864,94 @@ (list (make-rhs 'b)))) '((aa) (bb))))) (run-match-test + line `(match-pattern (compile-pattern ab-lang ',pat #t) ',exp) (match-pattern (compile-pattern ab-lang pat #t) exp) ans)) ;; test-ellipses : sexp sexp -> void - (define (test-ellipses pat expected) + (define-syntax (test-ellipses stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([line (syntax-line stx)]) + #'(test-ellipses/proc line . args))])) + + ;; pats : (listof pat) + (define (test-ellipses/proc line pats expected) (run-test - `(rewrite-ellipses test-suite:non-underscore-binder? ',pat (lambda (x) (values x #f))) - (let-values ([(compiled-pattern has-hole?) (rewrite-ellipses test-suite:non-underscore-binder? pat (lambda (x) (values x #f)))]) + line + `(rewrite-ellipses ',pats (lambda (x) (values x #f))) + (let-values ([(compiled-pattern has-hole?) (rewrite-ellipses pats (lambda (x) (values x #f)))]) (cons compiled-pattern has-hole?)) (cons expected #f))) - (define (test-suite:non-underscore-binder? x) - (memq x '(number any variable string))) - ;; test-ellipsis-binding: sexp sexp sexp -> boolean ;; Checks that `extract-empty-bindings' produces bindings in the same order ;; as the matcher, as required by `collapse-single-multiples' - (define (test-ellipsis-binding pat nts/sexp exp) + (define-syntax (test-ellipsis-binding stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([line (syntax-line stx)]) + #'(test-ellipsis-binding/proc line . args))])) + + (define (test-ellipsis-binding/proc line pat nts/sexp exp) (define (binding-names bindings) (map (λ (b) (cond [(bind? b) (bind-name b)] [(mismatch-bind? b) (mismatch-bind-name b)])) bindings)) (run-test + line `(test-ellipsis-binding ,pat) - (binding-names - (bindings-table-unchecked - (mtch-bindings - (car - ((compiled-pattern-cp - (let ([nts (map (λ (nt-def) (nt (car nt-def) (map rhs (cdr nt-def)))) nts/sexp)]) - (compile-pattern (compile-language 'pict-stuff-not-used nts (make-nt-map nts)) pat #t))) - exp - #t))))) - (binding-names (extract-empty-bindings test-suite:non-underscore-binder? pat)))) + (let ([mtch ((compiled-pattern-cp + (let ([nts (map (λ (nt-def) (nt (car nt-def) (map rhs (cdr nt-def)))) nts/sexp)]) + (compile-pattern (compile-language 'pict-stuff-not-used nts (make-nt-map nts)) pat #t))) + exp + #t)]) + (if mtch + (binding-names + (bindings-table-unchecked + (mtch-bindings + (car mtch)))) + 'failed-to-match)) + (binding-names (extract-empty-bindings pat)))) ;; run-test/cmp : sexp any any (any any -> boolean) ;; compares ans with expected. If failure, ;; prints info about the test and increments failures (define failures 0) (define test-count 0) - (define (run-test/cmp symbolic ans expected cmp?) + (define (run-test/cmp line symbolic ans expected cmp?) (set! test-count (+ test-count 1)) (cond [(cmp? ans expected) - '(printf "passed: ~s\n" symbolic)] + '(printf "passed: line ~a\n" line)] [else (set! failures (+ failures 1)) - (fprintf (current-error-port) - " test: ~s\nexpected: ~e\n got: ~e\n" - symbolic expected ans)])) + (eprintf " test on line ~a\n input: ~s\nexpected: ~s\n got: ~s\n" + line symbolic expected ans)])) - (define (run-test symbolic ans expected) (run-test/cmp symbolic ans expected equal/bindings?)) + (define (run-test line symbolic ans expected) (run-test/cmp line symbolic ans expected equal/bindings?)) ;; run-match-test : sexp got expected ;; expects both ans and expected to be lists or both to be #f and ;; compares them using a set-like equality if they are lists - (define (run-match-test symbolic ans expected) - (run-test/cmp - symbolic ans expected - (λ (xs ys) - (cond - [(and (not xs) (not ys)) #t] - [(and (list? xs) - (list? ys)) - (and (andmap (λ (x) (memf (λ (y) (equal/bindings? x y)) ys)) xs) - (andmap (λ (y) (memf (λ (x) (equal/bindings? x y)) xs)) ys) - (= (length xs) (length ys)))] - [else #f])))) + (define (run-match-test line symbolic ans expected) + (with-handlers ((exn:fail? (λ (x) + (eprintf "exception raised while running test on line ~a\n" line) + (raise x)))) + (run-test/cmp + line + symbolic ans expected + (λ (xs ys) + (cond + [(and (not xs) (not ys)) #t] + [(and (list? xs) + (list? ys)) + (and (andmap (λ (x) (memf (λ (y) (equal/bindings? x y)) ys)) xs) + (andmap (λ (y) (memf (λ (x) (equal/bindings? x y)) xs)) ys) + (= (length xs) (length ys)))] + [else #f]))))) (define (build-context c) (let loop ([c c]) @@ -844,4 +964,4 @@ (build-flat-context c)] [else (error 'build-context "unknown ~s" c)]))) - (test)) + (test) diff --git a/collects/redex/tests/rewrite-side-condition-test.rkt b/collects/redex/tests/rewrite-side-condition-test.rkt new file mode 100644 index 0000000000..44722f6c13 --- /dev/null +++ b/collects/redex/tests/rewrite-side-condition-test.rkt @@ -0,0 +1,134 @@ +#lang racket/base +(require (for-syntax "../private/rewrite-side-conditions.rkt" + racket/base) + "../private/term.rkt" ;; to get bindings for 'in-hole' etc + rackunit) + +(define-syntax (rsc stx) + (syntax-case stx () + [(_ pat (nts ...) bind-names?) + (with-syntax ([(pat (vars ...) (vars/ellipses ...)) + (rewrite-side-conditions/check-errs + (syntax->datum #'(nts ...)) + 'rsc + (syntax-e #'bind-names?) + #'pat)]) + #'(list `pat + `(vars ...) + `(vars/ellipses ...)))])) + +(check-equal? (rsc 1 () #t) `(1 () ())) +(check-equal? (rsc (1) () #t) `((list 1) () ())) +(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 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 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) #f) `((nt x) () ())) +(check-equal? (rsc x_1 (x) #t) `((name x_1 (nt x)) (x_1) (x_1))) +(check-equal? (rsc x_1 (x) #f) `((name x_1 (nt x)) (x_1) (x_1))) +(check-equal? (rsc any (x) #t) `((name any any) (any) (any))) +(check-equal? (rsc any (x) #f) `(any () ())) +(check-equal? (rsc any_1 (x) #t) `((name any_1 any) (any_1) (any_1))) +(check-equal? (rsc any_1 (x) #f) `((name any_1 any) (any_1) (any_1))) +(check-equal? (rsc ((x ...) ...) (x) #t) + `((list (repeat (list (repeat (name x (nt x)) #f #f)) #f #f)) + (x) + (((x ...) ...)))) + +(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)) + () + ())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; test the normalization of the ellipses underscores +;; +(check-equal? (car (rsc (x_1 ..._1 x_2 ..._2 x_2 ..._1) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_2 (nt x)) ..._1 #f) + (repeat (name x_2 (nt x)) ..._1 #f))) +(check-equal? (car (rsc ((x_1 ..._1 x_1 ..._2) (x_2 ..._1 x_2 ..._2) x_3 ..._2) (x) #t)) + '(list (list (repeat (name x_1 (nt x)) ..._2 #f) + (repeat (name x_1 (nt x)) ..._2 #f)) + (list (repeat (name x_2 (nt x)) ..._2 #f) + (repeat (name x_2 (nt x)) ..._2 #f)) + (repeat (name x_3 (nt x)) ..._2 #f))) +(check-equal? (car (rsc (x_1 ..._1 x ..._2 x_1 ..._2) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._2 #f) + (repeat (name x (nt x)) ..._2 #f) + (repeat (name x_1 (nt x)) ..._2 #f))) + + +(check-equal? (car (rsc (x_1 ..._1 x_2 ..._2 (x_1 x_2) ..._3) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._3 #f) + (repeat (name x_2 (nt x)) ..._3 #f) + (repeat (list (name x_1 (nt x)) (name x_2 (nt x))) ..._3 #f))) +(check-equal? (car (rsc ((x_1 ..._1) ..._2 x_2 ..._3 (x_1 ..._4 x_2) ..._5) (x) #t)) + '(list (repeat (list (repeat (name x_1 (nt x)) ..._4 #f)) ..._5 #f) + (repeat (name x_2 (nt x)) ..._5 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._4 #f) + (name x_2 (nt x))) + ..._5 + #f))) +(check-equal? (car (rsc ((x_1 ..._1) ..._2 (x_1 ..._3) ..._4 (x_1 ..._5) ..._6) (x) #t)) + '(list (repeat (list (repeat (name x_1 (nt x)) ..._5 #f)) ..._6 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._5 #f)) ..._6 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._5 #f)) ..._6 #f))) + +(check-equal? (car (rsc (x_1 ..._1 x_1 ..._2 x_2 ..._1 x_2 ..._4 x_2 ..._3) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._3 #f) + (repeat (name x_1 (nt x)) ..._3 #f) + (repeat (name x_2 (nt x)) ..._3 #f) + (repeat (name x_2 (nt x)) ..._3 #f) + (repeat (name x_2 (nt x)) ..._3 #f))) + +(check-equal? (car (rsc (x_1 ... x_1 ..._!_1 x_1 ..._1) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_1 (nt x)) ..._1 #f))) + +(check-equal? (car (rsc (x_1 ... x_1 ..._!_1 x_1 ..._1 x_2 ..._!_1) (x) #t)) + '(list (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_1 (nt x)) ..._1 ..._!_1) + (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_2 (nt x)) #f ..._!_1))) + +(check-equal? (car (rsc ((3 ..._1) ..._2 (4 ..._1) ..._3) (x) #t)) + '(list (repeat (list (repeat 3 ..._1 #f)) ..._3 #f) + (repeat (list (repeat 4 ..._1 #f)) ..._3 #f))) + +(check-equal? (car (rsc (x ..._1 x ..._2 + variable ..._2 variable ..._3 variable_1 ..._3 variable_1 ..._4) + (x) #t)) + '(list (repeat (name x (nt x)) ..._4 #f) + (repeat (name x (nt x)) ..._4 #f) + (repeat (name variable variable) ..._4 #f) + (repeat (name variable variable) ..._4 #f) + (repeat (name variable_1 variable) ..._4 #f) + (repeat (name variable_1 variable) ..._4 #f))) + +(check-equal? (car (rsc (z_1 ... z_2 ..._!_1 (z_1 z_2) ...) (z) #t)) + '(list (repeat (name z_1 (nt z)) ..._r3 #f) + (repeat (name z_2 (nt z)) ..._r3 #f) + (repeat (list (name z_1 (nt z)) + (name z_2 (nt z))) + ..._r3 + #f))) + +(check-equal? (car (rsc (z_1 ... z_2 ..._!_1 z_3 ..._!_1 (z_1 z_2) ...) (z) #t)) + '(list (repeat (name z_1 (nt z)) ..._r4 #f) + (repeat (name z_2 (nt z)) ..._r4 ..._!_1) + (repeat (name z_3 (nt z)) #f ..._!_1) + (repeat (list (name z_1 (nt z)) + (name z_2 (nt z))) + ..._r4 + #f))) + +;; +;; test the normalization of the ellipses underscores +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 6b3c9e3d29..08f03dc908 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -43,14 +43,11 @@ [(exn:fail:redex:test _ _ (? exn:fail:contract:blame? e) _) e] [x x])))])) -(define find-base-cases/unparsed - (compose find-base-cases parse-language)) - (let () (define-language lc (e x (e e) (λ (x) e)) (x variable)) - (let ([bc (find-base-cases/unparsed lc)]) + (let ([bc (find-base-cases lc)]) (test (to-table (base-cases-non-cross bc)) '((e . (1 2 2)) (x . (0)))) (test (to-table (base-cases-cross bc)) @@ -59,7 +56,7 @@ (let () (define-language lang (e (e e))) - (let ([bc (find-base-cases/unparsed lang)]) + (let ([bc (find-base-cases lang)]) (test (to-table (base-cases-non-cross bc)) '((e . (inf)))) (test (to-table (base-cases-cross bc)) '((e-e . (0 inf inf)))))) @@ -67,11 +64,11 @@ (define-language lang (a 1 2 3) (b a (a_1 b_!_1))) - (let ([bc (find-base-cases/unparsed lang)]) + (let ([bc (find-base-cases lang)]) (test (to-table (base-cases-non-cross bc)) '((a . (0 0 0)) (b . (1 2)))) (test (to-table (base-cases-cross bc)) - '((a-a . (0)) (a-b . (1)) (b-b . (0)))))) + '((a-a . (0)) (a-b . (1 2 2)) (b-b . (0 1)))))) (let () (define-language lc @@ -82,7 +79,7 @@ (v (λ (x) e) number) (x variable)) - (let ([bc (find-base-cases/unparsed lc)]) + (let ([bc (find-base-cases lc)]) (test (to-table (base-cases-non-cross bc)) '((e . (2 2 1 1)) (v . (2 0)) (x . (0)))) (test (to-table (base-cases-cross bc)) @@ -96,7 +93,7 @@ (name x 1) (name y 1)) (y y)) - (test (hash-ref (base-cases-non-cross (find-base-cases/unparsed L)) 'x) + (test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x) '(0 0 0 0))) (define (make-random . nums) @@ -325,7 +322,7 @@ (test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(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 \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\) in 42") + #rx"generate-term: unable to generate pattern .* in 42") (test (raised-exn-msg exn:fail:redex:generation-failure? (parameterize ([generation-decisions @@ -340,7 +337,9 @@ #rx"generate-term: unable to generate pattern variable-not-otherwise-mentioned in 1") (test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) (test (generate-term/decisions - lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + lang + ((0 ..._!_1) ... (1 ..._!_1) ...) + 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) '((0 0 0) (0 0 0 0) (1 1 1))) @@ -412,7 +411,7 @@ (test (generate-term lang b 5) 43) (test (generate-term lang (side-condition a (odd? (term a))) 5) 43) (test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang c 5)) - #px"unable to generate pattern \\(side-condition a\\_1 #\\)") + #rx"unable to generate pattern") (test (let/ec k (generate-term lang (number_1 (side-condition 7 (k (term number_1)))) 5)) 'number_1) @@ -603,7 +602,7 @@ (decisions #:nt (patterns first))) 47) - (test (hash-ref (base-cases-non-cross (find-base-cases/unparsed name-collision)) 'e-e) + (test (hash-ref (base-cases-non-cross (find-base-cases name-collision)) 'e-e) '(0))) (let () @@ -1217,109 +1216,66 @@ (check-metafunction n (λ (_) #t) #:retries 42)) #rx"check-metafunction: unable .* in 42")) -;; parse/unparse-pattern -(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) - (define-language lang (x variable)) - (let ([pattern '((x_1 number) ... 3)]) - (test-match (list - (struct ellipsis - ('... - (list (struct binder ('x_1)) (struct binder ('number))) - _ - (list (struct binder ('number)) (struct binder ('x_1))))) - 3) - (parse-pattern pattern lang 'top-level)) - (test (unparse-pattern (parse-pattern pattern lang 'top-level)) pattern)) - (let ([pattern '((x_1 ..._1 x_2) ..._!_1)]) - (test-match (struct ellipsis - ((struct mismatch (i_1 '..._!_1)) - (list - (struct ellipsis - ('..._1 - (struct binder ('x_1)) - (struct class ('..._1)) - (list (struct binder ('x_1))))) - (struct binder ('x_2))) - _ - (list (struct binder ('x_2)) '..._1 (struct class ('..._1)) (struct binder ('x_1))))) - (car (parse-pattern pattern lang 'grammar))) - (test (unparse-pattern (parse-pattern pattern lang 'grammar)) pattern)) - (let ([pattern '((name x_1 x_!_2) ...)]) - (test-match (struct ellipsis - ('... `(name x_1 ,(struct mismatch (i_2 'x_!_2))) _ - (list (struct binder ('x_1)) (struct mismatch (i_2 'x_!_2))))) - (car (parse-pattern pattern lang 'grammar))) - (test (unparse-pattern (parse-pattern pattern lang 'grammar)) pattern)) - (let ([pattern '((x ...) ..._1)]) - (test-match (struct ellipsis - ('..._1 - (list - (struct ellipsis - ('... - (struct binder ('x)) - (struct class (c_1)) - (list (struct binder ('x)))))) - _ - (list (struct class (c_1)) (struct binder ('x))))) - (car (parse-pattern pattern lang 'top-level))) - (test (unparse-pattern (parse-pattern pattern lang 'top-level)) pattern)) - (let ([pattern '((variable_1 ..._!_1) ...)]) - (test-match (struct ellipsis - ('... - (list - (struct ellipsis - ((struct mismatch (i_1 '..._!_1)) - (struct binder ('variable_1)) - (struct class (c_1)) - (list (struct binder ('variable_1)))))) - _ - (list (struct class (c_1)) (struct mismatch (i_1 '..._!_1)) (struct binder ('variable_1))))) - (car (parse-pattern pattern lang 'grammar))) - (test (unparse-pattern (parse-pattern pattern lang 'grammar)) pattern)) - (test (parse-pattern '(cross x) lang 'grammar) '(cross x-x)) - (test (parse-pattern '(cross x) lang 'cross) '(cross x)) - (test (parse-pattern 'x lang 'grammar) 'x) - (test (parse-pattern 'variable lang 'grammar) 'variable)) - (let () (define-language lang (x variable)) (define-syntax test-class-reassignments (syntax-rules () [(_ pattern expected) - (test (to-table (class-reassignments (parse-pattern pattern lang 'top-level))) + (test (to-table (class-reassignments pattern)) expected)])) (test-class-reassignments - '(x_1 ..._1 x_2 ..._2 x_2 ..._1) + '(list (repeat (name x_1 (nt x)) ..._1 #f) (repeat (name x_2 (nt x)) ..._2 #f) (repeat (name x_2 (nt x)) ..._1 #f)) '((..._2 . ..._1))) (test-class-reassignments - '((x_1 ..._1 x_1 ..._2) (x_2 ..._1 x_2 ..._2) x_3 ..._2) + '(list (list (repeat (name x_1 (nt x)) ..._1 #f) (repeat (name x_1 (nt x)) ..._2 #f)) + (list (repeat (name x_2 (nt x)) ..._1 #f) (repeat (name x_2 (nt x)) ..._2 #f)) + (repeat (name x_3 (nt x)) ..._2 #f)) '((..._1 . ..._2) (..._2 . ..._2))) (test-class-reassignments - '(x_1 ..._1 x ..._2 x_1 ..._2) + '(list (repeat (name x_1 (nt x)) ..._1 #f) (repeat (name x (nt x)) ..._2 #f) (repeat (name x_1 (nt x)) ..._2 #f)) '((..._1 . ..._2))) (test-class-reassignments - '(x_1 ..._1 x_2 ..._2 (x_1 x_2) ..._3) + '(list (repeat (name x_1 (nt x)) ..._1 #f) (repeat (name x_2 (nt x)) ..._2 #f) (repeat (list (name x_1 (nt x)) (name x_2 (nt x))) ..._3 #f)) '((..._1 . ..._3) (..._2 . ..._3))) (test-class-reassignments - '((x_1 ..._1) ..._2 x_2 ..._3 (x_1 ..._4 x_2) ..._5) + '(list (repeat (list (repeat (name x_1 (nt x)) ..._1 #f)) ..._2 #f) + (repeat (name x_2 (nt x)) ..._3 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._4 #f) + (name x_2 (nt x))) + ..._5 + #f)) '((..._1 . ..._4) (..._2 . ..._5) (..._3 . ..._5))) (test-class-reassignments - '((x_1 ..._1) ..._2 (x_1 ..._3) ..._4 (x_1 ..._5) ..._6) + '(list (repeat (list (repeat (name x_1 (nt x)) ..._1 #f)) ..._2 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._3 #f)) ..._4 #f) + (repeat (list (repeat (name x_1 (nt x)) ..._5 #f)) ..._6 #f)) '((..._1 . ..._5) (..._2 . ..._6) (..._3 . ..._5) (..._4 . ..._6))) (test-class-reassignments - '(x_1 ..._1 x_1 ..._2 x_2 ..._1 x_2 ..._4 x_2 ..._3) + '(list (repeat (name x_1 (nt x)) ..._1 #f) + (repeat (name x_1 (nt x)) ..._2 #f) + (repeat (name x_2 (nt x)) ..._1 #f) + (repeat (name x_2 (nt x)) ..._4 #f) + (repeat (name x_2 (nt x)) ..._3 #f)) '((..._1 . ..._3) (..._2 . ..._3) (..._4 . ..._3))) (test (hash-map - (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1) lang 'top-level)) + (class-reassignments '(list (repeat (name x_1 (nt x)) #f #f) + (repeat (name x_1 (nt x)) ..._!_1 #t) + (repeat (name x_1 (nt x)) ..._1 #f))) (λ (_ cls) cls)) - '(..._1 ..._1)) + '(..._1 ..._1)) (test-class-reassignments - '((3 ..._1) ..._2 (4 ..._1) ..._3) + '(list (repeat (list (repeat 3 ..._1 #f)) ..._2 #f) + (repeat (list (repeat 4 ..._1 #f)) ..._3 #f)) '((..._2 . ..._3))) (test-class-reassignments - '(x ..._1 x ..._2 variable ..._2 variable ..._3 variable_1 ..._3 variable_1 ..._4) + '(list (repeat (name x (nt x)) ..._1 #f) + (repeat (name x (nt x)) ..._2 #f) + (repeat (name variable variable) ..._2 #f) + (repeat (name variable variable) ..._3 #f) + (repeat (name variable_1 variable) ..._3 #f) + (repeat (name variable_1 variable) ..._4 #f)) '((..._1 . ..._4) (..._2 . ..._4) (..._3 . ..._4)))) ;; redex-test-seed diff --git a/collects/redex/tests/run-tests.rkt b/collects/redex/tests/run-tests.rkt index 0368d5c510..3b1ada02e0 100644 --- a/collects/redex/tests/run-tests.rkt +++ b/collects/redex/tests/run-tests.rkt @@ -18,6 +18,7 @@ (append '("lw-test.rkt" "matcher-test.rkt" + "rewrite-side-condition-test.rkt" "tl-test.rkt" "term-test.rkt" "rg-test.rkt" @@ -34,6 +35,7 @@ '("../examples/cbn-letrec.rkt" "../examples/stlc.rkt" "../examples/pi-calculus.rkt" + "../examples/list-machine/test.rkt" ("../examples/beginner.rkt" main) "../examples/racket-machine/reduction-test.rkt" "../examples/racket-machine/verification-test.rkt" diff --git a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd index 284564f050..171617ba00 100644 --- a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd +++ b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd @@ -171,8 +171,8 @@ (let () (define-judgment-form syn-err-lang #:mode (pat-depth I O) - [(pat-depth (binder2 ellipsis) ()) - (pat-depth () binder1)]) + [(pat-depth (binder1 ellipsis) ()) + (pat-depth () binder2)]) (void))) (#rx"too many ellipses" ([premise (no-ellipsis any)]) diff --git a/collects/redex/tests/syn-err-tests/reduction-relation-definition.rktd b/collects/redex/tests/syn-err-tests/reduction-relation-definition.rktd index 5793d437ea..d9be2b2519 100644 --- a/collects/redex/tests/syn-err-tests/reduction-relation-definition.rktd +++ b/collects/redex/tests/syn-err-tests/reduction-relation-definition.rktd @@ -32,7 +32,7 @@ (#rx"different depths" - ([binder2 number_1] [binder1 number_1]) ([ellipsis ...]) + ([binder1 number_1] [binder2 number_1]) ([ellipsis ...]) (reduction-relation syn-err-lang (--> binder1 diff --git a/collects/redex/tests/test-util.rkt b/collects/redex/tests/test-util.rkt index bfe6f7db42..d9bcbffc12 100644 --- a/collects/redex/tests/test-util.rkt +++ b/collects/redex/tests/test-util.rkt @@ -29,7 +29,7 @@ (define-syntax (test stx) (syntax-case stx () [(_ expected got) - (with-syntax ([line (syntax-line (syntax got))] + (with-syntax ([line (syntax-line stx)] [fn (if (path? (syntax-source (syntax got))) (path->string (syntax-source (syntax got))) "")]) @@ -142,7 +142,7 @@ (matches? got expected)) (set! failures (+ 1 failures)) (fprintf (current-error-port) - "test/proc: file ~a line ~a:\n got ~s\nexpected ~s\n\n" + "test: file ~a line ~a:\n got ~s\nexpected ~s\n\n" filename line got diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index a8b5fc57c3..4fa70d918b 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -2533,7 +2533,7 @@ ; test that names are properly bound for side-conditions in shortcuts (let* ([lhs ((rewrite-proc-lhs (first (reduction-relation-make-procs r))) grammar)] [proc (third lhs)] - [name (cadadr lhs)] + [name (cadar (cddadr lhs))] [bind (λ (n) (make-bindings (list (make-bind name n))))]) (test (and (proc (bind 4)) (not (proc (bind 3)))) #t)) @@ -2551,7 +2551,7 @@ ; test shortcut in terms of shortcut (test (match ((rewrite-proc-lhs (third (reduction-relation-make-procs r))) grammar) - [`(((side-condition 5 ,(? procedure?) ,_) 2) 1) #t] + [`(list (list (side-condition 5 ,(? procedure?) ,_) 2) 1) #t] [else #f]) #t))