#lang racket

(require "private/drracket-test-util.rkt"
         tests/utils/gui
         mred
         framework
         (prefix-in fw: framework))

(define language (make-parameter "<<not a language>>"))

;; set-language : boolean -> void
(define (set-language close-dialog?)
  (set-language-level! (language) close-dialog?))

(define (common-test-engine dmda?)
  (test-expression "(check-expect 1 1)"
                   "The test passed!"
                   #:repl-expected "Both tests passed!")
  
  (test-expression "(check-within 1 1.1 0.5)"
                   "The test passed!"
                   #:repl-expected "Both tests passed!")
  
  (test-expression "(check-expect 1 2)"
                   ""
                   #:check-failures-expected
                   (list (make-check-expect-failure "1" "2" 1 0))
                   #:repl-check-failures-expected
                   (list (make-check-expect-failure "1" "2" 3 2)))
  
  (unless dmda?
    (test-expression (format "~s" '(check-error (first 212) "first: expects a non-empty list; given: 212"))
                     "The test passed!"
                     #:repl-expected "Both tests passed!"))
  
  (unless dmda?
    (test-expression "(check-expect (car 0) 2)"
                     "car: expects a pair, given 0"
                     #:check-failures-expected
                     (list (make-check-expect-error "2." ":: car: expects a pair, given 0" 1 0))
                     #:repl-check-failures-expected
                     (list (make-check-expect-error "2." ":: car: expects a pair, given 0" 4 2)))))

(define (common-signatures-*sl)
  (test-expression "(: foo Integer) (define foo 5)"
		   ""
		   #:repl-expected "foo: this name was defined previously and cannot be re-defined")
  (test-expression "(: foo Integer) (define foo \"bar\")"
		   ""
		   #:repl-expected "foo: this name was defined previously and cannot be re-defined"
		   #:signature-violations-expected
		   (list (make-signature-violation "\"bar\"" 1 7)))
  (test-expression "(: foo (Integer -> Integer)) (define (foo x) x) (foo \"foo\")"
		   "\"foo\""
		   #:repl-expected "foo: this name was defined previously and cannot be re-defined\n"
		   #:signature-violations-expected
		   (list (make-signature-violation "\"foo\" at line 1, column 48 " 1 8))
		   #:repl-signature-violations-expected
                   (list))
  (test-expression "(: foo (Integer -> Integer)) (define foo (lambda (x) x))"
		   ""
		   #:repl-expression "(foo \"foo\")"
		   #:repl-expected "\"foo\""
		   #:repl-signature-violations-expected
		   (list (make-signature-violation "\"foo\" at line 3, column 2 " 1 8))))

(define (common-signatures-DMdA)
  (test-expression "(: foo integer) (define foo 5)"
		   ""
		   #:repl-expected "define: Zweite Definition für denselben Namen")
  (test-expression "(: foo integer) (define foo \"bar\")"
		   ""
		   #:repl-expected "define: Zweite Definition für denselben Namen"
		   #:signature-violations-expected
		   (list (make-signature-violation "\"bar\"" 1 7)))
  (test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x)) (foo \"foo\")"
		   "\"foo\""
                   #:repl-expected "define: Zweite Definition für denselben Namen"
		   #:signature-violations-expected
		   (list (make-signature-violation "\"foo\" at line 1, column 57 " 1 8))
		   #:repl-signature-violations-expected
		   (list))
  (test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x))"
		   ""
		   #:repl-expression "(foo \"foo\")"
		   #:repl-expected "\"foo\""
		   #:repl-signature-violations-expected
		   (list (make-signature-violation "\"foo\" at line 3, column 2 " 1 8))))



;                                                             
;  ;;;                    ;;                                  
;   ;;                    ;;                                  
;   ;;                                                        
;   ;;;;;   ;;;;   ;;;;;;;;;  ;;; ;;   ;;; ;;    ;;;;  ;;; ;; 
;   ;;  ;; ;;  ;; ;;  ;;  ;;   ;;; ;;   ;;; ;;  ;;  ;;  ;;;;; 
;   ;;  ;; ;;  ;; ;;  ;;  ;;   ;;  ;;   ;;  ;;  ;;  ;;  ;;    
;   ;;  ;; ;;;;;;  ;;;;   ;;   ;;  ;;   ;;  ;;  ;;;;;;  ;;    
;   ;;  ;; ;;      ;      ;;   ;;  ;;   ;;  ;;  ;;      ;;    
;   ;;  ;; ;;   ;  ;;;;;  ;;   ;;  ;;   ;;  ;;  ;;   ;  ;;    
;   ;;;;;   ;;;;   ;;;;;;;;;; ;;;; ;;; ;;;; ;;;  ;;;;  ;;;;   
;                 ;;   ;;                                     
;                 ;;   ;;                                     
;                  ;;;;;                                      

(define (beginner)
  (parameterize ([language (list #rx"Beginning Student(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #f)))


;                                                                            
;  ;;;                                 ;;;     ;;;                           
;   ;;                       ;          ;;      ;;                           
;   ;;                       ;          ;;      ;;                           
;   ;;;;;   ;;;;   ;;;;;;   ;   ;;;;    ;;;;;   ;;;;;  ;;; ;;  ;;;;  ;;; ;;; 
;   ;;  ;; ;;  ;; ;;  ;;    ;      ;;   ;;  ;;  ;;  ;;  ;;;;; ;;  ;;  ;;  ;  
;   ;;  ;; ;;  ;; ;;  ;;   ;       ;;   ;;  ;;  ;;  ;;  ;;    ;;  ;;  ;;  ;  
;   ;;  ;; ;;;;;;  ;;;;    ;    ;;;;;   ;;  ;;  ;;  ;;  ;;    ;;;;;;   ;;;   
;   ;;  ;; ;;      ;       ;   ;;  ;;   ;;  ;;  ;;  ;;  ;;    ;;       ;;;   
;   ;;  ;; ;;   ;  ;;;;;  ;    ;;  ;;   ;;  ;;  ;;  ;;  ;;    ;;   ;   ;;;   
;   ;;;;;   ;;;;   ;;;;;; ;     ;;;;;;  ;;;;;   ;;;;;  ;;;;    ;;;;     ;    
;                 ;;   ;;;                                                   
;                 ;;   ;;;                                                   
;                  ;;;;;                                                     


(define (beginner/abbrev)
  (parameterize ([language (list #rx"Beginning Student with List Abbreviations(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #f)))


;                                                                                          
;   ;;                                                      ;;;   ;;                       
;   ;;            ;;                                         ;;   ;;           ;;          
;                 ;;                                         ;;                ;;          
;  ;;;  ;;; ;;   ;;;;;  ;;;;  ;;; ;; ;;; ;;  ;;    ;;;;   ;;;;;  ;;;   ;;;;   ;;;;;  ;;;;  
;   ;;   ;;; ;;   ;;   ;;  ;;  ;;;;;  ;;; ;;; ;;  ;;  ;; ;;  ;;   ;;      ;;   ;;   ;;  ;; 
;   ;;   ;;  ;;   ;;   ;;  ;;  ;;     ;;  ;;  ;;  ;;  ;; ;;  ;;   ;;      ;;   ;;   ;;  ;; 
;   ;;   ;;  ;;   ;;   ;;;;;;  ;;     ;;  ;;  ;;  ;;;;;; ;;  ;;   ;;   ;;;;;   ;;   ;;;;;; 
;   ;;   ;;  ;;   ;;   ;;      ;;     ;;  ;;  ;;  ;;     ;;  ;;   ;;  ;;  ;;   ;;   ;;     
;   ;;   ;;  ;;   ;;   ;;   ;  ;;     ;;  ;;  ;;  ;;   ; ;;  ;;   ;;  ;;  ;;   ;;   ;;   ; 
;  ;;;; ;;;; ;;;   ;;;  ;;;;  ;;;;   ;;;; ;;; ;;;  ;;;;   ;;;;;; ;;;;  ;;;;;;   ;;;  ;;;;  
;                                                                                          
;                                                                                          
;                                                                                          


(define (intermediate)
  (parameterize ([language (list #rx"Intermediate Student(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #f)))

;                                                                                    
;                                                                                    
;                                                                                    
;    ;;               ;   ;;;;;;                        ;;;;           ;;;;          
;    ;;              ;;   ;;;;;;                        ;;;;           ;;;;          
;       ;;;; ;;;   ;;;;;  ;;;;;; ;;;;;;;  ;;;;;;; ;;;;  ;;;;;;;     ;;;;;;; ;;;;;;;  
;  ;;;; ;;;;;;;;; ;;;;;;  ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;;   ;;;;;;;; ;;;;;;;; 
;  ;;;; ;;;; ;;;;  ;;;;   ;;;;;;     ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;;     ;;;; 
;  ;;;; ;;;; ;;;;  ;;;;  ;; ;;;;  ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;  ;;;;;;; 
;  ;;;; ;;;; ;;;;  ;;;;; ;; ;;;; ;;  ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;  ;;;; 
;  ;;;; ;;;; ;;;;  ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;   ;;;;;;;; ;;;;;;;; 
;  ;;;; ;;;; ;;;;   ;;;; ;; ;;;;  ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;     ;;;;;;;  ;; ;;;; 
;                        ;;                                                          
;                                                                                    
;                                                                                    


(define (intermediate/lambda)
  (parameterize ([language (list #rx"Intermediate Student with lambda(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #f)))


;                                                                           
;                                                                           
;                                                                           
;                ;;;;                                                  ;;;; 
;                ;;;;                                                  ;;;; 
;  ;;;;;;;    ;;;;;;; ;;;  ;;; ;;;;;;;  ;;;; ;;;    ;;;;;   ;;;     ;;;;;;; 
;  ;;;;;;;;  ;;;;;;;; ;;;  ;;; ;;;;;;;; ;;;;;;;;;  ;;;;;;  ;;;;;   ;;;;;;;; 
;      ;;;; ;;;;;;;;;  ;;;;;;      ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; 
;   ;;;;;;; ;;;; ;;;;  ;;;;;;   ;;;;;;; ;;;; ;;;; ;;;;    ;;;;;;; ;;;; ;;;; 
;  ;;  ;;;; ;;;;;;;;;  ;;;;;;  ;;  ;;;; ;;;; ;;;; ;;;;;;; ;;;;;   ;;;;;;;;; 
;  ;;;;;;;;  ;;;;;;;;   ;;;;   ;;;;;;;; ;;;; ;;;;  ;;;;;;  ;;;;;;  ;;;;;;;; 
;   ;; ;;;;   ;;;;;;;   ;;;;    ;; ;;;; ;;;; ;;;;   ;;;;;   ;;;;    ;;;;;;; 
;                                                                           
;                                                                           
;                                                                           


(define (advanced)
  (parameterize ([language (list #rx"Advanced Student(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #f)
    (common-signatures-*sl)))


(define (DMdA-beginner)
  (parameterize ([language (list #rx"Die Macht der Abstraktion - Anfänger(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #t)
    (common-signatures-DMdA)))

(define (DMdA-vanilla)
  (parameterize ([language (list #rx"Die Macht der Abstraktion(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #t)
    (common-signatures-DMdA)))

(define (DMdA-assignments)
  (parameterize ([language (list #rx"Die Macht der Abstraktion mit Zuweisungen(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #t)
    (common-signatures-DMdA)))

(define (DMdA-advanced)
  (parameterize ([language (list #rx"Die Macht der Abstraktion - fortgeschritten(;|$)")])
    (prepare-for-test-expression)
    (common-test-engine #t)
    (common-signatures-DMdA)))

(define (prepare-for-test-expression)
  (let ([drs (wait-for-drracket-frame)])
    (clear-definitions drs)
    (set-language #t)
    (sleep 1) ;; this shouldn't be neccessary....
    (do-execute drs)))

;; test-setting : (-> void) string string string -> void
;; opens the language dialog, runs `set-setting'
;; closes the language dialog, executes,
;; makes sure that `expression' produces
;; `result'. `set-setting' is expected to click around
;; in the language dialog.
;; `setting-name' is used in the error message when the test fails.
(define (test-setting set-setting setting-name expression result)
  (set-language #f)
  (set-setting)
  (let ([f (test:get-active-top-level-window)])
    (fw:test:button-push "OK")
    (wait-for-new-frame f))
  (let* ([drs (test:get-active-top-level-window)]
         [interactions (send drs get-interactions-text)])
    (clear-definitions drs)
    (insert-in-definitions drs expression)
    (do-execute drs)
    (let ([got (fetch-output/should-be-tested drs)])
      (unless (string=? result got)
        (eprintf "FAILED: ~s ~s ~s test\n expected: ~s\n      got: ~s\n"
                 (language) setting-name expression result got)))))

(define (fetch-output/should-be-tested . args)
  (regexp-replace (regexp
                   (string-append
                    (regexp-quote "")
                    "$"))
                  (apply fetch-output args)
                  ""))

(define re:out-of-sync
  (regexp
   "WARNING: Interactions window is out of sync with the definitions window\\."))

(define (parse-number txt)
  (cond
    ((string=? txt "No") 0)
    ((string=? txt "One") 1)
    ((string=? txt "Two") 2)
    (else (string->number txt))))

(define (parse-test-failure-header txt)
  (cond
    ((regexp-match #rx"^Ran ([NoOneTwo0-9]+) tests?.\n([NoOneTwo0-9]+) tests? passed.\n([NoOneTwo0-9]+) signature violations?."
                          txt)
     => (lambda (match)
          (let-values (((_ test-count-text test-passed-count-text signature-violations-count-text)
                        (apply values match)))
            (values (parse-number test-count-text)
                    (parse-number test-passed-count-text)
                    (parse-number signature-violations-count-text)))))
    ((regexp-match #rx"^This program must be tested!\n([NoOneTwo0-9]+) signature violations?." txt)
     => (lambda (match)
          (values 0 0 (parse-number (cadr match)))))
    (else
     (error 'parse-test-failure-header "bad test failure header" txt))))

(define (parse-test-failures txt)
  (let-values (((test-count test-passed-count signature-violations-count)
                (parse-test-failure-header txt)))
    (let ((check-failures
           (cond
             ((regexp-match #rx"Check failures:\n(.*)" txt)
              => (lambda (res)
                   (parse-check-failures (cadr res))))
             (else '())))
          (signature-violations
           (cond
             ((regexp-match #rx"Signature violations:\n(.*)" txt)
              => (lambda (res)
                   (parse-signature-violations (cadr res))))
             (else '()))))
      (values test-count test-passed-count signature-violations-count
              check-failures
              signature-violations))))

(define-struct check-expect-failure
  (actual expected line column)
  #:transparent)

(define-struct check-expect-error (value message line column) #:transparent)

(define (parse-check-failures txt)
  (cond
    ((string=? txt "") '())
    ((regexp-match #rx"^Signature violations:" txt)
     '())
    ((regexp-match #rx"^[ \t]*\n(.*)" txt)
     => (lambda (match)
          (parse-check-failures (cadr match))))
    ((regexp-match #rx"^[ \t]+Actual value ([^\n]+) differs from ([^\n]+), the expected value.\nat line ([0-9]+), column ([0-9]+)(.*)"
                   txt)
     => (lambda (match)
          (let-values (((_ actual expected line-text col-text rest) (apply values match)))
            (cons
             (make-check-expect-failure actual expected
                                        (string->number line-text)
                                        (string->number col-text))
             (parse-check-failures rest)))))
    ((regexp-match #rx"^[ \t]+check-expect encountered the following error instead of the expected value, ([^\n]*). *\n[ \t]*([^\n]*)\n[^\n]*line ([0-9]+), column ([0-9]+)[ ]*\n(.*)$"
                   txt)
     => (lambda (match)
          (define-values (_ value message line-text col-text rest) (apply values match))
          (cons
           (make-check-expect-error value
                                    message
                                    (string->number line-text)
                                    (string->number col-text))
           (parse-check-failures rest))))
    (else 
     (error "unknown check failure" txt (string-ref txt 0)))))

(define-struct signature-violation
  (got line column)
  #:transparent)

(define (parse-signature-violations txt)
  (cond
    ((string=? txt "") '())
    ((regexp-match #rx"^[ \t]*\n(.*)" txt)
     => (lambda (match)
          (parse-signature-violations (cadr match))))
    ((regexp-match "got ([^\n]+), signature at line ([0-9]+), column ([0-9]+)(.*)"
                   txt)
     => (lambda (match)
          (let-values (((_ got line-text col-text rest) (apply values match)))
            (cons
             (make-signature-violation got
                                       (string->number line-text)
                                       (string->number col-text))
             (parse-signature-violations rest)))))
    (else '())))
  

;; types an expression in the definitions window, executes it and tests the output
;; types an expression in the REPL and tests the output from the REPL.
(define (test-expression expression defs-expected 
			 #:repl-expression (repl-expression expression)
                         #:repl-expected (repl-expected defs-expected)
			 #:check-failures-expected (check-failures-expected '())
			 #:signature-violations-expected (signature-violations-expected '())
			 #:repl-check-failures-expected (repl-check-failures-expected '())
			 #:repl-signature-violations-expected (repl-signature-violations-expected '()))
  (let* ([drs (wait-for-drracket-frame)]
         [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))]
         [definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))]
         [handle-definition-insertion
          (lambda (item)
	    (insert-in-definitions drs item))]
         [handle-interaction-insertion
          (lambda (item)
	    (insert-in-interactions drs item))]
         [check-expectation
          (lambda (expected got)
            (cond
              [(string? expected)
               (whitespace-string=? expected got)]
              [(regexp? expected)
               (regexp-match expected got)]
              [(procedure? expected)
               (expected got)]))]
	 [check-failures
	  (lambda (where signature-violations-expected check-failures-expected)
	    (let ((text
		   (cond
		    ((send (send definitions-text get-tab) get-test-editor)
		     => (lambda (test-editor)
			  (let ((text (send test-editor get-text 0 'eof #t)))
			    (if (string=? text "")
				#f
				text))))
		    (else #f))))
	   
	      (cond
	       ((and (null? signature-violations-expected)
		     (null? check-failures-expected))
		(when text
		  (eprintf "FAILED: ~s ~s expected ~s to produce no check failures or signature violations:\ngot:\n~a\ninstead\n"
			   where (language) expression text)))
	       (text
		(let-values (((test-count test-passed-count signature-violation-count check-failures signature-violations)
			      (parse-test-failures text)))
		  (when (not (equal? check-failures check-failures-expected))
		    (eprintf "FAILED: ~s ~s expected ~s to produce check failures:\n~s\ngot:\n~s\ninstead\n"
			     where (language) expression check-failures-expected check-failures))
		  (when (not (equal? signature-violations signature-violations-expected))
		    (eprintf "FAILED: ~s ~s expected ~s to produce signature violations:\n~s\ngot:\n~s\ninstead\n"
			     where (language) expression signature-violations-expected signature-violations))))
	       (else
		(eprintf "expected ~a check failures and ~a signature violations but got none"
			 (length check-failures-expected) (length signature-violations-expected))))))]

         [make-err-msg
          (lambda (expected)
            (cond
              [(string? expected)
               "FAILED: ~s ~s expected ~s to produce:\n  ~s\ngot:\n  ~s\ninstead\n"]
              [(regexp? expected)
               "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"]
              [(procedure? expected)
               "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))])
    (clear-definitions drs)
    (cond
      [(pair? expression) (for-each handle-definition-insertion expression)]
      [else (handle-definition-insertion expression)])
    (do-execute drs)

    (let ([got
           (fetch-output
            drs
            (queue-callback/res (λ () (send interactions-text paragraph-start-position 2)))
            (queue-callback/res
             (λ ()
               (send interactions-text paragraph-end-position
                     (- (send interactions-text last-paragraph) 1)))))])
      (when (regexp-match re:out-of-sync got)
        (error 'test-expression "got out of sync message"))
      (unless (check-expectation defs-expected got)
        (eprintf (make-err-msg defs-expected) 
                 'definitions (language) expression defs-expected got)))
    
    (check-failures 'definitions signature-violations-expected check-failures-expected)
    
    (cond
     [(pair? repl-expression) (for-each handle-interaction-insertion repl-expression)]
     [else (handle-interaction-insertion repl-expression)])
    
    (let ([last-para (queue-callback/res (lambda () (send interactions-text last-paragraph)))])
      (alt-return-in-interactions drs)
      (wait-for-computation drs)
      (let ([got
             (fetch-output
              drs
              (queue-callback/res
               (λ ()
                 (send interactions-text paragraph-start-position (+ last-para 1))))
              (queue-callback/res
               (λ ()
                 (send interactions-text paragraph-end-position
                       (- (send interactions-text last-paragraph) 1)))))])
        (when (regexp-match re:out-of-sync got)
          (error 'test-expression "got out of sync message"))
        (unless (check-expectation repl-expected got)
          (eprintf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got))))
    
    ;; the failures from the definition window stick around
    (check-failures 'interactions
                    (append signature-violations-expected repl-signature-violations-expected)
		    (append check-failures-expected repl-check-failures-expected))))

(define (test-disabling-tests)
  (define drs (wait-for-drracket-frame))
  
  (parameterize ([language (list #rx"Beginning Student(;|$)")]) 
    (prepare-for-test-expression)
    (test:menu-select "Racket" "Disable Tests")
    (test-expression "(check-expect 1 2)" "Tests disabled.")
    (test:menu-select "Racket" "Enable Tests"))
  
  (parameterize ([language (list #rx"Die Macht der Abstraktion - Anfänger(;|$)")])
    (prepare-for-test-expression)
    (test:menu-select "Racket" "Disable Tests")
    (test-expression "(check-expect 1 2)" "Tests disabled.")
    (test:menu-select "Racket" "Enable Tests")))
  
(define-syntax (go stx)
  (syntax-case stx ()
    [(_ arg)
     (identifier? (syntax arg))
     (syntax (begin (printf ">> starting ~a\n" 'arg)
                    (arg)
                    (printf ">> finished ~a\n" 'arg)))]))

(define (run-test)
  (preferences:set 'test-engine:test-window:docked? #t)
  (go beginner)
  (go beginner/abbrev)
  (go intermediate)
  (go intermediate/lambda)
  (go advanced)
  (go DMdA-beginner)
  (go DMdA-vanilla)
  (go DMdA-assignments)
  (go DMdA-advanced)
  (go test-disabling-tests))

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