PIKApp/plug-ins/script-fu/test/frameworks/testing.scm

; A testing framework
;
; Independent of PIKA except for pika_message,
; which you can redefine


; Testing language

; AssertStmt      ~ (assert '(<code>))
; AssertErrorStmt ~ (assert-error '(<code>)  <prefix of expected error string>)
; ReportStmt      ~ (testing:report)
; LoadStmt        ~ (testing:load-test <filename>)
; AllPassedPredicate ~ (testing:all-passed?)
;
; AssertStmt and AssertErrorStmt have side effects on the testing state,
; and the other statements yield or display the state.
;
; AssertStmt and AssertErrorStmt also have side effects on the display,
; displaying failures.
;
; AssertStmt and AssertErrorStmt also yield #t or #f
; meaning pass or fail.


; Syntax errors

; The test framework WILL NOT handle syntax errors.
; The quoted code under tests must parse without syntax errors.
; Some errors that TinyScheme throws ARE syntax errors, but not named such.
; For example '#\xzzz is a syntax error (z is not a hex digit).
; Thus the test framework won't handle '#\xzzz .


; Algebra of calls
;
; Typically one or more AssertStmt followed by a ReportStmt
; when viewed in the console.
; Or one or more AssertStmt followed by AllPassedPredicate
; to yield an overall testing result,
; when testing is automated.

; Testing error messages
;
; Error messages may have details such as line number of error
; that may change over time.
; Testing expects that details will be a suffix of the error message.
; Passing is measured by comparing given expected prefix of error
; with actual error message.


; Notes on implementation:
;
; Debug stream for testing is pika-message


; EvalResult object
; is-a tuple (result, error)
; <result> is dynamic type returned by eval
; <error> is type string

(define (make-evalresult result errors)
  ;(pika-message "make-evalresult")
  (list result errors))
(define (evalresult-get-result x) (car x))
(define (evalresult-get-error x)  (cadr x))
(define (evalresult-has-no-error? x)
   (= (string-length (cadr x)) 0))


;    state

(define testing:passed 0)  ; counter
(define testing:failed '())  ; list

(define (testing:reset!)
  (set! testing:passed 0)
  (set! testing:failed   '()))

(define (testing:log-passed!)
  ; Not announce success to console, but can debug
  (pika-message "Passed")
  (set! testing:passed (+ testing:passed 1)))

; log any failure
(define (testing:log-fail! failure-string)
  ; Announce fail as it happens
  (displayln "")
  (display "Failed: ")
  (displayln failure-string)
  ; save in state: prepend to list of failures
  (set! testing:failed
        (cons failure-string
              testing:failed)))


(define (testing:log-fail-assert! code eval-result)
  (testing:log-fail! (testing:format-fail-assert code eval-result)))

(define (testing:log-fail-assert-error! code actual-error expected-error)
  (testing:log-fail! (testing:format-fail-assert-error
                 code
                 actual-error
                 expected-error)))

; reset testing state when test framework is loaded
(testing:reset!)



;   reporting
; These methods encapsulate formatting of strings and reports

; A report is a summary of counts
; followed by line for each failure
(define (testing:report)
    (testing:display-summary)
    (testing:display-fails))

(define (testing:display-summary)
  (displayln "")
  (display "Passed: ")
  (display testing:passed)
  (display "   Failed: ")
  (displayln (length testing:failed)))

; Display list of failures in time order
; This does not iterate over the list.
; It relies on newlines in the individual failure formats.
(define (testing:display-fails)
  (if (> (length testing:failed) 0)
      (begin
        (displayln "Failures:")
        ; reverse list so it displays in time order
        (display (reverse testing:failed)))
      '()))

; returns a string for failed assert-error
; Of form: Code: foo Actual: bar Expected: zed
(define (testing:format-fail-assert-error code actual-error expected-error)
  (string-append
    "<Code> "
    (any->string code)
    (string #\newline)
    " <Actual> "
    actual-error
    (string #\newline)
    " <Expected> "
    expected-error
    (string #\newline)
    (string #\newline))
)

; returns a string for failed assert
; Of form    Code: foo Error: bar
(define (testing:format-fail-assert code eval-result)
  (string-append
    "<Code>"
    (any->string code)
    (string #\newline)
    ; Any error message.
    "<Error>"
    (evalresult-get-error eval-result)
    (string #\newline)
    (string #\newline)
    ; We don't display result, it must be false
    ; because were given a boolean proposition
    )
)


;   boolean result for entire testing session

(define (testing:all-passed? )
  (not (= (length testing:failed) 0)))



; Record eval-result, a tuple, from eval of code.
; This knows that a passed normal test has true result and empty error.
; <code is> a an object? a Scheme text, is a boolean proposition,
(define (testing:record-assert-result eval-result code)
  ;(pika-message "record-assert-result")
  ; passed when has no error and result is #t
  (if (and (evalresult-has-no-error? eval-result)
           (evalresult-get-result eval-result))
      (testing:log-passed!)
      ; fail
      (testing:log-fail-assert!
        code
        eval-result)))

; Record eval-result, a tuple, from eval of code.
; This knows that a passed assert-error test has don't care result.
; Instead, this knows the test passes if given <expected-error>
; matches a prefix of the actual error message yielded by eval.
; <result> is dynamic type returned by eval
; <error-message> is type string
; <code> is a an object? a Scheme text, is a boolean proposition.
; <expected-error> is type string
(define (testing:record-assert-error-result eval-result code expected-error)
  ; debug
  ;(displayln "record-assert-error-result")
  ;(displayln eval-result)

  ; expected error string a prefix of actual error string?
  (if (string-prefix?
        expected-error
        (evalresult-get-error eval-result))
      ; passed
      (begin
        (testing:log-passed!)
        #t)
      ; fail, pass asserted code, actual error, expected error
      (begin
        (testing:log-fail-assert-error!
          code
          (evalresult-get-error eval-result)
          expected-error)
        #f)))

; Strict equality of error strings:
;(if (equal?
;        (evalresult-get-error eval-result)
;        expected-error)


; Statments in the testing DSL.

; The usual or normal test.
; <code> is a boolean proposition expected to yield #t
(define (assert code)
  (let* ((eval-result (harnessed-eval code)))
    ; eval-result is tuple
    ; record normal result i.e. error not expected
    (testing:record-assert-result
      eval-result
      code)
    ; Statements have side-effect on testing state,
    ; but also return boolean result of predicate.
    (evalresult-get-result eval-result )))

; A test of abnormality.
; <code> is not expected to yield any particular value
; <error> is a prefix of error string that <code> is expected to throw.
(define (assert-error code expected-error)
  (let* ((eval-result (harnessed-eval code)))
    ; eval-result is tuple
    ; record normal result i.e. error not expected
    (testing:record-assert-error-result
      eval-result
      code
      expected-error)
    ; Returns whether error matches expected error prefix.
    ))


; eval code, returning tuple of result and errors
; This knows how to capture errors
; but not what result and errors mean for testing.
; Harnessed means: surrounded by code to capture error messages.
;
; Assert the pre-condition *error-hook* is (throw msg) see script-fu.init.
; So any call (error msg) is (throw msg)
; But we are not using (catch handler code).
; We are only overriding *error-hook*
;
; Any given eval of code under test may yield many calls to the error hook.
; We only record the first error message in an eval of the code under test.

(define (harnessed-eval code)
  ;(pika-message "harnessed-eval")
  (let* ((old-error-hook *error-hook*) ; save original handler, which is throw
         (errors "") ; initial empty string
         (result #f) ; initial result is #f, not () which is truthy

         (testing-error-hook
           (lambda (xs)
             ;(pika-message "testing-error-hook")

             ; Only record the first error
             (if (= (string-length errors) 0)
                 (if (string? xs)
                    (begin
                      ;(pika-message "xs is string")
                      (set! errors xs))
                    (set! errors "Non-string error")))

             ; Do not chain up to old handler: (old-error-hook xs)
             ; Old handler is usually throw, which is error,
             ; and that infinite loops
             ;
             ; This returns to current eval,
             ; which may call this error hook again.
             ;(pika-message "returning from error hook")
             )))
    ;(pika-message "override error hook")
    (set! *error-hook* testing-error-hook)
    ;(pika-message "eval test code")
    (set! result (eval code))
    ;(pika-message "restore error hook")
    ; restore the error hook for any code in a test script between asserts
    (set! *error-hook* old-error-hook)
    ; return an EvalResult
    (make-evalresult result errors)))





;    port utility


(define (with-string open-function str function)
  (let ((port (open-function str)))
    (if (port? port)
      (let ((result '()))
        (set! result (function port))
        (close-port port)
        result)
      ; Testing internal error.  Hijack the testing framework
      (testing:log-fail! "Failed to open string for string port!" '() ))))

(define (call-with-output-string str function)
  (with-string open-output-string str function))



;   string utility

(define (trim char chars)
  (if (= (char->integer char) (char->integer (car chars)))
      (trim char (cdr chars))
      chars))

(define (rtrim str)
  (list->string (reverse (trim #\space (reverse (string->list str))))))

; any is code
; Not using atom->string.  Using write
(define (any->string any)
  (let* ((to-string
           (lambda (any)
             (let* ((str (make-string 256)))
               (call-with-output-string str
                 (lambda (port) (write any port)))
               str))))
    (rtrim (to-string any))))


; string-prefix? is in R5RS but not tinyscheme.
; string-prefix? is in various SRFI's but we don't have them here
; So yet again, we need to implement it de novo
(define (string-prefix? str1 str2)
  ; if str1 is longer than str2, it is not a prefix
  (if (> (string-length str1) (string-length str2))
    #f
    ; else str2 is longer str2 than str1.
    ; str1 is a prefix if the leading substring of str2,
    ; that is the length of str1, equals str1.
    (string=?
      str1
      (substring str2 0 (string-length str1)))))



;     filesystem utility

; Return the fullpath of a test script.
; When fileScm is empty, returns path to dir of test scripts.
; From pika-data-directory i.e. the shared install dir for PIKA
; Require filename is string
; Require suffix, usually ".scm" on the filename

(define (path-to-test-scripts fileScm)
    (let*   (   (path (string-append pika-data-directory DIR-SEPARATOR "tests")))
        (if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))

(define (path-to-test-images fileScm)
    (let*   (   (path (string-append pika-data-directory DIR-SEPARATOR "images")))
        (if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))

; load a test file, which executes it
; Knows where PIKA installs test scripts
;
; Subsequently, testing:report will say results
(define (testing:load-test filename)
  (pika-message (path-to-test-scripts filename))
  (load (path-to-test-scripts filename)))

; Tell Pika to load a test image
; Returns ID of image
; Knows installed image directory (not dedicated to testing but always there.)
; Accepts image suffixes that Pika can load.
; Typical is /usr/local/share/pika/2.99/images/wilber.png
(define (testing:load-test-image filename)
  (pika-message (path-to-test-images filename))
  ; unpack ID via car
  (car (pika-file-load RUN-NONINTERACTIVE (path-to-test-images filename))))