tests/find-tests.lisp

   1 (defun find-test-files ()
   2   (append (directory "*.pure.lisp") (directory "*.impure.lisp")))
   3
   4 (defun file-tests (file)
   5   (with-simple-restart (continue "Skip file ~S" file)
   6     (let ((string (with-open-file (stream file
   7                                           :direction :input
   8                                           :element-type 'character
   9                                           :external-format :utf-8)
  10                     (with-output-to-string (output)
  11                       (let ((buffer (make-string 4096)))
  12                         (loop for characters-read = (read-sequence buffer stream)
  13                            do (write-sequence buffer output :end characters-read)
  14                            while (= characters-read 4096)))))))
  15       (loop with prefix = "(with-test "
  16          for match = (search prefix string) then (search prefix string :start2 position)
  17          for position = (when match (+ match (length prefix)))
  18          while position
  19          appending (with-simple-restart (continue "Skip WITH-TEST form")
  20                      (let* ((options (read-from-string string nil nil :start position))
  21                             (name    (getf options :name)))
  22                        (list (cons name file))))))))
  23
  24 (defun all-tests ()
  25   (let ((skip-count 0))
  26     (handler-bind ((error (lambda (condition)
  27                             (declare (ignore condition))
  28                             (incf skip-count)
  29                             (continue))))
  30       (prog1
  31           (mapcan #'file-tests (find-test-files))
  32         (when (plusp skip-count)
  33           (warn "Skipped ~D WITH-TEST form~:P" skip-count))))))
  34
  35 (defun in-name-p (query name)
  36   (let ((query (let ((*package* (find-package :cl-user)))
  37                  (with-standard-io-syntax
  38                    (read-from-string query)))))
  39     (labels ((in-name-p (name)
  40                (typecase name
  41                  (cons   (some #'in-name-p name))
  42                  (t      (equal query name)))))
  43       (in-name-p name))))
  44
  45 (defun in-name-p/fuzzy (query name)
  46   (let ((query (string-downcase query)))
  47     (labels ((in-name-p (name)
  48                (typecase name
  49                  (cons   (some #'in-name-p name))
  50                  (symbol (search query (string-downcase name)))
  51                  (t      (search query (princ-to-string name))))))
  52       (in-name-p name))))
  53
  54 (defun tests-for (query &key (test #'in-name-p/fuzzy))
  55   (remove query (all-tests) :test-not test :key #'car))
  56
  57 (defun print-matches (matches &key (stream *standard-output*))
  58   (let ((*print-right-margin* most-positive-fixnum)
  59         (*print-miser-width* most-positive-fixnum))
  60     (loop for (name . file) in matches
  61        do (format stream "~32@<~A:~> ~S~%"
  62                   (enough-namestring file *default-pathname-defaults*) name))))
  63
  64 (multiple-value-bind (predicate queries)
  65     (let ((args (rest sb-ext:*posix-argv*)))
  66       (if (equal (first args) "--fuzzy")
  67           (values #'in-name-p/fuzzy (rest args))
  68           (values #'in-name-p args)))
  69   (dolist (query queries)
  70     (print-matches (tests-for query :test predicate))))