Moved tests into a separate directory. Changed run-tests.ss to suppress the diffs window when bitmap-test.ss fails, to avoid tripping up DrDr.
svn: r17836
This commit is contained in:
Casey Klein
parent
4cb01a48b3
commit
9c6fdd86c8
161
collects/redex/tests/bitmap-test-util.ss
Normal file
161
collects/redex/tests/bitmap-test-util.ss
Normal file
|
|
@ -0,0 +1,161 @@
|
|||
#lang scheme/gui
|
||||
(require framework
|
||||
slideshow
|
||||
"../pict.ss"
|
||||
"../reduction-semantics.ss"
|
||||
"config.ss")
|
||||
|
||||
(provide test done)
|
||||
|
||||
(define tests 0)
|
||||
(define failed '())
|
||||
(define (done)
|
||||
(printf "~a tests" tests)
|
||||
(if (null? failed)
|
||||
(printf ", all passed\n")
|
||||
(printf ", ~a failed\n" (length failed))))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test-exp bitmap-filename)
|
||||
#`(test/proc
|
||||
#,(syntax-line stx)
|
||||
test-exp
|
||||
bitmap-filename)]))
|
||||
|
||||
(define (test/proc line-number pict raw-bitmap-filename)
|
||||
(set! tests (+ tests 1))
|
||||
(let* ([bitmap-filename
|
||||
(build-path (format "bmps-~a" (system-type))
|
||||
(case (system-type)
|
||||
[(unix) (string-append "unix-" raw-bitmap-filename)]
|
||||
[else raw-bitmap-filename]))]
|
||||
[old-bitmap (if (file-exists? bitmap-filename)
|
||||
(make-object bitmap% bitmap-filename)
|
||||
(let* ([bm (make-object bitmap% 100 20)]
|
||||
[bdc (make-object bitmap-dc% bm)])
|
||||
(send bdc clear)
|
||||
(send bdc draw-text "does not exist" 0 0)
|
||||
(send bdc set-bitmap #f)
|
||||
bm))]
|
||||
[new-bitmap (make-object bitmap%
|
||||
(ceiling (inexact->exact (pict-width pict)))
|
||||
(ceiling (inexact->exact (pict-height pict))))]
|
||||
[bdc (make-object bitmap-dc% new-bitmap)])
|
||||
(send bdc clear)
|
||||
(draw-pict pict bdc 0 0)
|
||||
(send bdc set-bitmap #f)
|
||||
(let ([diff-bitmap (compute-diffs old-bitmap new-bitmap)])
|
||||
(when diff-bitmap
|
||||
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
|
||||
(set! failed (append failed (list failed-panel))))))))
|
||||
|
||||
(define (compute-diffs old-bitmap new-bitmap)
|
||||
(let* ([w (max (send old-bitmap get-width)
|
||||
(send new-bitmap get-width))]
|
||||
[h (max (send old-bitmap get-height)
|
||||
(send new-bitmap get-height))]
|
||||
[diff-bitmap (make-object bitmap% w h)]
|
||||
[new (make-object bitmap-dc% new-bitmap)]
|
||||
[old (make-object bitmap-dc% old-bitmap)]
|
||||
[diff (make-object bitmap-dc% diff-bitmap)]
|
||||
[new-c (make-object color%)]
|
||||
[old-c (make-object color%)]
|
||||
[any-different? #f])
|
||||
(let loop ([x 0])
|
||||
(unless (= x w)
|
||||
(let loop ([y 0])
|
||||
(unless (= y h)
|
||||
(cond
|
||||
[(and (<= x (send new-bitmap get-width))
|
||||
(<= y (send new-bitmap get-height))
|
||||
(<= x (send old-bitmap get-width))
|
||||
(<= y (send old-bitmap get-height)))
|
||||
(send new get-pixel x y new-c)
|
||||
(send old get-pixel x y old-c)
|
||||
(cond
|
||||
[(and (= (send new-c red) (send old-c red))
|
||||
(= (send new-c green) (send old-c green))
|
||||
(= (send new-c blue) (send old-c blue)))
|
||||
(send diff set-pixel x y new-c)]
|
||||
[else
|
||||
(set! any-different? #t)
|
||||
(send new-c set 255 0 0)
|
||||
(send diff set-pixel x y new-c)])]
|
||||
[else
|
||||
(set! any-different? #t)
|
||||
(send new-c set 255 0 0)
|
||||
(send diff set-pixel x y new-c)])
|
||||
(loop (+ y 1))))
|
||||
(loop (+ x 1))))
|
||||
(send diff set-bitmap #f)
|
||||
(send old set-bitmap #f)
|
||||
(send new set-bitmap #f)
|
||||
(and any-different? diff-bitmap)))
|
||||
|
||||
(define test-result-single-panel #f)
|
||||
(define (get-test-result-single-panel)
|
||||
(cond
|
||||
[test-result-single-panel
|
||||
test-result-single-panel]
|
||||
[else
|
||||
(let ()
|
||||
(define f (new frame% [label "bitmap-test.ss failures"]))
|
||||
(define lined (new vertical-panel% [parent f] [style '(border)]))
|
||||
(define sp (new panel:single% [parent lined]))
|
||||
(define current-index 0)
|
||||
(define hp (new horizontal-panel% [parent f]))
|
||||
(define prev
|
||||
(new button%
|
||||
[label "Prev"]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(set! current-index (modulo (- current-index 1) (length failed)))
|
||||
(update-gui))]))
|
||||
(define next (new button%
|
||||
[label "Next"]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(set! current-index (modulo (+ current-index 1) (length failed)))
|
||||
(update-gui))]))
|
||||
(define (update-gui)
|
||||
(send sp active-child (list-ref failed current-index)))
|
||||
(set! test-result-single-panel sp)
|
||||
(when (get-show-bitmaps?) (send f show #t))
|
||||
sp)]))
|
||||
|
||||
(define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap)
|
||||
(define f (new vertical-panel% [parent (get-test-result-single-panel)]))
|
||||
(define msg (new message% [label (format "line ~a" line-number)] [parent f]))
|
||||
(define hp (new horizontal-panel% [parent f]))
|
||||
(define vp1 (new vertical-panel% [parent hp]))
|
||||
(define vp2 (new vertical-panel% [parent hp]))
|
||||
(define chk (new check-box%
|
||||
[label "Show diff"]
|
||||
[parent f]
|
||||
[callback
|
||||
(λ (_1 _2)
|
||||
(cond
|
||||
[(send chk get-value)
|
||||
(send right-hand set-label diff-bitmap)]
|
||||
[else
|
||||
(send right-hand set-label new-bitmap)]))]))
|
||||
(define btn (new button%
|
||||
[parent f]
|
||||
[label "Save"]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(send new-bitmap save-file filename 'png))]))
|
||||
(define left-label (new message% [parent vp1] [label "Old"]))
|
||||
(define left-hand (new message%
|
||||
[parent vp1]
|
||||
[label diff-bitmap]))
|
||||
(define right-label (new message% [parent vp2] [label "New"]))
|
||||
(define right-hand (new message%
|
||||
[parent vp2]
|
||||
[label diff-bitmap]))
|
||||
(send left-hand set-label old-bitmap)
|
||||
(send right-hand set-label new-bitmap)
|
||||
f)
|
||||
167
collects/redex/tests/bitmap-test.ss
Normal file
167
collects/redex/tests/bitmap-test.ss
Normal file
|
|
@ -0,0 +1,167 @@
|
|||
#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)
|
||||
BIN
collects/redex/tests/bmps-macosx/extended-language.png
Normal file
BIN
collects/redex/tests/bmps-macosx/extended-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.9 KiB |
BIN
collects/redex/tests/bmps-macosx/extended-reduction-relation.png
Normal file
BIN
collects/redex/tests/bmps-macosx/extended-reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 394 B |
BIN
collects/redex/tests/bmps-macosx/language-nox.png
Normal file
BIN
collects/redex/tests/bmps-macosx/language-nox.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.9 KiB |
BIN
collects/redex/tests/bmps-macosx/language.png
Normal file
BIN
collects/redex/tests/bmps-macosx/language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.9 KiB |
BIN
collects/redex/tests/bmps-macosx/lw.png
Normal file
BIN
collects/redex/tests/bmps-macosx/lw.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.2 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.7 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-Name.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-Name.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.3 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-T.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-T.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-TL.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-TL.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-multi-arg.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-multi-arg.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 8.3 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction-subst.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction-subst.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.3 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunction.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunction.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.1 KiB |
BIN
collects/redex/tests/bmps-macosx/metafunctions-multiple.png
Normal file
BIN
collects/redex/tests/bmps-macosx/metafunctions-multiple.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 9.1 KiB |
BIN
collects/redex/tests/bmps-macosx/red2.png
Normal file
BIN
collects/redex/tests/bmps-macosx/red2.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.1 KiB |
BIN
collects/redex/tests/bmps-macosx/reduction-relation.png
Normal file
BIN
collects/redex/tests/bmps-macosx/reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.8 KiB |
BIN
collects/redex/tests/bmps-macosx/superscripts.png
Normal file
BIN
collects/redex/tests/bmps-macosx/superscripts.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 944 B |
BIN
collects/redex/tests/bmps-macosx/unix-extended-language.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-extended-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.1 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 507 B |
BIN
collects/redex/tests/bmps-macosx/unix-language-nox.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-language-nox.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 3.1 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-language.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.5 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-lw.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-lw.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.2 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 4.4 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-Name.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-Name.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 3.7 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-T.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-T.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 3.9 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-TL.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-TL.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.4 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-multi-arg.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-multi-arg.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 7.0 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-subst.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction-subst.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.2 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunction.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunction.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.1 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-metafunctions-multiple.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-metafunctions-multiple.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 10 KiB |
BIN
collects/redex/tests/bmps-macosx/unix-reduction-relation.png
Normal file
BIN
collects/redex/tests/bmps-macosx/unix-reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.9 KiB |
69
collects/redex/tests/color-test.ss
Normal file
69
collects/redex/tests/color-test.ss
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
#|
|
||||
|
||||
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))
|
||||
5
collects/redex/tests/config.ss
Normal file
5
collects/redex/tests/config.ss
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
#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?)
|
||||
82
collects/redex/tests/core-layout-test.ss
Normal file
82
collects/redex/tests/core-layout-test.ss
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "../private/core-layout.ss"
|
||||
"../private/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")
|
||||
32
collects/redex/tests/hole-test.ss
Normal file
32
collects/redex/tests/hole-test.ss
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
#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))
|
||||
46
collects/redex/tests/keyword-macros-test.ss
Normal file
46
collects/redex/tests/keyword-macros-test.ss
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
#lang scheme
|
||||
|
||||
(require "../private/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)
|
||||
43
collects/redex/tests/lw-test-util.ss
Normal file
43
collects/redex/tests/lw-test-util.ss
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
(module lw-test-util mzscheme
|
||||
(require "../private/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)))
|
||||
282
collects/redex/tests/lw-test.ss
Normal file
282
collects/redex/tests/lw-test.ss
Normal file
|
|
@ -0,0 +1,282 @@
|
|||
#|
|
||||
|
||||
DO NOT TABIFY THIS FILE
|
||||
|
||||
|#
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;;;
|
||||
; ; ; ;
|
||||
; ; ; ;;; ;; ;; ;;; ;;;;;
|
||||
; ; ; ; ; ;; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;; ;;; ;;; ;;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ; ;;;
|
||||
; ; ; ;
|
||||
; ;;;;; ;;; ; ;; ;;; ;;;;; ;;; ;;;
|
||||
; ; ; ; ;; ; ; ; ; ;
|
||||
; ; ;;;; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;;
|
||||
; ;;; ;;;;;;;;;; ;;;;; ;;;;; ;
|
||||
; ;
|
||||
; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ; ;;; ; ;;
|
||||
; ; ; ; ;
|
||||
; ;;;;; ; ;; ;;; ;;;; ;;;;; ;;; ; ;;;
|
||||
; ; ;; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ;;; ; ; ; ;;;;;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;; ;;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(module lw-test mzscheme
|
||||
(require "test-util.ss"
|
||||
"../private/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"))
|
||||
|
||||
820
collects/redex/tests/matcher-test.ss
Normal file
820
collects/redex/tests/matcher-test.ss
Normal file
|
|
@ -0,0 +1,820 @@
|
|||
(module matcher-test mzscheme
|
||||
(require "../private/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))
|
||||
53
collects/redex/tests/pict-test.ss
Normal file
53
collects/redex/tests/pict-test.ss
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
(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"))
|
||||
1081
collects/redex/tests/rg-test.ss
Normal file
1081
collects/redex/tests/rg-test.ss
Normal file
File diff suppressed because it is too large
Load Diff
41
collects/redex/tests/run-tests.ss
Normal file
41
collects/redex/tests/run-tests.ss
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
;; 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? #f)
|
||||
|
||||
(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)
|
||||
177
collects/redex/tests/term-test.ss
Normal file
177
collects/redex/tests/term-test.ss
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
(module term-test scheme
|
||||
(require "../private/term.ss"
|
||||
"../private/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))
|
||||
132
collects/redex/tests/test-util.ss
Normal file
132
collects/redex/tests/test-util.ss
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
#lang scheme
|
||||
|
||||
(require "../private/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)))
|
||||
"<unknown file>")])
|
||||
(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)))
|
||||
1850
collects/redex/tests/tl-test.ss
Normal file
1850
collects/redex/tests/tl-test.ss
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user