move racket/package tests to "compatibility-test"
The tests were formerly in the "racket-test" package.
This commit is contained in:
Matthew Flatt
parent
328c3d3276
commit
be6ae83cbd
369
compatibility-test/tests/racket/package.rkt
Normal file
369
compatibility-test/tests/racket/package.rkt
Normal file
|
|
@ -0,0 +1,369 @@
|
|||
#lang racket/load
|
||||
(require rackunit racket/package (for-syntax racket/base))
|
||||
|
||||
(define-syntax test
|
||||
(syntax-rules ()
|
||||
[(_ #t p? args ...) (check-true (p? args ...))]
|
||||
[(_ #f p? args ...) (check-false (p? args ...))]
|
||||
[(_ e n args ...) (if (procedure? n)
|
||||
(check-equal? e (n args ...))
|
||||
(check-equal? e args ...))]))
|
||||
|
||||
(define-syntax err/rt-test
|
||||
(syntax-rules ()
|
||||
[(_ e) (check-exn exn:fail? (λ () e))]
|
||||
[(_ e ty?) (check-exn ty? (λ () e))]))
|
||||
|
||||
(define-syntax (test-pack-seq stx)
|
||||
(syntax-case stx ()
|
||||
[(_ result form ...)
|
||||
(let loop ([forms #'(form ...)]
|
||||
[pre null])
|
||||
(syntax-case forms ()
|
||||
[([#:fail expr exn?])
|
||||
(with-syntax ([(form ...) (reverse pre)])
|
||||
#`(test-pack-seq* (list (quote-syntax form) ...)
|
||||
(quote-syntax [#:fail expr])
|
||||
'expr
|
||||
exn?))]
|
||||
[(expr)
|
||||
(with-syntax ([(form ...) (reverse pre)])
|
||||
#`(test-pack-seq* (list (quote-syntax form) ...)
|
||||
(quote-syntax expr)
|
||||
'expr
|
||||
result))]
|
||||
[([#:fail expr exn?] . more)
|
||||
#`(begin
|
||||
#,(loop #'([#:fail expr exn?]) pre)
|
||||
#,(loop #'more pre))]
|
||||
[(form . more)
|
||||
(loop #'more (cons #'form pre))]))]))
|
||||
|
||||
(define (fail? e)
|
||||
(syntax-case e ()
|
||||
[(#:fail e) #'e]
|
||||
[_ #f]))
|
||||
|
||||
(define (fail-expr e)
|
||||
(or (fail? e) e))
|
||||
|
||||
(define (test-pack-seq* forms expr q-expr result)
|
||||
(test-pack-seq** forms expr q-expr result)
|
||||
(test-pack-seq** (map syntax->datum forms) (syntax->datum expr) q-expr result))
|
||||
|
||||
(define (test-pack-seq** forms expr q-expr result)
|
||||
(printf "As ~a: ~s\n"
|
||||
(if (syntax? (car forms))
|
||||
"syntax"
|
||||
"datum")
|
||||
forms)
|
||||
(let ([orig (current-namespace)])
|
||||
;; top level
|
||||
(printf "top\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(namespace-require '(for-syntax racket/base))
|
||||
(namespace-require 'racket/package)
|
||||
(for-each eval forms)
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval (fail-expr expr)) result)
|
||||
(test result q-expr (eval expr)))))
|
||||
;; let
|
||||
(printf "let\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(namespace-require '(for-syntax racket/base))
|
||||
(namespace-require 'racket/package)
|
||||
(let ([e `(let () (begin . ,forms) ,(fail-expr expr))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval e) result)
|
||||
(test result `(let ... ,q-expr) (eval e))))))
|
||||
;; nested let
|
||||
(printf "nested let\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(namespace-require '(for-syntax racket/base))
|
||||
(namespace-require 'racket/package)
|
||||
(let ([e (let loop ([forms forms])
|
||||
(if (null? (cdr forms))
|
||||
`(let () (begin . ,forms) ,(fail-expr expr))
|
||||
`(let () ,(car forms)
|
||||
,(loop (cdr forms)))))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval e) result)
|
||||
(test result `(let ... ,q-expr) (eval e))))))
|
||||
;; module
|
||||
(printf "module\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(let ([m `(module m racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package)
|
||||
(begin . ,forms)
|
||||
(define result ,(fail-expr expr))
|
||||
(provide result))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval m) exn:fail:syntax?)
|
||||
(begin
|
||||
(eval m)
|
||||
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
|
||||
;; multiple modules
|
||||
(printf "2 modules\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(let ([m `(begin
|
||||
(module m0 racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package)
|
||||
(begin . ,forms)
|
||||
(provide ,#'(all-defined-out)))
|
||||
(module m racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package
|
||||
'm0)
|
||||
(define result ,(fail-expr expr))
|
||||
(provide result)))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval m) exn:fail:syntax?)
|
||||
(begin
|
||||
(eval m)
|
||||
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
|
||||
;; more modules
|
||||
(printf "3 modules\n")
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'racket/package)
|
||||
(let ([m `(begin
|
||||
(module m0 racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package)
|
||||
,(car forms)
|
||||
(provide ,#'(all-defined-out)))
|
||||
(module m1 racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package
|
||||
'm0)
|
||||
(begin . ,(cdr forms))
|
||||
(provide ,#'(all-defined-out)))
|
||||
(module m racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/package
|
||||
'm0 'm1)
|
||||
(define result ,(fail-expr expr))
|
||||
(provide result)))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval m) exn:fail:syntax?)
|
||||
(begin
|
||||
(eval m)
|
||||
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
12
|
||||
(define-package p (x)
|
||||
(define y 5)
|
||||
(define x 12))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package p)
|
||||
x
|
||||
[#:fail y exn:fail:contract:variable?])
|
||||
|
||||
(test-pack-seq
|
||||
13
|
||||
(define-package p (q)
|
||||
(define-package q (x)
|
||||
(define y 8)
|
||||
(define x 13)))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
[#:fail (open-package q) exn:fail:syntax?]
|
||||
(open-package p)
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package q)
|
||||
x
|
||||
[#:fail y exn:fail:contract:variable?])
|
||||
|
||||
(test-pack-seq
|
||||
14
|
||||
(define-package p (q)
|
||||
(define-package q (r)
|
||||
(define-package r (x)
|
||||
(define x 14))))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
[#:fail (open-package q) exn:fail:syntax?]
|
||||
[#:fail (open-package r) exn:fail:syntax?]
|
||||
(open-package p)
|
||||
(open-package q)
|
||||
(open-package r)
|
||||
x)
|
||||
|
||||
(test-pack-seq
|
||||
15
|
||||
(define-package p (x)
|
||||
(define x 15))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(define-package q #:all-defined
|
||||
(open-package p))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package q)
|
||||
x)
|
||||
|
||||
(test-pack-seq
|
||||
'(16 160)
|
||||
(define-package p #:all-defined
|
||||
(define x 16)
|
||||
(define y 160))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
(test-pack-seq
|
||||
170
|
||||
(define-package p #:all-defined-except (x)
|
||||
(define x 17)
|
||||
(define y 170))
|
||||
(open-package p)
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
y)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
2
|
||||
(define-package p (x)
|
||||
(define* x 1)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
x)
|
||||
|
||||
(test-pack-seq
|
||||
14
|
||||
(define-package p (z)
|
||||
(define* x (lambda () y))
|
||||
(define z x)
|
||||
(define* x 2)
|
||||
(define y 14))
|
||||
(open-package p)
|
||||
(z))
|
||||
|
||||
(test-pack-seq
|
||||
21
|
||||
(define-package p (x)
|
||||
(define* x (lambda () y))
|
||||
(define* x2 0)
|
||||
(define* x3 1)
|
||||
(define* x4 1)
|
||||
(define y 21))
|
||||
(open-package p)
|
||||
(x))
|
||||
|
||||
(test-pack-seq
|
||||
'(2 1)
|
||||
(define-package p (x y)
|
||||
(define* x 1)
|
||||
(define y x)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
(test-pack-seq
|
||||
'(2 1)
|
||||
(define-package p (x y)
|
||||
(define* x 1)
|
||||
(define y x)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
5
|
||||
(define-package p1 #:all-defined
|
||||
(define-package p2 ()
|
||||
(define x 10))
|
||||
(open-package p2))
|
||||
(open-package p1)
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
5)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
'(17 12)
|
||||
(define-syntax-rule (mk id)
|
||||
(begin
|
||||
(define-package p (x)
|
||||
(define x 17))
|
||||
(open-package p)
|
||||
(define id x)))
|
||||
(define x 12)
|
||||
(mk z)
|
||||
(list z x))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
10
|
||||
(define-package p5 (q)
|
||||
(define* x 10)
|
||||
(define-syntax (y stx)
|
||||
(syntax-case stx ()
|
||||
[(_ z) #'(begin (define z x))]))
|
||||
(define* x 12)
|
||||
(define* z 13)
|
||||
(y q))
|
||||
(open-package p5)
|
||||
q)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; In a submodule
|
||||
|
||||
(module package-in-a-submodule racket/base
|
||||
(require racket/package)
|
||||
|
||||
(define-package pkg (foo)
|
||||
(define foo 5))
|
||||
|
||||
(module+ main
|
||||
(open-package pkg)
|
||||
(define out foo)
|
||||
(provide out)))
|
||||
|
||||
(test 5 dynamic-require '(submod 'package-in-a-submodule main) 'out)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; `package-begin`
|
||||
|
||||
(package-begin)
|
||||
|
||||
(package-begin
|
||||
(define pbx 1)
|
||||
(test 1 'use-package-begin pbx))
|
||||
(err/rt-test pbx)
|
||||
|
||||
(package-begin
|
||||
(define pbx 2)
|
||||
(define (use-pbx) pbx)
|
||||
(test 2 'use-package-begin (use-pbx)))
|
||||
(err/rt-test pbx)
|
||||
(err/rt-test use-pbx)
|
||||
|
||||
(package-begin
|
||||
(define pbx 3)
|
||||
(define (use-pbx) pbx)
|
||||
(define* pbx 4)
|
||||
(test 3 'use-package-begin (use-pbx))
|
||||
(test 4 'use-package-begin pbx))
|
||||
(err/rt-test pbx)
|
||||
(err/rt-test use-pbx)
|
||||
|
||||
(test 3 'expr (+ (package-begin
|
||||
(define x 1)
|
||||
x)
|
||||
2))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user