#lang at-exp racket/base
(require "private/module-lang-test-utils.rkt"
         "private/drracket-test-util.rkt")
(provide run-test)

;; set up for tests that need external files
(write-test-modules
 (module module-lang-test-tmp1 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]))
 (module module-lang-test-tmp4 racket/base
   (/ 888 2)
   (provide (except-out (all-from-out racket/base) #%top-interaction)))
 (module module-lang-test-syn-error racket/base
   (lambda)))

(test @t{}
      #f
      @rx{Module Language: There must be a valid module
          Try starting your program with
          Interactions disabled}
      #t)
(test @t{1}
      #f
      @rx{Module Language: only a module expression is allowed
          Interactions disabled}
      #t)
(test @t{(module m racket) 1}
      #f
      @rx{Module Language: there can only be one expression in the definitions
          Interactions disabled}
      #t)
(test @t{.}
      #f
      @rx{Module Language: invalid module text
          read: illegal
          Interactions disabled}
      #t)
(test @t{#lang mzscheme
         (define x 1)}
      @t{x}
      "1")
(test @t{#lang m-z-scheme
         (define x 1)}
      #f
      @rx{Module Language: invalid module text
          collection not found
          Interactions disabled}
      #t)
(test @t{#lang racket
         3}
      #f
      "3")
(test @t{(module m racket (provide x) (define x 1))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1) (define y 1) (provide y))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1) (define y 2) (provide y))}
      @t{y}
      "2")
(test @t{(module m mzscheme (require mzlib/list))}
      @t{foldl}
      #rx"foldl")
(test @t{(module m mzscheme (require (rename mzlib/list local-foldl foldl)))}
      @t{local-foldl}
      #rx"foldl>")
(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))}
      @t{first}
      #rx"first>")
(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))}
      @t{foldl}
      #rx"[.] [.] foldl:.*cannot reference an identifier before its definition")
(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: mzlib/list) mzlib/list))}
      @t{foldl}
      #rx"foldl>")
(test @t{(module m mzscheme
           (require (prefix x: mzlib/list) mzlib/list))}
      @t{x:foldl}
      #rx"foldl>")
(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 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-tmp1.rkt}) x)}
      @t{+}
      #rx"[.] [.] [+]:.*cannot reference 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}
      #rx"[.] [.] a:.*cannot reference an identifier before its definition")
(test @t{(module m mzscheme
           (define-syntax (x stx) #'(define-syntax (a stx) #'10))
           x
           x)}
      @t{a}
      #rx"[.] [.] a:.*cannot reference an identifier before its definition")
(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.rkt}))
           (provide s)
           (define-syntax (s stx) e))}
      @t{(require 'm) s}
      @rx{[?]:.*literal data is not allowed.*no #%datum syntax transformer is bound in: 1$})
(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 racket
         (eval 'cons)}
      #f
      @rx{cons: unbound identifier.*no #%top syntax transformer is bound})
(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 1 2 3)}
      @t{1} ;; just make sure no errors.
      "1")

(test @t{#lang racket}
      @t{(begin-for-syntax (+ 1 2))}
      @t{})

(test @t{#lang racket}
      @t{(begin (struct s (x)) (struct t s (y)) (s-x (t 1 2)))}
      "1")

;; check that we have a working repl in the right language after
;; syntax errors, unless it's a bad language
(test @t{#lang racket
         (define x 1)
         (define y (/ 0))}
      @t{(+ 122 x)}
      @rx{. /: division by zero
          123}
      #t)
(test @t{#lang racket
         (define x 1)
         (define y (/ 0))}
      @t{(if x 123)}
      @rx{/: division by zero.*if: missing an "else"}
      #t)
(test @t{#lang mzscheme
         (define x 1)
         (define y (/ 0))}
      @t{(if x 123)}
      @rx{. /: division by zero
          123}
      #t)
(test @t{(module xx scheme/list
           (define x 1)
           (define y (/ 0)))}
      #f
      @rx{no #%module-begin binding in the module's language
          Interactions disabled:
          does not support a REPL \(no #%top-interaction\)}
      #t)
(test @t{(module xx (file @in-here{module-lang-test-tmp4.rkt})
           (define x 1)
           (* x 123))}
      #f
      @rx{444
          123
          Interactions disabled:
          does not support a REPL \(no #%top-interaction\)
          }
      #t)
(test @t{(module xx (file @in-here{this-file-does-not-exist})
           (define x 1)
           (* x 123))}
      #f
      @rx{cannot open input file
          Module Language: invalid language specification
          Interactions disabled}
      #t)
(test @t{#lang setup/infotab}
      #f
      ;; test the complete buffer, to make sure that there is no error
      "\nInteractions disabled: setup/infotab does not support a REPL (no #%top-interaction)"
      #t)

;; test racket/load behavior
(test @t{#lang racket/load
         (module m mzscheme (provide x) (define x 2))
         (require 'm)
         (printf "~s\n" x)
         (flush-output)}
      #f
      "2")
(test @t{#lang racket/load
         (module m mzscheme (provide x) (define x 2))
         (module n racket/base (require 'm) (provide y) (define y (* x x)))
         (require 'n)
         (printf "~s\n" y)
         (flush-output)}
      #f
      "4")

(test @t{#lang racket
         (define-syntax (f stx)
           (syntax-case stx ()
             [(f)
              (raise (make-exn:fail:syntax "both" (current-continuation-marks) (list #'f stx)))]))}
      @t{(f)}
      (string-append "> (f)\n"
                     ". both in:\n"
                     "  f\n"
                     "  (f)")
      #t)

(test @t{#lang racket/base}
      @t{(begin (values) 1)}
      "1")

(test @t{#lang racket/base}
      @t{    (eval '(values 1 2))}
      @t{1@"\n"2})
(test @t{#lang racket/base}
      @t{    (eval '(list 1 2))}
      @t{'(1 2)})
(test @t{#lang racket/base}
      @t{    (eval '(lambda ()))}
      @t{lambda: bad syntax in: (lambda ())})
(test @t{#lang racket/base}
      @t{(expt 3 (void))}
      @rx{expt: contract violation.*given: #<void>})
(test @t{#lang racket/base}
      @t{1 2 ( 3 4}
      @t{1@"\n"2@"\n". read: expected a `)' to close `('})
(test @t{#lang racket/base}
      "1 2 . 3 4"
      "1\n2\n. read: illegal use of `.'")
(test @t{#lang racket/base}
      "1 2 (lambda ()) 3 4"
      "1\n2\n. lambda: bad syntax in: (lambda ())")
(test @t{#lang racket/base}
      "1 2 x 3 4"
      #rx"1\n2\n[.] [.] x:.*cannot reference an identifier before its definition")
(test @t{#lang racket/base}
      "1 2 (raise 1) 3 4"
      "1\n2\nuncaught exception: 1")
(test @t{#lang racket/base}
      "1 2 (raise #f) 3 4"
      "1\n2\nuncaught exception: #f")
(test @t{#lang racket/base}
      "(current-namespace (make-empty-namespace)) if"
      #rx". #%top-interaction: unbound identifier.*no #%app syntax transformer is bound")
(test @t{#lang racket/base}
      (string-append
       "(let ([old (error-escape-handler)])\n"
       "(+ (let/ec k\n(dynamic-wind\n"
       "(lambda () (error-escape-handler (lambda () (k 5))))\n"
       "(lambda () (expt 3 #f))\n"
       "(lambda () (error-escape-handler old))))\n"
       "10))")
      #rx"[.] [.] expt: contract violation.*given: #f\n15")
(test @t{#lang racket/base}
      "(write (list (syntax x)))"
      "(.)")
(test @t{#lang racket/base}
      "(parameterize ([current-output-port (open-output-string)]) (write #'1))"
      "")
(test @t{#lang racket/base}
      "(write-special 1)"
      "1#t")
(test @t{#lang racket/gui}
      (format "~s ~s ~s"
              '(define s (make-semaphore 0))
              '(queue-callback
                (lambda ()
                  (dynamic-wind
                   void
                   (lambda () (expt 3 #f))
                   (lambda () (semaphore-post s)))))
              '(begin (yield s) (void)))
      #rx"[.] [.] expt: contract violation.*given: #f")
(test @t{#lang racket/base}
      (format "~s ~s" 
              '(define x 1) 
              '((λ (x y) y) (set! x (call/cc (lambda (x) x))) (x 3)))
      #rx". . application:.*given: 3")
(test @t{#lang racket/base}
      (format "~s ~s ~s ~s"
              '(begin (define k (call/cc (λ (x) x)))
                      (define x 'wrong))
              '(set! x 'right)
              '(k 1)
              'x)
      "'right")
(test @t{#lang racket/base}
      (format "~s"
              '(call-with-continuation-prompt
                (lambda ()
                  (eval '(begin (abort-current-continuation
                                 (default-continuation-prompt-tag)
                                 1 2 3)
                                10)))
                (default-continuation-prompt-tag)
                list))
      "'(1 2 3)")
(test @t{#lang racket/gui}
      "(vector (new snip%))"
      "(vector .)")
(test @t{#lang racket/base}
      "(begin (thread (lambda () x)) (sleep 1/10))"
      #rx"[.] [.] x:.*cannot reference an identifier before its definition")
(test @t{#lang racket/base}
      "(require texpict/utils)(disk 3)"
      ".")
(test @t{#lang racket/base}
      (string-append
       "(require mzlib/pretty)"
       "(pretty-print-print-hook (lambda x (expt 3 #f)))"
       "(list 1 2 3)")
      "'(1 2 3)")

;; test protection against user-code changing the namespace
(test @t{#lang racket/base
         (current-namespace (make-base-namespace))}
      "(+ 1 2)"
      "3")
(test @t{#lang racket/base
         (current-namespace (make-base-empty-namespace))}
      "(+ 1 2)"
      "3")
(test @t{#lang racket/base}
     @t{(parameterize ([current-directory "/does/not/exists/well/it/better/not/anwyays"])
         (load @in-here{module-lang-test-syn-error.rkt}))}
     ;; test to make sure that we don't get "exception raised by error display handler"
     #rx"module-lang-test-syn-error.rkt:[0-9]+:[0-9]+: lambda: bad syntax in: \\(lambda\\)")

(test @t{#lang racket
(module+ main (printf "main\n"))
(module+ test (printf "test\n"))
(module+ other (printf "other\n"))}
      #f
      #rx"main\ntest")


(test @t{#lang racket}
      (format "~s" '(+ 1 (+ 1 (abort-current-continuation
                               (default-continuation-prompt-tag)
                               (lambda () 
                                 (abort-current-continuation
                                  (default-continuation-prompt-tag)
                                  (λ () 0)))))))
      "0")
   
(test @t{#lang racket}
      (format "~s ~s ~s" 
              '1
              '(+ 1 (+ 1 (abort-current-continuation
                          (default-continuation-prompt-tag)
                          (lambda () 
                            (abort-current-continuation
                             (default-continuation-prompt-tag)
                             (λ () 0))))))
              '2)
      "1\n0")

(test @t{#lang racket}
      (format "~s" 
              '(begin
                 1
                 (+ 1 (+ 1 (abort-current-continuation
                            (default-continuation-prompt-tag)
                            (lambda () 
                              (abort-current-continuation
                               (default-continuation-prompt-tag)
                               (λ () 0))))))
                 2))
      "0")

(fire-up-drracket-and-run-tests run-test)