#!/usr/bin/env guile
!#

;; Copyright (c) 2022 Nikolay Puzanov <punzik@gmail.com>
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.

;; -*- geiser-scheme-implementation: guile -*-

(import
 ;; (scheme base)                ; R7RS base (not needed for Guile)
 (srfi srfi-1)                   ; Lists
 (srfi srfi-9)                   ; Records
 (srfi srfi-11)                  ; let-values
 (srfi srfi-13)                  ; String library
 (srfi srfi-28)                  ; Simple format
 (srfi srfi-39))                 ; Parameters

(use-modules
 (ice-9 regex)
 (ice-9 popen)
 (ice-9 textual-ports)
 (ice-9 threads)
 (ice-9 getopt-long))

(define APP_VERSION "0.0.1")

(define MAKEFILE_NAME_REGEXP ".*\\.utest$")
(define TIMEOUT_MODULE_NAME  "utest_timeout")
(define DUMP_MODULE_NAME     "utest_dump")
(define WORK_DIR_PREFIX      "")

;;; Globals
(define utest/force-dump    (make-parameter #f))
(define utest/restart-dump  (make-parameter #f))
(define utest/keep-output   (make-parameter #f))
(define utest/verbose       (make-parameter #f))
(define utest/nocolor       (make-parameter #f))
(define utest/base-path     (make-parameter ""))
(define utest/work-path     (make-parameter ""))

(define-record-type <log-type>
  (log-type log-prefix color out-prefix verbose)
  log-type?
  (log-prefix lt-log-prefix)
  (color      lt-color)
  (out-prefix lt-out-prefix)
  (verbose    lt-verbose))

(define LOG_PREFIX_INFO "INFO#")
(define LOG_PREFIX_WARN "WARN#")
(define LOG_PREFIX_FAIL "FAIL#")

(define log-types
  `((info      ,(log-type LOG_PREFIX_INFO 15  "   | " #t))
    (warning   ,(log-type LOG_PREFIX_WARN 226 "   + " #t))
    (error     ,(log-type LOG_PREFIX_FAIL 196 "   + " #t))
    (test-head ,(log-type "TSTH#"         14  ""      #t))
    (test-info ,(log-type "TSTI#"         6   ""      #t))
    (test-succ ,(log-type "TSTS#"         47  ""      #t))
    (test-fail ,(log-type "TSTF#"         196 ""      #t))))

(define log-type-default
  (log-type "" 244 "   | " #f))

;;; Like assoc but with functional predicate
(define (assf f l)
  (find (lambda (x) (f (car x))) l))

;;; Get log type by id (level)
(define (log-type-by-id id)
  (let ((t (assq id log-types)))
    (if t (cadr t) log-type-default)))

;;; Get log type with log-prefix matched to prefix of str
(define (log-type-by-prefix str)
  (let ((t (assf (lambda (x) (string-prefix? x str))
                 (map (lambda (x) (let ((t (cadr x)))
                               (list (lt-log-prefix t) t)))
                      log-types))))
    (if t (cadr t) log-type-default)))

;;; Useful print functions
(define (printf . rest) (display (apply format rest)))
(define (println . rest) (for-each (lambda (x) (display x) (newline)) rest))

;;; Return log line as string
(define (utest/slog a . args)
  (if (string? a)
      (apply format a args)
      (string-append
       (lt-log-prefix (log-type-by-id a))
       (apply format args))))

;;; Display log line
;;; Split line by newline character and display
;;; each piece as seperate line.
(define (utest/log a . args)
  (let* ((pre (if (string? a) "" (lt-log-prefix (log-type-by-id a))))
         (fmt (if (string? a) (cons a args) args))
         (strs
          (map (lambda (x) (string-append pre x))
               (string-split
                (apply format fmt)
                #\newline))))
    (for-each println strs) #t))

;;;
;;; Colorize text
;;;
(define* (color text fg #:optional (bg 'default))
  (format "~a~a~a~a[0m"
          ;; Foreground
          (if (number? fg)
              (format "~a[38;5;~am" #\esc fg)
              (format "~a[~am" #\esc (case fg
                                       ((black)   "30")
                                       ((red)     "31")
                                       ((green)   "32")
                                       ((yellow)  "33")
                                       ((blue)    "34")
                                       ((magenta) "35")
                                       ((cyan)    "36")
                                       ((white)   "37")
                                       ((default) "39"))))
          ;; Background
          (if (number? bg)
              (format "~a[48;5;~am" #\esc bg)
              (format "~a[~am" #\esc (case bg
                                       ((black)   "40")
                                       ((red)     "41")
                                       ((green)   "42")
                                       ((yellow)  "43")
                                       ((blue)    "44")
                                       ((magenta) "45")
                                       ((cyan)    "46")
                                       ((white)   "47")
                                       ((default) "49"))))
          text #\esc))

;;;
;;; Print log
;;;
(define (convert-log-item item colorize)
  (let* ((t (log-type-by-prefix item))
         (pre (lt-out-prefix t))
         (str (substring item (string-length (lt-log-prefix t)))))
    (string-append
     pre
     (if colorize
         (color str (lt-color t))
         str))))

(define* (print-log log-strings
                    #:key
                    (verbose #f)
                    (colorize #f))
  (for-each
   (lambda (str)
     (let ((t (log-type-by-prefix str)))
       (when (or verbose (lt-verbose t))
         (println (convert-log-item str colorize)))))
   log-strings))

;;;
;;; Catch exception and continue with default value
;;;
(define-syntax guard
  (syntax-rules ()
    ((_ default code...)
     (with-exception-handler (lambda (e) default)
       (lambda () code...)
       #:unwind? #t))))

;;;
;;; Check path existence
;;; If path not exists throw exception
;;;
(define (check-path path)
  (if (not (file-exists? path))
      (raise-exception (format "Path ~a is not exists" path))
      (let ((type (stat:type (stat path))))
        (if (or (not (access? path R_OK))
                (and (eq? type 'directory)
                     (not (access? path X_OK))))
            (raise-exception (format "Path ~a is not readable" path))
            #t))))

;;;
;;; Convert path to absolute path
;;;
(define* (path->absolute path #:optional (base ""))
  (let ((path
         (if (or (string-null? base)
                 (absolute-file-name? path))
             path
             (string-append base "/" path))))
    (check-path path)
    (canonicalize-path path)))

;;;
;;; Create file with simulation timeout watchdog
;;;
(define (create-timeout-module path modname timeout)
  (define (* . fmt) (println (apply format fmt)))
  (let ((filename (format "~a/~a.v" path modname)))
    (with-output-to-file filename
      ;; #:exists 'replace
      (lambda ()
        (* "// Automatically generated file")
        (* "`timescale 1ps/1ps")
        (* "module ~a();" modname)
        (* "  initial begin")
        (if (list? timeout)
            (* "    #(~a~a);"
               (car timeout)
               (if (null? (cdr timeout))
                   ""
                   (symbol->string (cadr timeout))))
            (* "    #~a;" timeout))
        (* "    $display(\"~aTimeout at %0t\", $time);"
           (lt-log-prefix (log-type-by-id 'error)))
        (* "    $finish;")
        (* "  end")
        (* "endmodule")))
    (path->absolute filename)))

;;;
;;; Create dump module
;;;
(define (create-dump-module path modname top dump-type)
  (define (* . fmt) (println (apply format fmt)))
  (let ((filename (format "~a/~a.v" path modname)))
    (with-output-to-file filename
      ;; #:exists 'replace
      (lambda ()
        (* "// Automatically generated file")
        (* "`timescale 1ps/1ps")
        (* "module ~a();" modname)
        (* "  initial begin")
        (* "    $dumpfile(\"~a/~a.~a\");" path top dump-type)
        (* "    $dumpvars(0, ~a);" top)
        (* "  end")
        (* "endmodule")))
    (path->absolute filename)))

;;;
;;; Return directory list
;;;
(define (list-dir path)
  (if (file-exists? path)
      (let ((dir (opendir path)))
        (let loop ((ls '()))
          (let ((item (readdir dir)))
            (if (eof-object? item)
                (begin
                  (closedir dir)
                  ls)
                (if (or (string=? item ".")
                        (string=? item ".."))
                    (loop ls)
                    (loop (cons (string-append path "/" item) ls)))))))
      '()))

;;;
;;; Recursive delete directory
;;;
(define (delete-recursive path)
  (let ((path (path->absolute path)))
    (if (eq? 'directory (stat:type (stat path)))
        (begin
          (for-each delete-recursive (list-dir path))
          (rmdir path))
        (delete-file path))))

;;;
;;; Recursive find path items for which the function f returns true
;;; (fn fullpath type) : (-> (string symbol) boolean)
;;; Returns empty list if files not found
;;;
(define* (find-paths-rec fn base #:optional (follow-symlink #f))
  (let ((ls (list-dir base)))
    (let ((files.dirs
           (fold (lambda (name f.d)
                   ;; There is a risk that some paths may have disappeared during recursive search.
                   ;; To avoid an error, we can catch the exception from the stat function

                   ;; (let ((t (guard #f (stat:type (stat name)))))
                   ;;   (if t
                   ;;       (let* ((files (car f.d))
                   ;;              (dirs  (cdr f.d))
                   ;;              (f (if (fn name t) (cons name files) files)))
                   ;;         (if (or (eq? t 'directory)
                   ;;                 (and follow-symlink
                   ;;                      (eq? t symlink)))
                   ;;             (cons f (cons name dirs))
                   ;;             (cons f dirs)))
                   ;;       f.d))

                   (let* ((files (car f.d))
                          (dirs  (cdr f.d))
                          (t (stat:type (stat name)))
                          (f (if (fn name t) (cons name files) files)))
                     (if (or (eq? t 'directory)
                             (and follow-symlink
                                  (eq? t symlink)))
                         (cons f (cons name dirs))
                         (cons f dirs))))
                 '(()) ls)))
      (let ((files (car files.dirs))
            (dirs (cdr files.dirs)))
        (fold (lambda (dir files)
                (append files (find-paths-rec fn dir follow-symlink)))
              files dirs)))))

;;;
;;; Recursive find files with name matched a regular expression
;;; (find-files-rec-regexp rx base [follow-symlink #f]) -> (listof path?)
;;;   rx   : string?
;;;   base : string?
;;;   follow-symlink : boolean?
;;;
;;; rx - regulat expression
;;; base - base directory for files search
;;;
(define* (find-files-rec-regexp rx base #:optional (follow-symlink #f))
  (if (eq? 'regular (stat:type (stat base)))
      (if (string-match rx (basename base)) (list base) '())
      (find-paths-rec
       (lambda (f t)
         (and (eq? t 'regular)
              (string-match rx (basename f))))
       base follow-symlink)))

;;;
;;; Recursive find files in testbench base directory
;;;
(define* (utest/find-files-rec rx #:key (base "") (follow-symlink #f))
  (find-files-rec-regexp
   rx
   (if (string-null? base)
       (utest/base-path)
       (format "~a/~a" (utest/base-path) base))
   follow-symlink))

;;;
;;; Find files in testbench base directory
(define* (utest/find-files rx #:key (base "") (follow-symlink #f))
  (let* ((base (path->absolute
                (if (string-null? base)
                    (utest/base-path)
                    (format "~a/~a" (utest/base-path) base))))
         (ls (list-dir base)))
    (filter (lambda (f)
              (and (not (string=? f "."))
                   (not (string=? f ".."))
                   (string-match rx f)))
            ls)))

;;;
;;; Prepare argument list
;;;   #f -> '()
;;;   Value -> '(Value)
;;;   '(...) -> '(...)
;;;
(define (arg-to-list arg)
  (cond ((not arg)'())
        ((list? arg) arg)
        (else (list arg))))

;;;
;;; Flatten list
;;;
(define (flatten x)
  (cond ((null? x) '())
        ((pair? x) (append (flatten (car x)) (flatten (cdr x))))
        (else (list x))))

;;;
;;; Trim list
;;;
(define (list-trim-left l pred)
  (if (or (null? l) (not (pred (car l))))
      l
      (list-trim-left (cdr l) pred)))

(define (list-trim-right l pred)
  (reverse (list-trim-left (reverse l) pred)))

(define (list-trim l pred)
  (list-trim-right
   (list-trim-left l pred)
   pred))

;;;
;;; Execute system command and capture stdout and stderr to string list
;;;
(define (system-to-string-list cmd)
  (let* ((cmd (string-append cmd " 2>&1;"))
         (p (open-input-pipe cmd))
         (out (get-string-all p)))
    (values
     (close-pipe p)
     (list-trim (string-split out #\newline) string-null?))))

;;;
;;; Compile code with Icarus Verilog
;;;
(define* (iverilog-compile sources
                           #:key
                           (iverilog-executable "iverilog")
                           (modpaths '())           ; -y
                           (modtypes '(".v" ".sv")) ; -Y
                           (includes '())           ; -I
                           (top #f)                 ; -s
                           (output #f)              ; -o
                           (lang "2012")            ; -g2012
                           (features '())           ; -g
                           (vpipaths '())           ; -L
                           (vpimods '())            ; -m
                           (libs '())               ; -l
                           (netlist #f)             ; -N
                           (separate #f)            ; -u
                           (warnings "all")         ; -W
                           (defines '())            ; -D=X
                           (parameters '())         ; -P=X
                           (other '()))

  (define (string-or-num-param x)
    (if (number? x)
        (format "~a" x)
        (format "'\"~a\"'" x)))

  (let ((opts
         (cons
          iverilog-executable
          (append
           (if lang (list (format "-g~a" lang)) '())
           (if output (list "-o" output) '())
           (if separate '("-u") '())
           (if netlist (list (format "-N~a" netlist)) '())
           (flatten (map (lambda (x) (list "-s" x)) (arg-to-list top)))
           (map (lambda (x) (format "-W~a" x)) (arg-to-list warnings))
           (map (lambda (x) (format "-y~a" x)) (arg-to-list modpaths))
           (map (lambda (x) (format "-Y~a" x)) (arg-to-list modtypes))
           (map (lambda (x) (format "-I~a" x)) (arg-to-list includes))
           (map (lambda (x) (format "-g~a" x)) (arg-to-list features))
           (map (lambda (x) (format "-L~a" x)) (arg-to-list vpipaths))
           (map (lambda (x) (format "-m~a" x)) (arg-to-list vpimods))
           (map (lambda (x) (format "-l~a" x)) (arg-to-list libs))
           (map (lambda (x)
                  (format "-P~a=~a"
                          (if (or (not top) (list? top))
                              (car x)
                              (format "~a.~a" top (car x)))
                          (string-or-num-param (cadr x))))
                parameters)
           (map (lambda (x)
                  (if (list? x)
                      (format "-D~a=~a" (car x) (string-or-num-param (cadr x)))
                      (format "-D~a" x)))
                defines)
           other
           (arg-to-list sources)))))

    (let ((cmdline (fold (lambda (x s) (string-append s x " ")) "" opts)))
      (let-values (((status output)
                    (system-to-string-list cmdline)))
        (values (= status 0) cmdline output)))))

;;;
;;; Run simulation of executable compiled with Icarus Verilog
;;;
(define* (iverilog-run vvp-binary
                       #:key
                       (vvp-executable "vvp")
                       (vpipaths '())           ; -M
                       (vpimods '())            ; -m
                       (dumpformat 'fst)
                       (plusargs '()))
  (let ((opts
         (cons
          vvp-executable
          (append
           (map (lambda (x) (format "-M~a" x)) (arg-to-list vpipaths))
           (map (lambda (x) (format "-m~a" x)) (arg-to-list vpimods))
           (list "-N" vvp-binary)   ; $finish on CTRL-C
           (case dumpformat
             ((vcd) '("-vcd"))
             ((fst) '("-fst"))
             ((lxt) '("-lxt"))
             ((lxt2) '("-lxt2"))
             ((none) '("-none"))
             (else '()))
           (map (lambda (x) (format "+~a" x)) plusargs)))))

    (let ((cmdline (fold (lambda (x s) (string-append s x " ")) "" opts)))
      (let-values (((status output)
                    (system-to-string-list cmdline)))
        (let ((status
               ;; Fix vvp issue (https://github.com/steveicarus/iverilog/issues/737)
               (if (find (lambda (x) (string-prefix? "VCD Error: " x)) output) -1 status)))
          (values (= status 0) cmdline output))))))

;;;
;;; Check log for errors or warnings
;;;
(define (check-log log)
  (let ((sim-fail-prefix (lt-log-prefix (log-type-by-id 'error)))
        (sim-warn-prefix (lt-log-prefix (log-type-by-id 'warning))))
    (cond
     ((find (lambda (x) (string-prefix? sim-fail-prefix x)) log) #f)
     ((find (lambda (x) (string-prefix? sim-warn-prefix x)) log) 'warning)
     (else #t))))

;;;
;;; Run compile and simulation with Icarus Verilog
;;;
(define* (utest/run-simulation-iverilog sources
                                        top
                                        #:key
                                        (iverilog-executable "iverilog")
                                        (vvp-executable "vvp")
                                        (modpaths '())
                                        (modtypes '(".v" ".sv"))
                                        (includes '())
                                        (lang "2012")
                                        (parameters '())
                                        (defines '())
                                        (features '())
                                        (separate #f)
                                        (plusargs '())
                                        (vpimods '())
                                        (vpipaths '())
                                        (warnings "all")
                                        (dumpformat 'fst)
                                        (timeout '(1 s)))

  ;; Get parameters
  (let ((force-dump (utest/force-dump))
        (base-path (utest/base-path))
        (work-path (utest/work-path)))

    ;; Create helper modules - timeout watchdog and waveform dumper
    (let ((timeout-module (create-timeout-module work-path TIMEOUT_MODULE_NAME timeout))
          (dump-module (create-dump-module work-path DUMP_MODULE_NAME top dumpformat)))

      ;; Convert relative paths to absolute
      (let ((sources (append (map (lambda (x) (path->absolute x base-path))
                                  (arg-to-list sources))
                             (list timeout-module dump-module)))

            (defines (append defines
                             `((UTEST_BASE_DIR ,(format "'\"~a\"'" base-path))
                               (UTEST_WORK_DIR ,(format "'\"~a\"'" work-path)))))

            (includes (map (lambda (x) (path->absolute x base-path)) (arg-to-list includes)))
            (modpaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list modpaths)))
            (vpipaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list vpipaths)))
            (execfile (format "~a/~a.vvp" work-path top)))

        (let ((succ
               ;; Start compilation
               (let-values
                   (((succ cmdl outp)
                     (iverilog-compile sources
                                       #:iverilog-executable iverilog-executable #:modpaths modpaths
                                       #:modtypes '(".v" ".sv") #:includes includes
                                       #:top top #:other `("-s" ,TIMEOUT_MODULE_NAME "-s" ,DUMP_MODULE_NAME)
                                       #:output execfile #:lang lang #:features features #:vpipaths vpipaths
                                       #:vpimods vpimods #:separate separate #:warnings warnings #:defines defines
                                       #:parameters parameters)))

                 ;; Print iverilog command line and output
                 (printf "$ ~a\n" cmdl)
                 (for-each println outp)

                 ;; Run simulation. On error the simulation will retry
                 ;; with dump enabled, if needed
                 (if succ
                     (let retry ((dump force-dump))
                       (let-values
                           (((succ cmdl outp)
                             (iverilog-run execfile
                                           #:vvp-executable vvp-executable #:vpipaths vpipaths
                                           #:vpimods vpimods #:dumpformat (if dump dumpformat 'none)
                                           #:plusargs plusargs)))
                         (let ((succ (if succ (check-log outp) succ)))
                           (if (or succ dump (not (utest/restart-dump)))
                               (begin
                                 ;; Print vvp command line and output
                                 (printf "$ ~a\n" cmdl)
                                 (for-each println outp)
                                 succ)
                               (retry #t)))))
                     succ))))
          succ)))))

;;;
;;; Return all test procs from make files
;;; Return list of pairs (base-dir . test-proc)
;;;
(define (collect-test-procs files)
  (fold
   (lambda (f procs)
     (let ((f (path->absolute f)))
       (append
        procs
        (map (lambda (proc) (list proc (dirname f) (basename f)))
             (let ((procs (load f)))
               (if (list? procs) procs (list procs)))))))
   '() files))

;;;
;;; Call test proc. Collect output to list of string
;;;
(define (call-test test work)
  (let* ((pass #f)
         (proc  (car test))
         (base  (cadr test))
         (name  (proc 'name))
         (name  (format "~a~a/~a"
                        (let* ((pwd (string-append (path->absolute (getcwd)) "/"))
                               (base-loc
                                (if (string-prefix? pwd base)
                                    (substring base (string-length pwd))
                                    base)))
                          (if (string-null? base-loc)
                              ""
                              (string-append base-loc "/")))
                        (caddr test)
                        (if name name "-")))
         (descr (proc 'description))
         (log
          (string-split
           (with-output-to-string
             (lambda ()
               (utest/log 'test-head "TEST ~a" name)
               (when descr (utest/log 'test-info "~a" descr))
               (utest/log "Base: ~a" base)
               (utest/log "Work: ~a" work)
               (set! pass
                     (with-exception-handler (lambda (e)
                                               (display "EXCEPTION: ")
                                               (display e) #f)
                       (lambda ()
                         (parameterize ((utest/base-path base)
                                        (utest/work-path work))
                           (proc)))
                       #:unwind? #t))))
           #\newline)))

    ;; Check log
    (let ((log (append log
                       (list (if pass
                                 (utest/slog 'test-succ "PASS")
                                 (utest/slog 'test-fail "FAIL (~a)" (basename work)))))))
      (values pass log))))

;;;
;;; Create temporary working directory, call test,
;;; print log to stdout and save verbose log to a file.
;;;
;;; test : (list test-proc base-path makefile-base-name)
;;; returns: (values pass output)
;;;
(define (execute-test test)
  (let ((proc (car test))
        (base (cadr test))
        (makefile-name (caddr test)))
    (let* ((name (proc 'name))
           (name (if name name "noname"))
           (work (mkdtemp (format "~a/~a~a-~a-~a-XXXXXX"
                                  base WORK_DIR_PREFIX
                                  makefile-name
                                  (string-map (lambda (c) (if (char-whitespace? c) #\_ c))
                                              (string-downcase name))
                                  (current-time)))))
      ;; Execute test
      (let* ((p #f)
             (o (with-output-to-string
                  (lambda ()
                    (let-values (((pass log)
                                  (call-test test work)))
                      (set! p pass)

                      ;; Print log
                      (print-log log
                                 #:colorize (not (utest/nocolor))
                                 #:verbose (or (utest/verbose)
                                               (not (eq? pass #t))))

                      ;; Save log
                      (with-output-to-file (format "~a/test-log.txt" work)
                        (lambda () (print-log log #:colorize #f #:verbose #t)))

                      ;; Delete work dir if test pass and no need to keep directory
                      (if (and (eq? pass #t)
                               (not (utest/force-dump))
                               (not (utest/keep-output)))
                          (begin
                            (when (utest/verbose)
                              (printf "Delete work dir ~a\n" work))
                            (delete-recursive work))
                          (printf "See output at ~a\n" work)))))))
        (values p o)))))

;;;
;;; Execute tests in series (in one thread)
;;; tests : list-of (test-proc base-path makefile-base-name)
;;;
(define (execute-tests tests)
  (let ((test-count (length tests))
        (pass-count
         (fold (lambda (test cnt)
                 (let-values (((pass out) (execute-test test)))
                   (println out)
                   (+ cnt (if pass 1 0))))
               0 tests)))
    (printf "PASSED ~a/~a\n\n" pass-count test-count)))

;;;
;;; Execute tests in parallel
;;; tests : list-of (test-proc base-path makefile-base-name)
;;;
(define (execute-tests-parallel tests max-threads-count)
  (let ((test-count (length tests)))
    (let loop ((tests tests)
               (threads '())
               (pass-count 0))

      (if (and (null? tests)
               (null? threads))
          ;; Done
          (printf "PASSED ~a/~a\n\n" pass-count test-count)

          ;; Not all tests complete
          (let ((threads-prev threads))
            ;; Run new thread if thread pool is not full
            (let-values
                (((tests threads)
                  (if (and (< (length threads) max-threads-count)
                           (not (null? tests)))
                      (let* ((test (car tests))
                             (thd
                              (call-with-new-thread
                               (lambda ()
                                 (execute-test test)))))
                        (values (cdr tests) (cons thd threads)))
                      (values tests threads))))

              ;; Get exited threads
              (let* ((trest.passc
                      (fold
                       (lambda (thd t.p)
                         (let ((trest (car t.p))
                               (passc  (cdr t.p)))
                           (if (thread-exited? thd)
                               (let-values (((pass out) (join-thread thd)))
                                 (println out)
                                 (cons trest (+ passc (if pass 1 0))))
                               (cons (cons thd trest) passc))))
                       (cons '() pass-count) threads))

                     (threads    (car trest.passc))
                     (pass-count (cdr trest.passc)))

                ;; Sleep when no new threads and no exited threads
                (when (= (length threads-prev)
                         (length threads))
                  (usleep 10000)
                  (yield))

                ;; Loop
                (loop tests threads pass-count))))))))

;;;
;;; Test item macro
;;;
(define-syntax utest/tb
  (syntax-rules ()
    ((_ (n d ...) body ...)
     (lambda id
       (cond
        ((null? id) (begin body ...))
        ((eq? (car id) 'name) n)
        ((eq? (car id) 'description)
         ((lambda rest
            (if (null? rest)
                #f
                (string-append
                 (car rest)
                 (apply string-append
                        (map (lambda (x) (string-append "\n" x))
                             (cdr rest))))))
          d ...))
        (else #f))))

    ((_ () body ...)
     (utest/tb (#f) body ...))))

;;;
;;; Delete working folders
;;;
(define (delete-work-dirs base force)
  (let ((work-dirs
         (if force
             (find-paths-rec
              (lambda (p t)
                (and (eq? t 'directory)
                     (string-match
                      (format "^~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX)
                      (basename p))))
              base)
             (fold
              (lambda (makefile work-dirs)
                (append
                 work-dirs
                 (find-paths-rec
                  (lambda (p t)
                    (and (eq? t 'directory)
                         (string-match
                          (format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile))
                          (basename p))))
                  (dirname makefile))))
              '() (find-files-rec-regexp MAKEFILE_NAME_REGEXP base)))))
    (if (null? work-dirs)
        (printf "Working folders not found\n")
        (for-each
         (lambda (dir)
           (printf "Delete \"~a\"\n" dir)
           (delete-recursive dir))
         work-dirs))))

;;;
;;; Print log level verilog defines
;;;
(define (print-verilog-defines)
  (define (* . fmt) (apply printf fmt) (newline))
  (* "`ifndef UTEST_VERILOG_DEFINES")
  (* " `define UTEST_VERILOG_DEFINES")
  (* "")
  (* "// Log level string prefixes for use with $display function.")
  (* "// Example usage: $display(\"%sError message\", `LOG_ERR);")
  (* " `define LOG_INFO \"~a\"" LOG_PREFIX_INFO)
  (* " `define LOG_WARN \"~a\"" LOG_PREFIX_WARN)
  (* " `define LOG_ERR  \"~a\"" LOG_PREFIX_FAIL)
  (* "")
  (* "// Dirty hacked redefine of $display function. Must be used with two parentheses.")
  (* "// Example usage: `log_info((\"Information message\"));")
  (* " `define log_info(msg)  begin $display({`LOG_INFO, $sformatf msg}); end")
  (* " `define log_warn(msg)  begin $display({`LOG_WARN, $sformatf msg}); end")
  (* " `define log_error(msg) begin $display({`LOG_ERR, $sformatf msg}); end")
  (* "`endif"))

;;;
;;; Print help
;;;
(define (print-help app-name)
  (define (* . fmt) (apply printf fmt) (newline))
  (* "Usage: ~a [OPTION]... [FILE|PATH]" app-name)
  (* "Run testbenches with recursive search in the PATH, or in the current folder")
  (* "if PATH is not specified. If argument is a file, testbench is launched from FILE.")
  (* "")
  (* "Options:")
  (* "  -k, --keep           Do not delete work directory if test is pass.")
  (* "  -d, --dump           Force dump waveforms.")
  (* "  -r, --norestart      Do not restart testbench with waveform dump enabled if")
  (* "                       test failed (true by default)")
  (* "  -n, --nocolor        Do not use color for print log")
  (* "  -j, --jobs NUM       Use NUM threads for running testbenches. If <=0")
  (* "                       use as many threads as there are processors in the system.")
  (* "  -f, --defines        Print useful Verilog defines")
  (* "  -c, --clean          Delete work folders that have a corresponding makefile.")
  (* "      --force-clean    Delete all work folders regardless of the presence of a makefile.")
  (* "  -v, --verbose        Verbose output")
  (* "  -V, --version        Print version")
  (* "  -h, --help           Print this message and exit")
  (* "")
  (* "Source code and issue tracker: <https://github.com/punzik/utest>"))

;;;
;;; Print app version, legals and copyright
;;;
(define (print-version)
  (define (* . fmt) (apply printf fmt) (newline))
  (* "utest ~a" APP_VERSION))

;;;
;;; Main
;;;
(let ((args (command-line)))
  (let* ((optspec `((keep (single-char #\k))
                    (dump (single-char #\d) (value #f))
                    (norestart (single-char #\r) (value #f))
                    (nocolor (single-char #\n) (value #f))
                    (verbose (single-char #\v) (value #f))
                    (jobs (single-char #\j) (value #t) (predicate ,string->number))
                    (help (single-char #\h) (value #f))
                    (version (single-char #\V) (value #f))
                    (clean (single-char #\c) (value #f))
                    (force-clean (value #f))
                    (defines (single-char #\f) (value #f))))

         (options (getopt-long args optspec))
         (jobs    (string->number (option-ref options 'jobs "0")))
         (jobs    (if (zero? jobs) (current-processor-count) jobs))
         (rest    (option-ref options '() '()))
         (path    (path->absolute (if (null? rest) (getcwd) (car rest)))))

    (cond
     ((option-ref options 'help #f)        (print-help (car args)))
     ((option-ref options 'version #f)     (print-version))
     ((option-ref options 'defines #f)     (print-verilog-defines))
     ((option-ref options 'clean #f)       (delete-work-dirs path #f))
     ((option-ref options 'force-clean #f) (delete-work-dirs path #t))

     (else
      (utest/keep-output  (option-ref options 'keep #f))
      (utest/force-dump   (option-ref options 'dump #f))
      (utest/restart-dump (not (option-ref options 'norestart #f)))
      (utest/nocolor      (option-ref options 'nocolor #f))
      (utest/verbose      (option-ref options 'verbose #f))

      (let ((makefiles
             (if (eq? 'regular (stat:type (stat path)))
                 (list path)
                 (find-files-rec-regexp MAKEFILE_NAME_REGEXP path))))

        (if (<= jobs 1)
            (execute-tests (collect-test-procs makefiles))
            (execute-tests-parallel (collect-test-procs makefiles) jobs)))))))