From be6ae83cbdc72bec9561840bc510057969eef718 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 21 Jul 2015 13:09:11 -0600
Subject: [PATCH] move `racket/package` tests to "compatibility-test"

The tests were formerly in the "racket-test" package.
---
 compatibility-test/tests/racket/package.rkt | 369 ++++++++++++++++++++
 1 file changed, 369 insertions(+)
 create mode 100644 compatibility-test/tests/racket/package.rkt

diff --git a/compatibility-test/tests/racket/package.rkt b/compatibility-test/tests/racket/package.rkt
new file mode 100644
index 0000000..55134be
--- /dev/null
+++ b/compatibility-test/tests/racket/package.rkt
@@ -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))
+