external/lift.darcs/dev/reports.lisp

   1 (in-package #:lift)
   2
   3 ;; dribble
   4 ;; full output for all tests on separate pages per suite? whatever.
   5 ;; test environment
   6
   7 #|
   8 For *standard-input*: an input stream
   9
  10 For *error-output*, *standard-output*, and *trace-output*: an output stream.
  11
  12 For *debug-io*, *query-io*: a bidirectional stream.
  13 |#
  14
  15 #|
  16 (progn
  17   (setf (test-result-property *test-result* :style-sheet) "test-style.css")
  18   (setf (test-result-property *test-result* :title) "Test Results X")
  19   (setf (test-result-property *test-result* :if-exists) :supersede)
  20   (test-result-report *test-result*  #p"/tmp/report.html" :html))
  21
  22 lift::(progn
  23   (setf (test-result-property *test-result* :style-sheet) "test-style.css")
  24   (setf (test-result-property *test-result* :title) "Merge LUBM 8000")
  25   (setf (test-result-property *test-result* :if-exists) :error)
  26   (test-result-report *test-result*  #p"/tmp/report.sav" :save))
  27
  28 (run-tests :suite '(lift-test test-cursors))
  29
  30 (run-tests :suite 'lift-test-ensure)
  31
  32 (test-result-property *test-result* :title)
  33 |#
  34
  35 #|
  36 in start-test (result test name)
  37    (push `(,name ,(current-values test)) (tests-run result))
  38
  39 if fails / errors, will get problem appended
  40
  41 current-values comes from prototype stuff
  42
  43 use property-list format
  44   start-time
  45   end-time
  46   time
  47   space??
  48
  49 :created
  50 :testsuite-setup
  51 :testing
  52
  53 run-tests-internal
  54   do-testing with testsuite-run
  55
  56 do-testing (suite)
  57   testsuite-setup *
  58   foreach prototype
  59     initialize-test
  60     <fn> (= testsuite-run)
  61   testsuite-teardown *
  62
  63 run-tests
  64   run-test-internal
  65
  66 run-test-internal
  67   start-test - push, name, value onto test-placeholder *
  68   setup-test *
  69   lift-test *
  70   teardown-test *
  71   end-test - setf :end-time *
  72   (add test-data to tests-run of result)
  73
  74 testsuite-run
  75   foreach method in suite, run-test-internal
  76   if children, foreach direct-subclass, run-tests-internal
  77
  78 run-test
  79   do-testing with run-test-internal
  80 |#
  81
  82 ;; when it doubt, add a special
  83 (defvar *report-environment* nil
  84   "Used internally by LIFT reports.")
  85
  86 (defun make-report-environment ()
  87   nil)
  88
  89 ;; env variables need to be part saved in result
  90
  91 (defun test-result-report (result output format
  92                            &rest args
  93                            &key (package *package*) &allow-other-keys)
  94   (let ((*report-environment* (make-report-environment))
  95         (*package* (or (find-package package) *package*)))
  96     (cond ((or (stringp output)
  97                (pathnamep output))
  98            (with-open-file (stream
  99                             output
 100                             :direction :output
 101                             :if-does-not-exist :create
 102                             :if-exists (or (test-result-property
 103                                             result :if-exists)
 104                                            :error))
 105              (%test-result-report-stream result stream format)))
 106           ((streamp output)
 107            (%test-result-report-stream result output format))
 108           (t
 109            (error "Don't know how to send a report to ~s" output)))))
 110
 111 (defun %test-result-report-stream (result stream format)
 112   (start-report-output result stream format)
 113   (summarize-test-result result stream format)
 114   (summarize-test-environment result stream format)
 115   (when (or (failures result) (errors result)
 116             (expected-failures result) (expected-errors result))
 117     (summarize-test-problems result stream format))
 118   (summarize-tests-run result stream format)
 119   (end-report-output result stream format)
 120   (generate-detailed-reports result stream format))
 121
 122 (defmethod start-report-output (result stream format)
 123   (declare (ignore result stream format))
 124   )
 125
 126 (defmethod summarize-test-result (result stream format)
 127   (declare (ignore format))
 128   (format stream"~&Test results for: ~a~%"
 129           (results-for result))
 130   (let ((complete-success? (and (null (errors result))
 131                                 (null (failures result)))))
 132     (cond (complete-success?
 133            (format stream"~&~A Successful test~:P~%"
 134                    (length (tests-run result))))
 135           (t
 136            (format stream "~&~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].~%"
 137                         (length (tests-run result))
 138                         (length (failures result))
 139                         (length (errors result)))))))
 140
 141 (defmethod summarize-test-environment (result stream format)
 142   (declare (ignore result stream format))
 143   )
 144
 145 (defmethod summarize-test-problems (result stream format)
 146   (declare (ignore result stream format))
 147   )
 148
 149 (defmethod generate-detailed-reports (result stream format)
 150   (declare (ignore result stream format))
 151   )
 152
 153 (defmethod summarize-tests-run (result stream format)
 154   (declare (ignore result stream format)))
 155
 156 (defmethod end-report-output (result stream format)
 157   (declare (ignore result stream format))
 158   )
 159
 160 #+(or)
 161 (defun summarize-test-environment (result stream format)
 162   (loop for symbol in (sort `((*lift-dribble-pathname*)
 163                               (*lift-debug-output* interpret-lift-stream)
 164                               (*lift-standard-output* interpret-lift-stream)
 165                               (*test-break-on-errors?*)
 166                               (*test-do-children?*)
 167                               (*lift-equality-test*)
 168                               (*test-print-length*)
 169                               (*test-print-level*)
 170                               (*lift-if-dribble-exists*))
 171                             'string-lessp :key 'first) do
 172
 173        (print)))
 174
 175
 176 ;; some cruft stolen from cl-markdown
 177 (defvar *html-meta*
 178   '((name (:author :description :copyright :keywords :date))
 179     (http-equiv (:refresh :expires))))
 180
 181 (defmethod start-report-output (result stream (format (eql :html)))
 182   (html-header
 183    stream
 184    (test-result-property result :title)
 185    (test-result-property result :style-sheet)))
 186
 187 (defmethod html-header (stream title style-sheet)
 188   (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
 189         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
 190   (format stream "~&<html>~&<head>")
 191   (when title
 192     (format stream "~&<title>~a</title>" title))
 193   (when style-sheet
 194     (unless (search ".css" style-sheet)
 195       (setf style-sheet (concatenate 'string style-sheet ".css")))
 196     (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />"
 197             style-sheet))
 198   (format stream "~&</head>~&<body>"))
 199
 200 (defmethod summarize-test-result (result stream (format (eql :html)))
 201   (format stream "~&<div id=\"summary\">")
 202   (format stream "~&<h1>Test results for: ~a</h1>~%"
 203           (results-for result))
 204   (let ((complete-success? (and (null (errors result))
 205                                 (null (failures result)))))
 206     (cond (complete-success?
 207            (format stream "~&<h2>~A Successful test~:P</h2>~%"
 208                    (length (tests-run result))))
 209           (t
 210            (format stream
 211                    "~&<h2>~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].</h2>~%"
 212                    (length (tests-run result))
 213                    (length (failures result))
 214                    (length (errors result)))))
 215
 216     (when (or (expected-errors result) (expected-failures result))
 217       (format stream "~&<h3>~[~:;~:*Expected failure~p: ~:*~a~]~[~:;, ~]~[~:;~:*Expected error~p: ~:*~a~]</h3>~%"
 218               (length (expected-failures result))
 219               ;; zero if only one or the other (so we don't need a separator...)
 220               (* (length (expected-failures result))
 221                  (length (expected-errors result)))
 222               (length (expected-errors result))))
 223
 224     (when (and (slot-boundp result 'end-time-universal)
 225                (numberp (end-time-universal result))
 226                (numberp (start-time-universal result)))
 227       (format stream "~&<h3>Testing took: ~:d seconds</h3>"
 228               (- (end-time-universal result)
 229                  (start-time-universal result))))
 230     #+(or)
 231     (when (and (numberp (real-end-time result))
 232                (numberp (real-start-time result)))
 233       (format stream "~&Time: ~,2f real-time"
 234               (/ (- (real-end-time result) (real-start-time result))
 235                  internal-time-units-per-second))))
 236   (format stream "~&</div>"))
 237
 238 (defmethod summarize-test-environment (result stream (format (eql :html)))
 239   (declare (ignore result))
 240   (format stream "~&<div id=\"environment\">")
 241
 242   (format stream "~&</div>"))
 243
 244 (defmethod summarize-test-problems (result stream  (format (eql :html)))
 245   (format stream "~&<div id=\"problem-summary\">")
 246   (format stream "~&<h2>Problem Summary:</h2>")
 247   (when (failures result)
 248     (summarize-test-problems-of-type
 249      (failures result) stream "failure-summary" "Failures"))
 250   (when (errors result)
 251     (summarize-test-problems-of-type
 252      (errors result) stream "error-summary" "Errors"))
 253   (when (expected-failures result)
 254     (summarize-test-problems-of-type
 255      (expected-failures result)
 256      stream "expected-failure-summary" "Expected Failures"))
 257   (when (expected-errors result)
 258     (summarize-test-problems-of-type
 259      (expected-errors result) stream "expected-failure-summary"
 260      "Expected Errors"))
 261   (format stream "~&</div>"))
 262
 263 (defmethod summarize-test-problems-of-type
 264     (problems stream id heading)
 265   (format stream "~&<div id=\"id\">" id)
 266   (format stream "~&<h3>~a</h3>" heading)
 267   (report-tests-by-suite
 268    (mapcar (lambda (problem)
 269              `(,(type-of (testsuite problem))
 270                 ,(test-method problem)
 271                 (:problem ,problem)))
 272            problems) stream)
 273   (format stream "~&</div>"))
 274
 275 (defmethod summarize-tests-run (result stream (format (eql :html)))
 276   (format stream "~&<div id=\"results\">")
 277   (format stream "~&<h2>Tests Run:</h2>")
 278   (report-tests-by-suite (tests-run result) stream)
 279   (format stream "~&</div>"))
 280
 281 (defun report-tests-by-suite (tests stream)
 282   (let ((current-suite nil))
 283     (loop for rest = (sort
 284                       ;; FIXME - this is a hack intended to show tests
 285                       ;; in the order they were run (even if it works, it's
 286                       ;; bound to be fragile)
 287                       (copy-list tests)
 288                       #+(or) (nreverse (copy-list tests))
 289                       'string-lessp :key 'first) then (rest rest)
 290        while rest
 291        for (suite test-name datum) = (first rest) do
 292        (unless (eq current-suite suite)
 293          (when current-suite
 294            (format stream "</div>"))
 295          (setf current-suite suite)
 296          (format stream "~&<div class=\"testsuite\">")
 297          (let* ((this-suite-end (or
 298                                  (position-if
 299                                   (lambda (datum)
 300                                     (not (eq current-suite (first datum))))
 301                                   rest)
 302                                  (length rest)))
 303                 (error-count (count-if
 304                               (lambda (datum)
 305                                 (and (getf (third datum) :problem)
 306                                      (typep (getf (third datum) :problem)
 307                                             'test-error)))
 308                               rest
 309                               :end this-suite-end))
 310                 (failure-count (count-if
 311                                 (lambda (datum)
 312                                   (and (getf (third datum) :problem)
 313                                        (typep (getf (third datum) :problem)
 314                                               'test-failure)))
 315                                 rest
 316                                 :end this-suite-end))
 317                 (extra-class (cond ((and (= error-count 0) (= failure-count 0))
 318                                     'testsuite-all-passed)
 319                                    ((> error-count 0)
 320                                     'testsuite-some-errors)
 321                                    (t
 322                                     'testsuite-some-failures))))
 323            (format stream "~&<div class=\"testsuite-title\"><table class=\"~a\"><tr><td>~a</td>" extra-class suite)
 324            (format stream "<td class=\"testsuite-test-count\">~:d test~:p</td>"
 325                    this-suite-end)
 326            (format stream "<td class=\"testsuite-summary\">")
 327            (cond ((and (= error-count 0) (= failure-count 0))
 328                   (format stream "all passed"))
 329                  (t
 330                   (format stream "~[~:;~:*~:d failure~:p~]"
 331                           failure-count)
 332                   (when (and (> error-count 0) (> failure-count 0))
 333                     (format stream ", "))
 334                   (format stream  "~[~:;~:*~a error~:p~]"
 335                           error-count)))
 336            (format stream "</td></tr></table>")
 337            (format stream "</div>")))
 338          (format stream "~&<div class=\"test-case\">")
 339          (let ((problem (getf datum :problem)))
 340            (cond ((typep problem 'test-failure)
 341                   (format stream "~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a</a></span>"
 342                           (details-link stream suite test-name)
 343                           test-name)
 344                   (format stream
 345                           "~&<span class=\"test-failure\">failure</span>" ))
 346                  ((typep problem 'test-error)
 347                   (format stream "~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a [during ~a]</a></span>"
 348                           (details-link stream suite test-name)
 349                           test-name
 350                           (test-step problem))
 351                   (format stream "~&<span class=\"test-error\">error</span>"))
 352                  (t
 353                   (format stream "~&<span class=\"test-name\">~a</span>"
 354                           test-name)
 355                   (let ((seconds (getf datum :seconds))
 356                         (conses (getf datum :conses)))
 357                     (when seconds
 358                       (format stream "<span class=\"test-time\">~,3f</span>"
 359                               seconds))
 360                     (when conses
 361                       (format stream "<span class=\"test-space\">~:d</span>"
 362                               conses)))))
 363            (format stream "~&</div>")))
 364     (when current-suite
 365       (format stream "</div>"))))
 366
 367 (defun get-details-links-table ()
 368   (let ((hash (getf *report-environment* :details-links)))
 369     (or hash
 370         (setf (getf *report-environment* :details-links)
 371               (make-hash-table :test 'equal)))))
 372
 373 #+(or)
 374 (get-details-links-table)
 375
 376 (defun details-link (stream suite name)
 377   (declare (ignore stream))
 378   (let* ((hash (get-details-links-table)))
 379     (or (gethash (cons suite name) hash)
 380         (progn
 381           (incf (getf *report-environment* :details-links-count 0))
 382           (setf (gethash (cons suite name) hash)
 383                 (make-pathname
 384                  :name (format nil "details-~a"
 385                                (getf *report-environment* :details-links-count))
 386                  :type "html"))))))
 387
 388 (defmethod end-report-output (result stream (format (eql :html)))
 389   (let ((style-sheet (test-result-property result :style-sheet)))
 390     (when style-sheet
 391       (ignore-errors
 392         (copy-file (asdf:system-relative-pathname
 393                     'lift "resources/test-style.css")
 394                    (make-pathname
 395                     :name (pathname-name style-sheet)
 396                     :type (pathname-type style-sheet)
 397                     :defaults (pathname stream))
 398                    :if-exists :supersede))))
 399   (html-footer stream))
 400
 401 (defun html-footer (stream)
 402   (format stream "<div id=\"footer\">")
 403   (format stream "~&generated on ~a"
 404           #+allegro
 405           (excl:locale-print-time
 406            (get-universal-time)
 407            :fmt "%B %d, %Y %T GMT%z" :stream nil)
 408           #-allegro
 409           (get-universal-time))
 410   (format stream "</div>")
 411   (format stream "~&</body></html>"))
 412
 413 (defmethod generate-detailed-reports (result stream (format (eql :html)))
 414   (loop for (suite test-name datum)  in (tests-run result)
 415      when (getf datum :problem) do
 416      (let ((output-pathname (merge-pathnames
 417                              (details-link stream suite test-name)
 418                              stream)))
 419        (ensure-directories-exist output-pathname)
 420        (let ((*print-right-margin* 64))
 421          (with-open-file (out output-pathname
 422                               :direction :output
 423                               :if-does-not-exist :create
 424                               :if-exists :supersede)
 425            (html-header
 426             out
 427             (format nil "Test ~a details | ~a"
 428                     test-name (test-result-property result :title))
 429             (test-result-property result :style-sheet))
 430            (format out "~&<h2>Test ~a details</h2>" test-name)
 431            (format out "~&<a href=\"~a\">Back</a>"
 432                    (namestring (make-pathname :name (pathname-name stream)
 433                                               :type (pathname-type stream))))
 434            (format out "~&<pre>")
 435            (format out "~a"
 436                    (wrap-encode-pre
 437                     (with-output-to-string (s)
 438                       (print-test-problem "" (getf datum :problem) s t))
 439                     :width (test-result-property
 440                             *test-result* :print-width 60)))
 441            (format out "~&</pre>")
 442            (html-footer out))))))
 443
 444 #+(or)
 445 (defmethod summarize-test-environment (result stream format)
 446   (loop for symbol in (sort `((*lift-dribble-pathname*)
 447                               (*lift-debug-output* interpret-lift-stream)
 448                               (*lift-standard-output* interpret-lift-stream)
 449                               (*test-break-on-errors?*)
 450                               (*test-do-children?*)
 451                               (*lift-equality-test*)
 452                               (*test-print-length*)
 453                               (*test-print-level*)
 454                               (*lift-if-dribble-exists*))
 455                             'string-lessp :key 'first) do
 456
 457        (print)))
 458
 459 (defun wrap-encode-pre (string &key (width 80))
 460   ;; Copied from CL-Markdown
 461   ;; Copied from HTML-Encode
 462   ;;?? this is very consy
 463   ;;?? crappy name
 464   (declare (simple-string string))
 465   (let ((output (make-array (truncate (length string) 2/3)
 466                             :element-type 'character
 467                             :adjustable t
 468                             :fill-pointer 0))
 469         (column 0))
 470     (with-output-to-string (out output)
 471       (loop for char across string
 472          do (case char
 473               ((#\&) (incf column) (write-string "&amp;" out))
 474               ((#\<) (incf column) (write-string "&lt;" out))
 475               ((#\>) (incf column) (write-string "&gt;" out))
 476               ((#\Tab #\Space #\Return #\Newline)
 477                (cond ((or (>= column width)
 478                           (char= char #\Return)
 479                           (char= char #\Newline))
 480                       (setf column 0)
 481                       (terpri out))
 482                      ((char= char #\Space)
 483                       (incf column)
 484                       (write-char char out))
 485                      ((char= char #\Tab)
 486                       (incf column 4)
 487                       (write-string "    " out))))
 488               (t (incf column) (write-char char out)))))
 489     (coerce output 'simple-string)))
 490
 491 ;;;;;
 492
 493 (defmethod summarize-test-result (result stream (format (eql :describe)))
 494   (describe result stream))
 495
 496 (defmethod summarize-tests-run (result stream (format (eql :describe)))
 497   (declare (ignore result stream))
 498   )
 499
 500 ;;;;;
 501
 502 (defmethod summarize-test-result (result stream (format (eql :save)))
 503   (flet ((add-property (name)
 504            (when (slot-boundp result name)
 505              (format stream "~&\(~s ~a\)"
 506                      (intern (symbol-name name) :keyword)
 507                      (slot-value result name)))))
 508     (format stream "\(~%")
 509     (add-property 'results-for)
 510     (format stream "~&\(:date-time ~a\)" (get-universal-time))
 511     (add-property 'real-start-time-universal)
 512     (add-property 'start-time-universal)
 513     (add-property 'end-time-universal)
 514     (add-property 'real-end-time-universal)
 515     (format stream "~&\(:tests-run ")
 516     (loop for (suite name data) in
 517        ;; FIXME - this is a hack intended to show tests
 518        ;; in the order they were run (even if it works, it's
 519        ;; bound to be fragile)
 520          (copy-list (tests-run result)) do
 521          (summarize-single-test format suite name data :stream stream))
 522     (format stream "~&\)")
 523     (format stream "~&\)")))
 524
 525 #+(or)
 526 (progn
 527   (setf (test-result-property *test-result* :if-exists) :supersede)
 528   (test-result-report *test-result* #p"/tmp/report.save" :save))
 529
 530 (defun symbol->turtle (symbol)
 531   (let ((upcase? nil))
 532     (coerce
 533      (loop for char across (string-downcase (symbol-name symbol))
 534         when (char= char #\-) do (setf upcase? t)
 535         else collect (if upcase?
 536                          (prog1 (char-upcase char)
 537                            (setf upcase? nil))
 538                          char))
 539      'string)))
 540
 541 (defun turtlefy (thing)
 542   (typecase thing
 543     (string thing)
 544     (pathname (namestring thing))
 545     (number
 546      (etypecase thing
 547        (integer (format nil "\"~a\"^^xsd:integer" thing))
 548        (double-float (format nil "\"~f\"^^xsd:double" thing))
 549        (single-float (format nil "\"~f\"^^xsd:single" thing))))
 550     (symbol (symbol-name thing))
 551     (t (format nil "\"~a\"" thing))))
 552
 553 (defun ensure-symbol (thing)
 554   (etypecase thing
 555     (symbol thing)
 556     (string (intern thing))))
 557
 558 #+(or)
 559 (symbol->turtle 'real-start-time-universal)
 560
 561 (defun date->turtle (&key (datetime (get-universal-time)) (include-time? nil))
 562   (multiple-value-bind
 563         (second minute hour day month year day-of-the-week)
 564       (decode-universal-time datetime)
 565     (declare (ignore day-of-the-week))
 566     (let ((date-part (format nil "~d-~2,'0d-~2,'0d" year month day))
 567           (time-part (and include-time?
 568                           (format nil "T-~2,'0d:~2,'0d:~2,'0d"
 569                                         hour minute second)))
 570           (data-type (if include-time?
 571                          "xsd:dateTime" "xsd:date")))
 572       (concatenate 'string "\"" date-part time-part  "\"" "^^" data-type))))
 573
 574 ;; http://www.dajobe.org/2004/01/turtle/
 575 (defmethod summarize-test-result (result stream (format (eql :turtle)))
 576   (labels ((convert-value (value type)
 577              (ecase type
 578                (string (turtlefy value))
 579                (symbol (ensure-symbol value))
 580                (date (date->turtle :datetime value))
 581                (dateTime (date->turtle :datetime value :include-time? t))))
 582            (add-property (name type)
 583              (let ((value (slot-value result name)))
 584                (when value
 585                  (format stream "~&:~a ~s ;"
 586                          (symbol->turtle name)
 587                          (convert-value value type))))))
 588     (format stream
 589             "~&@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .~%")
 590     (format stream
 591             "~&@prefix : <http://www.metabang.com/2007/04/lift#> .~%")
 592     (format stream "\[~%")
 593     (add-property 'results-for 'string)
 594     (add-property 'real-start-time 'dateTime)
 595     (add-property 'start-time 'dateTime)
 596     (add-property 'end-time 'dateTime)
 597     (add-property 'real-end-time 'dateTime)
 598     (format stream "~&\:testsRun (")
 599     (loop for (suite name data) in
 600        ;; FIXME - this is a hack intended to show tests
 601        ;; in the order they were run (even if it works, it's
 602        ;; bound to be fragile)
 603          (copy-list (tests-run result))
 604          #+(or)
 605          (nreverse (copy-list (tests-run result))) do
 606          (labels ((write-datum (name type &key (source data))
 607                     (let* ((key (intern (symbol-name name) :keyword))
 608                            (value (getf source key)))
 609                       (when value
 610                         (format stream "~&  :~a ~a ;"
 611                                 (symbol->turtle name)
 612                                 (convert-value value type)))))
 613                   (prop (name type)
 614                     (write-datum name type :source (getf data :properties))))
 615            (format stream "~&\[ ")
 616            (format stream ":testSuite ~s ;" (symbol-name suite))
 617            (format stream "~&  :testName ~s ;" (symbol-name name))
 618            ;; FIXME - we could make these extensible
 619            (write-datum 'start-time 'dateTime)
 620            (write-datum 'end-time 'dateTime)
 621            (write-datum 'result 'string)
 622            (write-datum 'seconds 'string)
 623            (write-datum 'conses 'string)
 624            (loop for stuff in (getf data :properties) by #'cddr do
 625                 (prop stuff 'string))
 626            (format stream " \]")))
 627     (format stream " ) ~&\] . ")))
 628
 629 #+(or)
 630 (progn
 631   (setf (test-result-property *test-result* :if-exists) :supersede)
 632   (test-result-report *test-result*  #p"/tmp/report.n3" :turtle))
 633
 634 ;;;;
 635
 636 (defmacro append-to-report ((var output-to) &body body)
 637   (let ((gclosep (gensym "closep"))
 638         (gstream (gensym "stream")))
 639     `(let* ((,gclosep nil)
 640             (,gstream ,output-to)
 641             (,var (etypecase ,gstream
 642                     (stream ,gstream)
 643                     ((or pathname string)
 644                      (setf ,gclosep t)
 645                      (open ,gstream
 646                            :if-does-not-exist :create
 647                            :if-exists :append
 648                            :direction :output)))))
 649        (unwind-protect
 650             (labels ((out (key value)
 651                        (when value
 652                          (let ((*print-readably* nil))
 653                            (format out "~&\(~s ~s\)" key value)))))
 654               (declare (ignorable (function out)))
 655               (progn ,@body))
 656          (when ,gclosep
 657            (close ,var))))))
 658
 659 (defvar *lift-report-header-hook* nil)
 660
 661 (defvar *lift-report-footer-hook* nil)
 662
 663 (defvar *lift-report-detail-hook* nil)
 664
 665 (defun write-report-header (stream result args)
 666   (append-to-report (out stream)
 667     (format out "~&\(")
 668     (out :results-for (results-for result))
 669     (out :arguments args)
 670     (out :features (copy-list *features*))
 671     (out :datetime (get-universal-time))
 672     (loop for hook in *lift-report-header-hook* do
 673          (funcall hook out result))
 674     (format out "~&\)~%")))
 675
 676 (defun write-report-footer (stream result)
 677   (append-to-report (out stream)
 678     (format out "~&\(")
 679     (out :test-case-count (length (tests-run result)))
 680     (out :test-suite-count (length (suites-run result)))
 681     (out :failure-count (length (failures result)))
 682     (out :error-count (length (errors result)))
 683     (out :expected-failure-count (length (expected-failures result)))
 684     (out :expected-error-count (length (expected-errors result)))
 685     (out :start-time-universal (start-time-universal result))
 686     (when (slot-boundp result 'end-time-universal)
 687       (out :end-time-universal (end-time-universal result)))
 688     (out :testsuite-summary (collect-testsuite-summary result))
 689     (loop for hook in *lift-report-footer-hook* do
 690          (funcall hook out result))
 691     (format out "~&\)~%")))
 692
 693 (defmethod summarize-single-test :around
 694     (format suite-name test-case-name data &key stream)
 695   (append-to-report (out stream)
 696     (call-next-method format suite-name test-case-name data :stream out)))
 697
 698 (defmethod summarize-single-test
 699     ((format (eql :save)) suite-name test-case-name data
 700      &key (stream *standard-output*))
 701   (labels ((out (key value)
 702              (when value
 703                (format stream "~&\(~s ~s\)" key value)))
 704            (write-datum (name &key (source data))
 705              (let* ((key (intern (symbol-name name) :keyword))
 706                     (value (getf source key)))
 707                (out key value)))
 708            (prop (name)
 709              (write-datum name :source (getf data :properties))))
 710     (format stream "~&\(~%")
 711     (format stream "~&\(:suite ~a\)" suite-name)
 712     (format stream "~&\(:name ~a\)" test-case-name)
 713     ;; FIXME - we could make these extensible
 714     (write-datum 'start-time-universal)
 715     (write-datum 'end-time-universal)
 716     (write-datum 'result)
 717     (write-datum 'seconds)
 718     (write-datum 'conses)
 719     (loop for stuff in (getf data :properties) by #'cddr do
 720          (prop stuff))
 721     (cond ((getf data :problem)
 722            (let ((problem (getf data :problem)))
 723              (out :problem-kind (test-problem-kind problem))
 724              (out :problem-step (test-step problem))
 725              (out :problem-condition
 726                   (let ((*print-readably* nil))
 727                     (format nil "~s" (test-condition problem))))
 728              (out :problem-condition-description
 729                   (format nil "~a" (test-condition problem)))
 730              (when (slot-exists-p problem 'backtrace)
 731                (out :problem-backtrace (backtrace problem)))))
 732           (t
 733            (out :result t)))
 734     (loop for hook in *lift-report-detail-hook* do
 735          (funcall hook stream data))
 736     (format stream "\)~%")))
 737
 738 ;;;;
 739
 740 (defun collect-testsuite-summary (result)
 741   (let ((seen (make-hash-table)))
 742     (flet ((seenp (suite)
 743              (gethash suite seen))
 744            (see (suite)
 745              (setf (gethash suite seen) t)))
 746       (declare (ignore (function see) (function seenp)))
 747       (loop for suite in (suites-run result) collect
 748            (list suite
 749                  :testcases (testsuite-tests suite)
 750                  :direct-subsuites (mapcar
 751                                     (lambda (class)
 752                                       (class-name class))
 753                                     (direct-subclasses suite)))))))
 754
 755 #+(or)
 756 (collect-testsuite-summary r)
 757