run-tests

#!/usr/bin/env racket
#lang racket

(require srfi/13)

(define (find-tests path)
 (define (find-tests-in-folder path acc)
  (let ((paths (map (curry build-path path) (directory-list path))))
   (for/fold ((acc acc)) ((path paths))
    (cond
     ((filename-extension path) =>
      (lambda (ext)
       (if (equal? ext #"tiger")
           (cons path acc)
           acc)))
     ((directory-exists? path)
      (find-tests-in-folder path acc))
     (else acc)))))
 (find-tests-in-folder path empty))


(struct test (path error exit-code output))
(struct bad-test (message))
(define (read-test path)
 (define (other-file ext)
  (path-replace-suffix path ext))
 (define expected-output
  (let ((output-file (other-file ".out")))
   (and (file-exists? output-file)
    (call-with-input-file output-file port->string))))

 (define expected-error
  (let ((error-file (other-file ".error")))
   (and (file-exists? error-file)
    (call-with-input-file error-file port->string))))

 (let/ec return
  (define expected-exit
   (let ((exit-file (other-file ".exit")))
    (and (file-exists? exit-file)
     (let ((string (call-with-input-file exit-file port->string)))
      (or (string->number (string-trim-both string))
          (return (bad-test (format "Exit code in file ~a was not a number" exit-file))))))))

  (when (and expected-error expected-exit)
   (return (bad-test (format "Both an error file and exit file exist: ~a, ~a" (other-file ".error") (other-file ".exit")))))
 
  (when (and expected-error expected-output)
   (return (bad-test (format "Both an error file and output file exist: ~a, ~a" (other-file ".error") (other-file ".out")))))
 
  (when (and (not expected-error) (not expected-exit))
   (return (bad-test (format "Neither an error file nor an exit file exist: ~a, ~a" (other-file ".error") (other-file ".exit")))))
  (test path expected-error expected-exit expected-output)))

(define (print-bad-tests tests)
 (define bad-tests #f)
 (for ((test tests))
  (when (bad-test? test)
   (printf "Bad Test: ~a~n" (bad-test-message test))
   (set! bad-tests #t)))
 bad-tests)





(struct compiler-failed (exit-code stdout stderr))
(struct compiler-passed (stdout stderr)) ;it shouldn't have
(struct prog-failed (exit-code stdout stderr))
(struct passed ())


(define (print-result test result)
 (match result
  ((compiler-failed exit-code stdout stderr)
   (printf "---Test ~a---~n" (test-path test))
   (printf "Compiler failed with exit code: ~a~n" exit-code)
   (when (not (equal? "" stdout))
    (printf "Standard Output:~n~a" stdout))
   (when (not (equal? "" stderr))
    (printf "Standard Error:~n~a" stderr))
   (printf "-----~n")
   #t)

  ((compiler-passed stdout stderr)
   (printf "---Test ~a---~n" (test-path test))
   (printf "Compiler passed, should have had error: ~a~n" (test-error test))
   (when (not (equal? "" stdout))
    (printf "Standard Output:~n~a" stdout))
   (when (not (equal? "" stderr))
    (printf "Standard Error:~n~a" stderr))
   (printf "-----~n")
   #t)

  ((prog-failed exit stdout stderr)
   (printf "---Test ~a---~n" (test-path test))
   (printf "Program failed~n")
   (unless (equal? exit (test-exit-code test))
    (printf "Exit code was ~a, should have been ~a~n" exit (test-exit-code test)))
   (unless (equal? stdout (test-output test))
    (printf "Output was:~n~a~nShould have been:~n~a~n" stdout (test-output test)))
   (when (not (equal? "" stderr))
    (printf "Standard Error:~n~a" stderr))
   (printf "-----~n")
   #t)

  ((passed) #f)))


(define (server-run-tests tests send-result)
 (define compiler-subprocess #f)
 (define compiler-input #f)
 (define compiler-output #f)
 (let/ec esc
 (dynamic-wind
  (let ((first #t)) (lambda () (if first (set! first #f) (error 'server-run-tests "Re-entered tests"))))
  (lambda () 
   (let-values (((sub c-output c-input _err) (subprocess #f #f (current-error-port) compiler)))
    (for ((test tests))
     (set! compiler-subprocess sub)
     (set! compiler-output c-output)
     (set! compiler-input c-input)
     (define first #t)
     (define compiled-file #f)
     (define output-file #f)
     (define error-file #f)
     (define tiger-path (test-path test))
     (define (other-file ext)
      (path-replace-suffix tiger-path ext))
     (dynamic-wind
      (let ((first #t)) (lambda () (if first (set! first #f) (error 'server-run-tests "Re-entered test for ~a" tiger-path))))
      (lambda ()
       (set! compiled-file
        (make-temporary-file
         (let-values (((base end dir) (split-path tiger-path)))
          (if (path? end)
              (string-append (path->string end) "~a")
              "tiger~a"))))
       (set! output-file (make-temporary-file))
       (set! error-file (make-temporary-file))
    
       (write (map path->string (list tiger-path compiled-file output-file error-file)) compiler-input)
       (flush-output compiler-input)
       (let* ((message (read-line compiler-output)) (exit-code (and (string? message) (string->number message))))
        (if (not exit-code)
         (error 'server-run-tests "Compiler sent back bad message: ~a" message)
         (let ()
          (define output (file->string output-file))
          (define err-output (file->string error-file))
          (send-result
           (cons test
             (if (and (= 0 exit-code) (string=? "" output) (string=? "" err-output))
                 (if (test-error test)
                     (compiler-passed output err-output)
                     (if front-end (passed) (run-prog compiled-file (other-file ".in") (test-output test) (test-exit-code test))))
                 (if (and (not (= 0 exit-code)) (test-error test))
                     (passed)
                     (compiler-failed exit-code output err-output)))))))))
      (lambda ()
       (when output-file
        (when (file-exists? output-file)
         (delete-file output-file))
        (set! output-file #f))
  
       (when error-file
        (when (file-exists? error-file)
         (delete-file error-file))
        (set! error-file #f))))
  
       (when compiled-file
        (when (file-exists? compiled-file)
         (delete-file compiled-file))
        (set! compiled-file #f)))))
  (lambda ()
   (close-output-port compiler-input)
   (close-input-port compiler-output)
   (subprocess-wait compiler-subprocess)
   (let ((exit-code (subprocess-status compiler-subprocess)))
    (unless (zero? exit-code)
     (error 'run-server-tests "Compiler exited with exit code: ~a" exit-code)))))))

  


(define (run-prog compiled-file input-file test-output test-exit-code)
 (call-with-input-file input-file 
  (lambda (input-file-port)
   (let-values (((sub out _in err) (subprocess #f input-file-port #f compiled-file)))
    (define output #f)
    (define err-output #f)
    (define out-thread (thread (lambda () (set! output (port->string out)))))
    (define err-thread (thread (lambda () (set! err-output (port->string err)))))
    (thread-wait out-thread)
    (thread-wait err-thread)
    (subprocess-wait sub)
    (define exit-code (subprocess-status sub))
    (if (and (= exit-code test-exit-code) (string=? output test-output))
        (passed)
        (prog-failed exit-code output err-output))))))


(define (run-test test)
 (define compiled-file #f)
 (define tiger-path (test-path test))
 (define (other-file ext)
  (path-replace-suffix tiger-path ext))
 (dynamic-wind
  (let ((first #t)) (lambda () (if first (set! first #f) (error 'running-tests "Re-entered test for ~a" tiger-path))))
  (lambda ()
   (set! compiled-file
    (make-temporary-file
     (let-values (((base end dir) (split-path tiger-path)))
      (if (path? end)
          (string-append (path->string end) "~a")
          "tiger~a"))))



    
    (let-values (((sub out in err) (subprocess #f #f #f compiler "-o" (path->string compiled-file) (path->string tiger-path))))
     (close-output-port in)
     (define output #f)
     (define err-output #f)
     (define out-thread (thread (lambda () (set! output (port->string out)))))
     (define err-thread (thread (lambda () (set! err-output (port->string err)))))
     (thread-wait out-thread)
     (thread-wait err-thread)
     (subprocess-wait sub)
     (let ((exit-code (subprocess-status sub)))
      (if (and (= 0 exit-code) (string=? "" output) (string=? "" err-output))
          (if (test-error test)
              (compiler-passed output err-output)
              (if front-end
                  (passed)
                  (run-prog compiled-file (other-file ".in") (test-output test) (test-exit-code test))))
          (if (and (not (= 0 exit-code)) (test-error test))
              (passed)
              (compiler-failed exit-code output err-output))))))
  (lambda ()
   (when compiled-file
    (when (file-exists? compiled-file)
     (delete-file compiled-file))
    (set! compiled-file #f)))))
   

(define ((receive-result-loop finish-chan))
 (let loop ((failed-test #f))
  (let ((test+result (thread-receive)))
   (if test+result
       (loop (or (print-result (car test+result) (cdr test+result)) failed-test))
       (channel-put finish-chan failed-test)))))


(define-values (compiler front-end test-dir server)
 (let ((comp 'default) (test-dir "tests") (front-end #f) (server #f))
  (command-line 
    #:once-each
    (("-d" "--tests-dir") directory ("test directory" "Default directory is 'tests'") (set! test-dir directory))
    (("-c" "--compiler") compiler ("compiler path"
                                   "Default path is 'tiger', unless the server option is set, then it is 'tiger-server'") (set! comp compiler))
    (("-f" "--front-end") "only run the front-end" (set! front-end #t))
    (("-s" "--server") ("run the compiler as a server"
                        "Sends input on lines in standard in, instead of in the arguments") (set! server #t))
    #:args ()
     (values
      (expand-user-path (if (equal? 'default comp) (if server "tiger-server" "tiger") comp))
      front-end
      (expand-user-path test-dir)
      server))))
 


(define tests (map read-test (find-tests test-dir)))
(when (print-bad-tests tests)
  (exit 1))

(define-values (send-result all-passed-evt)
 (let* ((all-passed-evt (make-channel))
        (thr (thread (receive-result-loop all-passed-evt))))
  (values
   (lambda (v) (thread-send thr v))
   all-passed-evt)))
   
(if server
    (server-run-tests tests send-result)
    (for ((test tests))
     (let ((result (run-test test)))
      (send-result (cons test result)))))

(send-result #f); All tests are done

(if (sync all-passed-evt)
    (exit 1)
    (printf "All tests passed~n"))