#lang racket/load
(require rackunit
         racket/package
         syntax/strip-context
         (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))]))

;; Need to remove use-site scopes on syntax objects
;; that we're going to pass on to `eval`.
(define-for-syntax (remove-use-site stx)
  (cond
   [(identifier? stx) (syntax-local-identifier-as-binding stx)]
   [(syntax? stx)
    (datum->syntax (syntax-local-identifier-as-binding (datum->syntax stx 'x))
                   (remove-use-site (syntax-e stx))
                   stx
                   stx)]
   [(pair? stx)
    (cons (remove-use-site (car stx))
          (remove-use-site (cdr stx)))]
   [else stx]))

(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)]
                        [expr (remove-use-site #'expr)])
            #`(test-pack-seq* (list (quote-syntax form) ...)
                              (quote-syntax [#:fail expr])
                              'expr
                              exn?))]
         [(expr) 
          (with-syntax ([(form ...) (reverse pre)]
                        [expr (remove-use-site #'expr)])
            #`(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 (remove-use-site #'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))