diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss deleted file mode 100644 index e5f73397d9..0000000000 --- a/collects/redex/private/bitmap-test.ss +++ /dev/null @@ -1,167 +0,0 @@ -#lang scheme -(require "bitmap-test-util.ss" - "../main.ss") - -;; tests: -;; - language, -;; - multi-line non-terminals, single-line non-terminals -(define-language lang - (e (e e) - x - (λ (x) e) - number) - (v number (λ (x) e)) - ((x y) variable-not-otherwise-mentioned)) - -(test (render-language lang) "language.png") - -(test (render-language lang #:nts '(e v)) "language-nox.png") - -(define-extended-language lang++ lang - (e .... number (+ e e)) - (v .... number)) - -(test (render-language lang++) "extended-language.png") - -(define red - (reduction-relation - lang - (--> ((λ (x) e) v) (S x v e)))) - -;; tests: reduction-relation -(test (render-reduction-relation red) - "reduction-relation.png") - -(test (render-reduction-relation - (extend-reduction-relation red lang (--> 1 2))) - "extended-reduction-relation.png") - -;; this test should fail because it gets the order wrong -;; for the where/side-conditions -(define red2 - (reduction-relation - lang - (--> (number_a number_b number_c number_d) - any_z - (where (any_x any_y) (number_a number_b)) - (side-condition (= (term number_c) 5)) - (where any_z any_x) - (side-condition (= (term number_d) 5))))) - -(test (render-reduction-relation red2) - "red2.png") - -(define-metafunction lang - [(S x v e) e]) - -(test (render-metafunction S) - "metafunction.png") - -(define-metafunction lang - [(T x y) - 1 - (side-condition (not (eq? (term x) (term y))))] - [(T x x) - (any_1 any_2) - (where any_1 2) - (where any_2 2)]) - -;; in this test, the metafunction has 2 clauses -;; with a side-condition on the first clause -;; and a 'where' in the second clause -(test (render-metafunction T) "metafunction-T.png") - -;; in this test, teh `x' is italic and the 'z' is sf, since 'x' is in the grammar, and 'z' is not. -(test (render-lw - lang - (to-lw ((λ (x) (x x)) - (λ (z) (z z))))) - "lw.png") - -(define-metafunction lang - [(TL 1) (a - ,(term-let ((x (term 1))) - (term x)) - below-only)] - [(TL 2) (a - ,(term-let ((x (term 1))) - (term x)) beside - below)]) - -;; this tests that term-let is sucked away properly -;; when the metafunction is rendered -(test (render-metafunction TL) "metafunction-TL.png") - -(define-metafunction lang - [(Name (name x-arg arg)) - ,(term-let ((x-term-let (term 1))) - (term (x-where x-term-let))) - (where x-where 2)]) - -;; this tests that the three variable bindings -;; (x-arg, x-term-let, and x-where) -;; all show up in the output. -(test (render-metafunction Name) "metafunction-Name.png") - -;; same as previous, but with vertical organization of the bindings -(test (parameterize ([metafunction-pict-style 'up-down/vertical-side-conditions]) - (render-metafunction Name)) - "metafunction-Name-vertical.png") - -;; makes sure that there is no overlap inside or across metafunction calls -;; or when there are unquotes involved -(define-metafunction lang - [(multi-arg a - b - c) - ((multi-arg a - b - c) - (multi-arg a - b - c))] - [(multi-arg unquote-test) - (,@(term (multi-arg with-unquote)) - ,@(term (multi-arg with-unquote)) - ,@(term (multi-arg with-unquote)))]) - -(test (render-metafunction multi-arg) "metafunction-multi-arg.png") - -;; makes sure that the LHS and RHS of metafunctions are appropriately -;; rewritten - -(define-metafunction lang - subst : e x e -> e - [(subst x x e) e] - [(subst number x e) number] - [(subst x_1 x_2 e) x_1] - [(subst (e_1 e_2) x e) - ((subst e_1 x e) (subst e_2 x e))] - [(subst (λ (x) e_b) x e) - (λ (x) e)] - [(subst (λ (x_f) e_f) x_a e_a) - (λ (x_f) (subst e_f x_a e_a))]) - -(define (subst-rw lws) - (list "" - (list-ref lws 2) - "{" - (list-ref lws 3) - ":=" - (list-ref lws 4) - "}")) - -(test (with-compound-rewriter 'subst subst-rw - (render-metafunction subst)) - "metafunction-subst.png") - - -;; make sure two metafunctions simultaneously rewritten line up properly -(test (render-metafunctions S T TL) "metafunctions-multiple.png") - -;; Non-terminal superscripts -(test (render-lw lang (to-lw (x_^abcdef x_q^abcdef))) - "superscripts.png") - -(printf "bitmap-test.ss: ") -(done) diff --git a/collects/redex/private/bmps-macosx/extended-language.png b/collects/redex/private/bmps-macosx/extended-language.png deleted file mode 100644 index 448f4f9bfb..0000000000 Binary files a/collects/redex/private/bmps-macosx/extended-language.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/extended-reduction-relation.png b/collects/redex/private/bmps-macosx/extended-reduction-relation.png deleted file mode 100644 index 46e14cf703..0000000000 Binary files a/collects/redex/private/bmps-macosx/extended-reduction-relation.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/language-nox.png b/collects/redex/private/bmps-macosx/language-nox.png deleted file mode 100644 index 083d80cc66..0000000000 Binary files a/collects/redex/private/bmps-macosx/language-nox.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/language.png b/collects/redex/private/bmps-macosx/language.png deleted file mode 100644 index 1275c7b26c..0000000000 Binary files a/collects/redex/private/bmps-macosx/language.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/lw.png b/collects/redex/private/bmps-macosx/lw.png deleted file mode 100644 index 7a93ada00e..0000000000 Binary files a/collects/redex/private/bmps-macosx/lw.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-Name-vertical.png b/collects/redex/private/bmps-macosx/metafunction-Name-vertical.png deleted file mode 100644 index 631aa05f6d..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-Name-vertical.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-Name.png b/collects/redex/private/bmps-macosx/metafunction-Name.png deleted file mode 100644 index e4f7dc5331..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-Name.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-T.png b/collects/redex/private/bmps-macosx/metafunction-T.png deleted file mode 100644 index 23606d0bd5..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-T.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-TL.png b/collects/redex/private/bmps-macosx/metafunction-TL.png deleted file mode 100644 index 1b0410ede7..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-TL.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-multi-arg.png b/collects/redex/private/bmps-macosx/metafunction-multi-arg.png deleted file mode 100644 index 0ae325b3b0..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-multi-arg.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction-subst.png b/collects/redex/private/bmps-macosx/metafunction-subst.png deleted file mode 100644 index bf2dbc48f6..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction-subst.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunction.png b/collects/redex/private/bmps-macosx/metafunction.png deleted file mode 100644 index 5eb6cdbeff..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunction.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/metafunctions-multiple.png b/collects/redex/private/bmps-macosx/metafunctions-multiple.png deleted file mode 100644 index 84b93559ce..0000000000 Binary files a/collects/redex/private/bmps-macosx/metafunctions-multiple.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/red2.png b/collects/redex/private/bmps-macosx/red2.png deleted file mode 100644 index 6dfe8ab649..0000000000 Binary files a/collects/redex/private/bmps-macosx/red2.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/reduction-relation.png b/collects/redex/private/bmps-macosx/reduction-relation.png deleted file mode 100644 index 1da77851c2..0000000000 Binary files a/collects/redex/private/bmps-macosx/reduction-relation.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/superscripts.png b/collects/redex/private/bmps-macosx/superscripts.png deleted file mode 100644 index 69484218f2..0000000000 Binary files a/collects/redex/private/bmps-macosx/superscripts.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-extended-language.png b/collects/redex/private/bmps-macosx/unix-extended-language.png deleted file mode 100644 index 87e19556d4..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-extended-language.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png b/collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png deleted file mode 100644 index 68452ef4df..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-language-nox.png b/collects/redex/private/bmps-macosx/unix-language-nox.png deleted file mode 100644 index a05ce95394..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-language-nox.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-language.png b/collects/redex/private/bmps-macosx/unix-language.png deleted file mode 100644 index cb88a9a4d9..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-language.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-lw.png b/collects/redex/private/bmps-macosx/unix-lw.png deleted file mode 100644 index 708c9df4aa..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-lw.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png b/collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png deleted file mode 100644 index 9a89a3f870..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-Name.png b/collects/redex/private/bmps-macosx/unix-metafunction-Name.png deleted file mode 100644 index b299b86abd..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-Name.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-T.png b/collects/redex/private/bmps-macosx/unix-metafunction-T.png deleted file mode 100644 index 05edef4444..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-T.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-TL.png b/collects/redex/private/bmps-macosx/unix-metafunction-TL.png deleted file mode 100644 index 378e0fd05b..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-TL.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png b/collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png deleted file mode 100644 index 6753b06610..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-subst.png b/collects/redex/private/bmps-macosx/unix-metafunction-subst.png deleted file mode 100644 index 3f00d4671a..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction-subst.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunction.png b/collects/redex/private/bmps-macosx/unix-metafunction.png deleted file mode 100644 index b9d908c4ac..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunction.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png b/collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png deleted file mode 100644 index c7bb749a3a..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png and /dev/null differ diff --git a/collects/redex/private/bmps-macosx/unix-reduction-relation.png b/collects/redex/private/bmps-macosx/unix-reduction-relation.png deleted file mode 100644 index d2196e527c..0000000000 Binary files a/collects/redex/private/bmps-macosx/unix-reduction-relation.png and /dev/null differ diff --git a/collects/redex/private/color-test.ss b/collects/redex/private/color-test.ss deleted file mode 100644 index d13d212756..0000000000 --- a/collects/redex/private/color-test.ss +++ /dev/null @@ -1,69 +0,0 @@ -#| - -tests the color setting ability during a reduction sequence. - -In one window, you expect to see a red and a blue snip. as you reduce you expect to see a spectrum from blue to red - -In the other window, you expect to see the currently unreducted terms in green and all others white. - -|# - -#lang scheme/gui - -(require "../reduction-semantics.ss" - "../gui.ss") - -(reduction-steps-cutoff 1) - -(let () - - (define (get-range term-node) - (let loop ([node term-node]) - (let ([parents (term-node-parents node)]) - (cond - [(null? parents) (list node)] - [else (cons node (loop (car parents)))])))) - - (define (color-range-pred sexp term-node) - (let* ([parents (get-range term-node)] - [max-val (car (term-node-expr (car parents)))]) - (for-each - (λ (node) - (let ([val (car (term-node-expr node))]) - (term-node-set-color! node - (make-object color% - (floor (- 255 (* val (/ 255 max-val)))) - 0 - (floor (* val (/ 255 max-val))))))) - parents) - (term-node-color term-node))) - - (define-language empty-language) - - (traces - (reduction-relation - empty-language - (--> (number_1 word) - (,(+ (term number_1) 1) word) - inc)) - '(1 word) - #:pred color-range-pred)) - -(let () - (define-language empty-language) - - (define (last-color-pred sexp term-node) - (if (null? (term-node-children term-node)) - "green" - "white")) - - (traces (reduction-relation - empty-language - (--> (number_1 word) - (,(+ (term number_1) 1) word) - inc) - (--> (number_1 word) - (,(* (term number_1) 2) word) - dup)) - '(1 word) - #:pred last-color-pred)) diff --git a/collects/redex/private/config.ss b/collects/redex/private/config.ss deleted file mode 100644 index 721ab32da1..0000000000 --- a/collects/redex/private/config.ss +++ /dev/null @@ -1,5 +0,0 @@ -#lang scheme -(provide set-show-bitmaps? get-show-bitmaps?) -(define show-bitmaps? #t) -(define (set-show-bitmaps? sb?) (set! show-bitmaps? sb?)) -(define (get-show-bitmaps?) show-bitmaps?) \ No newline at end of file diff --git a/collects/redex/private/core-layout-test.ss b/collects/redex/private/core-layout-test.ss deleted file mode 100644 index b1edc2bc72..0000000000 --- a/collects/redex/private/core-layout-test.ss +++ /dev/null @@ -1,82 +0,0 @@ -#lang scheme/base - -(require "core-layout.ss" - "loc-wrapper.ss" - "lw-test-util.ss" - "test-util.ss" - (lib "struct.ss")) - -(require (lib "mrpict.ss" "texpict") - (lib "mred.ss" "mred") - (lib "class.ss")) -(dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))) - -(reset-count) - -(let ([content - (list (make-lw 'x 15 1 35 0 #f #f) - (make-lw (list - (make-lw "(" 15 0 35 1 #f #f) - (make-lw 'a 15 0 36 1 #f #f) - (make-lw 'b 16 0 36 1 #f #f) - (make-lw ")" 16 0 37 1 #f #f)) - 15 1 35 3 #f #f))]) - (test (find-enclosing-loc-wrapper content) - (build-lw content - 15 1 35 3))) - -(define (replace-pict-tokens x) - (let loop ([x x]) - (cond - [(line? x) (make-line (line-n x) (loop (line-tokens x)))] - [(pair? x) (cons (loop (car x)) - (loop (cdr x)))] - [(pict-token? x) - (copy-struct pict-token x [pict-token-pict 'pict])] - [else x]))) - -(test (replace-pict-tokens - (build-lines - '() - (normalize-lw - (to-lw - ,(term - (a b c)))))) - (list (make-line 0 - (list (make-spacer-token 0 2) - (make-string-token 2 1 "(" 'roman) - (make-string-token 3 1 "a" 'swiss) - (make-string-token 4 1 " " 'roman) - (make-string-token 5 1 "b" 'swiss) - (make-string-token 6 1 " " 'roman) - (make-string-token 7 1 "c" 'swiss) - (make-string-token 8 1 ")" 'roman))) - (make-line 0 - (list (make-string-token 0 0 "" 'roman) - (make-pict-token 0 1 'pict) - (make-pict-token 1 0 'pict))))) - -(test (replace-pict-tokens - (build-lines - '() - (normalize-lw - (to-lw - ,(term - (a b - c)))))) - (list (make-line 1 - (list (make-spacer-token 0 5) - (make-string-token 5 1 "c" 'swiss) - (make-string-token 6 1 ")" 'roman))) - (make-line 0 - (list (make-spacer-token 0 2) - (make-string-token 2 1 "(" 'roman) - (make-string-token 3 1 "a" 'swiss) - (make-string-token 4 1 " " 'roman) - (make-string-token 5 1 "b" 'swiss))) - (make-line 0 - (list (make-string-token 0 0 "" 'roman) - (make-pict-token 0 1 'pict) - (make-pict-token 1 0 'pict))))) - -(print-tests-passed "core-layout.ss") diff --git a/collects/redex/private/hole-test.ss b/collects/redex/private/hole-test.ss deleted file mode 100644 index 7536526d5a..0000000000 --- a/collects/redex/private/hole-test.ss +++ /dev/null @@ -1,32 +0,0 @@ -#lang scheme -(require redex) - -(define-language tl-grammar - [v (cont (hide-hole E))] - [E hole - (v ... E)]) - -(define test1 - (reduction-relation - tl-grammar - [--> (in-hole E_1 (explode)) - (in-hole E_1 1)])) - -(test--> test1 - (term ((cont hole) (explode))) - (term ((cont hole) 1))) - -(define test2 - (reduction-relation - tl-grammar - [--> (in-hole E_1 (explode)) - (asplode E_1)])) - -(define-metafunction tl-grammar - asplode : E -> any - [(asplode ((cont hole) hole)) - okay]) - -(test--> test2 - (term ((cont hole) (explode))) - (term okay)) diff --git a/collects/redex/private/keyword-macros-test.ss b/collects/redex/private/keyword-macros-test.ss deleted file mode 100644 index ab3ddc8dbb..0000000000 --- a/collects/redex/private/keyword-macros-test.ss +++ /dev/null @@ -1,46 +0,0 @@ -#lang scheme - -(require "keyword-macros.ss" - "test-util.ss") - -(reset-count) - -(let* ([formals `((#:b . ,#'1) (#:c . ,#'2))] - [parse - (λ (actuals) - (map syntax-e - (parse-kw-args formals (cdr (syntax-e actuals)) actuals)))]) - (let-syntax ([msg-src - (syntax-rules () - [(_ expr) - (with-handlers ([exn:fail:syntax? - (λ (exn) - (values (exn-message exn) - (exn:fail:syntax-exprs exn)))]) - (begin expr (values 'no-msg 'no-src)))])]) - (let () - (test (parse #'(a #:c 3 #:b 4)) '(4 3)) - (test (parse #'(a #:b 4 #:c 3)) '(4 3)) - (test (parse #'(a #:c 3)) '(1 3)) - (let*-values ([(kw) #'#:b] - [(msg src) (msg-src (parse #`(a #,kw)))]) - (test msg #rx"a: missing argument expression after keyword") - (test src (list kw))) - (let*-values ([(arg) #'1] - [(msg src) (msg-src (parse #`(a #:b 1 #,arg)))]) - (test msg #rx"a: expected a keyword") - (test src (list arg))) - (let*-values ([(kw) #'#:c] - [(msg src) (msg-src (parse #`(a #:c 1 #:b 2 #,kw 3)))]) - (test msg #rx"a: repeated keyword") - (test src (list kw))) - (let*-values ([(kw) #'#:c] - [(msg src) (msg-src (parse #`(a #:b #,kw 3)))]) - (test msg #rx"a: expected an argument expression") - (test src (list kw))) - (let*-values ([(kw) #'#:typo] - [(msg src) (msg-src (parse #`(a #:b 3 #,kw 4)))]) - (test msg #rx"a: invalid keyword") - (test src (list kw)))))) - -(print-tests-passed 'keyword-macros-test.ss) diff --git a/collects/redex/private/lw-test-util.ss b/collects/redex/private/lw-test-util.ss deleted file mode 100644 index fb6e335dc4..0000000000 --- a/collects/redex/private/lw-test-util.ss +++ /dev/null @@ -1,43 +0,0 @@ -(module lw-test-util mzscheme - (require "loc-wrapper.ss") - (provide normalize-lw) - - (define (normalize-lw lw) - (define-values (min-line min-column) (find-min-line/col lw)) - (define (normalize/lw lw) - (cond - [(lw? lw) - (make-lw (normalize/e (lw-e lw)) - (- (lw-line lw) min-line) - (lw-line-span lw) - (- (lw-column lw) min-column) - (lw-column-span lw) - (lw-unq? lw) - (lw-metafunction? lw))] - [else lw])) - (define (normalize/e e) - (cond - [(symbol? e) e] - [(string? e) e] - [else (map normalize/lw e)])) - (normalize/lw lw)) - - (define (find-min-line/col lw) - (define min-line #f) - (define min-col #f) - (define (find-min/lw lw) - (when (lw? lw) - (set! min-line (if min-line - (min min-line (lw-line lw)) - (lw-line lw))) - (set! min-col (if min-col - (min min-col (lw-column lw)) - (lw-column lw))) - (find-min/e (lw-e lw)))) - (define (find-min/e e) - (cond - [(symbol? e) (void)] - [(string? e) (void)] - [else (for-each find-min/lw e)])) - (find-min/lw lw) - (values min-line min-col))) diff --git a/collects/redex/private/lw-test.ss b/collects/redex/private/lw-test.ss deleted file mode 100644 index 109b17c9a5..0000000000 --- a/collects/redex/private/lw-test.ss +++ /dev/null @@ -1,282 +0,0 @@ -#| - - DO NOT TABIFY THIS FILE - -|# - - -; -; -; ;;;; -; ; ; ; -; ; ; ;;; ;; ;; ;;; ;;;;; -; ; ; ; ; ;; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; -; ;;;; ;;; ;;; ;;; ;;; ;;; -; -; -; -; -; -; -; ;; ; ;;; -; ; ; ; -; ;;;;; ;;; ; ;; ;;; ;;;;; ;;; ;;; -; ; ; ; ;; ; ; ; ; ; -; ; ;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ;; -; ;;; ;;;;;;;;;; ;;;;; ;;;;; ; -; ; -; ;;;; -; -; -; -; -; ;; ; ;;; ; ;; -; ; ; ; ; -; ;;;;; ; ;; ;;; ;;;; ;;;;; ;;; ; ;;; -; ; ;; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ;;; ; ; ; ;;;;; -; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; -; ;;; ;;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;; -; -; -; -; - - -(module lw-test mzscheme - (require "test-util.ss" - "loc-wrapper.ss" - "lw-test-util.ss") - - (reset-count) - - (test (normalize-lw (to-lw ())) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw ")" 0 0 1 1)) - 0 0 0 2)) - - (test (normalize-lw (to-lw "x")) - (build-lw "“x”" 0 0 0 3)) - - (test (normalize-lw (to-lw "#f")) - (build-lw "“#f”" 0 0 0 4)) - - (test (normalize-lw (to-lw #f)) - (build-lw "#f" 0 0 0 2)) - - (test (normalize-lw (to-lw/uq ())) - (make-lw (list (make-lw "(" 0 0 0 1 #t #f) - (make-lw ")" 0 0 1 1 #t #f)) - 0 0 0 2 #t #f)) - - (test (normalize-lw (to-lw (a))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw ")" 0 0 2 1)) - 0 0 0 3)) - - (test (normalize-lw (to-lw (a - b))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw 'b 1 0 1 1) - (build-lw ")" 1 0 2 1)) - 0 1 0 3)) - - (test (normalize-lw (to-lw (a b))) - (build-lw - (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw 'b 0 0 3 1) - (build-lw ")" 0 0 4 1)) - 0 0 0 5)) - - - (test (normalize-lw (to-lw (a - (b c) - d))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw - (list (build-lw "(" 1 0 1 1) - (build-lw 'b 1 0 2 1) - (build-lw 'c 1 0 4 1) - (build-lw ")" 1 0 5 1)) - 1 0 1 5) - (build-lw 'd 2 0 1 1) - (build-lw ")" 2 0 2 1)) - 0 2 0 3)) - - (test (normalize-lw (to-lw (abcdefghijkl - b))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'abcdefghijkl 0 0 1 12) - (build-lw 'b 1 0 1 1) - (build-lw ")" 1 0 2 1)) - 0 1 0 3)) - - (test (normalize-lw (to-lw ((a b) - c))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw - (list (build-lw "(" 0 0 1 1) - (build-lw 'a 0 0 2 1) - (build-lw 'b 0 0 4 1) - (build-lw ")" 0 0 5 1)) - 0 0 1 5) - (build-lw 'c 1 0 1 1) - (build-lw ")" 1 0 2 1)) - 0 1 0 3)) - - (test (normalize-lw (to-lw (aaa bbb - (ccc - ddd)))) ;; <--- the ddd should be lined up under the aaa - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'aaa 0 0 1 3) - (build-lw 'bbb 0 0 5 3) - (build-lw - (list - (build-lw "(" 1 0 5 1) - (build-lw 'ccc 1 0 6 3) - (build-lw 'ddd 2 0 1 3) - (build-lw ")" 2 0 4 1)) - 1 1 1 4) - (build-lw ")" 2 0 5 1)) - 0 2 0 6)) - - (test (normalize-lw (to-lw (aaa bbb - (ccc - ddd ;; <--- the ddd should be lined up under the aaa - eee)))) ;; <--- the eee should be lined up under the ccc - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'aaa 0 0 1 3) - (build-lw 'bbb 0 0 5 3) - (build-lw - (list - (build-lw "(" 1 0 5 1) - (build-lw 'ccc 1 0 6 3) - (build-lw 'ddd 2 0 1 3) - (build-lw 'eee 3 0 6 3) - (build-lw ")" 3 0 9 1)) - 1 2 1 9) - (build-lw ")" 3 0 10 1)) - 0 3 0 11)) - - (test (normalize-lw (to-lw ([{}]))) - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw - (list - (build-lw "[" 0 0 1 1) - (build-lw - (list - (build-lw "{" 0 0 2 1) - (build-lw "}" 0 0 3 1)) - 0 0 2 2) - (build-lw "]" 0 0 4 1)) - 0 0 1 4) - (build-lw ")" 0 0 5 1)) - 0 0 0 6)) - - (test (normalize-lw (to-lw ,x)) - (make-lw - (list - (make-lw "" 0 0 0 0 #f #f) - 'spring - (make-lw 'x 0 0 1 1 #t #f)) - 0 0 0 2 #f #f)) - - (test (normalize-lw (to-lw ,@x)) - (make-lw - (list - (make-lw "" 0 0 0 0 #f #f) - 'spring - (make-lw 'x 0 0 2 1 #t #f)) - 0 0 0 3 #f #f)) - - (test (normalize-lw (to-lw 'x)) - (make-lw - (list - (make-lw "'" 0 0 0 1 #f #f) - 'spring - (make-lw 'x 0 0 1 1 #f #f)) - 0 0 0 2 #f #f)) - - (test (normalize-lw (to-lw ,(term x))) - (make-lw - (list - (make-lw "" 0 0 0 0 #f #f) - 'spring - (make-lw - (list - (make-lw "" 0 0 1 0 #t #f) - 'spring - (make-lw 'x 0 0 7 1 #f #f)) - 0 0 1 7 #t #f)) - 0 0 0 8 #f #f)) - - (test (normalize-lw (to-lw (term x))) - (build-lw - (list - (build-lw "(" 0 0 0 1) - (build-lw 'term 0 0 1 4) - (build-lw 'x 0 0 6 1) - (build-lw ")" 0 0 7 1)) - 0 0 0 8)) - - (test (normalize-lw (to-lw '(term x))) - (build-lw - (list - (build-lw "'" 0 0 0 1) - 'spring - (build-lw - (list - (build-lw "(" 0 0 1 1) - (build-lw 'term 0 0 2 4) - (build-lw 'x 0 0 7 1) - (build-lw ")" 0 0 8 1)) - 0 - 0 - 1 - 8)) - 0 0 0 9)) - - (test (normalize-lw (to-lw ''x)) - (build-lw - (list - (build-lw "'" 0 0 0 1) - 'spring - (build-lw - (list - (build-lw "'" 0 0 1 1) - 'spring - (build-lw 'x 0 0 2 1)) - 0 - 0 - 1 - 2)) - 0 0 0 3)) - - ;; this one seems suspicious: why does the second comma start at 1 instead of 0? - ;; rendering seems to work, however, so we'll go with it .. - (test (normalize-lw (to-lw ,,x)) - (build-lw - (list - (build-lw "" 0 0 0 0) - 'spring - (make-lw - (list - (make-lw "," 0 0 1 1 #t #f) - 'spring - (make-lw 'x 0 0 2 1 #t #f)) - 0 0 1 2 - #t #f)) - 0 0 0 3)) - - (print-tests-passed "lw-test.ss")) - diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss deleted file mode 100644 index 6866eae34a..0000000000 --- a/collects/redex/private/matcher-test.ss +++ /dev/null @@ -1,820 +0,0 @@ -(module matcher-test mzscheme - (require "matcher.ss" - (only "test-util.ss" equal/bindings?) - (lib "list.ss")) - - (error-print-width 500) - - (define (make-test-mtch a b c) (make-mtch a (build-flat-context b) c)) - - (define (test) - (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 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))) - (test-empty 99999999999999999999999999999999999999999999999 - '() - #f) - (test-empty 'x 'x (list (make-test-mtch (make-bindings null) 'x none))) - (test-empty 'x '() #f) - (test-empty 1 2 #f) - (test-empty "a" "b" #f) - (test-empty "a" '(x) #f) - (test-empty "a" '() #f) - (test-empty "a" "a" (list (make-test-mtch (make-bindings null) "a" none))) - (test-empty '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 '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 '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 '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 '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 '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)) - (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))) - (test-empty '(variable-prefix x:) ': #f) - (test-empty '(variable-prefix x:) '() #f) - - (test-empty 'hole 1 #f) - (test-empty `hole - the-hole - (list (make-test-mtch (make-bindings (list)) the-hole none))) - (test-empty '(in-hole (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) - `(,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 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) - (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 ...)) - '((1 2 3 1 5) (1 2 3 1 5)) - #f) - (test-empty '((number_!_1 ...) (number_!_1 ...)) - '((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 ...) - '((1 1) (2 3) 1 4) - (list (make-test-mtch (make-bindings (list)) '((1 1) (2 3) 1 4) 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 '())) - #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)) ...) - `(,(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)) ...) - `(,(make-repeat '(in-hole (name x a) (name y b)) - (list (make-bind 'x '()) (make-bind 'y '())) #f #f))) - - (test-ellipses '(a ..._1) - `(,(make-repeat 'a (list) '..._1 #f))) - (test-ellipses '(a ..._!_1) - `(,(make-repeat 'a (list) '..._!_1 #t))) - - (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)) - '(z (x a)) - (list (make-test-mtch (make-bindings (list)) '(z (x a)) none))) - - (run-test/cmp '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) - 'should-have-raised-an-exception) - '("zero holes") - equal?) - - - (test-empty '(in-hole (in-hole (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 '(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 '(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 '(a ..._1 a ..._2) - '(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) - '(a a) - (list (make-test-mtch (make-bindings (list (make-bind '..._1 1))) '(a a) none))) - - (test-empty '((name x a) ..._!_1 (name y a) ..._!_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) ...) '() - (list (make-test-mtch (make-bindings (list (make-bind 'x '()) - (make-bind 'y '()))) - '() - none))) - (test-empty '((name y b) ... (name x a) ...) '(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) - (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) - (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) - (list (make-test-mtch (make-bindings (list (make-bind 'x '()) - (make-bind 'y '(a)))) - '(a) - none) - (make-test-mtch (make-bindings (list (make-bind 'x '(a)) - (make-bind 'y '()))) - '(a) - none))) - (test-empty '((name y a) ... (name x a) ...) '(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)) - (make-bind 'y '(a)))) - '(a a) - none) - (make-test-mtch (make-bindings (list (make-bind 'x '(a a)) - (make-bind 'y '()))) - '(a a) - none))) - - (test-ab '(bb_y ... aa_x ...) '() - (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) - (make-bind 'bb_y '()))) - '() - none))) - (test-ab '(bb_y ... aa_x ...) '(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) - (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) - (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) - (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) - (make-bind 'aa_y '(a)))) - '(a) - none) - (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a)) - (make-bind 'aa_y '()))) - '(a) - none))) - (test-ab '(aa_y ... aa_x ...) '(a a) - (list (make-test-mtch (make-bindings (list (make-bind 'aa_x '()) - (make-bind 'aa_y '(a a)))) - '(a a) - none) - (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a)) - (make-bind 'aa_y '(a)))) - '(a a) - none) - (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a a)) - (make-bind 'aa_y '()))) - '(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 '(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 '((name x any) - ((name x number) ...)) - '((1 1) (1 1)) - (list (make-test-mtch (make-bindings (list (make-bind 'x '(1 1)) - (make-bind 'any '(1 1)) - (make-bind 'number '(1 1)))) - '((1 1) (1 1)) - none))) - - (test-empty '((variable_1 variable_1) ...) - '((x y)) - #f) - - - (test-empty '(number ...) '() - (list (make-test-mtch (make-bindings (list (make-bind 'number '()))) '() none))) - (test-ab '(aa ...) '() - (list (make-test-mtch (make-bindings (list (make-bind 'aa '()))) '() none))) - - - ;; testing block-in-hole - (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) - '(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 '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) - '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)) - '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)) - '(+ 1 2) - (list (make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context the-hole)) - (make-bind 'c (build-context the-hole)) - (make-bind 'x '(+ 1 2)) - (make-bind 'any '(+ 1 2)))) - '(+ 1 2) none) - (make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context `(+ ,the-hole 2))) - (make-bind 'c (build-context `(+ ,the-hole 2))) - (make-bind 'x 1) - (make-bind 'any 1))) - '(+ 1 2) none) - (make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context `(+ 1 ,the-hole))) - (make-bind 'c (build-context `(+ 1 ,the-hole))) - (make-bind 'x 2) - (make-bind 'any 2))) - '(+ 1 2) none))) - (test-xab '(in-hole (name c ctxt) (name i (+ number_1 number_2))) - '(+ (+ 1 2) (+ 3 4)) - (list (make-test-mtch - (make-bindings (list (make-bind 'i '(+ 1 2)) - (make-bind 'number_1 1) - (make-bind 'number_2 2) - (make-bind 'ctxt (build-context `(+ ,the-hole (+ 3 4)))) - (make-bind 'c (build-context `(+ ,the-hole (+ 3 4)))))) - '(+ (+ 1 2) (+ 3 4)) - none) - (make-test-mtch (make-bindings (list (make-bind 'i '(+ 3 4)) - (make-bind 'number_1 3) - (make-bind 'number_2 4) - (make-bind 'ctxt `(+ (+ 1 2) ,the-hole)) - (make-bind 'c `(+ (+ 1 2) ,the-hole)))) - '(+ (+ 1 2) (+ 3 4)) - none))) - - (test-empty '(in-hole ((z hole)) (name x 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) - '(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) - '(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)) - '(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)) - '(a (b (c d) e)) - (list - (make-test-mtch (make-bindings (list (make-bind 'c2 `(c ,the-hole)) - (make-bind 'c1 `(b (c d) ,the-hole)))) - '(a (b (c d) e)) - none))) - - (test-empty '(in-hole (in-hole hole hole) a) - '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))) - '(a (b (c (d e)))) - (list - (make-test-mtch (make-bindings (list (make-bind 'c1 `(c (d ,the-hole))) - (make-bind 'c2 `(c ,the-hole)))) - '(a (b (c (d e)))) - none))) - - (test-empty `(+ 1 (side-condition 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)) - '(+ 1 b) - #f) - - (test-empty `(+ 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) - '(+ 1 b) - #f) - - (test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a)) - 'a - (list - (make-test-mtch (make-bindings (list (make-bind 'x 'a) - (make-bind 'any 'a))) - 'a - none))) - - (test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a))) - '(+ 1 a) - (list - (make-test-mtch (make-bindings (list (make-bind 'x 'a) - (make-bind 'any 'a))) - '(+ 1 a) - none))) - - (test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)) (eq? (term x) 'a)) - 'b - #f) - - (test-empty `(+ 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)) - ,(lambda (bindings) (error 'should-not-be-called)) - (error 'should-not-be-called)) - '((1 2 3) (4 5)) - #f) - - (test-xab 'exp_1 - '(+ 1 2) - (list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)))) '(+ 1 2) none))) - (test-xab '(exp_1 exp_2) - '((+ 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) - '((+ 1 2) (+ 3 4)) - #f) - (test-xab 'nesting-names - 'b - (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names 'b))) 'b none))) - (test-xab 'nesting-names - '(a b) - (list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a b)))) '(a b) none))) - (test-xab '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) - '(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 - '(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 - '(x x) - (list (make-test-mtch (make-bindings (list (make-bind 'same-in-nt '(x x)))) '(x x) none))) - (test-xab 'same-in-nt - '(x y) - #f) - - (test-xab '(in-hole (cross forever-list) 1) - '(a b c) - #f) - - (test-xab '(in-hole (cross forever-list) 1) - '(1 x x) - (list (make-test-mtch (make-bindings '()) '(1 x x) none))) - - (test-xab '(in-hole (cross forever-list) 1) - '(x 1 x) - (list (make-test-mtch (make-bindings '()) '(x 1 x) none))) - - - (test-xab '(in-hole (cross 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 '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))) - - (run-test - 'compatible-context-language1 - (build-compatible-context-language - (mk-hasheq '((exp . ()) (ctxt . ()))) - (list (make-nt 'exp - (list (make-rhs '(+ exp exp)) - (make-rhs 'number))) - (make-nt 'ctxt - (list (make-rhs '(+ ctxt exp)) - (make-rhs '(+ exp ctxt)) - (make-rhs 'hole))))) - (list - (make-nt 'ctxt-ctxt - (list (make-rhs 'hole) - (make-rhs `(+ (cross ctxt-ctxt) exp)) - (make-rhs `(+ ctxt (cross ctxt-exp))) - (make-rhs `(+ (cross ctxt-exp) ctxt)) - (make-rhs `(+ exp (cross ctxt-ctxt))))) - (make-nt 'ctxt-exp - (list (make-rhs `(+ (cross ctxt-exp) exp)) - (make-rhs `(+ exp (cross ctxt-exp))))) - (make-nt 'exp-ctxt - (list (make-rhs `(+ (cross exp-ctxt) exp)) - (make-rhs `(+ ctxt (cross exp-exp))) - (make-rhs `(+ (cross exp-exp) ctxt)) - (make-rhs `(+ exp (cross exp-ctxt))))) - (make-nt 'exp-exp - (list (make-rhs 'hole) - (make-rhs `(+ (cross exp-exp) exp)) - (make-rhs `(+ exp (cross exp-exp))))))) - - (run-test - '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 'v-v (list (make-rhs 'hole) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m))))) - (make-nt 'v-m - (list - (make-rhs (list (list 'cross 'v-m) 'm)) - (make-rhs (list 'm (list 'cross 'v-m))) - (make-rhs (list '+ (list 'cross 'v-m) 'm)) - (make-rhs (list '+ 'm (list 'cross 'v-m))) - (make-rhs (list 'cross 'v-v)))) - (make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m))))) - (make-nt 'm-m - (list - (make-rhs 'hole) - (make-rhs (list (list 'cross 'm-m) 'm)) - (make-rhs (list 'm (list 'cross 'm-m))) - (make-rhs (list '+ (list 'cross 'm-m) 'm)) - (make-rhs (list '+ 'm (list 'cross 'm-m))) - (make-rhs (list 'cross 'm-v)))))) - - (run-test - 'compatible-context-language3 - (build-compatible-context-language - (mk-hasheq '((m . ()) (seven . ()))) - (list (make-nt 'm (list (make-rhs '(m seven m)) (make-rhs 'number))) - (make-nt 'seven (list (make-rhs 7))))) - `(,(make-nt - 'm-m - `(,(make-rhs 'hole) ,(make-rhs `((cross m-m) seven m)) ,(make-rhs `(m seven (cross m-m))))) - ,(make-nt - 'seven-m - `(,(make-rhs `((cross seven-m) seven m)) ,(make-rhs `(m (cross seven-seven) m)) ,(make-rhs `(m seven (cross seven-m))))) - ,(make-nt 'seven-seven `(,(make-rhs 'hole))))) - - (run-test - '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))) - (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)))) - (make-nt 'c-a (list (make-rhs '(cross c-b)))) - (make-nt 'b-b (list (make-rhs 'hole))) - (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/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)) - - (cond - [(= failures 0) - (printf "matcher-test.ss: all ~a tests passed.\n" test-count)] - [else - (printf "matcher-test.ss: ~a test~a failed.\n" - failures - (if (= failures 1) - "" - "s"))])) - - ;; mk-hasheq : (listof (cons sym any)) -> hash-table - ;; builds a hash table that has the bindings in assoc-list - (define (mk-hasheq assoc-list) - (let ([ht (make-hash-table)]) - (for-each - (lambda (a) - (hash-table-put! 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) - (run-match-test - `(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) - exp) - ans)) - - ;; 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) - (let ([nt-map (map (λ (x) (list (nt-name x))) nts)]) - (run-match-test - `(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) - exp) - ans))) - - (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) - (unless xab-lang - (let ([nts - (list (make-nt 'exp - (list (make-rhs '(+ exp exp)) - (make-rhs 'number))) - (make-nt 'ctxt - (list (make-rhs '(+ ctxt exp)) - (make-rhs '(+ exp ctxt)) - (make-rhs 'hole))) - - (make-nt 'ec-one - (list (make-rhs '(+ (hole xx) exp)) - (make-rhs '(+ exp (hole xx))))) - - (make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any))))) - - (make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...)) - (make-rhs 'x))) - - (make-nt 'lsts - (list (make-rhs '()) - (make-rhs '(x)) - (make-rhs 'x) - (make-rhs '#f))) - (make-nt 'split-out - (list (make-rhs '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))) - (make-rhs 'b))) - (make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned))) - - (make-nt 'underscore (list (make-rhs 'exp_1))) - )]) - (set! xab-lang - (compile-language 'pict-stuff-not-used - nts - (map (λ (x) (list (nt-name x))) nts))))) - (run-match-test - `(match-pattern (compile-pattern xab-lang ',pat #t) ',exp) - (match-pattern (compile-pattern xab-lang pat #t) exp) - ans)) - - (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) - (unless ab-lang - (set! ab-lang - (compile-language - 'pict-stuff-not-used - (list (make-nt 'aa - (list (make-rhs 'a))) - (make-nt 'bb - (list (make-rhs 'b)))) - '((aa) (bb))))) - (run-match-test - `(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) - (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)))]) - (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 -> 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 exp) - (define (binding-names bindings) - (map (λ (b) - (cond [(bind? b) (bind-name b)] - [(mismatch-bind? b) (mismatch-bind-name b)])) - bindings)) - (run-test - `(test-ellipsis-binding ,pat) - (binding-names - (bindings-table-unchecked - (mtch-bindings - (car - ((compiled-pattern-cp - (compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t)) - exp - #t))))) - (binding-names (extract-empty-bindings test-suite:non-underscore-binder? 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?) - (set! test-count (+ test-count 1)) - (cond - [(cmp? ans expected) - '(printf "passed: ~s\n" symbolic)] - [else - (set! failures (+ failures 1)) - (fprintf (current-error-port) - " test: ~s\nexpected: ~e\n got: ~e\n" - symbolic expected ans)])) - - (define (run-test symbolic ans expected) (run-test/cmp 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 (build-context c) - (let loop ([c c]) - (cond - [(eq? c the-hole) the-hole] - [(pair? c) (build-cons-context (loop (car c)) (loop (cdr c)))] - [(or (null? c) - (number? c) - (symbol? c)) - (build-flat-context c)] - [else (error 'build-context "unknown ~s" c)]))) - - (test)) diff --git a/collects/redex/private/pict-test.ss b/collects/redex/private/pict-test.ss deleted file mode 100644 index c80da26ac0..0000000000 --- a/collects/redex/private/pict-test.ss +++ /dev/null @@ -1,53 +0,0 @@ -(module pict-test mzscheme - ;; these tests just make sure that errors don't - ;; happen. These tests are really only last resorts - ;; for testing functions that aren't easily extraced - ;; from the pict.ss library - - (require "../reduction-semantics.ss" - "../pict.ss") - - (require (lib "mrpict.ss" "texpict") - (lib "mred.ss" "mred") - (lib "class.ss")) - - (define-language empty-language) - - (define-language var-ab - [var (a - b)]) - (render-language var-ab) - - (define-language var-not-ab - [var (variable-except x - y)]) - (render-language var-not-ab) - - (let () - (define-metafunction empty-language [(zero any_in) 0]) - (render-metafunction zero)) - - (render-reduction-relation - (reduction-relation - empty-language - (--> number_const - ,(term - (+ number_const 0))))) - - (render-reduction-relation - (reduction-relation - empty-language - (--> a b - (fresh x) - (fresh y)))) - - - (define-language x1-9 - (x 1 2 3 4 5 6 7 8 9)) - - (define-extended-language x0-10 x1-9 - (x 0 .... 10)) - - (render-language x0-10) - - (printf "pict-test.ss passed\n")) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss deleted file mode 100644 index 307b595aa0..0000000000 --- a/collects/redex/private/rg-test.ss +++ /dev/null @@ -1,1081 +0,0 @@ -#lang scheme - -(require "test-util.ss" - "reduction-semantics.ss" - "matcher.ss" - "term.ss" - "rg.ss" - "keyword-macros.ss" - "error.ss") - -(reset-count) - -;; to-table : hash-table -> assoc -;; extracts the hash-table's mapping in a deterministic way -(define (to-table ht) - (sort (hash-map ht cons) - (λ (x y) (string<=? (format "~a" (car x)) (format "~a" (car y)))))) - -(let () - (define-language lc - (e x (e e) (λ (x) e)) - (x variable)) - (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)) - '((e-e . (0 2 2 1)) (x-e . (1 2 2 2 2)) (x-x . (0)))))) - -(let () - (define-language lang - (e (e e))) - (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)))))) - -(let () - (define-language lang - (a 1 2 3) - (b a (a_1 b_!_1))) - (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)))))) - -(let () - (define-language lc - (e (e e ...) - (+ e e) - x - v) - (v (λ (x) e) - number) - (x variable)) - (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)) - '((e-e . (0 2 2 2 2 2)) (e-v . (1)) (v-e . (2 2 2 2 1)) (v-v . (0 2)) - (x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0)))))) - -(let () - (define-language L - (x (variable-prefix x) - (variable-except y)) - (y y)) - (test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x) - '(0 0))) - -(let () - (define-language lang - (e number x y) - (x variable) - (y y)) - (test (min-prods (car (compiled-lang-lang lang)) - (base-cases-non-cross (find-base-cases lang))) - (list (car (nt-rhs (car (compiled-lang-lang lang))))))) - -(define (make-random . nums) - (let ([nums (box nums)]) - (λ ([m +inf.0]) - (cond [(null? (unbox nums)) (error 'make-random "out of numbers")] - [(>= (car (unbox nums)) m) (error 'make-random "number too large")] - [else (begin0 (car (unbox nums)) (set-box! nums (cdr (unbox nums))))])))) - -(test (pick-from-list '(a b c) (make-random 1)) 'b) - -(test (pick-number 24 (make-random 1/5)) 3) -(test (pick-number 224 (make-random 0 0 1/5)) -5) -(test (pick-number 524 (make-random 0 0 1 1/5 1/5)) 3/4) -(test (pick-number 1624 (make-random 0 0 0 .5 1 .5)) 3.0) -(test (pick-number 2624 (make-random 0 0 0 0 1 1 1/5 1/5 2 .5 0 .5)) - (make-rectangular 7/8 -3.0)) - -(test (pick-natural 224 (make-random 1/5)) 5) -(test (pick-integer 900 (make-random 0 0 1/5)) -7) -(test (pick-real 9000 (make-random 0 0 0 .5 1 1/8)) 11.0) - -(let* ([lits '("bcd" "cbd")]) - (test (pick-char 0 (make-random 0 0)) #\A) - (test (pick-char 0 (make-random 2 1)) #\c) - (test (pick-char 1000 (make-random 1 25 0)) #\Z) - (test (pick-char 1000 (make-random 0 65)) #\a) - (test (pick-char 1500 (make-random 0 1 65)) #\a) - (test (pick-char 1500 (make-random 0 0 3)) #\⇒) - (test (pick-char 2500 (make-random 0 0 1 3)) #\⇒) - (test (pick-char 2500 (make-random 0 0 0 1)) (integer->char #x4E01)) - (test (pick-char 1000 (make-random 0 (- (char->integer #\_) #x20))) #\`) - (test (random-string lits 3 0 (make-random 0 1)) "cbd") - (test (random-string lits 3 0 (make-random 1 0 1 1 1 2 1)) "abc") - (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc") - (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc)) - -(let () - (define-language L - (a 5 (x a)) - (b 4)) - (test (pick-nt 'a #f L 1 'dontcare) - (nt-rhs (car (compiled-lang-lang L)))) - (test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1)) - (nt-rhs (car (compiled-lang-lang L)))) - (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))]) - (test (pick-nt 'a #f L preferred-production-threshold - (make-pref-prods 'dont-care - (make-immutable-hash `((a ,pref)))) - (make-random 0)) - (list pref))) - (test (pick-nt 'b #f L preferred-production-threshold #f) - (nt-rhs (cadr (compiled-lang-lang L))))) - -(define-syntax raised-exn-msg - (syntax-rules () - [(_ expr) (raised-exn-msg exn:fail? expr)] - [(_ exn? expr) - (with-handlers ([exn? exn-message]) - (begin - expr - (let () - (define-struct exn-not-raised ()) - (make-exn-not-raised))))])) - -(define (patterns . selectors) - (map (λ (selector) - (λ (name cross? lang size pref-prods) - (list (selector (nt-rhs (nt-by-name lang name cross?)))))) - selectors)) - -(define (iterator name items) - (let ([bi (box items)]) - (λ () - (if (null? (unbox bi)) - (error name "empty") - (begin0 (car (unbox bi)) (set-box! bi (cdr (unbox bi)))))))) - -(let ([iter (iterator 'test-iterator '(a b))]) - (test (iter) 'a) - (test (iter) 'b) - (test (raised-exn-msg (iter)) #rx"empty")) - -(define (decisions #:var [var pick-var] - #:nt [nt pick-nt] - #:str [str pick-string] - #:num [num pick-number] - #:nat [nat pick-natural] - #:int [int pick-integer] - #:real [real pick-real] - #:any [any pick-any] - #:seq [seq pick-sequence-length] - #:pref [pref pick-preferred-productions]) - (define-syntax decision - (syntax-rules () - [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) - (unit (import) (export decisions^) - (define next-variable-decision (decision var)) - (define next-non-terminal-decision (decision nt)) - (define next-number-decision (decision num)) - (define next-natural-decision (decision nat)) - (define next-integer-decision (decision int)) - (define next-real-decision (decision real)) - (define next-string-decision (decision str)) - (define next-any-decision (decision any)) - (define next-sequence-decision (decision seq)) - (define next-pref-prods-decision (decision pref)))) - -(define-syntax generate-term/decisions - (syntax-rules () - [(_ lang pat size attempt decisions) - (parameterize ([generation-decisions decisions]) - (generate-term lang pat size #:attempt attempt))])) - -(let () - (define-language lc - (e (e e) x (λ (x) e)) - (x (variable-except λ))) - - ;; Generate (λ (x) x) - (test - (generate-term/decisions - lc e 1 0 - (decisions #:var (list (λ _ 'x) (λ _'x)) - #:nt (patterns third first first first))) - '(λ (x) x)) - - ;; Generate pattern that's not a non-terminal - (test - (generate-term/decisions - lc (x x x_1 x_1) 1 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y)))) - '(x x y y)) - - ; After choosing (e e), size decremented forces each e to x. - (test - (generate-term/decisions - lc e 1 0 - (decisions #:nt (patterns first) - #:var (list (λ _ 'x) (λ _ 'y)))) - '(x y))) - -;; variable-except pattern -(let () - (define-language var - (e (variable-except x y))) - (test - (generate-term/decisions - var e 2 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) - 'z)) - -(let () - (define-language L - (n natural) - (i integer) - (r real)) - (test (let ([n (generate-term L n 0 #:attempt 10000)]) - (and (integer? n) - (exact? n) - (not (negative? n)))) - #t) - (test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42) - (test (let ([i (generate-term L i 0 #:attempt 10000)]) - (and (integer? i) (exact? i))) - #t) - (test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42) - (test (real? (generate-term L r 0 #:attempt 10000)) #t) - (test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2)) - -(let () - (define-language lang - (a (number number ... "foo" ... "bar" #t ...)) - (b (number_1 ..._!_1 number_1 ..._1)) - (c (variable_1 ..._1 number_2 ..._1)) - (d (z_1 ... z_2 ..._!_1 (z_1 z_2) ...)) - (e (n_1 ..._!_1 n_2 ..._!_1 (n_1 n_2) ..._3)) - (f (n_1 ..._1 n_2 ..._2 n_2 ..._1)) - (g (z_1 ..._!_1 z_2 ... (z_1 z_2) ...)) - (n number) - (z 4)) - (test - (generate-term/decisions - lang a 2 0 - (decisions #:num (build-list 3 (λ (n) (λ (_) n))) - #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1)))) - `(0 1 2 "foo" "foo" "foo" "bar" #t)) - (test (generate-term/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0)))) - null) - (test (generate-term/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0)))) - null) - (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 e in 42") - (test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate-term/decisions - 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))) - (test (generate-term/decisions - lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 - (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) - '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) - -(let () - (define-language lang (e (variable-prefix pf))) - (test - (generate-term/decisions - lang e 5 0 - (decisions #:var (list (λ _ 'x)))) - 'pfx)) - -(let () - (define-language lang (x variable literal)) - (test ((is-nt? lang) 'x) #t) - (test ((is-nt? lang) 'y) #f)) - -(let () - (define-language lang - (e number (e_1 e_2 e e_1 e_2))) - (test - (generate-term/decisions - lang e 5 0 - (decisions #:nt (patterns second first first first) - #:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) - '(2 3 4 2 3))) - -(let () - (define-language lang - (a (number_!_1 number_!_2 number_!_1)) - (b (c_!_1 c_!_1 c_!_1)) - (c 1 2)) - (test - (generate-term/decisions - lang a 5 0 - (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) - '(1 1 2)) - (test - (generate-term/decisions - lang (number_!_1 number_!_2 number_!_1) 5 0 - (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) - '(1 1 2)) - (test - (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang b 5000)) - #rx"unable")) - -(let () - (define-language lang - (e string) - (f foo bar)) - (test - (let/ec k - (generate-term/decisions - lang e 5 0 - (decisions #:str (list (λ (l a) (k (sort l string<=?))))))) - '("bar" "foo"))) - -(let () - (define-language lang - (a 43) - (b (side-condition a_1 (odd? (term a_1)))) - (c (side-condition a_1 (even? (term a_1)))) - (e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x)))) - (x variable)) - (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 #\\)") - (test (let/ec k - (generate-term lang (number_1 (side-condition 7 (k (term number_1)))) 5)) - 'number_1) - - (test ; mismatch patterns work with side-condition failure/retry - (generate-term/decisions - lang e 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y)))) - '(y x y)) - (test ; generate compiles side-conditions in pattern - (generate-term/decisions - lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y)))) - 'y)) - -(let () - (define-language lang - (a (name x b)) - (b 4) - (c (side-condition (name x d) (zero? (term x)))) - (d 2 1 0) - (e ((side-condition (name d_1 d) (zero? (term d_1))) d_1))) - (test (generate-term lang a 5) 4) - (test (generate-term lang c 5) 0) - (test (generate-term lang e 5) '(0 0))) - -(let () - (define-language lang - (a number (+ a a)) - (A hole (+ a A) (+ A a)) - (C hole) - (e ((in-hole (in-hole f (number_1 hole)) number_1) number_1)) - (f (in-hole C (number_1 hole))) - (g (in-hole (side-condition (hole number_1) (zero? (term number_1))) number_2)) - (h ((in-hole i number_1) number_1)) - (i (number_1 (in-hole j (number_1 hole)))) - (j (in-hole (hole number_1) (number_1 hole))) - (x variable) - (y variable)) - - (test - (generate-term/decisions - lang (in-hole A number ) 5 0 - (decisions - #:nt (patterns second second first first third first second first first) - #:num (build-list 5 (λ (x) (λ (_) x))))) - '(+ (+ 1 2) (+ 0 (+ 3 4)))) - - (test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) - (test (generate-term lang (hole 4) 5) (term (hole 4))) - (test (generate-term/decisions - lang (variable_1 (in-hole C variable_1)) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) - '(x x)) - (test (generate-term/decisions - lang (variable_!_1 (in-hole C variable_!_1)) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) - '(x y)) - (test (generate-term/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) - '((2 (1 1)) 1)) - (test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) - '(1 0)) - (test (generate-term/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) - '((2 ((3 (2 1)) 3)) 1))) - -(let () - (define-language lc - (e (e e) (+ e e) x v) - (v (λ (x) e) number) - (x variable-not-otherwise-mentioned)) - (test (generate-term/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) - 'x)) - -(let () - (define-language four - (e 4) - (f 5)) - (define-language empty) - - ;; `any' pattern - (let ([four (prepare-lang four)] - [sexp (prepare-lang sexp)]) - (test (call-with-values (λ () (pick-any four sexp (make-random 0 1))) list) - (list four 'f)) - (test (call-with-values (λ () (pick-any four sexp (make-random 1))) list) - (list sexp 'sexp))) - (test (generate-term/decisions - four any 5 0 (decisions #:any (list (λ (lang sexp) (values lang 'e))))) 4) - (test (generate-term/decisions - four any 5 0 - (decisions #:any (list (λ (lang sexp) (values sexp 'sexp))) - #:nt (patterns fifth second second second) - #:seq (list (λ _ 3)) - #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) - '("foo" "bar" "baz")) - (test (generate-term/decisions - empty any 5 0 (decisions #:nt (patterns first) - #:var (list (λ _ 'x)))) - 'x)) - -;; `hide-hole' pattern -(let () - (define-language lang - (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) - (test (generate-term lang e 5) (term (hole 1)))) - -(define (output-error-port thunk) - (let ([port (open-output-string)]) - (parameterize ([current-error-port port]) - (thunk)) - (get-output-string port))) - -;; `cross' pattern -(let () - (define-language lang - (e x (e e) v) - (v (λ (x) e)) - (x variable-not-otherwise-mentioned)) - (define-extended-language name-collision lang (e-e 47)) - - (test (generate-term/decisions - lang (cross e) 3 0 - (decisions #:nt (patterns fourth first first second first first first) - #:var (list (λ _ 'x) (λ _ 'y)))) - (term (λ (x) (hole y)))) - - (test (generate-term/decisions name-collision (cross e) 3 0 - (decisions #:nt (patterns first))) - (term hole)) - (test (generate-term/decisions name-collision e-e 3 0 - (decisions #:nt (patterns first))) - 47) - - (test (hash-ref (base-cases-non-cross (find-base-cases name-collision)) 'e-e) - '(0))) - -(let () - (define-language L - (a ((a ...) ...))) - (test (generate-term/decisions - L (cross a) 3 0 - (decisions #:nt (patterns second first) - #:seq (list (λ _ 0) (λ _ 0) (λ _ 0) (λ _ 0)))) - (term ((hole))))) - -;; generation failures increase size and attempt -(let () - (define-language L - (a d b) - (b d c) - (c e) - - (x variable)) - (test - (generate-term/decisions - L (side-condition a (eq? (term a) 'e)) 0 0 - ; It isn't possible for `a' to generate 'y until size is 2. - ; When size is 0, the generator has no choice but the 'x production. - ; When size is 1, the generator has a choice for `a' but not for `b'. - ; Supply enough first-production choices to cover the size 1 attempts - ; followed by the choices that produce 'y on the first size 2 attempt. - (decisions - #:nt (apply patterns - (append (build-list (* default-retries proportion-at-size) - (λ (_) first)) - (list second second first))))) - 'e) - - (test - (generate-term/decisions - L (side-condition x (number? (term x))) 0 0 - (decisions #:var (λ (lang-lits attempt) - (if (>= attempt retry-threshold) 0 'x)))) - 0) - - (let ([attempts null] - [start (sub1 retry-threshold)] - [finish (+ retry-threshold post-threshold-incr)]) - (generate-term/decisions - L (side-condition x (number? (term x))) 0 start - (decisions #:var (λ (lang-lits attempt) - (set! attempts (cons attempt attempts)) - (if (= attempt finish) 0 'x)))) - (test attempts (list finish retry-threshold start)))) - -;; output : (-> (-> void) string) -(define (output thunk) - (let ([p (open-output-string)]) - (parameterize ([current-output-port p]) - (unless (void? (thunk)) - (error 'output "expected void result"))) - (begin0 - (get-output-string p) - (close-output-port p)))) - -;; preferred productions -(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))]) - (define-language L - (e (+ e e) (* e e) 7)) - (define-language M (e 0) (e-e 1)) - - (let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))]) - (test - (generate-term/decisions - L e 2 preferred-production-threshold - (decisions #:pref (list (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L)))))))) - #:nt (make-pick-nt (make-random 0 0 0)))) - '(+ (+ 7 7) (+ 7 7))) - (test - (generate-term/decisions - L any 2 preferred-production-threshold - (decisions #:nt (patterns first) - #:var (list (λ _ 'x)) - #:any (list (λ (lang sexp) (values sexp 'sexp))))) - 'x) - (test - (generate-term/decisions - L any 2 preferred-production-threshold - (decisions #:pref (list (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L)))))))) - #:nt (make-pick-nt (make-random 0 0 0)) - #:any (list (λ (lang sexp) (values lang 'e))))) - '(+ (+ 7 7) (+ 7 7))) - (test - (generate-term/decisions - M (cross e) 2 preferred-production-threshold - (decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t)))) - (term hole)) - (test - (generate-term/decisions - M e-e 2 preferred-production-threshold - (decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t)))) - 1) - - (test - (let ([generated null]) - (output - (λ () - (check-reduction-relation - (reduction-relation L (--> e e)) - (λ (t) (set! generated (cons t generated))) - #:decisions (decisions #:nt (make-pick-nt (make-random) - (λ (att rand) #t)) - #:pref (list (λ (_) 'dontcare) - (λ (_) 'dontcare) - (λ (_) 'dontcare) - ; size 0 terms prior to this attempt - (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L))))))) - (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(cadr (pats L))))))))) - #:attempts 5))) - generated) - '((* 7 7) (+ 7 7) 7 7 7)))) - -;; redex-check -(let () - (define-language lang - (d 5) - (e e 4) - (n number)) - (test (output (λ () (redex-check lang d #f))) - #rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n") - (test (output (λ () (redex-check lang d #t))) - #rx"redex-check: .*:.*\nno counterexamples in 1000 attempts\n") - (let-syntax ([noloc (λ (stx) - (syntax-case stx () - [(_ e) (datum->syntax stx (syntax->datum #'e) #f)]))]) - (test (output (λ () (noloc (redex-check lang d #t)))) - "redex-check: no counterexamples in 1000 attempts\n")) - (test (output (λ () (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2))) - #rx"no counterexamples") - (test (output (λ () (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2))) - #rx"no counterexamples") - (test (output (λ () (redex-check lang (d e) #f))) - #rx"counterexample found after 1 attempt:\n\\(5 4\\)\n") - (let* ([p (open-output-string)] - [m (parameterize ([current-output-port p]) - (with-handlers ([exn:fail? exn-message]) - (redex-check lang d (error 'pred-raised)) - 'no-exn-raised))]) - (test m "error: pred-raised") - (test (get-output-string p) #rx"checking 5 raises.*\n$") - (close-output-port p)) - - (test (output - (λ () - (redex-check lang n (eq? 42 (term n)) - #:attempts 1 - #:source (reduction-relation - lang - (--> 42 dontcare) - (--> 0 dontcare z))))) - #rx"counterexample found after 1 attempt with z:\n0\n") - - (let ([generated null]) - (test (output - (λ () - (redex-check lang n (set! generated (cons (term n) generated)) - #:attempts 5 - #:source (reduction-relation - lang - (--> 1 dontcare) - (--> 2 dontcare))))) - #rx"no counterexamples.*with each clause") - (test generated '(2 2 1 1))) - - (let () - (define-metafunction lang - [(mf 42) dontcare] - [(mf 0) dontcare]) - (test (output - (λ () - (redex-check lang (n) (eq? 42 (term n)) - #:attempts 1 - #:source mf))) - #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")) - - (let () - (define-metafunction lang - [(f) - dontcare - (side-condition #f)]) - (test (raised-exn-msg - exn:fail:redex:generation-failure? - (redex-check lang any #t - #:attempts 1 - #:source f)) - #px"unable to generate LHS of clause at .*:\\d+:\\d+")) - - (let () - (define-metafunction lang - [(mf d e) dontcare]) - (test (output - (λ () - (redex-check lang (number_1 number_2) - (and (= (term number_1) 5) - (= (term number_2) 4)) - #:attempts 1 - #:source mf))) - #rx"no counterexamples")) - - (test (raised-exn-msg - exn:fail:redex? - (redex-check lang n #t #:source (reduction-relation lang (--> x 1)))) - #rx"x does not match n") - (test (raised-exn-msg - exn:fail:redex:generation-failure? - (redex-check lang (side-condition any #f) #t #:retries 42 #:attempts 1)) - #rx"^redex-check: unable .* in 42") - (let ([unable-loc #px"^redex-check: unable to generate LHS of clause at .*:\\d+:\\d+ in 42"]) - (let-syntax ([test-gen-fail - (syntax-rules () - [(_ clauses ... expected) - (test - (raised-exn-msg - exn:fail:redex:generation-failure? - (redex-check lang any #t - #:source (reduction-relation - lang - clauses ...) - #:retries 42 - #:attempts 1)) - expected)])]) - (test-gen-fail - (--> (side-condition any #f) any) - unable-loc) - - (test-gen-fail - (==> (side-condition any #f) any) - with [(--> a b) (==> a b)] - unable-loc) - - (test-gen-fail - (--> (side-condition any #f) any impossible) - #rx"^redex-check: unable to generate LHS of impossible in 42")))) - -;; check-metafunction-contract -(let () - (define-language empty) - (define-metafunction empty - f : (side-condition number_1 (odd? (term number_1))) -> number - [(f 1) 1] - [(f 3) 'NaN]) - - (define-metafunction empty - g : number ... -> (any ...) - [(g number_1 ... 1 number_2 ...) (number_1 ...)]) - - (define-metafunction empty - h : number -> number - [(h any) any]) - - (define-metafunction empty - [(i any ...) (any ...)]) - - (define-metafunction empty - j : (side-condition any #f) -> any - [(j any ...) (any ...)]) - - ;; Dom(f) < Ctc(f) - (test (output - (λ () - (parameterize ([generation-decisions - (decisions #:num (list (λ _ 2) (λ _ 5)))]) - (check-metafunction-contract f)))) - #rx"check-metafunction-contract:.*counterexample found after 1 attempt:\n\\(5\\)\n") - ;; Rng(f) > Codom(f) - (test (output - (λ () - (parameterize ([generation-decisions - (decisions #:num (list (λ _ 3)))]) - (check-metafunction-contract f)))) - #rx"counterexample found after 1 attempt:\n\\(3\\)\n") - ;; LHS matches multiple ways - (test (output - (λ () - (parameterize ([generation-decisions - (decisions #:num (list (λ _ 1) (λ _ 1)) - #:seq (list (λ _ 2)))]) - (check-metafunction-contract g)))) - #rx"counterexample found after 1 attempt:\n\\(1 1\\)\n") - ;; OK -- generated from Dom(h) - (test (output (λ () (check-metafunction-contract h))) #rx"no counterexamples") - ;; OK -- generated from pattern (any ...) - (test (output (λ () (check-metafunction-contract i #:attempts 5))) #rx"no counterexamples") - - ;; Unable to generate domain - (test (raised-exn-msg - exn:fail:redex:generation-failure? - (check-metafunction-contract j #:attempts 1 #:retries 42)) - #rx"^check-metafunction-contract: unable .* in 42")) - -;; check-reduction-relation -(let () - (define-language L - (e (+ e ...) number) - (E (+ number ... E* e ...)) - (E* hole E*) - (n 4)) - - (let ([generated null] - [R (reduction-relation - L - (==> (+ number ...) whatever) - (--> (side-condition number (even? (term number))) whatever) - with - [(--> (in-hole E a) whatever) - (==> a b)])]) - (test (begin - (output - (λ () - (check-reduction-relation - R (λ (term) (set! generated (cons term generated))) - #:decisions (decisions #:seq (list (λ _ 0) (λ _ 0) (λ _ 0)) - #:num (list (λ _ 1) (λ _ 1) (λ _ 0))) - #:attempts 1))) - generated) - (reverse '((+ (+)) 0)))) - - (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) - (test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) - #rx"check-reduction-relation:.*no counterexamples") - (test (output - (λ () (check-reduction-relation S (λ (x) #f)))) - #rx"counterexample found after 1 attempt with name:\n1\n") - (test (output - (λ () (check-reduction-relation S (curry eq? 1)))) - #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n3\n")) - - (test (output - (λ () (check-reduction-relation (reduction-relation L (--> 1 2) (--> 3 4 name)) (curry eq? 1)))) - #px"counterexample found after 1 attempt with name:\n3\n") - - (let ([T (reduction-relation - L - (==> number number - (where any_num number) - (side-condition (eq? (term any_num) 4)) - (where any_numb any_num) - (side-condition (eq? (term any_numb) 4))) - with - [(--> (9 a) b) - (==> a b)])]) - (test (output - (λ () - (check-reduction-relation - T (curry equal? '(9 4)) - #:attempts 1 - #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x))))))) - #rx"no counterexamples")) - - (let ([U (reduction-relation L (--> (side-condition any #f) any))]) - (test (raised-exn-msg - exn:fail:redex:generation-failure? - (check-reduction-relation U (λ (_) #t))) - #rx"^check-reduction-relation: unable"))) - -; check-metafunction -(let () - (define-language empty) - - (define-metafunction empty - [(m 1) whatever] - [(m 2) whatever]) - (define-metafunction empty - [(n (side-condition any #f)) any]) - - (let ([generated null]) - (test (begin - (output - (λ () - (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1))) - generated) - (reverse '((1) (2))))) - - (test - (let/ec k - (define-language L (n 2)) - (define-metafunction L - [(f n) - n - (where number_2 ,(add1 (term n))) - (where number_3 ,(add1 (term number_2))) - (side-condition (k (term number_3)))] - [(f any) 0]) - (check-metafunction f (λ (_) #t))) - 4) - - (test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples") - (test (output (λ () (check-metafunction m (curry eq? 1)))) - #px"check-metafunction:.*counterexample found after 1 attempt with clause at .*:\\d+:\\d+") - (test (raised-exn-msg - exn:fail:contract? - (check-metafunction m (λ (_) #t) #:attempts 'NaN)) - #rx"check-metafunction: expected") - (test (raised-exn-msg - exn:fail:redex:generation-failure? - (check-metafunction n (λ (_) #t) #:retries 42)) - #rx"check-metafunction: unable .* in 42")) - -;; custom generators -(let () - (define-language L - (x variable)) - - (test - (generate-term - L x_1 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['x (values 'x env)] - [_ (def acc)]))) - 'x) - (test - (let/ec k - (equal? - (generate-term - L (x x) 0 - #:custom (let ([once? #f]) - (λ (pat sz i-h acc env att rec def) - (match pat - ['x (if once? - (k #f) - (begin - (set! once? #t) - (values 'x env)))] - [_ (def acc)])))) - '(x x))) - #t) - - (test - (hash-ref - (let/ec k - (generate-term - L (x (x)) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - [(struct binder ('x)) - (values 'y (hash-set env pat 'y))] - [(list (struct binder ('x))) (k env)] - [_ (def acc)])))) - (make-binder 'x)) - 'y) - - (test - (generate-term - L (in-hole hole 7) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - [`(in-hole hole 7) - (rec 'hole #:contractum 7)] - [_ (def acc)]))) - 7) - - (test - (let/ec k - (generate-term - L any 10 - #:attempt 42 - #:custom (λ (pat sz i-h acc env att rec def) (k (list sz att))))) - '(10 42)) - - (test - (let/ec k - (generate-term - L x 10 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['x (rec 7 #:size 0)] - [7 (k sz)] - [_ (def att)])))) - 0) - - (test - (generate-term - L (q 7) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['q (rec '(7 7) #:acc 8)] - [7 (values (or acc 7) env)] - [_ (def att)]))) - '((8 8) 7))) - -;; 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))) - expected)])) - - (test-class-reassignments - '(x_1 ..._1 x_2 ..._2 x_2 ..._1) - '((..._2 . ..._1))) - (test-class-reassignments - '((x_1 ..._1 x_1 ..._2) (x_2 ..._1 x_2 ..._2) x_3 ..._2) - '((..._1 . ..._2) (..._2 . ..._2))) - (test-class-reassignments - '(x_1 ..._1 x ..._2 x_1 ..._2) - '((..._1 . ..._2))) - (test-class-reassignments - '(x_1 ..._1 x_2 ..._2 (x_1 x_2) ..._3) - '((..._1 . ..._3) (..._2 . ..._3))) - (test-class-reassignments - '((x_1 ..._1) ..._2 x_2 ..._3 (x_1 ..._4 x_2) ..._5) - '((..._1 . ..._4) (..._2 . ..._5) (..._3 . ..._5))) - (test-class-reassignments - '((x_1 ..._1) ..._2 (x_1 ..._3) ..._4 (x_1 ..._5) ..._6) - '((..._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) - '((..._1 . ..._3) (..._2 . ..._3) (..._4 . ..._3))) - (test - (hash-map - (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1) lang 'top-level)) - (λ (_ cls) cls)) - '(..._1 ..._1)) - (test-class-reassignments - '((3 ..._1) ..._2 (4 ..._1) ..._3) - '((..._2 . ..._3))) - (test-class-reassignments - '(x ..._1 x ..._2 variable ..._2 variable ..._3 variable_1 ..._3 variable_1 ..._4) - '((..._1 . ..._4) (..._2 . ..._4) (..._3 . ..._4)))) - -(print-tests-passed 'rg-test.ss) diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss deleted file mode 100644 index 4ec5971dc6..0000000000 --- a/collects/redex/private/run-tests.ss +++ /dev/null @@ -1,41 +0,0 @@ -;; require this file to run all of the test suites for redex. - -#lang scheme/base -(require scheme/runtime-path - "config.ss" - "test-util.ss") - -(set-show-bitmaps? #t) - -(define test-files - '("lw-test.ss" - "matcher-test.ss" - "tl-test.ss" - "term-test.ss" - "rg-test.ss" - "keyword-macros-test.ss" - "core-layout-test.ss" - "bitmap-test.ss" - "pict-test.ss" - "hole-test.ss")) - -(define-runtime-path here ".") - -(define (flush) - ;; these flushes are here for running under cygwin, - ;; which somehow makes mzscheme think it isn't using - ;; an interative port - (flush-output (current-error-port)) - (flush-output (current-output-port))) - -(for-each - (λ (test-file) - (flush) - (printf "requiring ~a\n" test-file) - (flush) - (dynamic-require (build-path here test-file) #f) - (flush)) - test-files) - -(printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n") -(flush) diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss deleted file mode 100644 index 25059c7bbf..0000000000 --- a/collects/redex/private/term-test.ss +++ /dev/null @@ -1,177 +0,0 @@ -(module term-test scheme - (require "term.ss" - "matcher.ss" - "test-util.ss") - - (reset-count) - (test (term 1) 1) - (test (term (1 2)) (list 1 2)) - (test (term (1 ,(+ 1 1))) (list 1 2)) - (test (term-let ([x 1]) (term (x x))) (list 1 1)) - (test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3))) - - (test (term (in-hole (1 hole) 2)) (term (1 2))) - (test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x)))) - - (test (equal? (term hole) (term hole)) #t) - (test (hole? (term hole)) #t) - (test (hole? (term (hole #f))) #f) - (test (hole? (term (hole the-name))) #f) - - (test (term-let-fn ((f (lambda (q) q))) - (term (f 1 2 3))) - (term (1 2 3))) - - (test (term-let-fn ((f (lambda (q) `(y ,(car q))))) - (term (f (zzzz)))) - (term (y (zzzz)))) - - (test (term-let-fn ((f (λ (x) (add1 (car x))))) - (term (f 2))) - (term 3)) - - (test (term-let ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))]) - (term-let-fn ((f (λ (x) (car x)))) - (term ((qq (f x) ...) ...)))) - (term ((qq 1 1) (qq 2 2) (qq 3 3)))) - - (test (term-let-fn ((f (lambda (x) (car x)))) - (term (f hole))) - (term hole)) - - (test (term-let-fn ((f (lambda (q) `(y ,(car q))))) - (term-let-fn ((g (lambda (x) `(ff ,(car x))))) - (term (g (f (zzzz)))))) - (term (ff (y (zzzz))))) - - (test (term-let-fn ((f (lambda (q) `(y ,(car q))))) - (term-let-fn ((g (lambda (x) `(ff ,(car x))))) - (term (f (g (f (zzzz))))))) - (term (y (ff (y (zzzz)))))) - - (test (term-let ([x 1]) - (term (x . y))) - (term (1 . y))) - - (test (term-let ([(x ...) (list 3 2 1)]) - (term (x ... . y))) - (term (3 2 1 . y))) - - (test (term-let ([(x . y) (cons 1 2)]) - (term (x y))) - (term (1 2))) - - ;; test that the implicit `plug' inserted by `in-hole' - ;; deals with ellipses properly - (test (term-let ([(E ...) '(1 2 3)]) - (term ((in-hole E x) ...))) - (term (1 2 3))) - - (test (term-let-fn ((metafun car)) - (term-let ((x 'whatever) - ((y ...) '(4 5 6))) - (term (((metafun x) y) ...)))) - '((whatever 4) (whatever 5) (whatever 6))) - - (test (term-let-fn ((metafun (λ (x) (car x)))) - (term-let (((y ...) '(4 5 6))) - (term ((y (metafun 1)) ...)))) - '((4 1) (5 1) (6 1))) - - (test (term-let-fn ((f (compose add1 car))) - (term-let (((x ...) '(1 2 3)) - ((y ...) '(a b c))) - (term (((f x) y) ...)))) - '((2 a) (3 b) (4 c))) - - (test (term-let-fn ((f (curry foldl + 0))) - (term-let (((x ...) '(1 2 3))) - (term (f x ...)))) - 6) - - (test (term-let-fn ((f (compose add1 car))) - (term-let (((x ...) '(1 2 3)) - (((y ...) ...) '((a b c) (d e f) (g h i)))) - (term ((((f x) y) ...) ...)))) - '(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i)))) - - (test (term-let-fn ((f (curry foldl + 0))) - (term-let ((((x ...) ...) '((1 2) (3 4 5) (6)))) - (term ((f x ...) ...)))) - '(3 12 6)) - - (define-namespace-anchor here) - (define ns (namespace-anchor->namespace here)) - - (let ([src 'term-template]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term (((x y) ...) ...))) - src)) - src)) - - (let ([src 'term-template-metafunc]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term ((((f x) y) ...) ...)))) - src)) - src)) - - (let ([src 'ellipsis-args]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term (f ((x y) ...))))) - src)) - src)) - - (let ([src 'ellipsis-args/map]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term ((f (x y)) ...)))) - src)) - src)) - - (let ([src 'ellipsis-args/in-hole]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term ((in-hole hole (x y)) ...))) - src)) - src)) - - (let ([src 'term-let-rhs]) - (test - (parameterize ([current-namespace ns]) - (runtime-error-source - '(term-let ([(x ...) 'a]) - 3) - src)) - src)) - - (let ([src 'term-template]) - (test - (parameterize ([current-namespace ns]) - (syntax-error-sources - '(term-let ([(x ...) '(a b c)]) - (term x)) - src)) - (list src))) - - (print-tests-passed 'term-test.ss)) diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss deleted file mode 100644 index 491f32af3c..0000000000 --- a/collects/redex/private/test-util.ss +++ /dev/null @@ -1,132 +0,0 @@ -#lang scheme - -(require "matcher.ss" - errortrace/errortrace-lib - errortrace/errortrace-key) -(provide test test-syn-err tests reset-count - syn-err-test-namespace - print-tests-passed - equal/bindings? - runtime-error-source syntax-error-sources) - -(define syn-err-test-namespace (make-base-namespace)) -(parameterize ([current-namespace syn-err-test-namespace]) - (eval '(require redex/reduction-semantics))) - -(define-syntax (test stx) - (syntax-case stx () - [(_ expected got) - (with-syntax ([line (syntax-line (syntax got))] - [fn (if (path? (syntax-source (syntax got))) - (path->string (syntax-source (syntax got))) - "")]) - (syntax/loc stx (test/proc (λ () expected) got line fn)))])) - -(define-syntax (test-syn-err stx) - (syntax-case stx () - [(_ exp regexp) - (syntax/loc stx - (test - (parameterize ([current-namespace syn-err-test-namespace]) - (with-handlers ((exn:fail:syntax? exn-message)) - (expand 'exp) - 'no-error-raised)) - regexp))])) - -(define tests 0) -(define failures 0) -(define (reset-count) - (set! tests 0) - (set! failures 0)) - -(define (print-tests-passed filename) - (cond - [(= 0 failures) - (printf "~a: all ~a tests passed.\n" filename tests)] - [else - (printf "~a: ~a test~a failed.\n" filename failures (if (= 1 failures) "" "s"))])) - -(define (test/proc run expected line filename) - ;(printf "testing line ~s:~s\n" filename line) - (let ([got (with-handlers ((exn:fail? values)) (run))]) - (set! tests (+ tests 1)) - (unless (and (not (exn? got)) - (matches? got expected)) - (set! failures (+ 1 failures)) - (fprintf (current-error-port) - "test/proc: file ~a line ~a:\n got ~s\nexpected ~s\n\n" - filename - line - got - expected)))) - -(define (matches? got expected) - (cond - [(regexp? expected) - (and (string? got) (regexp-match expected got) #t)] - [else - (equal/bindings? got expected)])) - -;; equal/bindings? : any any -> boolean -;; compares two sexps (with embedded bindings) for equality. -;; uses an order-insensitive comparison for the bindings -(define (equal/bindings? fst snd) - (let loop ([fst fst] - [snd snd]) - (cond - [(pair? fst) - (and (pair? snd) - (loop (car fst) (car snd)) - (loop (cdr fst) (cdr snd)))] - [(mtch? fst) - (and (mtch? snd) - (loop (mtch-bindings fst) - (mtch-bindings snd)) - (let ([g1 (gensym 'run-match-test-sym)]) - (equal/bindings? (mtch-context fst) - (mtch-context snd))) - (equal/bindings? (mtch-hole fst) - (mtch-hole snd)))] - [(bindings? fst) - (and (bindings? snd) - (let ([fst-table (bindings-table fst)] - [snd-table (bindings-table snd)]) - (and (= (length fst-table) - (length snd-table)) - (andmap - loop - (sort fst-table rib-lt) - (sort snd-table rib-lt)))))] - [(and (bind? fst) - (bind? snd) - (context? (bind-exp fst)) - (context? (bind-exp snd))) - (and (equal? (bind-name fst) (bind-name snd)) - (let ([g (gensym 'run-match-test-sym2)]) - (equal/bindings? (bind-exp fst) - (bind-exp snd))))] - [(and (hole? fst) - (hole? snd)) - #t] - [else (equal? fst snd)]))) - -;; rib-lt : rib rib -> boolean -(define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1)) - (format "~s" (bind-name r2)))) - -(define (runtime-error-source sexp src) - (let/ec return - (cadar - (continuation-mark-set->list - (exn-continuation-marks - (with-handlers ((exn:fail? values)) - (parameterize ([current-compile (make-errortrace-compile-handler)]) - (eval (read-syntax src (open-input-string (format "~s" sexp))))) - (return 'no-source))) - errortrace-key)))) - -(define (syntax-error-sources sexp src) - (let ([p (read-syntax src (open-input-string (format "~s" sexp)))]) - (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x))))) - (expand p) - null))) \ No newline at end of file diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss deleted file mode 100644 index 8dd90a3884..0000000000 --- a/collects/redex/private/tl-test.ss +++ /dev/null @@ -1,1850 +0,0 @@ -(module tl-test scheme - (require "../reduction-semantics.ss" - "test-util.ss" - (only-in "matcher.ss" make-bindings make-bind) - scheme/match - "struct.ss") - - (reset-count) - - -; -; -; ;; -; ; -; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; -; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; -; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; -; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; -; ; ; -; ;;; ;;; -; -; - - - (define-language empty-language) - - (define-language grammar - (M (M M) - number) - (E hole - (E M) - (number E)) - (X (number any) - (any number)) - (Q (Q ...) - variable) - (UN (add1 UN) - zero)) - - (test (pair? (redex-match grammar M '(1 1))) #t) - (test (pair? (redex-match grammar M '(1 1 1))) #f) - (test (pair? (redex-match grammar - (side-condition (M_1 M_2) (equal? (term M_1) (term M_2))) - '(1 1))) - #t) - (test (pair? (redex-match grammar - (side-condition (M_1 M_2) (equal? (term M_1) (term M_2))) - '(1 2))) - #f) - - (test (pair? ((redex-match grammar M) '(1 1))) - #t) - - ;; next 3: test naming of subscript-less non-terminals - (test (pair? (redex-match grammar (M M) (term (1 1)))) #t) - (test (pair? (redex-match grammar (M M) (term (1 2)))) #f) - (test (pair? (redex-match grammar (M_1 M_2) (term (1 2)))) #t) - - (define-language base-grammar - (q 1) - (e (+ e e) number) - (x (variable-except +))) - - (define-extended-language extended-grammar - base-grammar - (e .... (* e e)) - (x (variable-except + *)) - (r 2)) - - (test (pair? (redex-match extended-grammar e '(+ 1 1))) #t) - (test (pair? (redex-match extended-grammar e '(* 2 2))) #t) - (test (pair? (redex-match extended-grammar r '2)) #t) - (test (pair? (redex-match extended-grammar q '1)) #t) - (test (pair? (redex-match extended-grammar x '*)) #f) - (test (pair? (redex-match extended-grammar x '+)) #f) - (test (pair? (redex-match extended-grammar e '....)) #f) - - ;; make sure that `language' with a four period ellipses signals an error - (test (regexp-match #rx"[.][.][.][.]" (with-handlers ([exn? exn-message]) - (let () - (define-language x (e ....)) - 12))) - '("....")) - - - - ;; test multiple variable non-terminals - (let () - (define-language lang - ((l m) (l m) x) - (x variable-not-otherwise-mentioned)) - (test (pair? (redex-match lang m (term x))) - #t)) - - ;; test multiple variable non-terminals - (let () - (define-language lang - ((l m) (l m) x) - (x variable-not-otherwise-mentioned)) - (test (pair? (redex-match lang l (term x))) - #t)) - - (let () - (define-language lang - ((x y) 1 2 3)) - (define-extended-language lang2 lang - (x .... 4)) - (test (pair? (redex-match lang2 x 4)) #t) - (test (pair? (redex-match lang2 y 4)) #t) - (test (pair? (redex-match lang2 x 1)) #t) - (test (pair? (redex-match lang2 y 2)) #t)) - - ;; test that the variable "e" is not bound in the right-hand side of a side-condition - ;; this one signaled an error at some point - (let () - (define-language bad - (e 2 (side-condition (e) #t))) - (test (pair? (redex-match bad e '(2))) - #t)) - - ;; test that the variable "e" is not bound in the right-hand side of a side-condition - ;; this one tests to make sure it really isn't bound - (let ([x #f]) - (define-language bad - (e 2 (side-condition (e) (set! x (term e))))) - (redex-match bad e '(2)) - (test x 'e)) - - ;; test multiple variable non-terminals being extended - (let () - (define-language lang - ((x y) 1 2 3)) - (define-extended-language lang2 lang - (x .... 4)) - (test (pair? (redex-match lang2 x 4)) #t) - (test (pair? (redex-match lang2 y 4)) #t) - (test (pair? (redex-match lang2 x 1)) #t) - (test (pair? (redex-match lang2 y 2)) #t)) - - ;; test multiple variable non-terminals in an extended language - (let () - (define-language lang - ((x y) 1 2 3)) - (define-extended-language lang2 lang - ((z w) 5 6 7)) - (test (pair? (redex-match lang2 z 5)) #t) - (test (pair? (redex-match lang2 w 6)) #t)) - - ;; test cases that ensure that extending any one of a - ;; multiply defined non-terminal gets extended properly - (let () - (define-language iswim - ((V U W) AA)) - - (define-extended-language iswim-cont - iswim - (W .... QQ)) - - (test (pair? (redex-match iswim-cont U (term QQ))) - #t)) - - (let () - (define-language iswim - ((V U W) AA)) - - (define-extended-language iswim-cont - iswim - (W .... QQ)) - - (test (pair? (redex-match iswim-cont V (term QQ))) - #t) - (test (pair? (redex-match iswim-cont U (term QQ))) - #t) - (test (pair? (redex-match iswim-cont W (term QQ))) - #t)) - - (let () - (define-language iswim - ((V U W) AA)) - - (define-extended-language iswim-cont - iswim - (V .... QQ)) - - (test (pair? (redex-match iswim-cont V (term QQ))) - #t) - (test (pair? (redex-match iswim-cont U (term QQ))) - #t) - (test (pair? (redex-match iswim-cont W (term QQ))) - #t)) - - (let () - (define-language okay - [(X Y) z]) - - (define-extended-language replace-both - okay - [(X Y) q]) - - ;; this test ran into an infinite loop in an earlier version of redex. - (test (redex-match replace-both X (term explode)) #f)) - - (test (with-handlers ([exn? exn-message]) - (let () - (define-language main - [(X Y) z]) - (define-extended-language new - main - [(X Y Z) q]) - (void))) - "extend-language: new language extends old non-terminal X and also adds new shortcut Z") - - (test (with-handlers ([exn? exn-message]) - (let () - (define-language main - [(X Y) z] - [(P Q) w]) - (define-extended-language new - main - [(X P) q]) - (void))) - "extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language") - - ;; test caching - (let () - (define match? #t) - - (define-language lang - (x (side-condition any match?))) - - (test (pair? (redex-match lang x 1)) #t) - (set! match? #f) - (test (pair? (redex-match lang x 1)) #t) - (parameterize ([caching-enabled? #f]) - (test (pair? (redex-match lang x 1)) #f))) - - - (let () - (define sc-eval-count 0) - (define-language lang - (x (side-condition any (begin (set! sc-eval-count (+ sc-eval-count 1)) - #t)))) - - (redex-match lang x 1) - (redex-match lang x 1) - (parameterize ([caching-enabled? #f]) - (redex-match lang x 1)) - (test sc-eval-count 2)) - - (let () - (define rhs-eval-count 0) - (define-metafunction empty-language - [(f any) ,(begin (set! rhs-eval-count (+ rhs-eval-count 1)) - 1)]) - - (term (f 1)) - (term (f 1)) - (parameterize ([caching-enabled? #f]) - (term (f 1))) - (test rhs-eval-count 2)) - - (define-namespace-anchor here) - (define ns (namespace-anchor->namespace here)) - - (let ([src 'bad-underscore]) - (test - (parameterize ([current-namespace ns]) - (syntax-error-sources - '(define-language L (n m_1)) - src)) - (list src))) - -; -; -; ;;; ; -; ; ; ; -; ;;; ; ;;; ;;;;; ;;; ;;;;; ;; ;; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;;;; -; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; -; ; ; ; ;;;;; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;;;;;; ;;;; ;;; ;;;;; ;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;; -; -; -; -; - - - (define-metafunction grammar - [(f (side-condition (number_1 number_2) - (< (term number_1) - (term number_2)))) - x] - [(f (number 1)) y] - [(f (number_1 2)) ,(+ (term number_1) 2)] - [(f (4 4)) q] - [(f (4 4)) r]) - - (define-metafunction grammar - [(g X) x]) - - (test (term (f (1 17))) 'x) - (test (term (f (11 1))) 'y) - (test (term (f (11 2))) 13) - - - ;; match two clauess => take first one - (test (term (f (4 4))) 'q) - - ;; match one clause two ways => error - (let () - (define-metafunction empty-language - [(ll (number_1 ... number_2 ...)) (number_1 ...)]) - (test (with-handlers ((exn? (λ (x) 'exn-raised))) - (term (ll ())) - 'no-exn) - 'no-exn) - (test (with-handlers ((exn? (λ (x) 'exn-raised))) - (term (ll (4 4))) - 'no-exn) - 'exn-raised)) - - ;; match no ways => error - (test (with-handlers ((exn? (λ (x) 'exn-raised))) (term (f mis-match)) 'no-exn) - 'exn-raised) - - (define-metafunction grammar - [(h (M_1 M_2)) ((h M_2) (h M_1))] - [(h number_1) ,(+ (term number_1) 1)]) - - (test (term (h ((1 2) 3))) - (term (4 (3 2)))) - - (define-metafunction grammar - [(h2 (Q_1 ...)) ((h2 Q_1) ...)] - [(h2 variable) z]) - - (test (term (h2 ((x y) a b c))) - (term ((z z) z z z))) - - (let () - (define-metafunction empty-language - [(f (1)) 1] - [(f (2)) 2] - [(f 3) 3]) - (test (in-domain? (f 1)) #f) - (test (in-domain? (f (1))) #t) - (test (in-domain? (f ((1)))) #f) - (test (in-domain? (f 3)) #t) - (test (in-domain? (f 4)) #f)) - - (let () - (define-metafunction empty-language - f : number -> number - [(f 1) 1]) - (test (in-domain? (f 1)) #t) - (test (in-domain? (f 2)) #t) - (test (in-domain? (f x)) #f)) - - (let () - (define-metafunction empty-language - [(f x) x]) - (test - (term-let ((y 'x)) - (in-domain? (f y))) - #t) - (test - (term-let ((y 'z)) - (in-domain? (f y))) - #f)) - - ;; mutually recursive metafunctions - (define-metafunction grammar - [(odd zero) #f] - [(odd (add1 UN_1)) (even UN_1)]) - - (define-metafunction grammar - [(even zero) #t] - [(even (add1 UN_1)) (odd UN_1)]) - - (test (term (odd (add1 (add1 (add1 (add1 zero)))))) - (term #f)) - - (let () - (define-metafunction empty-language - [(pRe xxx) 1]) - - (define-metafunction empty-language - [(Merge-Exns any_1) any_1]) - - (test (term (pRe (Merge-Exns xxx))) - 1)) - - (let () - (define-metafunction empty-language - [(f (x)) ,(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup)))] - [(f y) y] - [(f var-should-be-lookedup) var-should-be-lookedup]) ;; taking this case is bad! - - (test (term (f (x))) (term y))) - - (let () - (define-metafunction empty-language - [(f (x)) (x ,@(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup))) x)] - [(f y) (y)] - [(f var-should-be-lookedup) (var-should-be-lookedup)]) ;; taking this case is bad! - - (test (term (f (x))) (term (x y x)))) - - (let () - (define-metafunction empty-language - [(f (any_1 any_2)) - case1 - (side-condition (not (equal? (term any_1) (term any_2)))) - (side-condition (not (equal? (term any_1) 'x)))] - [(f (any_1 any_2)) - case2 - (side-condition (not (equal? (term any_1) (term any_2))))] - [(f (any_1 any_2)) - case3]) - (test (term (f (q r))) (term case1)) - (test (term (f (x y))) (term case2)) - (test (term (f (x x))) (term case3))) - - (let () - (define-metafunction empty-language - [(f (n number)) (n number)] - [(f (a any)) (a any)] - [(f (v variable)) (v variable)] - [(f (s string)) (s string)]) - (test (term (f (n 1))) (term (n 1))) - (test (term (f (a (#f "x" whatever)))) (term (a (#f "x" whatever)))) - (test (term (f (v x))) (term (v x))) - (test (term (f (s "x"))) (term (s "x")))) - - ;; test ..._1 patterns - (let () - (define-metafunction empty-language - [(zip ((variable_id ..._1) (number_val ..._1))) - ((variable_id number_val) ...)]) - - (test (term (zip ((a b) (1 2)))) (term ((a 1) (b 2))))) - - (let () - (define-metafunction empty-language - [(f any_1 any_2 any_3) (any_3 any_2 any_1)]) - (test (term (f 1 2 3)) - (term (3 2 1)))) - - (let () - (define-metafunction empty-language - [(f (any_1 any_2 any_3)) 3]) - (define-metafunction/extension f empty-language - [(g (any_1 any_2)) 2]) - (define-metafunction/extension g empty-language - [(h (any_1)) 1]) - (test (term (h (1))) 1) - (test (term (h (1 2))) 2) - (test (term (h (1 2 3))) 3)) - - (let () - (define-metafunction empty-language - [(f any_1 any_2 any_3) 3]) - (define-metafunction/extension f empty-language - [(g any_1 any_2) 2]) - (define-metafunction/extension g empty-language - [(h any_1) 1]) - (test (term (h 1)) 1) - (test (term (h 1 2)) 2) - (test (term (h 1 2 3)) 3)) - - (let () - (define-metafunction empty-language - [(f number_1 number_2) (f number_1)]) - (define-metafunction/extension f empty-language - [(g number_1) number_1]) - (define-metafunction empty-language - [(h number_1 number_2) (h number_1)] - [(h number_1) number_1]) - (test (term (g 11 17)) 11) - (test (term (h 11 17)) 11)) - - (let () - (define-metafunction empty-language - [(f (number_1 number_2)) - number_3 - (where number_3 ,(+ (term number_1) (term number_2)))]) - (test (term (f (11 17))) 28)) - - (let () - (define-metafunction empty-language - [(f variable) - (any_x any_x) - (where any_x (variable variable))]) - (test (term (f z)) - (term ((z z) (z z))))) - - (let () - (define-metafunction empty-language - [(f number_1) - number_1 - (where number_2 ,(add1 (term number_1))) - (where number_3 ,(add1 (term number_2))) - (side-condition (and (number? (term number_3)) - (= (term number_3) 4)))] - [(f any) 0]) - (test (term (f 2)) 2)) - - (let () - (define-language x-lang - (x variable)) - (define-metafunction x-lang - f : x x -> x - [(f x_1 x_2) x_1]) - (test (term (f p q)) (term p)) - (test (in-domain? (f p q)) #t)) - - (let () - (define-metafunction empty-language - [(err number_1 ... number_2 ...) (number_1 ...)]) - (test (term (err)) (term ())) - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - (term (err 1 2)) - 'no-exn) - 'right-exn)) - - (let () - (define-metafunction empty-language - err : number ... -> number - [(err number ...) 1]) - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - (term (err #f #t)) - 'no-exn) - 'right-exn)) - - (let () - (define-metafunction empty-language - err : number ... -> number - [(err number ...) #f]) - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - (term (err 1 2)) - 'no-exn) - 'right-exn)) - - (let () - (define-metafunction empty-language - err : number ... -> (number number) - [(err number ...) (number ...)]) - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - (term (err 1 2)) - 'no-exn) - 'no-exn) - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - (term (err 1 1)) - 'no-exn) - 'no-exn)) - - (let () - ;; test that 'where' clauses can contain recursive calls. - (define-metafunction empty-language - [(f (any)) - x - (where x (f any))] - [(f any) any]) - (test (term (f ((((x)))))) - (term x))) - - (let () - (define-language lamv - (z variable hole)) - - (define-metafunction lamv - foo : z -> any - [(foo hole) dontcare] - [(foo variable) docare]) - - (test (term (foo hole)) - (term dontcare)) - (test (term (foo y)) - (term docare))) - - (let () - (define f-called? #f) - (define-metafunction empty-language - f : (side-condition any_1 (begin (set! f-called? #t) #t)) -> any - [(f any_1) any_1]) - (test (term (f 1)) 1) - (test f-called? #t)) - - (let () - (define g-called? #f) - (define-metafunction empty-language - g : any -> (side-condition any_1 (begin (set! g-called? #t) #t)) - [(g any_1) any_1]) - (test (term (g 1)) 1) - (test g-called? #t)) - - ;; test that tracing works properly - ;; note that caching comes into play here (which is why we don't see the recursive calls) - (let () - (define-metafunction empty-language - [(f 0) 0] - [(f number) (f ,(- (term number) 1))]) - - (let ([sp (open-output-string)]) - (parameterize ([current-output-port sp]) - (term (f 1))) - (test (get-output-string sp) "")) - - (let ([sp (open-output-string)]) - (parameterize ([current-output-port sp] - [current-traced-metafunctions 'all]) - (term (f 1))) - (test (get-output-string sp) ">(f 1)\n<0\n")) - - (let ([sp (open-output-string)]) - (parameterize ([current-output-port sp] - [current-traced-metafunctions '(f)]) - (term (f 1))) - (test (get-output-string sp) ">(f 1)\n<0\n"))) - - (let () - (define-language var-lang [(x y z w) variable]) - - ;; this should produce the second case, - ;; since the where clause (should) fail to match - ;; in the first case. - (define-metafunction var-lang - [(f x) - first-case - (where (AnotherAtom y) (Atom x))] - [(f x) - second-case]) - - (test (term (f a)) (term second-case))) - - (let () - - ;; this is an ambiguous function - ;; and should signal an error if it is ever called - ;; with multiple different arguments, but if the - ;; arguments are all the same, it will return - ;; the same result for any parse, and thus should be allowed. - (define-metafunction empty-language - [(f any_x ... any_y any_z ...) - any_y]) - - (test (term (f 1 1 1 1 1)) (term 1))) - - (let () - (define-metafunction empty-language - [(ex variable_x) - variable_x - (where quote variable_x)]) - - (test (term (ex quote)) (term quote))) - - (let () - (define-metafunction empty-language - [(f any ...) - (any ...) - (where variable_1 x) - (side-condition #f) - (where (number ...) y)] - [(f any ...) - 12345]) - - (test (term (f 8)) 12345)) - - -; -; -; -; -; -; -; ;; ;;; ;; ;; ;; ;; -; ;; ;;; ;; ;; ;;; ;; -; ;;;;; ;;;; ;;;;; ;; ;; ;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;; ;;;; ;; ;;; -; ;;;;;; ;; ;; ;;;; ;; ;;;;;; ;; ;; ;;;; ;; ;; ;; ;; ;; ;;;; ;; ;;;;;; ;;;;;; -; ;;; ;; ;;;;;;;; ;; ;; ;; ;; ;;;;;;;;;;;; ;; ;;;;;;;; ;; ;;;; ;;; ;; ;;; ;;; ;; ;; -; ;;; ;; ;;; ;; ;; ;; ;; ;;; ;;;; ;; ;;; ;; ;;; ;; ;;; ;; ;;; ;;; ;; ;; -; ;;;;;; ;;; ;; ;; ;; ;; ;; ;;; ;; ;; ;;; ;; ;; ;;; ;; ;;;; ;; ;;;;;; ;; ;; -; ;;;;; ;;;; ;; ;; ;; ;; ;;;; ;; ;;;; ;; ;;;;;; ;;; ;; ;;;; ;; ;; -; -; -; - - - (let () - (define-relation empty-language - [(<: any any) #t]) - - (test (term (<: 1 1)) #t) - (test (term (<: 1 2)) #f)) - - (let () - (define-relation empty-language - [(<: number_1 number_2) ,(< (term number_1) (term number_2))] - [(<: number_1 number_1) #t]) - - (test (term (<: 1 2)) #t) - (test (term (<: 1 1)) #t) - (test (term (<: 2 1)) #f)) - - (let () - (define-relation empty-language - [(<: number_1 ... number_2 number_3 ... number_2 number_4 ...) #t]) - - (test (term (<: 1 2 3 4)) #f) - (test (term (<: 1 1 2 3 4)) #t) - (test (term (<: 1 2 1 3 4)) #t) - (test (term (<: 1 2 3 1 4)) #t) - (test (term (<: 1 2 3 4 1)) #t)) - - (let () - (define-relation empty-language - [(<: number_1 number_1)]) - (test (term (<: 1 1)) #t) - (test (term (<: 1 2)) #f)) - - (let () - (define-relation empty-language - [(<: number_1 number_2 number_3) - ,(= (term number_1) (term number_2)) - ,(= (term number_2) (term number_3))]) - (test (term (<: 1 2 3)) #f) - (test (term (<: 1 1 2)) #f) - (test (term (<: 1 2 2)) #f) - (test (term (<: 1 1 1)) #t)) - - -; ;; ; ;; ; -; ; ; ; ; -; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;; -; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ;; ; -; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;;;; ;;;; ;;;;; ;; ;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;; ;;;;; ;;; ;;; ;;; -; -; -; -; - - - - (test (apply-reduction-relation - (reduction-relation - grammar - (--> (in-hole E_1 (number_1 number_2)) - (in-hole E_1 ,(* (term number_1) (term number_2))))) - '((2 3) (4 5))) - (list '(6 (4 5)))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (~~> (number_1 number_2) - ,(* (term number_1) (term number_2))) - with - [(--> (in-hole E_1 a) (in-hole E_1 b)) (~~> a b)]) - '((2 3) (4 5))) - (list '(6 (4 5)))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (==> (number_1 number_2) - ,(* (term number_1) (term number_2))) - with - [(--> (M_1 a) (M_1 b)) (~~> a b)] - [(~~> (M_1 a) (M_1 b)) (==> a b)]) - '((1 2) ((2 3) (4 5)))) - (list '((1 2) ((2 3) 20)))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (~~> (number_1 number_2) - ,(* (term number_1) (term number_2))) - (==> (number_1 number_2) - ,(* (term number_1) (term number_2))) - with - [(--> (M_1 a) (M_1 b)) (~~> a b)] - [(--> (a M_1) (b M_1)) (==> a b)]) - '((2 3) (4 5))) - (list '(6 (4 5)) - '((2 3) 20))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (--> (M_1 (number_1 number_2)) - (M_1 ,(* (term number_1) (term number_2)))) - (==> (number_1 number_2) - ,(* (term number_1) (term number_2))) - with - [(--> (a M_1) (b M_1)) (==> a b)]) - '((2 3) (4 5))) - (list '((2 3) 20) - '(6 (4 5)))) - - ; shortcuts like this fail if compilation fails to preserve - ; lexical context for side-conditions expressions. - (test (let ([x #t]) - (apply-reduction-relation - (reduction-relation - grammar - (==> variable variable) - with - [(--> (a (side-condition number x)) b) - (==> a b)]) - '(x 4))) - '(x)) - - (test (apply-reduction-relation/tag-with-names - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mul)) - '(4 5)) - (list (list "mul" 20))) - - (test (apply-reduction-relation/tag-with-names - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - "mul")) - '(4 5)) - (list (list "mul" 20))) - - (test (apply-reduction-relation/tag-with-names - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)))) - '(4 5)) - (list (list #f 20))) - - (test (apply-reduction-relation/tag-with-names - (reduction-relation - grammar - (==> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult) - with - [(--> (M_1 a) (M_1 b)) (==> a b)]) - '((2 3) (4 5))) - (list (list "mult" '((2 3) 20)))) - - (test (apply-reduction-relation - (union-reduction-relations - (reduction-relation empty-language - (--> x a) - (--> x b)) - (reduction-relation empty-language - (--> x c) - (--> x d))) - 'x) - (list 'a 'b 'c 'd)) - - (test (apply-reduction-relation - (union-reduction-relations - (reduction-relation empty-language (--> x a)) - (reduction-relation empty-language (--> x b)) - (reduction-relation empty-language (--> x c)) - (reduction-relation empty-language (--> x d))) - 'x) - (list 'a 'b 'c 'd)) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> (number_1 number_2) - number_2 - (side-condition (< (term number_1) (term number_2)))) - (--> (number_1 number_2) - number_1 - (side-condition (< (term number_2) (term number_1))))) - '(1 2)) - (list 2)) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> x #f)) - (term x)) - (list #f)) - - (define-language x-language - (x variable)) - - (test (apply-reduction-relation - (reduction-relation - x-language - (--> x (x x))) - 'y) - (list '(y y))) - - (test (apply-reduction-relation - (reduction-relation - x-language - (--> (x ...) ((x ...)))) - '(p q r)) - (list '((p q r)))) - - #; - (test (apply-reduction-relation - (reduction-relation - empty-language - #:main-arrow :-> - (:-> 1 2)) - 1) - '(2)) - - (test (apply-reduction-relation - (reduction-relation - empty-language - #:domain number - (--> 1 2)) - 1) - '(2)) - - - (test (let ([red - (reduction-relation - empty-language - #:domain number - (--> 1 2))]) - (with-handlers ((exn? exn-message)) - (apply-reduction-relation red 'x) - 'no-exception-raised)) - "reduction-relation: relation not defined for x") - - (test (let ([red - (reduction-relation - empty-language - #:domain number - (--> 1 x))]) - (with-handlers ((exn? exn-message)) - (apply-reduction-relation red 1) - 'no-exception-raised)) - "reduction-relation: relation reduced to x via rule #0 (counting from 0), which is outside its domain") - - (let* ([red1 - (reduction-relation - empty-language - #:domain (side-condition number_1 (even? (term number_1))) - (--> number number))] - [red2 - (reduction-relation - empty-language - #:domain (side-condition number_1 (odd? (term number_1))) - (--> number number))] - [red-c - (union-reduction-relations red1 red2)]) - - ;; ensure first branch of 'union' is checked - (test (with-handlers ((exn? exn-message)) - (apply-reduction-relation red-c 1) - 'no-exception-raised) - "reduction-relation: relation not defined for 1") - - ;; ensure second branch of 'union' is checked - (test (with-handlers ((exn? exn-message)) - (apply-reduction-relation red-c 2) - 'no-exception-raised) - "reduction-relation: relation not defined for 2")) - - (let () - (define-language l1 - (D 0 1 2)) - (define r1 - (reduction-relation - l1 - #:domain D - (--> D D))) - (define-language l2 - (D 0 1 2 3)) - (define r2 - (extend-reduction-relation r1 l2)) - - ;; test that the domain is re-interpreted for the extended reduction-relation - (test (apply-reduction-relation r2 3) - '(3))) - - (let () - (define-language l1 - (D 0 1 2)) - (define r1 - (reduction-relation - l1 - #:domain (D D) - (--> (D_1 D_2) (D_2 D_1)))) - - ;; test that duplicated identifiers in the domain contract do not have to be equal - (test (apply-reduction-relation r1 (term (1 2))) - (list (term (2 1))))) - - ;;test that #:arrow keyword works - (test (apply-reduction-relation - (reduction-relation - empty-language - #:arrow :-> - (:-> 1 2)) - 1) - '(2)) - - (let () - (define-language n-lang - [n number]) - (test (apply-reduction-relation - (reduction-relation n-lang [--> any ,(length (redex-match n-lang n 1))]) - 11) - '(1))) - - (parameterize ([current-namespace syn-err-test-namespace]) - (eval (quote-syntax - (define-language grammar - (M (M M) - number) - (E hole - (E M) - (number E)) - (X (number any) - (any number)) - (Q (Q ...) - variable) - (UN (add1 UN) - zero))))) - - (test-syn-err (reduction-relation - grammar - (~~> (number_1 number_2) - ,(* (term number_1) (term number_2))) - with - [(--> (M a) (M b)) (~~> a b)] - [(~~> (M a) (M b)) (==> a b)]) - #rx"no rules") - - (test-syn-err (reduction-relation grammar) - #rx"no rules use -->") - - (test-syn-err (reduction-relation - grammar - (~~> (number_1 number_2) - ,(* (term number_1) (term number_2)))) - #rx"~~> relation is not defined") - - (test-syn-err (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult) - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - #rx"same name on multiple rules") - - (test-syn-err (reduction-relation - grammar - (--> 1 2) - (==> 3 4)) - #rx"not defined.*==>") - - (test-syn-err (reduction-relation - empty-language - (--> 1 2) - (==> 3 4) - with - [(~> a b) (==> a b)]) - #rx"not defined.*~>") - - (test-syn-err (define-language bad-lang1 (e name)) #rx"name") - (test-syn-err (define-language bad-lang2 (name x)) #rx"name") - (test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y") - (test-syn-err (define-language bad-lang4 (a 1 2) (b)) #rx"no productions") - (test-syn-err (let () - (define-language good-lang (a 1 2)) - (define-extended-language bad-lang5 good-lang (a) (b 2))) - #rx"no productions") - - ;; expect union with duplicate names to fail - (test (with-handlers ((exn? (λ (x) 'passed))) - (union-reduction-relations - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult))) - 'failed) - 'passed) - - (test (with-handlers ((exn? (λ (x) 'passed))) - (union-reduction-relations - (union-reduction-relations - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult3))) - - (union-reduction-relations - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult2)))) - 'passed) - 'passed) - - ;; sorting in this test case is so that the results come out in a predictable manner. - (test (sort - (apply-reduction-relation - (compatible-closure - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - grammar - M) - '((2 3) (4 5))) - (λ (x y) (string<=? (format "~s" x) (format "~s" y)))) - (list '((2 3) 20) - '(6 (4 5)))) - - (test (apply-reduction-relation - (compatible-closure - (reduction-relation - grammar - (--> (number_1 number_2) - ,(* (term number_1) (term number_2)) - mult)) - grammar - M) - '(4 2)) - (list '8)) - - (test (apply-reduction-relation - (context-closure - (context-closure - (reduction-relation grammar (--> 1 2)) - grammar - (y hole)) - grammar - (x hole)) - '(x (y 1))) - (list '(x (y 2)))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (--> (variable_1 variable_2) - (variable_1 variable_2 x) - mul - (fresh x))) - '(x x1)) - (list '(x x1 x2))) - - (test (apply-reduction-relation - (reduction-relation - grammar - (~~> number - x - (fresh x)) - with - [(--> (variable_1 variable_2 a) (variable_1 variable_2 b)) (~~> a b)]) - '(x x1 2)) - (list '(x x1 x2))) - - (test (apply-reduction-relation - (reduction-relation - x-language - (--> (x_1 ...) - (x ...) - (fresh ((x ...) (x_1 ...))))) - '(x y x1)) - (list '(x2 x3 x4))) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> (variable_1 ...) - (x ... variable_1 ...) - (fresh ((x ...) (variable_1 ...) (variable_1 ...))))) - '(x y z)) - (list '(x1 y1 z1 x y z))) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> any (any_y x) - (where any_y x) - (fresh x))) - (term junk)) - (list '(x x1))) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> (variable ...) (variable_0 ... variable_1 ...) - (fresh ((variable_0 ...) (variable ...))) - (fresh ((variable_1 ...) (variable ...))))) - (term (x y))) - (list '(variable_0 variable_1 variable_2 variable_3))) - - - ;; test that redex match can be used in a side-condition - ;; with the same language that is used to define the - ;; reduction relation. - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> any_1 3 - (side-condition (redex-match empty-language (any_1 any_2) (term any_1))))) - '(a b)) - '(3)) - - (test (apply-reduction-relation - (reduction-relation - empty-language - (--> variable_1 - (x variable_1) - (fresh (x variable_1)))) - 'q) - (list '(q1 q))) - - (test (apply-reduction-relation - (extend-reduction-relation (reduction-relation empty-language (--> 1 2)) - empty-language - (--> 1 3)) - 1) - '(3 2)) - - (let () - (define-language e1 - (e 1)) - (define-language e2 - (e 2)) - (define red1 (reduction-relation e1 (--> e (e e)))) - (define red2 (extend-reduction-relation red1 e2 (--> ignoreme ignoreme))) - (test (apply-reduction-relation red1 1) '((1 1))) - (test (apply-reduction-relation red1 2) '()) - (test (apply-reduction-relation red2 1) '()) - (test (apply-reduction-relation red2 2) '((2 2)))) - - (let () - (define red1 (reduction-relation empty-language - (--> a (a a) - a) - (--> b (b b) - b) - (--> q x))) - (define red2 (extend-reduction-relation red1 - empty-language - (--> a (c c) - a) - (--> q z))) - (test (apply-reduction-relation red1 (term a)) (list (term (a a)))) - (test (apply-reduction-relation red1 (term b)) (list (term (b b)))) - (test (apply-reduction-relation red1 (term q)) (list (term x))) - (test (apply-reduction-relation red2 (term a)) (list (term (c c)))) - (test (apply-reduction-relation red2 (term b)) (list (term (b b)))) - (test (apply-reduction-relation red2 (term q)) (list (term z) (term x)))) - - (let () - (define red1 - (reduction-relation - empty-language - (==> a (a a) - a) - (==> b (b b) - b) - (==> q w) - with - [(--> (X a) (X b)) (==> a b)])) - - (define red2 - (extend-reduction-relation - red1 - empty-language - (==> a (c c) - a) - (==> q z) - with - [(--> (X a) (X b)) (==> a b)])) - - (test (apply-reduction-relation red1 (term (X a))) (list (term (X (a a))))) - (test (apply-reduction-relation red1 (term (X b))) (list (term (X (b b))))) - (test (apply-reduction-relation red1 (term (X q))) (list (term (X w)))) - (test (apply-reduction-relation red2 (term (X a))) (list (term (X (c c))))) - (test (apply-reduction-relation red2 (term (X b))) (list (term (X (b b))))) - (test (apply-reduction-relation red2 (term (X q))) (list (term (X z)) - (term (X w))))) - - (test (reduction-relation->rule-names - (reduction-relation - empty-language - (--> x y a))) - '(a)) - - (test (reduction-relation->rule-names - (reduction-relation - empty-language - (--> x y a) - (--> y z b) - (--> z w c))) - '(a b c)) - - (test (reduction-relation->rule-names - (reduction-relation - empty-language - (--> x y a) - (--> y z b) - (--> z w c) - (--> p q z) - (--> q r y) - (--> r p x))) - '(a b c z y x)) - - (test (reduction-relation->rule-names - (extend-reduction-relation - (reduction-relation - empty-language - (--> x y a) - (--> y z b) - (--> z w c)) - empty-language - (--> p q z) - (--> q r y) - (--> r p x))) - '(a b c z y x)) - - (test (reduction-relation->rule-names - (union-reduction-relations - (reduction-relation - empty-language - (--> x y a) - (--> y z b) - (--> z w c)) - (reduction-relation - empty-language - (--> p q z) - (--> q r y) - (--> r p x)))) - '(a b c z y x)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; examples from doc.txt - ;; - - (define-language lc-lang - (e (e e ...) - x - v) - (c (v ... c e ...) - hole) - (v (lambda (x ...) e)) - (x variable-not-otherwise-mentioned)) - - (test (let ([m (redex-match lc-lang e (term (lambda (x) x)))]) - (and m (length m))) - 1) - - (define-extended-language qabc-lang lc-lang (q a b c)) - - (test (redex-match qabc-lang - e - (term (lambda (a) a))) - #f) - - (test (let ([m (redex-match qabc-lang - e - (term (lambda (z) z)))]) - (and m (length m))) - 1) - - (require (lib "list.ss")) - (let () - (define-metafunction lc-lang - free-vars : e -> (x ...) - [(free-vars (e_1 e_2 ...)) - (∪ (free-vars e_1) (free-vars e_2) ...)] - [(free-vars x) (x)] - [(free-vars (lambda (x ...) e)) - (- (free-vars e) (x ...))]) - - (define-metafunction lc-lang - ∪ : (x ...) ... -> (x ...) - [(∪ (x_1 ...) (x_2 ...) (x_3 ...) ...) - (∪ (x_1 ... x_2 ...) (x_3 ...) ...)] - [(∪ (x_1 ...)) - (x_1 ...)] - [(∪) ()]) - - (define-metafunction lc-lang - - : (x ...) (x ...) -> (x ...) - [(- (x ...) ()) (x ...)] - [(- (x_1 ... x_2 x_3 ...) (x_2 x_4 ...)) - (- (x_1 ... x_3 ...) (x_2 x_4 ...)) - (side-condition (not (memq (term x_2) (term (x_3 ...)))))] - [(- (x_1 ...) (x_2 x_3 ...)) - (- (x_1 ...) (x_3 ...))]) - - (test (term (∪)) (term ())) - (test (term (∪ (x y) (z a) (b c))) (term (x y z a b c))) - - (test (term (- (x y) ())) (term (x y))) - (test (term (- (x y) (x))) (term (y))) - (test (term (- (y x) (x))) (term (y))) - (test (term (- (x x x x x) (x))) (term ())) - - (test (term (free-vars (lambda (x) (x y)))) (list 'y)) - (test (term (free-vars (a (b (c (d e)))))) (term (a b c d e)))) - - (test (variable-not-in (term (x y z)) 'x) - (term x1)) - - (test (variable-not-in (term (y z)) 'x) - (term x)) - (test (variable-not-in (term (x x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) 'x) - (term x11)) - (test (variable-not-in (term (x x11)) 'x) - (term x1)) - (test (variable-not-in (term (x x1 x2 x3)) 'x1) - (term x4)) - (test (variable-not-in (term (x x1 x1 x2 x2)) 'x) - (term x3)) - - (test (variables-not-in (term (x y z)) '(x)) - '(x1)) - (test (variables-not-in (term (x2 y z)) '(x x x)) - '(x x1 x3)) - - (test ((term-match/single empty-language - [(variable_x variable_y) - (cons (term variable_x) - (term variable_y))]) - '(x y)) - '(x . y)) - - (test ((term-match/single empty-language - [(side-condition (variable_x variable_y) - (eq? (term variable_x) 'x)) - (cons (term variable_x) - (term variable_y))]) - '(x y)) - '(x . y)) - - - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - ((term-match/single empty-language - [(number_1 ... number_2 ...) 1]) - '(1 2 3)) - 'no-exn) - 'right-exn) - - (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) - ((λ (x) #t) (λ (x) 'wrong-exn))) - ((term-match/single empty-language - [(number_1 ... number_2 ...) 1]) - 'x) - 'no-exn) - 'right-exn) - - (test ((term-match empty-language - [(number_1 ... number_2 ...) 1]) - 'x) - '()) - - (define-language x-is-1-language - [x 1]) - - (test ((term-match/single x-is-1-language - [(x x) - 1]) - '(1 1)) - 1) - - (test (call-with-values - (λ () - ((term-match/single empty-language - [() (values 1 2)]) - '())) - list) - '(1 2)) - - (test (let ([x 0]) - (cons ((term-match empty-language - [(any_a ... number_1 any_b ...) - (begin (set! x (+ x 1)) - (term number_1))]) - '(1 2 3)) - x)) - '((3 2 1) . 3)) - - (test ((term-match empty-language - [number_1 - (term number_1)] - [number_1 - (term number_1)]) - '1) - '(1 1)) - - (test (apply-reduction-relation - (reduction-relation - x-language - (--> (x_one x_!_one x_!_one x_!_one) - (x_one x_!_one))) - (term (a a b c))) - (list (term (a x_!_one)))) - - ;; tests `where' clauses in reduction relation - (test (apply-reduction-relation - (reduction-relation empty-language - (--> number_1 - any_y - (where any_y ,(+ 1 (term number_1))))) - 3) - '(4)) - - ;; tests `where' clauses scoping - (test (let ([x 5]) - (apply-reduction-relation - (reduction-relation empty-language - (--> any - any_z - (where any_y ,x) - (where any_x 2) - (where any_z ,(+ (term any_y) (term any_x))))) - 'whatever)) - '(7)) - - ;; tests `where' clauses bind in side-conditions - (test (let ([x 'unk]) - (apply-reduction-relation - (reduction-relation empty-language - (--> any - the-result - (where any_y any) - (side-condition (eq? (term any_y) 'whatever)))) - 'whatever)) - '(the-result)) - - ;; test that where clauses bind in side-conditions that follow - (let ([save1 #f] - [save2 #f]) - (term-let ([any_y (term outer-y)]) - (test (begin (apply-reduction-relation - (reduction-relation empty-language - (--> number_1 - any_y - (side-condition (set! save1 (term any_y))) - (where any_y inner-y) - (side-condition (set! save2 (term any_y))))) - 3) - (list save1 save2)) - (list 'outer-y 'inner-y)))) - - (test (apply-reduction-relation - (reduction-relation empty-language - (--> any - any_y - (fresh x) - (where any_y x))) - 'x) - '(x1)) - - (let () - ;; tests where's ability to have redex patterns, not just syntax-case patterns - (define-language var-lang [(x y z w) variable]) - - (define red - (reduction-relation - var-lang - (--> (x ...) - (y ... z ...) - (where (y ... w z ...) (x ...))))) - - (test (apply-reduction-relation red (term (a b c))) - (list (term (a b)) (term (a c)) (term (b c))))) - - - (let ([r (reduction-relation - grammar - (->1 1 2) - (->2 3 4) - (->4 5 6) - with - [(--> (side-condition (a number) (even? (term number))) b) - (->1 a b)] - [(--> (X - (number number) - (X_1 X_1) - (M_!_1 M_!_1) - (1 ..._1 1 ..._1) - (1 ..._!_1 1 ..._!_1)) - b) - (->2 X b)] - [(--> (a 1) b) - (->3 a b)] - [(->3 (a 2) b) - (->4 a b)])]) - - ; test that names are properly bound for side-conditions in shortcuts - (let* ([lhs ((rewrite-proc-lhs (first (reduction-relation-make-procs r))) grammar)] - [proc (third lhs)] - [name (cadadr lhs)] - [bind (λ (n) (make-bindings (list (make-bind name n))))]) - (test (and (proc (bind 4)) (not (proc (bind 3)))) #t)) - - ; test binder renaming - (let ([sym-mtch? (λ (rx) (λ (s) (and (symbol? s) (regexp-match? rx (symbol->string s)))))]) - (match (rewrite-proc-lhs (second (reduction-relation-make-procs r))) - [`(3 - (,(and n1 (? (sym-mtch? #px"^number_\\d+$"))) ,n1) - (,(and n2 (? (sym-mtch? #px"^X_1\\d+$"))) ,n2) - (,(and m1 (? (sym-mtch? #px"^M_!_1\\d+$"))) ,m1) - (1 ,(and ...1 (? (sym-mtch? #px"^\\.\\.\\._1\\d+$"))) 1 ,...1) - (1 ,(and ...!1 (? (sym-mtch? #px"^\\.\\.\\._!_1\\d+$"))) 1 ,...!1)) - #t] - [else #f])) - - ; 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] - [else #f]) - #t)) - - (let ([< (λ (c d) (string number (q ,(add1 (term number))) - (side-condition (odd? (term number))) - side-condition) - (--> 1 4 plain) - (==> 2 t - shortcut) - with - [(--> (q a) b) - (==> a b)])] - [c (make-coverage R)]) - (parameterize ([relation-coverage (list c)]) - (apply-reduction-relation R 4) - (test (sort (covered-cases c) <) - '(("plain" . 0) ("shortcut" . 0) ("side-condition" . 0))) - - (apply-reduction-relation R 3) - (test (sort (covered-cases c) <) - '(("plain" . 0) ("shortcut" . 0) ("side-condition" . 1))) - - (apply-reduction-relation* R 1) - (test (sort (covered-cases c) <) - '(("plain" . 1) ("shortcut" . 1) ("side-condition" . 2))))) - - (let* ([S (reduction-relation - empty-language - (--> 1 1 uno))] - [S+ (extend-reduction-relation - S empty-language - (--> 2 2 dos))]) - (let ([c (make-coverage S+)]) - (parameterize ([relation-coverage (list c)]) - (apply-reduction-relation S (term 1)) - (test (sort (covered-cases c) <) - '(("dos" . 0) ("uno" . 1))))) - (let ([c (make-coverage S)]) - (parameterize ([relation-coverage (list c)]) - (apply-reduction-relation S+ (term 1)) - (test (sort (covered-cases c) <) - '(("uno" . 1)))))) - - (let* ([T (reduction-relation empty-language (--> any any))] - [c (make-coverage T)]) - (parameterize ([relation-coverage (list c)]) - (apply-reduction-relation T (term q)) - (test (and (regexp-match #px"tl-test.ss:\\d+:\\d+" (caar (covered-cases c))) #t) - #t)))) - - (let* ([R (reduction-relation - empty-language - (--> any any id))] - [c (make-coverage R)] - [c* (make-coverage R)]) - (parameterize ([relation-coverage (list c c*)]) - (apply-reduction-relation R 4) - (test (covered-cases c) '(("id" . 1))) - (test (covered-cases c*) '(("id" . 1))))) - - (let* ([< (λ (c d) - (let ([line-no (compose - string->number - second - (curry regexp-match #px".*:(\\d+):\\d+"))]) - (< (line-no (car c)) (line-no (car d)))))] - [src-ok? (curry regexp-match? #px"tl-test.ss:\\d+:\\d+")] - [sorted-counts (λ (cc) (map cdr (sort (covered-cases cc) <)))]) - (define-metafunction empty-language - [(f 1) 1] - [(f 2) 2]) - (define-metafunction/extension f empty-language - [(g 3) 3]) - (define-relation empty-language - [(R number) - ,(even? (term number))] - [(R number) - ,(= 3 (term number))]) - - (let ([fc (make-coverage f)] - [rc (make-coverage (reduction-relation empty-language (--> any any)))]) - (parameterize ([relation-coverage (list rc fc)]) - (term (f 2)) - (test (andmap (compose src-ok? car) (covered-cases fc)) - #t) - (test (sorted-counts fc) '(0 1)) - - (term (f 1)) - (term (f 1)) - (test (sorted-counts fc) '(2 1)))) - - (let ([c (make-coverage f)]) - (parameterize ([relation-coverage (list c)]) - (term (g 1)) - (test (sorted-counts c) '(1 0)))) - (let ([c (make-coverage g)]) - (parameterize ([relation-coverage (list c)]) - (term (f 1)) - (test (sorted-counts c) '(1 0 0)))) - - (let ([c (make-coverage R)]) - (parameterize ([relation-coverage (list c)]) - (term (R 2)) - (term (R 3)) - (term (R 5)) - (test (sorted-counts c) '(1 1)))) - - (let ([c (make-coverage f)] - [c* (make-coverage f)]) - (parameterize ([relation-coverage (list c* c)]) - (term (f 1)) - (test (sorted-counts c) '(1 0)) - (test (sorted-counts c*) '(1 0))))) - -; -; -; -; -; ;;; -; ;; ;; ; ;; ;; -; ;; ;; ; ;; ;; -; ;;;;; ;;; ;;; ;;;;; ;; ;;; ;;;; ;;;; -; ;; ;; ;; ;; ; ;; ;;;;;;;; ;; ;;; ;; ; ;; ;; -; ;; ;;;;; ;;; ;; ;;; ;; ; ;; ;; ;; ;; -; ;; ;; ;; ;; ;;; ;; ;;;; ;; ;; ;; -; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ; ;; ;; -; ;;;; ;;; ;;; ;;;; ; ;;;;; ;; ;;;; ;;;; -; -; -; - - - (define-syntax-rule - (capture-output arg1 args ...) - (let ([p (open-output-string)]) - (parameterize ([current-output-port p] - [current-error-port p]) - arg1 args ...) - (get-output-string p))) - - (let () - (define red (reduction-relation empty-language (--> 1 2))) - (test (capture-output (test-->> red 1 2) (test-results)) - "One test passed.\n") - (test (capture-output (test-->> red 2 3) (test-results)) - #rx"FAILED tl-test.ss:[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n")) - - (let () - (define red-share (reduction-relation - empty-language - (--> a b) - (--> a c) - (--> c d) - (--> b d))) - (test (capture-output (test-->> red-share (term a) (term d)) (test-results)) - "One test passed.\n")) - - (let () - (define red-cycle (reduction-relation - empty-language - (--> a a))) - (test (capture-output (test-->> red-cycle #:cycles-ok (term a)) (test-results)) - "One test passed.\n") - (test (capture-output (test-->> red-cycle (term a)) (test-results)) - #rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n")) - - (let () - (define-metafunction empty-language [(f any) ((any))]) - (test (capture-output (test-equal (term (f 1)) (term ((1)))) - (test-results)) - "One test passed.\n")) - - (let () - (test (capture-output (test-predicate odd? 1) - (test-results)) - "One test passed.\n")) - - (let () - (define red (reduction-relation empty-language (--> any (any)))) - (test (capture-output (test--> red (term (1 2 3)) (term ((1 2 3)))) (test-results)) - "One test passed.\n")) - - (let () - (define red (reduction-relation empty-language - (--> any (any)) - (--> (any) any))) - (test (capture-output (test--> red (term (x)) (term ((x))) (term x)) (test-results)) - "One test passed.\n") - (test (capture-output (test--> red (term (x)) (term x) (term ((x)))) (test-results)) - "One test passed.\n")) - - (print-tests-passed 'tl-test.ss))