; A testing framework
;
; Independent of GIMP except for gimp_message,
; which you can redefine


; Testing language

; AssertStmt      ~ (assert '(<code>))
; AssertErrorStmt ~ (assert-error '(<code>)  <prefix of expected error string>)
; AssertPDBTrueStmt ~ (assert-PDB-true '(<code>)) !!! Where code is only a call to a PDB returning bool
;                   !!! (assert-PDB-true (not `(code)) is invalid
; AssertPDBFalseStmt ~ (assert-PDB-false '(<code>)) !!! Where code is only a call to a PDB returning bool

; ReportStmt      ~ (testing:report)
; LoadStmt        ~ (testing:load-test <filename>)
; AllPassedPredicate ~ (testing:all-passed?)

; PrintStmt       ~ (test! "message")
;
; AssertStmt and AssertErrorStmt and AssertPDBTrue
;   - have side effects on the testing state,
;   - have side effects on the display, displaying failures.
;   - yield #t or #f meaning pass or fail.

; The other statements yield or display the state.


; 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 gimp-message


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

(define (make-evalresult result errors)
  ;(gimp-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
  (gimp-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)))

; Print a line break and a string, usually the test name.
; Side effects on the REPL.
; No affect on testing state, no association with any test result
; except by proximity in the output.
(define (test! string)
  (displayln "")
  (displayln string)
  ; also to GIMP Error Console
  (gimp-message string))


; 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)
  ;(gimp-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)))


(define (testing:record-assert-PDB-truth-result eval-result code ctruth)
  ; ctruth is 0,1
  ; passed when has no error and result is (ctruth)

  ; convert ([0,1]) result to Scheme truth
  (let* ((truth (= (car (evalresult-get-result eval-result))
                  ctruth)))
    (if (and (evalresult-has-no-error? eval-result)
             truth)
        (testing:log-passed!)
        ; fail
        (testing:log-fail-assert!
          code
          eval-result))))

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


; Statements 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.
    ))


; The next two functions go away when
; ScriptFu binds more naturally to PDB boolean

; Special test for calls to PDB returning boolean.
; <code> is a call to the PDB expected to yield ([0,1])
; The PDB yields unnatural notion of truth: 0 or 1 wrapped in a list
(define (assert-PDB-true code)
  (let* ((eval-result (harnessed-eval code)))
    ; eval-result is tuple

    ; record normal result i.e. thrown error not expected
    (testing:record-assert-PDB-truth-result
      eval-result
      code
      1)
    ; Statements have side-effect on testing state,
    ; but also return boolean result of predicate.
    (evalresult-get-result eval-result )))

(define (assert-PDB-false code)
  (let* ((eval-result (harnessed-eval code)))
    ; eval-result is tuple

    ; record normal result i.e. thrown error not expected
    (testing:record-assert-PDB-truth-result
      eval-result
      code
      0)
    ; Statements have side-effect on testing state,
    ; but also return boolean result of predicate.
    (evalresult-get-result eval-result )))



; 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)
  ;(gimp-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)
             ;(gimp-message "testing-error-hook")

             ; Only record the first error
             (if (= (string-length errors) 0)
                 (if (string? xs)
                    (begin
                      ;(gimp-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.
             ;(gimp-message "returning from error hook")
             )))
    ;(gimp-message "override error hook")
    (set! *error-hook* testing-error-hook)
    ;(gimp-message "eval test code")
    (set! result (eval code))
    ;(gimp-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)))



;   string utility


; 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 gimp-data-directory i.e. the shared install dir for GIMP
; Require filename is string
; Require suffix, usually ".scm" on the filename

(define (path-to-test-scripts fileScm)
    (let*   (   (path (string-append gimp-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 gimp-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 GIMP installs test scripts
;
; Subsequently, testing:report will say results
(define (testing:load-test filename)
  (gimp-message (path-to-test-scripts filename))
  (load (path-to-test-scripts filename)))

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


; Tell Gimp to load a basic image always distributed with Gimp
; This hides the name of the file.
; Many tests use this, so you can temporarily change the file name
; and many tests will then use a different image.
; But some tests expect the image to have certain properties, like 256x256.
(define (testing:load-test-image-basic)
  (testing:load-test-image "gimp-logo.png"))

; Load a basic image while we are using v3 binding: no car
(define (testing:load-test-image-basic-v3)
  (gimp-file-load RUN-NONINTERACTIVE (path-to-test-images "gimp-logo.png")))

; Returns path to file containing named color profile
; Currently, assumes color profiles downloaded to /work dir.
; FUTURE: platform independent path
; FUTURE: color profile test files in the repo
(define (testing:path-to-color-profile name)
  (string-append "/work/colorProfilesICC/" name))

; Return a new layer in the given image, not inserted.
; The new layer initial attributes are hard-coded.
; The new layer is not added i.e. inserted in the image.
(define (testing:layer-new testImage)
  (gimp-layer-new
    testImage
    "LayerNew"  ; name
    21 22      ; dimensions
    RGB-IMAGE   ; mode
    50.0        ; opacity
    LAYER-MODE-NORMAL))

; Return a new layer in the given image, inserted.
; The new layer initial attributes are hard-coded.
(define (testing:layer-new-inserted testImage)
  (let ((newLayer (testing:layer-new testImage)))
    (gimp-image-insert-layer
            testImage
            newLayer
            0 0) ; parent, position within parent
    newLayer))


; float comparison utility
; are a and b relatively equal, to within epsilon?
(define (equal-relative? a b epsilon)
  (<= (abs (- a b))
      (* epsilon (max (abs a) (abs b)))))


; graphical result utility

; When testing is in the GUI environment and not in batch mode,
; show an image result of testing.
; Now commented out.
; The PDB API has no predicate answering "can open display?"
(define (testing:show image)
  ;(gimp-display-new image)
  )