741 lines
34 KiB
Scheme
741 lines
34 KiB
Scheme
|
|
(module syncheck-test mzscheme
|
|
|
|
(require "drscheme-test-util.ss"
|
|
(lib "gui.ss" "tests" "utils")
|
|
(lib "etc.ss")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "file.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "text-string-style-desc.ss" "mrlib"))
|
|
|
|
(provide run-test)
|
|
|
|
;; type str/ann = (list (union symbol string) symbol)
|
|
;; type test = (make-test string
|
|
;; (listof str/ann)
|
|
;; (listof (cons (list number number) (listof (list number number)))))
|
|
(define-struct test (input expected arrows))
|
|
(define-struct (dir-test test) ())
|
|
|
|
(define build-test
|
|
(opt-lambda (input expected [arrow-table '()])
|
|
(make-test input expected arrow-table)))
|
|
|
|
;; tests : (listof test)
|
|
(define tests
|
|
(list
|
|
|
|
(build-test "12345"
|
|
'(("12345" constant)))
|
|
(build-test "'abcdef"
|
|
'(("'" imported-syntax)
|
|
("abcdef" constant)))
|
|
(build-test "(define f 1)"
|
|
'(("(" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")" default-color)))
|
|
(build-test "(lambda (x) x)"
|
|
'(("(" default-color)
|
|
("lambda" imported-syntax)
|
|
(" (" default-color)
|
|
("x" lexically-bound-variable)
|
|
(") " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((9 10) (12 13))))
|
|
(build-test "(lambda x x)"
|
|
'(("(" default-color)
|
|
("lambda" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((8 9) (10 11))))
|
|
(build-test "(lambda (x . y) x y)"
|
|
'(("(" default-color)
|
|
("lambda" imported-syntax)
|
|
(" (" default-color)
|
|
("x" lexically-bound-variable)
|
|
(" . " default-color)
|
|
("y" lexically-bound-variable)
|
|
(") " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("y" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((9 10) (16 17))
|
|
'((13 14) (18 19))))
|
|
|
|
(build-test "(case-lambda [(x) x])"
|
|
'(("(" default-color)
|
|
("case-lambda" imported-syntax)
|
|
(" [(" default-color)
|
|
("x" lexically-bound-variable)
|
|
(") " default-color)
|
|
("x" lexically-bound-variable)
|
|
("])" default-color))
|
|
(list '((15 16) (18 19))))
|
|
|
|
(build-test "(if 1 2 3)"
|
|
'(("(" default-color)
|
|
("if" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(" " default-color)
|
|
("3" constant)
|
|
(")" default-color)))
|
|
(build-test "(if 1 2)"
|
|
'(("(" default-color)
|
|
("if" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(")" default-color)))
|
|
|
|
(build-test "(begin 1 2)"
|
|
'(("(" default-color)
|
|
("begin" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(")" default-color)))
|
|
(build-test "(begin0 1 2)"
|
|
'(("(" default-color)
|
|
("begin0" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(")" default-color)))
|
|
(build-test "(let ([x x]) x)"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" ([" default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("x" error)
|
|
("]) " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((7 8) (13 14))))
|
|
(build-test "(letrec ([x x]) x)"
|
|
'(("(" default-color)
|
|
("letrec" imported-syntax)
|
|
(" ([" default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
("]) " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((10 11) (12 13) (16 17))))
|
|
(build-test "(#%top . x)"
|
|
'(("(" default-color)
|
|
("#%top" imported-syntax)
|
|
(" . " default-color)
|
|
("x" error)
|
|
(")" default-color)))
|
|
(build-test "(set! x 1)"
|
|
'(("(" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" error)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")" default-color)))
|
|
(build-test "(set! x 1) (define x 2)"
|
|
'(("(" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(") (" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" 2)" default-color))
|
|
(list '((19 20) (6 7))))
|
|
(build-test "(let ([x 1]) (set! x 2))"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" ([" default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("]) (" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("2" constant)
|
|
("))" default-color))
|
|
(list '((7 8) (19 20))))
|
|
(build-test "object%"
|
|
'(("object%" lexically-bound-variable)))
|
|
(build-test "unbound-id"
|
|
'(("unbound-id" error)))
|
|
(build-test "(define bd 1) bd"
|
|
'(("(" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("bd" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(") " default-color)
|
|
("bd" lexically-bound-variable))
|
|
(list '((8 10) (14 16))))
|
|
(build-test "#'abc"
|
|
'(("#'" imported-syntax)
|
|
("abc" constant)))
|
|
(build-test "(with-continuation-mark 1 2 3)"
|
|
'(("(" default-color)
|
|
("with-continuation-mark" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(" " default-color)
|
|
("3" constant)
|
|
(")" default-color)))
|
|
(build-test "(f x)"
|
|
'(("(" default-color)
|
|
("f" error)
|
|
(" " default-color)
|
|
("x" error)
|
|
(")" default-color)))
|
|
(build-test "(define-syntax (f stx) (syntax 1))"
|
|
'(("(" default-color)
|
|
("define-syntax" imported-syntax)
|
|
(" (" default-color)
|
|
("f" lexically-bound-syntax)
|
|
(" " default-color)
|
|
("stx" lexically-bound-variable)
|
|
(") (" default-color)
|
|
("syntax" imported-syntax)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("))" default-color)))
|
|
(build-test "(module m mzscheme)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m " default-color)
|
|
("mzscheme" error)
|
|
(")" default-color)))
|
|
(build-test "(require-for-syntax mzscheme)"
|
|
'(("(" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("mzscheme" error)
|
|
(")" default-color)))
|
|
(build-test "(require (lib \"list.ss\"))"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" " default-color)
|
|
("(lib \"list.ss\")" error)
|
|
(")" default-color)))
|
|
(build-test "(module m mzscheme (provide x) (define x 1))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("provide" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(") (" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("))" default-color))
|
|
(list '((10 18) (20 27) (32 38))
|
|
'((39 40) (28 29))))
|
|
|
|
(build-test "(module m mzscheme (+ 1 2))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("+" imported-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(" " default-color)
|
|
("2" constant)
|
|
("))" default-color))
|
|
(list '((10 18) (20 21))))
|
|
|
|
(build-test "(module m mzscheme (require (lib \"list.ss\")))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" " default-color)
|
|
("(lib \"list.ss\")" error)
|
|
("))" default-color))
|
|
(list '((10 18) (20 27))))
|
|
|
|
(build-test "(module m mzscheme (require-for-syntax (lib \"list.ss\")) (define-syntax s foldl))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" (lib \"list.ss\")) (" default-color)
|
|
("define-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
("))" default-color))
|
|
(list '((10 18) (20 38) (57 70))
|
|
'((39 54) (73 78))))
|
|
|
|
(build-test "(module m mzscheme (require-for-syntax (lib \"etc.ss\")) (define-syntax s (rec f 1)))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" (lib \"etc.ss\")) (" default-color)
|
|
("define-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" (" default-color)
|
|
("rec" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")))" default-color))
|
|
(list '((10 18) (20 38) (56 69))
|
|
'((39 53) (73 76))))
|
|
|
|
(build-test "(define-syntax s (lambda (stx) (syntax-case stx () (_ 123))))"
|
|
'(("(" default-color)
|
|
("define-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" (" default-color)
|
|
("lambda" imported-syntax)
|
|
(" (" default-color)
|
|
("stx" lexically-bound-variable)
|
|
(") (" default-color)
|
|
("syntax-case" imported-syntax)
|
|
(" " default-color)
|
|
("stx" lexically-bound-variable)
|
|
(" () (" default-color)
|
|
("_" lexically-bound-syntax)
|
|
(" " default-color)
|
|
("123" constant)
|
|
("))))" default-color))
|
|
(list '((26 29) (44 47))))
|
|
|
|
(build-test "(require (lib \"list.ss\")) first"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" (lib \"list.ss\")) " default-color)
|
|
("first" imported-variable))
|
|
(list '((9 24) (26 31))))
|
|
|
|
(build-test "(require (lib \"etc.ss\")) (rec f 1)"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" (lib \"etc.ss\")) (" default-color)
|
|
("rec" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")" default-color))
|
|
(list '((9 23) (26 29))))
|
|
|
|
(build-test "(define-struct s ())"
|
|
'(("(" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" ())" default-color)))
|
|
|
|
(build-test "(define-struct s ()) (define-struct (t s) ())"
|
|
'(("(" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" ()) (" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" (" default-color)
|
|
("t" lexically-bound-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(") ())" default-color))
|
|
(list '((15 16) (39 40))))
|
|
|
|
(build-test "(let () (define-struct s (x)) 1)"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" () (" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" (x)) " default-color)
|
|
("1" constant)
|
|
(")" default-color)))
|
|
|
|
(build-test "(let ([x 12]) (define-struct s (x)) x)"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" ([" default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("12" constant)
|
|
("]) (" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" (x)) " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((7 8) (36 37))))
|
|
|
|
(build-test "`(1 ,x 2)"
|
|
'(("`" imported-syntax)
|
|
("(" default-color)
|
|
("1" constant)
|
|
(" ," default-color)
|
|
("x" error)
|
|
(" " default-color)
|
|
("2" constant)
|
|
(")" default-color)))
|
|
|
|
(build-test "`(a ,2 b c d)"
|
|
`(("`" imported-syntax)
|
|
("(" default-color)
|
|
("a" constant)
|
|
(" ," default-color)
|
|
("2" constant)
|
|
(" " default-color)
|
|
("b" constant)
|
|
(" " default-color)
|
|
("c" constant)
|
|
(" " default-color)
|
|
("d" constant)
|
|
(")" default-color)))
|
|
|
|
(build-test "#!"
|
|
'(("#!" default-color)))
|
|
|
|
(build-test "#!\n"
|
|
'(("#!\n" default-color)))
|
|
|
|
(build-test "#!\n1"
|
|
'(("#!\n" default-color)
|
|
("1" constant)))
|
|
|
|
(build-test "#!\n1\n1"
|
|
'(("#!\n" default-color)
|
|
("1" constant)
|
|
("\n" default-color)
|
|
("1" constant)))
|
|
|
|
(build-test "(module m mzscheme (lambda (x) x) (provide))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("lambda" imported-syntax)
|
|
(" (" default-color)
|
|
("x" lexically-bound-variable)
|
|
(") " default-color)
|
|
("x" lexically-bound-variable)
|
|
(") (" default-color)
|
|
("provide" imported-syntax)
|
|
("))" default-color))
|
|
(list '((10 18) (20 26) (35 42))
|
|
'((28 29) (31 32))))
|
|
|
|
(build-test "(module m mzscheme (define-struct s (a)) s-a make-s s? set-s-a!)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("define-struct" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" (a)) " default-color)
|
|
("s-a" lexically-bound-variable)
|
|
(" " default-color)
|
|
("make-s" lexically-bound-variable)
|
|
(" " default-color)
|
|
("s?" lexically-bound-variable)
|
|
(" " default-color)
|
|
("set-s-a!" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 33))))
|
|
|
|
(build-test "(define tordu3 '(a . #0=(b c d . #0#)))"
|
|
'(("(" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("tordu3" lexically-bound-variable)
|
|
(" " default-color)
|
|
("'" imported-syntax)
|
|
("(a . #0=(b c d . #0#))" constant)
|
|
(")" default-color)))
|
|
|
|
(build-test "(let l () l l)"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" " default-color)
|
|
("l" lexically-bound-variable)
|
|
(" () " default-color)
|
|
("l" lexically-bound-variable)
|
|
(" " default-color)
|
|
("l" lexically-bound-variable)
|
|
(")" default-color))
|
|
(list '((5 6) (10 11) (12 13))))
|
|
(build-test "(class object% this)"
|
|
'(("(" default-color)
|
|
("class" imported-syntax)
|
|
(" " default-color)
|
|
("object%" lexically-bound-variable)
|
|
(" " default-color)
|
|
("this" imported-identifier)
|
|
(")" default-color)))
|
|
(build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (lib \"list.ss\")) " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 43) (45 50))))
|
|
(build-test "(module m (lib \"htdp-beginner.ss\" \"lang\") empty)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m (lib \"htdp-beginner.ss\" \"lang\") " default-color)
|
|
("empty" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 41) (42 47))))
|
|
(build-test "(module m mzscheme (require (prefix x: (lib \"list.ss\"))) x:foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (prefix x: (lib \"list.ss\"))) " default-color)
|
|
("x:foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 55) (57 64))))
|
|
|
|
(build-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")) x:foldl foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (prefix x: (lib \"list.ss\")) (lib \"list.ss\")) " default-color)
|
|
("x:foldl" imported-variable)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 55) (73 80) (81 86))
|
|
'((56 71) (73 80) (81 86))))
|
|
|
|
(build-test "(module m mzscheme (require (lib \"etc.ss\")) (rec f 1))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (lib \"etc.ss\")) (" default-color)
|
|
("rec" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("))" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 42) (45 48))))
|
|
|
|
(build-test "(module m (lib \"htdp-intermediate.ss\" \"lang\") (local ((define x x)) x))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m (lib \"htdp-intermediate.ss\" \"lang\") (" default-color)
|
|
("local" imported-syntax)
|
|
(" ((define " default-color)
|
|
("x" lexically-bound-variable)
|
|
(" " default-color)
|
|
("x" lexically-bound-variable)
|
|
(")) " default-color)
|
|
("x" lexically-bound-variable)
|
|
("))" default-color))
|
|
(list '((10 45) (47 52))
|
|
'((62 63) (64 65) (68 69))))
|
|
|
|
(make-dir-test "(module m mzscheme (require \"~a/list.ss\") foldl foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" \"" default-color)
|
|
(relative-path default-color)
|
|
("/list.ss\") " default-color)
|
|
("foldl" imported-variable)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
#f)))
|
|
|
|
(define (run-test)
|
|
(check-language-level #rx"Graphical")
|
|
(let* ([drs (wait-for-drscheme-frame)]
|
|
[defs (send drs get-definitions-text)]
|
|
[filename (make-temporary-file "syncheck-test~a")])
|
|
(let-values ([(dir _1 _2) (split-path filename)])
|
|
(send defs save-file filename)
|
|
(preferences:set 'framework:coloring-active #f)
|
|
(for-each (run-one-test (normalize-path dir)) tests)
|
|
(preferences:set 'framework:coloring-active #t)
|
|
(send defs save-file) ;; clear out autosave
|
|
(send defs set-filename #f)
|
|
(delete-file filename))))
|
|
|
|
(define ((run-one-test save-dir) test)
|
|
(let* ([drs (wait-for-drscheme-frame)]
|
|
[defs (send drs get-definitions-text)]
|
|
[input (test-input test)]
|
|
[expected (test-expected test)]
|
|
[arrows (test-arrows test)]
|
|
[relative (find-relative-path save-dir (collection-path "mzlib"))])
|
|
(clear-definitions drs)
|
|
(cond
|
|
[(dir-test? test)
|
|
(type-in-definitions drs (format input (path->string relative)))]
|
|
[else (type-in-definitions drs input)])
|
|
(test:button-push (send drs syncheck:get-button))
|
|
(wait-for-computation drs)
|
|
|
|
;; this isn't right -- seems like there is a race condition because
|
|
;; wait-for-computation isn't waiting long enough?
|
|
'(when (send defs in-edit-sequence?)
|
|
(error 'syncheck-test.ss "still in edit sequence for ~s" input))
|
|
|
|
(when (send drs syncheck:error-report-visible?)
|
|
(printf "FAILED ~s\n error report window is visible\n"
|
|
input))
|
|
|
|
;; need to check for syntax error here
|
|
(let ([got (get-annotated-output drs)])
|
|
(compare-output (cond
|
|
[(dir-test? test)
|
|
(map (lambda (x)
|
|
(list (if (eq? (car x) 'relative-path)
|
|
(path->string relative)
|
|
(car x))
|
|
(cadr x)))
|
|
expected)]
|
|
[else
|
|
expected])
|
|
got
|
|
arrows
|
|
(send defs syncheck:get-bindings-table)
|
|
input))))
|
|
|
|
(define remappings
|
|
'((constant default-color)
|
|
(imported-syntax imported-identifier)
|
|
(imported-variable imported-identifier)
|
|
(lexically-bound-syntax lexically-bound-identifier)
|
|
(lexically-bound-variable lexically-bound-identifier)))
|
|
|
|
(define (collapse-and-rename expected)
|
|
(let ([renamed
|
|
(map (lambda (ent)
|
|
(let* ([str (car ent)]
|
|
[id (cadr ent)]
|
|
[matches (assoc id remappings)])
|
|
(if matches
|
|
(list str (cadr matches))
|
|
ent)))
|
|
expected)])
|
|
(let loop ([ids renamed])
|
|
(cond
|
|
[(null? ids) null]
|
|
[(null? (cdr ids)) ids]
|
|
[else (let ([fst (car ids)]
|
|
[snd (cadr ids)])
|
|
(if (eq? (cadr fst) (cadr snd))
|
|
(loop (cons (list (string-append (car fst) (car snd)) (cadr fst))
|
|
(cddr ids)))
|
|
(cons fst (loop (cdr ids)))))]))))
|
|
|
|
;; compare-arrows : (listof (cons (list number number) (listof (list number number))))
|
|
;; hash-table[(list text number number) -o> (listof (list text number number))]
|
|
;; -> void
|
|
(define (compare-arrows test-exp expected raw-actual)
|
|
(when expected
|
|
(let ()
|
|
(define already-checked (make-hash-table 'equal))
|
|
|
|
(define actual-ht (make-hash-table 'equal))
|
|
(define stupid-internal-define-syntax1
|
|
(hash-table-for-each raw-actual
|
|
(lambda (k v)
|
|
(hash-table-put! actual-ht
|
|
(cdr k)
|
|
(quicksort
|
|
(map cdr v)
|
|
(lambda (x y) (< (car x) (car y))))))))
|
|
(define expected-ht (make-hash-table 'equal))
|
|
(define stupid-internal-define-syntax2
|
|
(for-each (lambda (binding) (hash-table-put! expected-ht (car binding) (cdr binding)))
|
|
expected))
|
|
;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean
|
|
(define (test-binding expected? ht)
|
|
(lambda (pr)
|
|
(let ([frm (car pr)]
|
|
[to (cdr pr)])
|
|
(hash-table-get
|
|
already-checked
|
|
frm
|
|
(lambda ()
|
|
(hash-table-put! already-checked frm #t)
|
|
(let ([ht-ent (hash-table-get ht frm (lambda () 'nothing-there))])
|
|
(unless (equal? ht-ent to)
|
|
(printf (if expected?
|
|
"FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n"
|
|
"FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n")
|
|
test-exp
|
|
frm
|
|
ht-ent
|
|
to))))))))
|
|
|
|
(for-each (test-binding #t expected-ht) (hash-table-map actual-ht cons))
|
|
(for-each (test-binding #f actual-ht) (hash-table-map expected-ht cons)))))
|
|
|
|
(define (compare-output raw-expected got arrows arrows-got input)
|
|
(let ([expected (collapse-and-rename raw-expected)])
|
|
(cond
|
|
[(equal? got expected)
|
|
(compare-arrows input arrows arrows-got)]
|
|
[else
|
|
(printf "FAILED: ~s\n expected: ~s\n got: ~s\n"
|
|
input expected got)])))
|
|
|
|
;; get-annotate-output : drscheme-frame -> (listof str/ann)
|
|
(define (get-annotated-output drs)
|
|
(let ([chan (make-channel)])
|
|
(queue-callback
|
|
(λ ()
|
|
(channel-put chan (get-string/style-desc (send drs get-definitions-text)))))
|
|
(channel-get chan))))
|
|
|