(use gauche.process)
(use gauche.selector)
(use srfi-13)
(use test.unit)

(sys-putenv "LIBUIM_SCM_FILES" "./scm")

(define (**default-test-suite**)
  (with-module test.unit *default-test-suite*))
(define <test-case>
  (with-module test.unit <test-case>))
(define make-tests
  (with-module test.unit make-tests))
(define add-test-case!
  (with-module test.unit add-test-case!))

(define *uim-sh-process* #f)
(define *uim-sh-selector* (make <selector>))

(define (uim-sh-select port . timeout)
  (selector-add! *uim-sh-selector*
                 port
                 (lambda (port flag)
                   (selector-delete! *uim-sh-selector* port #f #f))
                 '(r))
  (not (zero? (apply selector-select *uim-sh-selector* timeout))))

(define (uim-sh-write sexp out)
  (set! (port-buffering out) :none)
  (with-output-to-port out
    (lambda ()
      (write sexp)
      (newline)
      (flush))))

(define (uim-sh-read in)
  (set! (port-buffering in) :none)
  (uim-sh-select in)
  (let ((uim-sh-output (read in)))
    (if (and (eq? 'ERROR: uim-sh-output)
             (uim-sh-select in 3))
      (error (string-trim-both (read-block 10000 in)))
      uim-sh-output)))

(define (uim sexp)
  (uim-sh-write sexp (process-input *uim-sh-process*))
  (uim-sh-read (process-output *uim-sh-process*)))

(define (uim-bool sexp)
  (not (null? (uim sexp))))

(define (make-uim-sh-setup-proc . args)
  (let-optionals* args ((additional-setup-proc (lambda () #f)))
    (lambda ()
      (set! *uim-sh-process* (run-process "uim/uim-sh"
                                          "-b"
                                          :input :pipe
                                          :output :pipe))
      (additional-setup-proc))))

(define (make-uim-sh-teardown-proc . args)
  (let-optionals* args ((additional-teardown-proc (lambda () #f)))
    (lambda ()
      (close-input-port (process-input *uim-sh-process*))
      (set! *uim-sh-process* #f)
      (additional-teardown-proc))))

(define-syntax define-uim-test-case
  (syntax-rules ()
    ((_ name) #f)
    ((_ name rest ...)
     (add-test-case! (**default-test-suite**)
                     (make-uim-test-case name rest ...)))))

(define-syntax make-uim-test-case
  (syntax-rules (setup teardown)
    ((_ name (setup setup-proc) (teardown teardown-proc) test ...)
     (make <test-case>
       :name name
       :setup (make-uim-sh-setup-proc setup-proc)
       :teardown (make-uim-sh-teardown-proc teardown-proc)
       :tests (make-tests test ...)))
    ((_ name (setup proc) test ...)
     (make <test-case>
       :name name
       :setup (make-uim-sh-setup-proc proc)
       :teardown (make-uim-sh-teardown-proc)
       :tests (make-tests test ...)))
    ((_ name (teardown proc) test ...)
     (make <test-case>
       :name name
       :setup (make-uim-sh-setup-proc)
       :teardown (make-uim-sh-teardown-proc proc)
       :tests (make-tests test ...)))
    ((_ name test ...)
     (make <test-case>
       :name name
       :setup (make-uim-sh-setup-proc)
       :teardown (make-uim-sh-teardown-proc)
       :tests (make-tests test ...)))))

(provide "test/uim-test-utils")
