very improved module-language tests, update them to work with the new messages
svn: r11109
This commit is contained in:
Eli Barzilay
parent
e79ddc4f44
commit
2d553df7ef
|
|
@ -28,6 +28,8 @@
|
|||
clear-definitions
|
||||
type-in-definitions
|
||||
type-in-interactions
|
||||
paste-in-definitions
|
||||
paste-in-interactions
|
||||
type-string
|
||||
wait
|
||||
wait-pending
|
||||
|
|
@ -188,26 +190,30 @@
|
|||
(fw:test:menu-select "Edit" (if (eq? (system-type) 'macos)
|
||||
"Clear"
|
||||
"Delete")))
|
||||
|
||||
|
||||
(define (type-in-definitions frame str)
|
||||
(type-in-definitions/interactions (lambda (x) (send x get-definitions-canvas)) frame str))
|
||||
(define (type-in-interactions frame str)
|
||||
(type-in-definitions/interactions (lambda (x) (send x get-interactions-canvas)) frame str))
|
||||
|
||||
(define (type-in-definitions/interactions get-canvas frame str/sexp)
|
||||
(define (type-in-definitions frame str)
|
||||
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #f))
|
||||
(define (type-in-interactions frame str)
|
||||
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #f))
|
||||
(define (paste-in-definitions frame str)
|
||||
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #t))
|
||||
(define (paste-in-interactions frame str)
|
||||
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #t))
|
||||
|
||||
(define (put-in-frame get-canvas frame str/sexp paste?)
|
||||
(let ([str (if (string? str/sexp)
|
||||
str/sexp
|
||||
(let ([port (open-output-string)])
|
||||
(parameterize ([current-output-port port])
|
||||
(write str/sexp port))
|
||||
(get-output-string port)))])
|
||||
(verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame)
|
||||
(verify-drscheme-frame-frontmost 'put-in-frame frame)
|
||||
(let ([canvas (get-canvas frame)])
|
||||
(fw:test:new-window canvas)
|
||||
(send (send canvas get-editor) set-caret-owner #f)
|
||||
(type-string str))))
|
||||
|
||||
(let ([editor (send canvas get-editor)])
|
||||
(send editor set-caret-owner #f)
|
||||
(if paste? (send editor insert str) (type-string str))))))
|
||||
|
||||
;; type-string : string -> void
|
||||
;; to call test:keystroke repeatedly with the characters
|
||||
(define (type-string str)
|
||||
|
|
|
|||
92
collects/tests/drscheme/module-lang-test-utils.ss
Normal file
92
collects/tests/drscheme/module-lang-test-utils.ss
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
#lang scheme/gui
|
||||
(require "drscheme-test-util.ss" mzlib/etc framework scheme/string)
|
||||
|
||||
(provide test t run-test in-here write-test-modules)
|
||||
|
||||
;; utility to use with scribble/reader
|
||||
(define t string-append)
|
||||
|
||||
(define-struct test (definitions ; string
|
||||
interactions ; (union #f string)
|
||||
result ; string
|
||||
all?) ; boolean (#t => compare the whole window)
|
||||
#:omit-define-syntaxes)
|
||||
|
||||
(define in-here
|
||||
(let ([here (this-expression-source-directory)])
|
||||
(lambda (file) (path->string (build-path here file)))))
|
||||
|
||||
(define tests '())
|
||||
(define (test defs ints res [all? #f])
|
||||
(set! tests (cons (make-test (if (string? defs) defs (format "~s" defs))
|
||||
ints res all?)
|
||||
tests)))
|
||||
|
||||
(define temp-files '())
|
||||
(define (write-test-modules* name code)
|
||||
(let ([file (in-here (format "~a.ss" name))])
|
||||
(set! temp-files (cons file temp-files))
|
||||
(with-output-to-file file #:exists 'truncate
|
||||
(lambda () (printf "~s\n" code)))))
|
||||
(define-syntax write-test-modules
|
||||
(syntax-rules (module)
|
||||
[(_ (module name lang x ...) ...)
|
||||
(begin (write-test-modules* 'name '(module name lang x ...)) ...)]))
|
||||
|
||||
(define drs (wait-for-drscheme-frame))
|
||||
(define interactions-text (send drs get-interactions-text))
|
||||
|
||||
(define (single-test test)
|
||||
(let/ec k
|
||||
(clear-definitions drs)
|
||||
(paste-in-definitions drs (test-definitions test))
|
||||
(do-execute drs)
|
||||
|
||||
(let ([ints (test-interactions test)])
|
||||
|
||||
(when ints
|
||||
(let ([after-execute-output
|
||||
(send interactions-text
|
||||
get-text
|
||||
(send interactions-text paragraph-start-position 2)
|
||||
(send interactions-text paragraph-end-position 2))])
|
||||
(unless (string=? "> " after-execute-output)
|
||||
(printf "FAILED: ~a\n ~a\n expected no output after execution, got: ~s\n"
|
||||
(test-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
after-execute-output)
|
||||
(k (void)))
|
||||
(type-in-interactions drs ints)
|
||||
(test:keystroke #\return)
|
||||
(wait-for-computation drs)))
|
||||
|
||||
(let* ([text
|
||||
(if (test-all? test)
|
||||
(send interactions-text get-text)
|
||||
(let* ([para (- (send interactions-text position-paragraph
|
||||
(send interactions-text last-position))
|
||||
1)])
|
||||
(send interactions-text
|
||||
get-text
|
||||
(send interactions-text paragraph-start-position para)
|
||||
(send interactions-text paragraph-end-position para))))]
|
||||
[passed? (let ([r (test-result test)])
|
||||
((cond [(string? r) string=?]
|
||||
[(regexp? r) regexp-match?]
|
||||
[else 'module-lang-test "bad test value: ~e" r])
|
||||
r text))])
|
||||
(unless passed?
|
||||
(printf "FAILED: ~a\n ~a\n expected: ~s\n got: ~s\n"
|
||||
(test-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
(test-result test)
|
||||
text)
|
||||
(sleep 1000
|
||||
))))))
|
||||
|
||||
(define (run-test)
|
||||
(set-language-level! '("Module") #t)
|
||||
(for-each single-test (reverse tests))
|
||||
(clear-definitions drs)
|
||||
(send (send drs get-definitions-text) set-modified #f)
|
||||
(for ([file temp-files]) (when (file-exists? file) (delete-file file))))
|
||||
|
|
@ -1,221 +1,138 @@
|
|||
(module module-lang-test mzscheme
|
||||
(require "drscheme-test-util.ss"
|
||||
mzlib/class
|
||||
mzlib/file
|
||||
mzlib/etc
|
||||
mred
|
||||
framework
|
||||
(prefix fw: framework))
|
||||
|
||||
(provide run-test)
|
||||
|
||||
(define-struct test (definitions ;; string
|
||||
interactions ;; (union #f string)
|
||||
result)) ;; string
|
||||
#reader scribble/reader
|
||||
#lang scheme/gui
|
||||
(require "module-lang-test-utils.ss")
|
||||
(provide run-test)
|
||||
|
||||
(define this-dir (collection-path "tests" "drscheme"))
|
||||
;; set up for tests that need external files
|
||||
(write-test-modules
|
||||
(module module-lang-test-tmp mzscheme
|
||||
(provide (all-from-except mzscheme +)
|
||||
x)
|
||||
(define x 1))
|
||||
(module module-lang-test-tmp2 mzscheme
|
||||
(provide e)
|
||||
(define e #'1))
|
||||
(module module-lang-test-tmp3 mzscheme
|
||||
(define-syntax (bug-datum stx)
|
||||
(syntax-case stx ()
|
||||
[(dat . thing)
|
||||
(number? (syntax-e (syntax thing)))
|
||||
(syntax/loc stx (#%datum . thing))]))
|
||||
(provide #%module-begin [rename bug-datum #%datum])))
|
||||
|
||||
(define tests
|
||||
(list
|
||||
|
||||
(make-test ""
|
||||
#f
|
||||
(regexp "module-language: the definitions window must contain a module"))
|
||||
(make-test "1"
|
||||
#f
|
||||
(regexp "module-language: only module expressions are allowed"))
|
||||
(make-test "(module m mzscheme) 1"
|
||||
#f
|
||||
(regexp "module-language: there can only be one expression in the definitions window"))
|
||||
(make-test "#lang mzscheme\n(define x 1)" "x" "1")
|
||||
(make-test "(module m mzscheme (provide x) (define x 1))" "x" "1")
|
||||
(make-test "(module m mzscheme (define x 1))" "x" "1")
|
||||
(make-test "(module m mzscheme (define x 1) (define y 1) (provide y))" "x" "1")
|
||||
(make-test "(module m mzscheme (define x 1) (define y 2) (provide y))" "y" "2")
|
||||
(make-test "(module m mzscheme (require (lib \"list.ss\")))"
|
||||
"foldl"
|
||||
(regexp "foldl"))
|
||||
|
||||
(make-test "(module m mzscheme (require (rename (lib \"list.ss\") local-foldl foldl)))"
|
||||
"local-foldl"
|
||||
(regexp "foldl>"))
|
||||
|
||||
(make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))"
|
||||
"first"
|
||||
(regexp "first>"))
|
||||
(make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))"
|
||||
"foldl"
|
||||
". . reference to an identifier before its definition: foldl")
|
||||
|
||||
(make-test "(module m mzscheme (require (prefix mz: mzscheme)))" "mz:+" #rx"procedure:+")
|
||||
|
||||
(make-test "(module n mzscheme (provide (all-from-except mzscheme +)))"
|
||||
"+"
|
||||
#rx"procedure:+")
|
||||
|
||||
(make-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")))"
|
||||
"foldl"
|
||||
(regexp "foldl>"))
|
||||
(make-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")))"
|
||||
"x:foldl"
|
||||
(regexp "foldl>"))
|
||||
|
||||
(make-test (format "~s"
|
||||
`(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss")))
|
||||
x))
|
||||
"x"
|
||||
"1")
|
||||
|
||||
;; + shouldn't be bound in the REPL because it isn't bound
|
||||
;; in the module.
|
||||
(make-test (format "~s"
|
||||
`(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss")))
|
||||
x))
|
||||
"+"
|
||||
". . reference to an identifier before its definition: +")
|
||||
|
||||
(make-test (format "~s" '(module m mzscheme (provide lambda)))
|
||||
"(lambda (x) x)"
|
||||
#rx"<procedure")
|
||||
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax (m x) (syntax 1)) (provide m)))
|
||||
"(m)"
|
||||
"1")
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax s (syntax 1)) (provide s)))
|
||||
"s"
|
||||
". s: illegal use of syntax in: s")
|
||||
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x))
|
||||
"a"
|
||||
". . reference to an identifier before its definition: a")
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x))
|
||||
"a"
|
||||
". . reference to an identifier before its definition: a")
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x (define a 77)))
|
||||
"a"
|
||||
"77")
|
||||
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x (define a 78)))
|
||||
"a"
|
||||
"78")
|
||||
|
||||
(make-test
|
||||
(format "~s" `(module m mzscheme
|
||||
(require-for-syntax (file ,(path->string (build-path this-dir "module-lang-test-tmp2.ss"))))
|
||||
(provide s)
|
||||
(define-syntax (s stx) e)))
|
||||
(format "~s ~s" '(require m) 's)
|
||||
(test @t{}
|
||||
#f
|
||||
#rx"Module Language: There must be a valid module .* Try starting"
|
||||
#t)
|
||||
(test @t{1}
|
||||
#f
|
||||
#rx"Module Language: only a module expression is allowed"
|
||||
#t)
|
||||
(test @t{(module m mzscheme) 1}
|
||||
#f
|
||||
#rx"Module Language: there can only be one expression in the definitions"
|
||||
#t)
|
||||
(test @t{#lang mzscheme
|
||||
(define x 1)}
|
||||
@t{x}
|
||||
"1")
|
||||
(test @t{(module m mzscheme (provide x) (define x 1))}
|
||||
@t{x}
|
||||
"1")
|
||||
(test @t{(module m mzscheme (define x 1))}
|
||||
@t{x}
|
||||
"1")
|
||||
(test @t{(module m mzscheme (define x 1) (define y 1) (provide y))}
|
||||
@t{x}
|
||||
"1")
|
||||
(test @t{(module m mzscheme (define x 1) (define y 2) (provide y))}
|
||||
@t{y}
|
||||
"2")
|
||||
(test @t{(module m mzscheme (require (lib "list.ss")))}
|
||||
@t{foldl}
|
||||
#rx"foldl")
|
||||
(test @t{(module m mzscheme (require (rename (lib "list.ss") local-foldl foldl)))}
|
||||
@t{local-foldl}
|
||||
#rx"foldl>")
|
||||
(test @t{(module m mzscheme (require (all-except (lib "list.ss") foldl)))}
|
||||
@t{first}
|
||||
#rx"first>")
|
||||
(test @t{(module m mzscheme (require (all-except (lib "list.ss") foldl)))}
|
||||
@t{foldl}
|
||||
". . reference to an identifier before its definition: foldl")
|
||||
(test @t{(module m mzscheme (require (prefix mz: mzscheme)))}
|
||||
@t{mz:+}
|
||||
#rx"procedure:+")
|
||||
(test @t{(module n mzscheme (provide (all-from-except mzscheme +)))}
|
||||
@t{+}
|
||||
#rx"procedure:+")
|
||||
(test @t{(module m mzscheme
|
||||
(require (prefix x: (lib "list.ss")) (lib "list.ss")))}
|
||||
@t{foldl}
|
||||
#rx"foldl>")
|
||||
(test @t{(module m mzscheme
|
||||
(require (prefix x: (lib "list.ss")) (lib "list.ss")))}
|
||||
@t{x:foldl}
|
||||
#rx"foldl>")
|
||||
(test @t{(module m (file "@in-here{module-lang-test-tmp.ss}") x)}
|
||||
@t{x}
|
||||
"1")
|
||||
;; + shouldn't be bound in the REPL because it isn't bound in the module.
|
||||
(test @t{(module m (file "@in-here{module-lang-test-tmp.ss}") x)}
|
||||
@t{+}
|
||||
". . reference to an identifier before its definition: +")
|
||||
(test @t{(module m mzscheme (provide lambda))}
|
||||
@t{(lambda (x) x)}
|
||||
#rx"<procedure")
|
||||
(test @t{(module m mzscheme (define-syntax (m x) (syntax 1)) (provide m))}
|
||||
@t{(m)}
|
||||
"1")
|
||||
(test @t{(module m mzscheme (define-syntax s (syntax 1)) (provide s))}
|
||||
@t{s}
|
||||
". s: illegal use of syntax in: s")
|
||||
(test @t{(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x)}
|
||||
@t{a}
|
||||
". . reference to an identifier before its definition: a")
|
||||
(test @t{(module m mzscheme
|
||||
(define-syntax (x stx) #'(define-syntax (a stx) #'10))
|
||||
x
|
||||
x)}
|
||||
@t{a}
|
||||
". . reference to an identifier before its definition: a")
|
||||
(test @t{(module m mzscheme
|
||||
(define-syntax (x stx) #'(define a 10))
|
||||
x
|
||||
x
|
||||
(define a 77))}
|
||||
@t{a}
|
||||
"77")
|
||||
(test @t{(module m mzscheme
|
||||
(define-syntax (x stx) #'(define-syntax (a stx) #'10))
|
||||
x
|
||||
x
|
||||
(define a 78))}
|
||||
@t{a}
|
||||
"78")
|
||||
(test @t{(module m mzscheme
|
||||
(require-for-syntax (file "@in-here{module-lang-test-tmp2.ss}"))
|
||||
(provide s)
|
||||
(define-syntax (s stx) e))}
|
||||
@t{(require m) s}
|
||||
#rx"module-lang-test-tmp2.ss:1:[67][90]: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1$")
|
||||
|
||||
(make-test (format "~s"
|
||||
'(module tmp mzscheme
|
||||
(provide (rename app #%app)
|
||||
(rename -current-namespace current-namespace)
|
||||
(rename -module->namespace module->namespace))
|
||||
(define x 2)
|
||||
(define -current-namespace error)
|
||||
(define -module->namespace error)
|
||||
(define-syntax app
|
||||
(syntax-rules ()
|
||||
((app . x) '(app . x))))))
|
||||
"x"
|
||||
"2")
|
||||
|
||||
(make-test
|
||||
"#lang scheme\n(eval 'cons)"
|
||||
(test @t{(module tmp mzscheme
|
||||
(provide (rename app #%app)
|
||||
(rename -current-namespace current-namespace)
|
||||
(rename -module->namespace module->namespace))
|
||||
(define x 2)
|
||||
(define -current-namespace error)
|
||||
(define -module->namespace error)
|
||||
(define-syntax app (syntax-rules () ((app . x) '(app . x)))))}
|
||||
@t{x}
|
||||
"2")
|
||||
(test @t{#lang scheme
|
||||
(eval 'cons)}
|
||||
#f
|
||||
". compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: cons")
|
||||
|
||||
(make-test
|
||||
(format "~s" `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) 1 2 3))
|
||||
"1" ;; just make sure no errors.
|
||||
"1")))
|
||||
|
||||
;; set up for tests that need external files
|
||||
(call-with-output-file (build-path this-dir "module-lang-test-tmp.ss")
|
||||
(lambda (port)
|
||||
(write `(module module-lang-test-tmp mzscheme
|
||||
(provide (all-from-except mzscheme +)
|
||||
x)
|
||||
(define x 1))
|
||||
port))
|
||||
'truncate
|
||||
'text)
|
||||
|
||||
(call-with-output-file (build-path this-dir "module-lang-test-tmp2.ss")
|
||||
(lambda (port)
|
||||
(write `(module module-lang-test-tmp2 mzscheme
|
||||
(provide e)
|
||||
(define e #'1))
|
||||
port))
|
||||
'truncate
|
||||
'text)
|
||||
|
||||
(call-with-output-file (build-path this-dir "module-lang-test-tmp3.ss")
|
||||
(lambda (port)
|
||||
(write `(module module-lang-test-tmp3 mzscheme
|
||||
(define-syntax (bug-datum stx)
|
||||
(syntax-case stx ()
|
||||
[(dat . thing)
|
||||
(number? (syntax-e (syntax thing)))
|
||||
(syntax/loc stx (#%datum . thing))]))
|
||||
|
||||
(provide #%module-begin [rename bug-datum #%datum]))
|
||||
|
||||
port))
|
||||
'truncate
|
||||
'text)
|
||||
|
||||
(define drs (wait-for-drscheme-frame))
|
||||
(define interactions-text (send drs get-interactions-text))
|
||||
|
||||
(define (single-test test)
|
||||
(let/ec k
|
||||
(clear-definitions drs)
|
||||
(type-in-definitions drs (test-definitions test))
|
||||
(do-execute drs)
|
||||
|
||||
(let ([ints (test-interactions test)])
|
||||
|
||||
(when ints
|
||||
(let ([after-execute-output
|
||||
(send interactions-text
|
||||
get-text
|
||||
(send interactions-text paragraph-start-position 2)
|
||||
(send interactions-text paragraph-end-position 2))])
|
||||
(unless (string=? "> " after-execute-output)
|
||||
(printf "FAILED: ~a\n ~a\n expected no output after execution, got: ~s\n"
|
||||
(test-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
after-execute-output)
|
||||
(k (void)))
|
||||
(type-in-interactions drs ints)
|
||||
(fw:test:keystroke #\return)
|
||||
(wait-for-computation drs)))
|
||||
|
||||
(let* ([para-to-check (- (send interactions-text position-paragraph
|
||||
(send interactions-text last-position))
|
||||
1)]
|
||||
[after-int-start
|
||||
(send interactions-text paragraph-start-position para-to-check)]
|
||||
[after-int-end
|
||||
(send interactions-text paragraph-end-position para-to-check)]
|
||||
[after-int-output (send interactions-text
|
||||
get-text
|
||||
after-int-start
|
||||
after-int-end)]
|
||||
[passed?
|
||||
(cond
|
||||
[(string? (test-result test))
|
||||
(string=? after-int-output (test-result test))]
|
||||
[(regexp? (test-result test))
|
||||
(regexp-match (test-result test) after-int-output)])])
|
||||
(unless passed?
|
||||
(printf "FAILED: ~a\n ~a\n expected: ~s\n got: ~s\n"
|
||||
(test-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
(test-result test)
|
||||
after-int-output))))))
|
||||
|
||||
(define (run-test)
|
||||
(set-language-level! '("Module") #t)
|
||||
(for-each single-test tests)))
|
||||
(test @t{(module m (file "@in-here{module-lang-test-tmp.ss}") 1 2 3)}
|
||||
@t{1} ;; just make sure no errors.
|
||||
"1")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user