test-utils/test-utils.run.scm

;;;; test-utils.run.scm  -*- Scheme -*-

;; Notes
;;
;; - chicken-install invokes "run.scm" as "<csi> -s run.scm <eggnam>"

(module (test-utils run)

(;export
  ;
  make-test-filename
  make-test-pathname
  ;
  test-list-order<
  ;
  run-ident runid
  ;
  run-test run-test-for
  test-files-rx
  test-lineup
  run-tests run-tests-for
  ;
  csi-options csc-options
  run-test-evaluated run-test-compiled)

(import scheme
  (scheme case-lambda)
  (chicken base)
  (chicken type)
  (only (chicken pathname)
    make-pathname pathname-file pathname-replace-directory
    pathname-strip-extension pathname-directory
    pathname-strip-directory)
  (only (chicken process) system)
  (only (chicken process-context)
    command-line-arguments get-environment-variable executable-pathname)
  (only (chicken format) format)
  (only (chicken sort) sort)
  (only (chicken file) file-exists? find-files)
  (only (chicken irregex) irregex? irregex irregex-match?))

(define-type filename string)
(define-type pathname string)
(define-type irregex (struct regexp))

(define-type alist (list-of (pair symbol *)))

(define-type eggname string)
(define-type testname (or eggname pathname))

(define-type options (list-of string))
(define-type tests (list-of testname))

(define-type opt-options (or false (list-of string)))
(define-type opt-tests (or false tests))

(: test-list-order< ((list-of testname) -> (testname testname -> boolean)))

(: run-ident (#!optional (or false alist) -> (or false alist)))
(: runid (symbol #!optional * -> *))

(: make-test-filename (string -> filename))
(: make-test-pathname (string -> pathname))

(: test-files-rx (#!optional (or false list irregex) -> (or false irregex)))

(: test-lineup (#!optional opt-tests -> opt-tests))

(: run-test (#!optional testname options options -> fixnum))
(: run-test-for (eggname #!optional testname options options -> fixnum))

(: run-tests (#!optional tests options options -> void))
(: run-tests-for (eggname #!optional tests options options -> void))

;not so "testy"

(: csi-options (#!optional opt-options -> opt-options))
(: csc-options (#!optional opt-options -> opt-options))

(: run-test-evaluated (pathname options -> fixnum))
(: run-test-compiled (pathname options -> fixnum))

;; Support

(define (system-must cmd)
  (let ((stat (system cmd)))
    (if (zero? stat) 0
        ;failed, actual code irrelevant
        (exit 1) ) ) )

;(srfi 1)

;/1 good enough
(define (list-index pd? ls)
  (let loop ((ls ls) (i 0))
    (cond ((null? ls) #f)
          ((pd? (car ls)) i)
          (else (loop (cdr ls) (add1 i)))) ) )

(define (remove rmv? ls)
  (let loop ((ls ls) (os '()))
    (cond ((null? ls)
            (reverse os))
          ((rmv? (car ls))
            (loop (cdr ls) os))
          (else
            (loop (cdr ls) (cons (car ls) os))) ) ) )

(define (remove/list os ls) (remove (cut member <> os) ls))

;; Globals

; Where to find CHICKEN binaries

(define *bin* (pathname-directory (executable-pathname)))

(define *csi* (or (get-environment-variable "CHICKEN_CSI") (make-pathname *bin* "csi")))
(define *csc* (or (get-environment-variable "CHICKEN_CSC") (make-pathname *bin* "csc")))

; What options for the test run

(define *csi-init-options* '())

(define *csc-init-options* '(
  ;Highly Problematic
  ;"-disable-interrupts" "-unsafe"
  "-local"
  "-inline-global" "-inline"
  "-specialize" "-strict-types"
  "-optimize-leaf-routines" "-clustering" "-lfa2"
  "-no-trace" "-no-lambda-info"))

(define *egg-name*
  (let ((args (command-line-arguments)))
    (if (null? args) "" (car args)) ) )

(define *run-ident* `(
  (*test-directory* . ".")
  (*test-extension* . "scm")
  (*csi-options* . ())
  (*csi-excl-options* . ())
  (*csc-options* . ())
  (*csc-excl-options* . ())
  (*test-excl-names* . ())
  (*test-order* . ,string<?)
  (EGG-NAME . ,*egg-name*) ) )

;; Test Run Support

(define ((test-list-order< ordered) a b)
  (define (warn-test-order i tst)
    (unless i (warning 'test-list-order< "unknown test" tst))
    tst )
  ;
  (let ((ai (list-index (cut string=? a <>) ordered))
        (bi (list-index (cut string=? b <>) ordered)) )
    (if (and ai bi) (< ai bi)
        (string<? (warn-test-order ai a) (warn-test-order bi b)) ) ) )

(define run-ident
  (let ((ids (the (or false alist) #f)))
    (case-lambda
      (()
        (or ids
            (run-ident *run-ident*)) )
      ((x)
        ;allow #f to reset
        (set! ids x) x) ) ) )

(define runid
  (case-lambda
    ((id)
      (let ((cell (assq id (run-ident))))
        (if cell (cdr cell)
            (error 'runid "no such run ident" id) ) ) )
    ((id v) (run-ident (cons (cons id v) (run-ident))) v) ) )

(define (make-test-filename name) (string-append name "-test"))

(define (make-test-pathname name)
  (make-pathname (runid '*test-directory*)
                 (make-test-filename name) (runid '*test-extension*)) )

(define csi-options
  (let ((opts (the (or false options) #f)))
    (case-lambda
      (()
        (or opts
            (remove/list (runid '*csi-excl-options*)
                         (append (runid '*csi-options*) *csi-init-options*))) )
      ((x)
        ;allow #f to reset
        (set! opts x) x) ) ) )

(define csc-options
  (let ((opts (the (or false options) #f)))
    (case-lambda
      (()
        (or opts
            (remove/list (runid '*csc-excl-options*)
                         (append (runid '*csc-options*) *csc-init-options*))) )
      ((x)
        ;allow #f to reset
        (set! opts x) x) ) ) )

(define (extn-test-files-rx ext) `(: (+ graph) #\- "test" #\. ,ext))

(define test-files-rx
  (let ((rx (the (or false irregex) #f)))
    (case-lambda
      (()
        (or rx
            (test-files-rx (extn-test-files-rx (runid '*test-extension*)))) )
      ((x)
        ;allow #f to reset
        (set! rx (and x
                      (if (irregex? x) x
                          (irregex x 'utf8))))
        rx) ) ) )

;Internal

(define (egg-name) (runid 'EGG-NAME))

(define (test-file-name? x) (irregex-match? (test-files-rx) x))

(define (matching-test-file? x #!optional (remvs '()))
  (and (test-file-name? x) (not (member x remvs))) )

(define (test-files)
  (let ((remvs (map make-test-pathname (runid '*test-excl-names*))))
    (find-files (runid '*test-directory*)
                #:test (cut matching-test-file? <> remvs)
                #:limit 0) ) )

;FIXME very weak
(define (ensure-test-pathname name)
  (if (test-file-name? name) name
      (make-test-pathname name)) )

(define (options->string opts)
  ;FIXME map ->string over options & allow symbols, etc, not just strings
  (apply string-append (intersperse opts " ")) )

;; Run Tests

(define test-lineup
  (let ((fls #f))
    (case-lambda
      (()
        (or fls
            (let ((fls (test-files))
                  (ord (runid '*test-order*)) )
              (define (stripped-ord a b)
                (ord (pathname-file a) (pathname-file b)) )
              (test-lineup (sort fls stripped-ord)))) )
      ((x)
        ;allow #f to reset
        (set! fls x) x) ) ) )

(define (run-test-evaluated source opts)
  (let ((optstr (options->string opts)))
    (format #t "*** ~A ~A ~A ***~%" *csi* (pathname-file source) optstr)
    (system-must (string-append *csi* " " optstr " -s " source)) ) )

(define (run-test-compiled source opts)
  (let ((optstr (options->string opts)))
    (format #t "*** ~A ~A ~A ***~%" *csc* (pathname-file source) optstr)
    ;csc output is in current directory
    (system-must (string-append *csc* " " optstr " " source)) )
  (system-must
    (pathname-replace-directory (pathname-strip-extension source)
                                (runid '*test-directory*))) )

(define (run-test #!optional
                  (name (egg-name))
                  (csc-options (csc-options))
                  (csi-options (csi-options)))
  (let ((source (ensure-test-pathname name)))
    (unless (file-exists? source)
      (error 'run-test "no such file" source) )
    (run-test-evaluated source csi-options)
    (newline)
    (run-test-compiled source csc-options) ) )

(define (run-tests #!optional
                   (tests (test-lineup))
                   (csc-options (csc-options))
                   (csi-options (csi-options)))
  (for-each (cut run-test <> csc-options csi-options) tests) )

(define (run-test-for eggnam . rest)
  (runid 'EGG-NAME eggnam)
  (apply run-test eggnam rest) )

(define (run-tests-for eggnam . rest)
  (runid 'EGG-NAME eggnam)
  (apply run-tests rest) )

) ;module (test-utils run)