external/lift.darcs/_darcs/pristine/dev/lift-interface.lisp

   1 ;;;-*- Mode: Lisp; Package: LIFT-INTERFACE -*-
   2
   3 (defpackage "LIFT-INTERFACE"
   4   (:use
   5    "LIFT"
   6    "COMMON-LISP"
   7    #+MCL       "CCL")
   8   (:import-from "LIFT"
   9                 #:number-of-failures
  10                 #:number-of-errors
  11                 #:errors
  12                 #:failures
  13                 #:tests-run
  14                 #:test-class-name
  15                 #:run-tests-internal))
  16
  17 (in-package #:lift-interface)
  18
  19 (defvar *lift-report-window* nil)
  20
  21 (defclass lift-report-window (fred-window)
  22   ()
  23   (:default-initargs
  24     :scratch-p t))
  25
  26 (defun show-last-test-results (result)
  27   (unless (and *lift-report-window*
  28                (typep *lift-report-window* 'fred-window)
  29                (window-shown-p *lift-report-window*))
  30     (setf *lift-report-window* (make-instance 'lift-report-window)))
  31   (let* ((*print-length* nil)
  32          (*print-level* nil)
  33          (*print-array* t)
  34          (win *lift-report-window*))
  35     (set-window-title
  36      win
  37      (format nil "~&Test Report for ~A: ~D test~:P run~:[~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~;, All Passed~]"
  38              (test-class-name result) (length (tests-run result))
  39              (not (or (failures result) (errors result)))
  40              (length (failures result))
  41              (length (errors result))))
  42
  43     (select-all win)
  44     (clear win)
  45     (describe-object result win)
  46     (force-output win)
  47     (fred-update win)))
  48
  49 #+Ignore
  50 (defmethod run-tests-internal :around ((case test-mixin) &key)
  51   (show-last-test-results (call-next-method)))
  52
  53 (u:define-around-advice run-tests show-results
  54   (show-last-test-results (u:call-next-advice)))
  55
  56 (run-tests :suite 'lift::test-lift)