(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

  (define this-dir (collection-path "tests" "drscheme"))

  (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)
      #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
      (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: ~a\n       got: ~a\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)))