1274 lines
57 KiB
Racket
1274 lines
57 KiB
Racket
#lang racket/base
|
|
|
|
(require "private/drracket-test-util.rkt"
|
|
drracket/private/syncheck/local-member-names
|
|
string-constants/string-constant
|
|
tests/utils/gui
|
|
racket/path
|
|
racket/class
|
|
racket/list
|
|
racket/file
|
|
mred
|
|
framework
|
|
mrlib/text-string-style-desc
|
|
(for-syntax racket/base))
|
|
|
|
(provide main)
|
|
|
|
;; 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 (line input expected arrows) #:transparent)
|
|
(define-struct (dir-test test) () #:transparent)
|
|
|
|
(define-struct rename-test (line input pos old-name new-name output) #:transparent)
|
|
|
|
(define build-test/proc
|
|
(λ (line input expected [arrow-table '()])
|
|
(make-test line input expected arrow-table)))
|
|
|
|
(define-syntax (build-test stx)
|
|
(syntax-case stx ()
|
|
[(_ args ...)
|
|
(with-syntax ([line (syntax-line stx)])
|
|
#'(build-test/proc line args ...))]))
|
|
|
|
(define-syntax (build-rename-test stx)
|
|
(syntax-case stx ()
|
|
[(_ args ...)
|
|
(with-syntax ([line (syntax-line stx)])
|
|
#'(rename-test line args ...))]))
|
|
|
|
(define-syntax (build-dir-test stx)
|
|
(syntax-case stx ()
|
|
[(_ args ...)
|
|
(with-syntax ([line (syntax-line stx)])
|
|
#'(make-dir-test line args ...))]))
|
|
|
|
;; 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" free-variable)
|
|
("]) " 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" free-variable)
|
|
(")" default-color)))
|
|
(build-test "(set! x 1)"
|
|
'(("(" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" free-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")" default-color)))
|
|
(build-test "(set! x 1) (define x 2)"
|
|
'(("(" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(") (" default-color)
|
|
("define" imported-syntax)
|
|
(" " default-color)
|
|
("x" set!d) ;; top-level doesn't help here ....
|
|
(" 2)" default-color))
|
|
(list '((19 20) (6 7))))
|
|
(build-test "(let ([x 1]) (set! x 2))"
|
|
'(("(" default-color)
|
|
("let" imported-syntax)
|
|
(" ([" default-color)
|
|
("x" set!d)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("]) (" default-color)
|
|
("set!" imported-syntax)
|
|
(" " default-color)
|
|
("x" set!d)
|
|
(" " 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" free-variable)))
|
|
(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" free-variable)
|
|
(" " default-color)
|
|
("x" free-variable)
|
|
(")" 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 "(define-syntax-rule (m x y z) (list (λ x y) (λ x z)))\n(m x x x)"
|
|
'(("(" default-color)
|
|
("define-syntax-rule" imported)
|
|
(" (" default-color)
|
|
("m" lexically-bound)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("y" lexically-bound)
|
|
(" " default-color)
|
|
("z" lexically-bound)
|
|
(") (list (λ " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("y" lexically-bound)
|
|
(") (λ " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("z" lexically-bound)
|
|
(")))\n(" default-color)
|
|
("m" lexically-bound)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(")" default-color))
|
|
(list '((21 22) (55 56))
|
|
'((23 24) (39 40) (47 48))
|
|
'((25 26) (41 42))
|
|
'((27 28) (49 50))
|
|
'((57 58) (59 60) (61 62))))
|
|
|
|
(build-test "(module m mzscheme)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme)" default-color)))
|
|
(build-test "(require-for-syntax mzscheme)"
|
|
'(("(" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("mzscheme" unused-require)
|
|
(")" default-color)))
|
|
(build-test "(require mzlib/list)"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" " default-color)
|
|
("mzlib/list" unused-require)
|
|
(")" 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 mzlib/list))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" " default-color)
|
|
("mzlib/list" unused-require)
|
|
("))" default-color))
|
|
(list '((10 18) (20 27))))
|
|
|
|
(build-test "(module m mzscheme (require-for-syntax mzlib/list) (define-syntax s foldl))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" mzlib/list) (" default-color)
|
|
("define-syntax" imported-syntax)
|
|
(" " default-color)
|
|
("s" lexically-bound-syntax)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
("))" default-color))
|
|
(list '((10 18) (20 38) (52 65))
|
|
'((39 49) (68 73))))
|
|
|
|
(build-test "(module m mzscheme (require-for-syntax mzlib/etc) (define-syntax s (rec f 1)))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require-for-syntax" imported-syntax)
|
|
(" mzlib/etc) (" 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) (51 64))
|
|
'((39 48) (68 71))))
|
|
|
|
(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 mzlib/list) first"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" mzlib/list) " default-color)
|
|
("first" imported-variable))
|
|
(list '((9 19) (21 26))))
|
|
|
|
(build-test "(require mzlib/etc) (rec f 1)"
|
|
'(("(" default-color)
|
|
("require" imported-syntax)
|
|
(" mzlib/etc) (" default-color)
|
|
("rec" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
(")" default-color))
|
|
(list '((9 18) (21 24))))
|
|
|
|
(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" free-variable)
|
|
(" " 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 mzlib/list) foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" mzlib/list) " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 38) (40 45))))
|
|
(build-test "(module m lang/htdp-beginner empty)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m lang/htdp-beginner " default-color)
|
|
("empty" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 28) (29 34))))
|
|
(build-test "(module m mzscheme (require (prefix x: mzlib/list)) x:foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (prefix x: mzlib/list)) " default-color)
|
|
("x:foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 50) (52 59))))
|
|
|
|
(build-test "(module m mzscheme (require (prefix x: mzlib/list) mzlib/list) x:foldl foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (prefix x: mzlib/list) mzlib/list) " default-color)
|
|
("x:foldl" imported-variable)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 50) (63 70))
|
|
'((51 61) (71 76))))
|
|
|
|
(build-test "(module m mzscheme (require (only mzlib/list foldr) (only mzlib/list foldl)) foldl foldr)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" (only mzlib/list foldr) (only mzlib/list foldl)) " default-color)
|
|
("foldl" imported-variable)
|
|
(" " default-color)
|
|
("foldr" imported-variable)
|
|
(")" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 51) (77 82) (83 88))
|
|
'((52 75) (77 82) (83 88))))
|
|
|
|
(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 mzlib/etc) (rec f 1))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" mzlib/etc) (" default-color)
|
|
("rec" imported-syntax)
|
|
(" " default-color)
|
|
("f" lexically-bound-variable)
|
|
(" " default-color)
|
|
("1" constant)
|
|
("))" default-color))
|
|
(list '((10 18) (20 27))
|
|
'((28 37) (40 43))))
|
|
|
|
(build-test "(module m lang/htdp-intermediate (local ((define x x)) x))"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m lang/htdp-intermediate (" 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 32) (34 39))
|
|
'((49 50) (51 52) (55 56))))
|
|
|
|
(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))))
|
|
|
|
(build-dir-test "(module m mzscheme (require \"~a/list.rkt\") foldl foldl)"
|
|
'(("(" default-color)
|
|
("module" imported-syntax)
|
|
(" m mzscheme (" default-color)
|
|
("require" imported-syntax)
|
|
(" \"" default-color)
|
|
(relative-path default-color)
|
|
("/list.rkt\") " default-color)
|
|
("foldl" imported-variable)
|
|
(" " default-color)
|
|
("foldl" imported-variable)
|
|
(")" default-color))
|
|
#f)
|
|
|
|
(build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))"
|
|
'(("#lang scheme/base\n(" default-color)
|
|
("require" imported)
|
|
(" scheme)\n(" default-color)
|
|
("define-syntax" imported)
|
|
(" " default-color)
|
|
("m" lexically-bound)
|
|
(" (" default-color)
|
|
("lambda" imported)
|
|
(" (" default-color)
|
|
("x" lexically-bound)
|
|
(") " default-color)
|
|
("#'" imported)
|
|
("1))" default-color))
|
|
(list '((27 33) (19 26) (36 49) (53 59) (64 66))))
|
|
|
|
(build-test "#lang racket (begin-for-syntax (require (for-syntax racket)) (define x 1) (begin-for-syntax (define x 2) x))"
|
|
'(("#lang racket (" default-color)
|
|
("begin-for-syntax" imported)
|
|
(" (" default-color)
|
|
("require" imported)
|
|
(" (for-syntax " default-color)
|
|
("racket" default-color)
|
|
(")) (" default-color)
|
|
("define" imported)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" 1) (" default-color)
|
|
("begin-for-syntax" imported)
|
|
(" (" default-color)
|
|
("define" imported)
|
|
(" " default-color)
|
|
("x" lexically-bound)
|
|
(" 2) " default-color)
|
|
("x" lexically-bound)
|
|
("))" default-color))
|
|
(list '((6 12) (14 30) (32 39) (62 68) (75 91))
|
|
'((52 58) (93 99))
|
|
'((100 101) (105 106))))
|
|
|
|
(build-test "#lang racket (provide (contract-out [f (->i ((p? any/c)) (_ (p?) p?))])) (define (f a) 1)"
|
|
'(("#lang racket (" default-color)
|
|
("provide" imported)
|
|
(" (contract-out [" default-color)
|
|
("f" lexically-bound)
|
|
(" (" default-color)
|
|
("->i" imported)
|
|
(" ((p? " default-color)
|
|
("any/c" imported)
|
|
(")) (_ (" default-color)
|
|
("p?" lexically-bound)
|
|
(") " default-color)
|
|
("p?" lexically-bound)
|
|
("))])) (" default-color)
|
|
("define" imported)
|
|
(" (" default-color)
|
|
("f" lexically-bound)
|
|
(" " default-color)
|
|
("a" lexically-bound)
|
|
(") 1)" default-color))
|
|
(list '((82 83) (37 38))
|
|
'((61 63) (65 67))
|
|
'((6 12) (14 21) (40 43) (49 54) (74 80))))
|
|
|
|
(build-rename-test "(lambda (x) x)"
|
|
9
|
|
"x"
|
|
"y"
|
|
"(lambda (y) y)")
|
|
|
|
(build-rename-test "(lambda (x) x)"
|
|
9
|
|
"x"
|
|
"yy"
|
|
"(lambda (yy) yy)")
|
|
|
|
(build-rename-test "(lambda (x) x)"
|
|
9
|
|
"x"
|
|
"yxy"
|
|
"(lambda (yxy) yxy)")
|
|
(build-rename-test "(lambda (x) x x)"
|
|
9
|
|
"x"
|
|
"yxy"
|
|
"(lambda (yxy) yxy yxy)")
|
|
(build-rename-test "(lambda (x) x x)"
|
|
12
|
|
"x"
|
|
"yxy"
|
|
"(lambda (yxy) yxy yxy)")
|
|
(build-rename-test "(lambda (x) x x)"
|
|
14
|
|
"x"
|
|
"yxy"
|
|
"(lambda (yxy) yxy yxy)")
|
|
|
|
(build-rename-test "(define-syntax-rule (m x) (λ (x) x))(m z)"
|
|
39
|
|
"z"
|
|
"qq"
|
|
"(define-syntax-rule (m x) (λ (x) x))(m qq)")
|
|
|
|
(build-rename-test (string-append
|
|
"#lang racket/base\n"
|
|
"(require (for-syntax racket/base))\n"
|
|
"(define-syntax-rule (m x)\n"
|
|
" (begin (λ (x) x) (define x 1) (λ (x) x)))\n"
|
|
"(m x)\n"
|
|
"x\n")
|
|
126
|
|
"x"
|
|
"y"
|
|
(string-append
|
|
"#lang racket/base\n"
|
|
"(require (for-syntax racket/base))\n"
|
|
"(define-syntax-rule (m x)\n"
|
|
" (begin (λ (x) x) (define x 1) (λ (x) x)))\n"
|
|
"(m y)\n"
|
|
"y\n"))
|
|
|
|
(build-rename-test (string-append
|
|
"#lang racket"
|
|
"\n"
|
|
"(define player%\n"
|
|
" (class object%\n"
|
|
" (init-field strategy player# tiles)\n"
|
|
" (field [score (set)])\n"
|
|
"\n"
|
|
" (super-new)\n"
|
|
"\n"
|
|
" (define/private (put t pl)\n"
|
|
" (set! tiles(remove t tiles)))))\n")
|
|
80
|
|
"tiles"
|
|
"*tiles"
|
|
(string-append
|
|
"#lang racket"
|
|
"\n"
|
|
"(define player%\n"
|
|
" (class object%\n"
|
|
" (init-field strategy player# *tiles)\n"
|
|
" (field [score (set)])\n"
|
|
"\n"
|
|
" (super-new)\n"
|
|
"\n"
|
|
" (define/private (put t pl)\n"
|
|
" (set! *tiles(remove t *tiles)))))\n"))
|
|
|
|
(build-rename-test (string-append
|
|
"#lang racket"
|
|
"\n"
|
|
"(define player%\n"
|
|
" (class object%\n"
|
|
" (init-field strategy player# *tiles)\n"
|
|
" (field [score (set)])\n"
|
|
"\n"
|
|
" (super-new)\n"
|
|
"\n"
|
|
" (define/private (put t pl)\n"
|
|
" (set! *tiles(remove t *tiles)))))\n")
|
|
80
|
|
"*tiles"
|
|
"tiles"
|
|
(string-append
|
|
"#lang racket"
|
|
"\n"
|
|
"(define player%\n"
|
|
" (class object%\n"
|
|
" (init-field strategy player# tiles)\n"
|
|
" (field [score (set)])\n"
|
|
"\n"
|
|
" (super-new)\n"
|
|
"\n"
|
|
" (define/private (put t pl)\n"
|
|
" (set! tiles(remove t tiles)))))\n"))))
|
|
|
|
|
|
(define (main)
|
|
(fire-up-drracket-and-run-tests
|
|
(λ ()
|
|
(let ([drs (wait-for-drracket-frame)])
|
|
;(set-language-level! (list "Pretty Big"))
|
|
(begin
|
|
(set-language-level! (list "Pretty Big") #f)
|
|
(test:set-radio-box-item! "No debugging or profiling")
|
|
(let ([f (test:get-active-top-level-window)])
|
|
(test:button-push "OK")
|
|
(wait-for-new-frame f)))
|
|
(do-execute drs)
|
|
(let* ([defs (queue-callback/res (λ () (send drs get-definitions-text)))]
|
|
[filename (make-temporary-file "syncheck-test~a")])
|
|
(let-values ([(dir _1 _2) (split-path filename)])
|
|
(queue-callback/res (λ () (send defs save-file filename)))
|
|
(preferences:set 'framework:coloring-active #f)
|
|
(close-the-error-window-test drs)
|
|
(for-each (run-one-test (normalize-path dir)) tests)
|
|
(preferences:set 'framework:coloring-active #t)
|
|
(queue-callback/res
|
|
(λ ()
|
|
(send defs save-file) ;; clear out autosave
|
|
(send defs set-filename #f)))
|
|
(delete-file filename)
|
|
|
|
(printf "Ran ~a tests.\n" total-tests-run)))))))
|
|
|
|
(define (close-the-error-window-test drs)
|
|
(clear-definitions drs)
|
|
(insert-in-definitions drs "(")
|
|
(click-check-syntax-button drs)
|
|
(wait-for-computation drs)
|
|
(unless (queue-callback/res (λ () (send drs syncheck:error-report-visible?)))
|
|
(error 'close-the-error-window-test "error report window never appeared"))
|
|
(do-execute drs)
|
|
(when (queue-callback/res (λ () (send drs syncheck:error-report-visible?)))
|
|
(error 'close-the-error-window-test "error report window did not go away after clicking Run")))
|
|
|
|
(define total-tests-run 0)
|
|
|
|
(define ((run-one-test save-dir) test)
|
|
(set! total-tests-run (+ total-tests-run 1))
|
|
(let* ([drs (wait-for-drracket-frame)]
|
|
[defs (queue-callback/res (λ () (send drs get-definitions-text)))])
|
|
(clear-definitions drs)
|
|
(cond
|
|
[(test? test)
|
|
(let ([input (test-input test)]
|
|
[expected (test-expected test)]
|
|
[arrows (test-arrows test)]
|
|
[relative (find-relative-path save-dir (collection-path "mzlib"))])
|
|
(cond
|
|
[(dir-test? test)
|
|
(insert-in-definitions drs (format input (path->require-string relative)))]
|
|
[else (insert-in-definitions drs input)])
|
|
(click-check-syntax-and-check-errors drs test)
|
|
|
|
;; 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->require-string relative)
|
|
(car x))
|
|
(cadr x)))
|
|
expected)]
|
|
[else
|
|
expected])
|
|
got
|
|
arrows
|
|
(queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
|
|
input)))]
|
|
[(rename-test? test)
|
|
(insert-in-definitions drs (rename-test-input test))
|
|
(click-check-syntax-and-check-errors drs test)
|
|
(define menu-item
|
|
(queue-callback/res
|
|
(λ ()
|
|
(define defs (send drs get-definitions-text))
|
|
(define menu (send defs syncheck:build-popup-menu (rename-test-pos test) defs))
|
|
(define item-name (format "Rename ~a" (rename-test-old-name test)))
|
|
(define menu-item
|
|
(for/or ([x (in-list (send menu get-items))])
|
|
(and (is-a? x labelled-menu-item<%>)
|
|
(equal? (send x get-label) item-name)
|
|
x)))
|
|
(cond
|
|
[menu-item
|
|
menu-item]
|
|
[else
|
|
(eprintf "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s"
|
|
test
|
|
item-name
|
|
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send menu get-items)))
|
|
#f]))))
|
|
(when menu-item
|
|
(queue-callback (λ () (send menu-item command (make-object control-event% 'menu))))
|
|
(wait-for-new-frame drs)
|
|
(for ([x (in-string (rename-test-new-name test))])
|
|
(test:keystroke x))
|
|
(test:button-push "OK")
|
|
(define result
|
|
(queue-callback/res (λ ()
|
|
(define defs (send drs get-definitions-text))
|
|
(send defs get-text 0 (send defs last-position)))))
|
|
(unless (equal? result (rename-test-output test))
|
|
(eprintf "syncheck-test.rkt FAILED\n test ~s\n got ~s\n"
|
|
test
|
|
result)))])))
|
|
|
|
(define (path->require-string relative)
|
|
(define (p->string p)
|
|
(cond
|
|
[(eq? p 'up) ".."]
|
|
[else (path->string p)]))
|
|
(apply string-append (add-between (map p->string (explode-path relative)) "/")))
|
|
|
|
|
|
(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))
|
|
|
|
(define actual-ht (make-hash))
|
|
(define stupid-internal-define-syntax1
|
|
(hash-for-each raw-actual
|
|
(lambda (k v)
|
|
(hash-set! actual-ht (cdr k)
|
|
(sort (map cdr v)
|
|
(lambda (x y) (< (car x) (car y))))))))
|
|
(define expected-ht (make-hash))
|
|
(define stupid-internal-define-syntax2
|
|
(for-each (lambda (binding) (hash-set! 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-ref
|
|
already-checked
|
|
frm
|
|
(lambda ()
|
|
(hash-set! already-checked frm #t)
|
|
(let ([ht-ent (hash-ref ht frm (lambda () 'nothing-there))])
|
|
(unless (equal? ht-ent to)
|
|
(eprintf (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-map actual-ht cons))
|
|
(for-each (test-binding #f actual-ht) (hash-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
|
|
(eprintf "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)
|
|
(queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))
|
|
|
|
(define (click-check-syntax-and-check-errors drs test)
|
|
(click-check-syntax-button drs)
|
|
(wait-for-computation drs)
|
|
(when (queue-callback/res (λ () (send (send drs get-definitions-text) in-edit-sequence?)))
|
|
(error 'syncheck-test.rkt "still in edit sequence for ~s" test))
|
|
|
|
(let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))])
|
|
(when err
|
|
(eprintf "FAILED ~s\n error report window is visible:\n ~a\n"
|
|
test
|
|
err))))
|
|
|
|
(define (click-check-syntax-button drs)
|
|
(test:run-one (lambda () (send (send drs syncheck:get-button) command))))
|
|
|
|
(main)
|