#! @GUILE@ \
--no-auto-compile -e main -s
!#

;;; Gash -- Guile As SHell
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (ice-9 match)
             (ice-9 popen)
             (ice-9 rdelim)
             (ice-9 receive)
             (srfi srfi-9))


;;; Test record

(define-record-type <test>
  (%make-test name script args status stdout stderr xfail?)
  test?
  (name test-name)
  (script test-script)
  (args test-args)
  (status test-status)
  (stdout test-stdout)
  (stderr test-stderr)
  (xfail? test-xfail?))

(define* (make-test name script #:key (args '()) (status 0)
                    stdout stderr xfail?)
  (unless (string? name)
    (error (format #f "invalid test name: ~s" name)))
  (unless (string? script)
    (error (format #f "invalid test script: ~s" script)))
  (match args
    ((or () ((? string?) ...)) #t)
    (_ (error (format #f "invalid test args: ~s" args))))
  (%make-test name script args status stdout stderr xfail?))


;;; Org-style input

(define (read-org-block ex-chr port)
  (define block-name
    (let ((name (read-delimited " \t\n" port 'peek)))
      ;; Consume the rest of the line.
      (read-line port)
      (unless (string-prefix-ci? "begin_" name)
        (error "Org blocks must start with \"begin_\""))
      (substring name 6)))

  (define delim
    (string-append "#+end_" block-name "\n"))

  (let loop ((line (read-line port 'concat)) (acc '()))
    (cond
     ((eof-object? line) (error "end of file in Org block"))
     ((string-ci=? line delim) (string-concatenate-reverse acc))
     (else
      (unless (string-prefix? "  " line)
        (error "All Org block lines must indented with two spaces"))
      (loop (read-line port 'concat) (cons (substring line 2) acc))))))

(read-hash-extend #\+ read-org-block)

(define (read-tests port)
  (let loop ((token (read port)) (test '()) (tests '()))
    (match token
      ((? eof-object?)
       (reverse! (match test
                   (() tests)
                   (_ (cons test tests)))))
      ('*
       (let ((name (read-line port)))
         (when (eof-object? name)
           (error "end of file while expecting a value"))
         (loop (read port) `((:name: . ,(string-trim name)))
               (match test
                 (() tests)
                 (_ (cons test tests))))))
      (key
       (let ((value (read port)))
         (when (eof-object? value)
           (error "end of file while expecting a value"))
         (loop (read port) (acons key value test) tests))))))

(define (test-alist->test alist)
  (make-test (assq-ref alist ':name:)
             (assq-ref alist ':script:)
             #:args (or (assq-ref alist ':args:) '())
             #:status (or (assq-ref alist ':status:) 0)
             #:stdout (assq-ref alist ':stdout:)
             #:stderr (assq-ref alist ':stderr:)
             #:xfail? (assq-ref alist ':xfail?:)))


;;; Invocation helpers

;; XXX: This is probably the slowest way possible to do this.  I hope
;; it is correct, at least.
(define (get-strings-all . ports)
  (define accs (make-hash-table (length ports)))

  (define (accs-cons! x port)
    (hashq-set! accs port (cons x (hashq-ref accs port '()))))

  (let loop ((ps ports))
    (match ps
      (() (map (lambda (port)
                 (reverse-list->string (hashq-ref accs port '())))
               ports))
      (_ (match (select ps '() '())
           (((ready-port . _) _ _)
            (match (read-char ready-port)
              ((? eof-object?)
               (loop (filter (lambda (port)
                               (not (eq? port ready-port)))
                             ps)))
              (chr (accs-cons! chr ready-port)
                   (loop ps)))))))))

(define (observe shell script filename args)
  "Use SHELL to interpret SCRIPT, returning the exit status, standard
output, and standard error as three values."
  (match-let (((stdout-input . stdout-output) (pipe))
              ((stderr-input . stderr-output) (pipe))
              ((ex-input . ex-output) (pipe)))
    (match (primitive-fork)
      (0 (catch #t
           (lambda ()
             (close-port stdout-input)
             (close-port stderr-input)
             (close-port ex-input)
             (dup stdout-output 1)
             (dup stderr-output 2)
             (setenv "TEST_TMP" (getcwd))
             (chdir "@abs_top_srcdir@")
             (apply execlp shell shell "-e" "-c" script filename args))
           (lambda args
             (write args ex-output)
             (force-output ex-output)
             (primitive-_exit EXIT_FAILURE))))
      (pid (close-port stdout-output)
           (close-port stderr-output)
           (close-port ex-output)
           (match (get-strings-all stdout-input stderr-input ex-input)
             ((stdout stderr "")
              (match-let (((pid . status) (waitpid pid)))
                (values (status:exit-val status) stdout stderr)))
             ((_ _ ex)
              (apply throw (call-with-input-string ex read))))))))


;;; Runner

(define (display-output output)
  (format #t "---~%~a~a---~%"
          output (if (string-suffix? "\n" output) "" "\n")))

(define (run-test test shell)
  (match-let ((($ <test> name script args
                  xstatus xstdout xstderr xfail?) test))
    (format #t "Start test: ~a~%" name)
    (display "Script: ")
    (display-output script)
    (format #t "Arguments: ~s~%" args)
    (catch #t
      (lambda ()
        (receive (status stdout stderr) (observe shell script "test" args)
          (let* ((status-ok? (= status xstatus))
                 (stdout-ok? (or (not xstdout) (string=? stdout xstdout)))
                 (stderr-ok? (or (not xstderr) (string=? stderr xstderr)))
                 (ok? (and status-ok? stdout-ok? stderr-ok?))
                 (result (if ok?
                             (if xfail? 'xpass 'pass)
                             (if xfail? 'xfail 'fail))))
            (unless status-ok?
              (format #t "Expected status: ~a~%" xstatus)
              (format #t "Actual status: ~a~%" status))
            (unless stdout-ok?
              (display "Expected stdout: ")
              (display-output xstdout)
              (display "Actual stdout: " )
              (display-output stdout))
            (unless stderr-ok?
              (display "Expected stderr: ")
              (display-output xstderr)
              (display "Actual stderr: " )
              (display-output stderr))
            (format #t "Result: ~a~%" result)
            (format #t "End test: ~a~%" name)
            result)))
      (lambda args
        (format #t "Test error: ~s~%" args)
        (format #t "End test: ~a~%" name)
        'error))))

(define (run-tests tests shell)
  (let loop ((tests tests) (pass 0) (fail 0) (xpass 0) (xfail 0) (error 0))
    (match tests
      (()
       (format #t "== Summary ==~%")
       (for-each (match-lambda
                   ((label . count)
                    (when (> count 0)
                      (format #t "~a~a~%" label count))))
                 `(("Expected passes: " . ,pass)
                   ("Expected failures: " . ,xfail)
                   ("Unexpected passes: " . ,xpass)
                   ("Unexpected failures: " . ,fail)
                   ("Errors: " . ,error)))
       (let ((pass? (and (= xpass 0) (= fail 0) (= error 0))))
         (format #t "Result: ~a~%" (if pass? "pass" "fail"))
         pass?))
      ((test . rest)
       (match (let ((result (run-test test shell)))
                (newline)
                result)
         ('pass (loop rest (1+ pass) fail xpass xfail error))
         ('fail (loop rest pass (1+ fail) xpass xfail error))
         ('xpass (loop rest pass fail (1+ xpass) xfail error))
         ('xfail (loop rest pass fail xpass (1+ xfail) error))
         ('error (loop rest pass fail xpass xfail (1+ error))))))))


;;; Main

(define (main args)
  (match args
    ((_ filename)
     (exit (run-tests (map test-alist->test
                           (call-with-input-file filename read-tests))
                      "gash")))
    (_ (error "invalid arguments"))))

;;; Local Variables:
;;; mode: scheme
;;; End: