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