(require 'compile)
(require 'cl)

(defvar run-test-suffixes '(".scm" ".rb" ".sh")
  "List of test file suffix.")

(defvar run-test-file-names '("test/run-test" "test/runner")
  "List of invoked file name by run-test.")

(defvar run-test-verbose-level-table '((0 . "-vs")
                                       (1 . "")
                                       (2 . "-vp")
                                       (3 . "-vn")
                                       (4 . "-vv"))
  "Passed argumets to run-test-file-names for set verbose level.")

(defvar run-test-mode-name "run-test"
  "Mode name of running test.")

(defun run-test-buffer-name ()
  (concat "*" run-test-mode-name "*"))

(defun flatten (lst)
  (cond ((null lst) '())
        ((listp (car lst))
         (append (flatten (car lst))
                 (flatten (cdr lst))))
        (t (cons (car lst) (flatten (cdr lst))))))

(defun get-verbose-level-arg (num)
  (let ((elem (assoc num run-test-verbose-level-table)))
    (concat " "
            (if elem (cdr elem) ""))))

(defun find-run-test-file-in-directory (directory filenames)
  (do ((fnames filenames (cdr fnames))
       (fname (concat directory (car filenames))
              (concat directory (car fnames))))
      ((or (file-exists-p fname)
           (null fnames))
       (if (file-exists-p fname)
           fname
         nil))))

(defun find-run-test-file (filenames)
  (let ((init-dir "./"))
    (do ((dir init-dir (concat dir "../"))
         (run-test-file (find-run-test-file-in-directory init-dir filenames)
                        (find-run-test-file-in-directory dir filenames)))
        ((or run-test-file (string= "/" (expand-file-name dir)))
         run-test-file))))

(defun find-test-files ()
  (mapcar (lambda (run-test-file)
            (let ((test-file (find-run-test-file
                              (mapcar (lambda (suffix)
                                        (concat run-test-file suffix))
                                      run-test-suffixes))))
              (if test-file
                  (cons run-test-file test-file)
                test-file)))
          run-test-file-names))

(defun run-test-if-find (test-file-infos verbose-arg runner)
  (cond ((null test-file-infos) nil)
        ((car test-file-infos)
         (let ((test-file-info (car test-file-infos)))
           (let ((current-directory (cadr (split-string(pwd))))
                 (run-test-file (car test-file-info))
                 (test-file (cdr test-file-info))
                 (name-of-mode "run-test"))
             (save-excursion
               (cd (car (split-string test-file run-test-file)))
               (save-some-buffers)
               (funcall runner
                        (concat (concat "./"
                                        (file-name-directory run-test-file))
                                (file-name-nondirectory test-file)
                                verbose-arg))
               (cd current-directory))
             t)))
        (t (run-test-if-find (cdr test-file-infos) verbose-arg))))

(defun run-test (&optional arg)
  (interactive "P")
  (run-test-if-find (find-test-files)
                    (get-verbose-level-arg (prefix-numeric-value arg))
                    (lambda (command)
                      (compile-internal command
                                        "No more failures/errors"
                                        "run-test"))))

(defun run-test-in-new-frame (&optional arg)
  (interactive "P")
  (if (member (run-test-buffer-name)
              (mapcar 'buffer-name (buffer-list)))
      (kill-buffer (run-test-buffer-name)))
  (let ((current-frame (car (frame-list)))
        (frame (make-frame)))
    (select-frame frame)
    (if (null (run-test arg))
        (delete-frame frame)
      (delete-window)
      (other-frame -1)
      (select-frame current-frame))))

(defun run-test-in-mini-buffer (&optional arg)
  (interactive "P")
  (run-test-if-find (find-test-files)
                    (get-verbose-level-arg (prefix-numeric-value arg))
                    (lambda (command)
                      (shell-command command))))

(provide 'run-test)