external/lift/dev/reports.lisp

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