#| tests involving object% are commented out, since they trigger runtime errors in check syntax. |# (module syncheck-test mzscheme (require "drscheme-test-util.ss" (lib "gui.ss" "tests" "utils") mzlib/etc mzlib/class mzlib/list mzlib/file mred 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%" imported-syntax))) ; used to be 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 "(define-for-syntax (f x) x)" '(("(" default-color) ("define-for-syntax" imported-syntax) (" (" default-color) ("f" lexically-bound-syntax) (" " default-color) ("x" lexically-bound-variable) (") " default-color) ("x" lexically-bound-variable) (")" default-color)) (list '((22 23) (25 26)))) (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-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))" '(("(" default-color) ("define-for-syntax" imported) (" (" default-color) ("f" lexically-bound) (" " default-color) ("x" lexically-bound) (") " default-color) ("x" lexically-bound) (") (" default-color) ("define" imported) (" (" default-color) ("f" lexically-bound) (" " default-color) ("x" lexically-bound) (") " default-color) ("x" lexically-bound) (") " default-color) ("f" lexically-bound) (" (" default-color) ("define-syntax" imported) (" (" default-color) ("m" lexically-bound) (" " default-color) ("x" lexically-bound) (") (" default-color) ("f" lexically-bound) (" " default-color) ("x" lexically-bound) ("))" default-color)) '(((20 21) (69 70)) ((22 23) (25 26)) ((37 38) (45 46)) ((39 40) (42 43)) ((65 66) (71 72)))) (build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))" '(("(" default-color) ("module" imported) (" m mzscheme (" default-color) ("define-for-syntax" imported) (" (" default-color) ("f" lexically-bound) (" " default-color) ("x" lexically-bound) (") " default-color) ("x" lexically-bound) (") (" default-color) ("define" imported) (" (" default-color) ("f" lexically-bound) (" " default-color) ("x" lexically-bound) (") " default-color) ("x" lexically-bound) (") " default-color) ("f" lexically-bound) (" (" default-color) ("define-syntax" imported) (" (" default-color) ("m" lexically-bound) (" " default-color) ("stx" lexically-bound) (") (" default-color) ("f" lexically-bound) (" " default-color) ("stx" lexically-bound) (")))" default-color)) '(((10 18) (20 37) (48 54) (67 80)) ((39 40) (90 91)) ((41 42) (44 45)) ((56 57) (64 65)) ((58 59) (61 62)) ((84 87) (92 95)))) (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 "#! /usr/bin/env" '(("#! /usr/bin/env" default-color))) (build-test "#! /usr/bin/env\n" '(("#! /usr/bin/env\n" default-color))) (build-test "#! /usr/bin/env\n1" '(("#! /usr/bin/env\n" default-color) ("1" constant))) (build-test "#! /usr/bin/env\n1\n1" '(("#! /usr/bin/env\n" default-color) ("1" constant) ("\n" default-color) ("1" constant))) (build-test "#! /usr/bin/env\n(lambda (x) x)" '(("#! /usr/bin/env\n(" default-color) ("lambda" imported-syntax) (" (" default-color) ("x" lexically-bound-variable) (") " default-color) ("x" lexically-bound-variable) (")" default-color)) (list '((25 26) (28 29)))) (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 "(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%" imported-syntax) ; was lexically-bound-variable (" " default-color) ("this" imported) (")" 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)) '((56 71) (81 86)))) (build-test "(module m mzscheme (require (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) foldl foldr)" '(("(" default-color) ("module" imported-syntax) (" m mzscheme (" default-color) ("require" imported-syntax) (" (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) " default-color) ("foldl" imported-variable) (" " default-color) ("foldr" imported-variable) (")" default-color)) (list '((10 18) (20 27)) '((28 56) (87 92) (93 98)) '((57 85) (87 92) (93 98)))) (build-test "(module m mzscheme (require (prefix x: mzscheme)) x:+ +)" '(("(" default-color) ("module" imported-syntax) (" m mzscheme (" default-color) ("require" imported-syntax) (" (prefix x: mzscheme)) " default-color) ("x:+" imported-variable) (" " default-color) ("+" imported-variable) (")" default-color)) (list '((10 18) (20 27) (54 55)) '((28 48) (50 53)))) (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)))) (build-test "(module m mzscheme (define-syntax rename #f) (require (rename mzscheme ++ +)))" '(("(" default-color) ("module" imported) (" m mzscheme (" default-color) ("define-syntax" imported) (" " default-color) ("rename" lexically-bound) (" #f) (" default-color) ("require" imported) (" (rename mzscheme ++ +)))" default-color)) (list '((10 18) (20 33) (46 53)))) (build-test "(module m mzscheme (define-syntax rename #f) (define f 1) (provide (rename f g)))" '(("(" default-color) ("module" imported) (" m mzscheme (" default-color) ("define-syntax" imported) (" " default-color) ("rename" lexically-bound) (" #f) (" default-color) ("define" imported) (" " default-color) ("f" lexically-bound) (" 1) (" default-color) ("provide" imported) (" (rename " default-color) ("f" lexically-bound) (" g)))" default-color)) (list '((10 18) (20 33) (46 52) (59 66)) '((53 54) (75 76)))) (build-test "(module m mzscheme (define X 1) (provide (all-defined-except X)))" '(("(" default-color) ("module" imported) (" m mzscheme (" default-color) ("define" imported) (" " default-color) ("X" lexically-bound) (" 1) (" default-color) ("provide" imported) (" (all-defined-except " default-color) ("X" lexically-bound) (")))" default-color)) (list '((10 18) (20 26) (33 40)) '((27 28) (61 62)))) (build-test "(module m mzscheme (require-for-syntax mzscheme) (require-for-template mzscheme) (quote-syntax +))" '(("(" default-color) ("module" imported) (" m mzscheme (" default-color) ("require-for-syntax" imported) (" mzscheme) (" default-color) ("require-for-template" imported) (" mzscheme) (" default-color) ("quote-syntax" imported) (" +))" default-color)) (list '((71 79) (95 96)) '((10 18) (20 38) (50 70) (82 94) (95 96)) '((39 47) (95 96)))) ;; test case from Chongkai (build-test (format "~s\n\n#reader'reader\n1\n" '(module reader mzscheme (provide (rename mrs read-syntax) read) (define (mrs sv p) (datum->syntax-object (read-syntax #f (open-input-string "a")) `(module f mzscheme (provide x) (define x 1)) (list sv #f #f #f #f))))) '(("(" default-color) ("module" imported) (" reader mzscheme (" default-color) ("provide" imported) (" (rename " default-color) ("mrs" lexically-bound) (" read-syntax) " default-color) ("read" imported) (") (" default-color) ("define" imported) (" (" default-color) ("mrs" lexically-bound) (" " default-color) ("sv" lexically-bound) (" " default-color) ("p" lexically-bound) (") (" default-color) ("datum->syntax-object" imported) (" (" default-color) ("read-syntax" imported) (" #f (" default-color) ("open-input-string" imported) (" \"a\")) (" default-color) ("quasiquote" imported) (" (module f mzscheme (provide x) (define x 1))) (" default-color) ("list" imported) (" " default-color) ("sv" lexically-bound) (" #f #f #f #f))))\n\n#reader'reader\n1\n" default-color)) (list '((15 23) (25 32) (58 62) (65 71) (84 104) (106 117) (122 139) (147 157) (205 209)) '((77 79) (210 212)) '((73 76) (41 44)))) (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"Pretty") (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:run-one (lambda () (send (send drs syncheck:get-button) command))) (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) (imported-variable imported) (lexically-bound-syntax lexically-bound) (lexically-bound-variable lexically-bound))) (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 : expression ;; (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) (sort (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))))