path: root/lib/conspire.scm

#| Copyright © 2025 Peter McGoron
 |
 | Permission is hereby granted, free of charge, to any person obtaining
 | a copy of this software and associated documentation files (the
 | “Software”), to deal in the Software without restriction, including
 | without limitation the rights to use, copy, modify, merge, publish,
 | distribute, sublicense, and/or sell copies of the Software, and to
 | permit persons to whom the Software is furnished to do so, subject to
 | the following conditions:
 |
 | The above copyright notice and this permission notice shall be included
 | in all copies or substantial portions of the Software.
 |
 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND,
 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
 | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
 | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
 | THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 |#

;;; ;;;;;;;;;;;;;;;;;;;
;;; Manipulating the test info
;;; ;;;;;;;;;;;;;;;;;;;

(define (modify-test-info! proc)
  (let ((mutex (test-info-mutex (test-info))))
    (dynamic-wind
     (lambda () (mutex-lock! mutex))
     (lambda ()
       (set-test-info-dict! (test-info)
                            (proc (test-info-dto (test-info))
                                  (test-info-dict (test-info)))))
     (lambda () (mutex-unlock! mutex)))))

(define (inspect-test-info proc)
  (let ((mutex (test-info-mutex (test-info))))
    (dynamic-wind
     (lambda () (mutex-lock! mutex))
     (lambda () (proc (test-info-dto (test-info))
                      (test-info-dict (test-info))))
     (lambda () (mutex-unlock! mutex)))))

(define-syntax define-destructive-test-info-procedure
  (syntax-rules ()
    ((_ (name args ...) proc)
     (define (name args ...)
       (modify-test-info! (lambda (dto dictionary)
                            (proc dto dictionary args ...)))))
    ((_ (name . args) proc)
     (define (name . other-args)
       (modify-test-info! (lambda (dto dictionary)
                            (apply proc dto dictionary other-args)))))))

(define-syntax define-inspecting-test-info-procedure
  (syntax-rules ()
    ((_ (name args ...) proc)
     (define (name args ...)
       (inspect-test-info (lambda (dto dictionary)
                            (proc dto dictionary args ...)))))
    ((_ (name . args) proc)
     (define (name . other-args)
       (inspect-test-info (lambda (dto dictionary)
                            (apply proc dto dictionary other-args)))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mutating operations on the test info
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(define-destructive-test-info-procedure
    (test-set! . args) dict-set!)
(define-destructive-test-info-procedure
    (test-update! key updater . rest) dict-update!)
(define-destructive-test-info-procedure
    (test-update/default! key updater default) dict-update/default!)
(define-destructive-test-info-procedure
    (test-delete! . keys) dict-delete!)

(define-inspecting-test-info-procedure
    (test-contains? key) dict-contains?)
(define-inspecting-test-info-procedure
    (test-ref key . rest) dict-ref)
(define-inspecting-test-info-procedure
    (test-ref/default key default) dict-ref/default)
(define-inspecting-test-info-procedure
    (test-set . args) dict-set!)
(define-inspecting-test-info-procedure
    (test-update/default key value) dict-update/default!)

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulating the parameter object
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(define (call-with-name name thunk)
  (define dict
    (inspect-test-info
     (lambda (dto dict)
       (set! dict (dict-set! dto dict 'name name))
       (if name
           (dict-update/default! dto dict
                                 'name-stack
                                 (lambda (pair) (cons name pair))
                                 '())
           dict))))
  (parameterize ((test-info (list 'replace dict)))
    (thunk)))

(define (call-as-test name thunk)
  (when ((test-ref 'before-test) name)
    (let ((thunk
           (lambda ()
             (call/cc
              (lambda (return)
                (define handle
                  (let ((on-exception (test-ref 'on-exception))
                        (return (lambda () (return #f))))
                    (lambda (exn) (on-exception exn return))))
                ((test-ref 'setup-test))
                (with-exception-handler handle thunk)))
             (inspect-test-info values))))
      (call-with-values (lambda () (call-with-name name thunk))
        (test-ref 'after-test)))))

;;; ;;;;;;;;;;
;;; Default handlers
;;; ;;;;;;;;;;

(define (default-setup-test)
  (test-delete! 'success?))

(define (default-after-test previous-dto previous-test-info)
  (test-update/default! 'tests
                        (lambda (x) (+ x 1))
                        0)
  (let ((success? (dict-ref/default previous-dto
                                    previous-test-info
                                    'success?
                                    #f)))
    (test-update/default! (if success? 'passed 'failed)
                          (lambda (x) (+ 1 x))
                          0)
    ((test-ref 'report-test) previous-dto previous-test-info)))

(define (default-report-test previous-dto previous-test-info)
  (let ((verbose? (test-ref/default 'verbose? #f))
        (specifically-verbose? (dict-ref/default previous-dto
                                                 previous-test-info
                                                 'verbose?
                                                 #f))
        (success? (dict-ref/default previous-dto
                                    previous-test-info
                                    'success?
                                    #f))
        (name (cond
                ((dict-ref previous-dto previous-test-info 'name))
                (else ""))))
    (cond
      (success?
       (when (or verbose? specifically-verbose?)
         (display (string-append "success:           \"" name "\"\n"))))
      (else
       (display (string-append "FAILED:           \"" name "\"\n"))
       (when (dict-contains? previous-dto previous-test-info 'exception)
         (display (list 'exception (dict-ref previous-dto
                                             previous-test-info
                                             'exception)))
         (newline))))
    (values previous-dto previous-test-info)))

(define (default-before-test name)
  #t)

(define (default-before-group name)
  (if name
      (display (string-append "entering group \"" name "\"\n"))
      (display "entering group\n"))
  #t)

(define (default-setup-group name)
  (test-set! 'tests 0)
  (test-set! 'passed 0)
  (test-set! 'failed 0)
  (test-set! 'skipped 0))

(define (default-after-group previous-dto previous-info)
  (define (update/previous! name)
    (test-update/default!
     name
     (lambda (x) (+ x (dict-ref/default previous-dto
                                        previous-info
                                        name
                                        0)))
     0))
  (update/previous! 'tests)
  (update/previous! 'passed)
  (update/previous! 'failed)
  (update/previous! 'skipped)
  ((test-ref 'report-group) previous-dto previous-info))

(define (default-report-group previous-dto previous-info)
  (cond
    ((dict-ref previous-dto previous-info 'name)
     => (lambda (name)
          (display (string-append "group \"" name "\" exited.\n"))))
    (else (display "group exited.\n")))
  (values previous-dto previous-info))

(define (default-on-exception exn return)
  (test-set! 'success? #f)
  (test-set! 'exception exn)
  (return))

;;; ;;;;;;;;;;;;;;;;
;;; test info
;;; ;;;;;;;;;;;;;;;;

(define default-test-info-dict
  `((before-test . ,default-before-test)
    (setup-test . ,default-setup-test)
    (after-test . ,default-after-test)
    (report-test . ,default-report-test)
    (setup-group . ,default-setup-group)
    (after-group . ,default-after-group)
    (before-group . ,default-before-group)
    (report-group . ,default-report-group)
    (on-exception . ,default-on-exception)
    (passed . 0)
    (failed . 0)
    (skipped . 0)
    (tests . 0)))

(define default-dto equal-alist-dto)

(define test-info
  (make-parameter
   (list 'replace default-dto default-test-info-dict)
   (lambda (value)
     (cond
       ((not (pair? value))
        (raise-conspire-error "invalid arguments to parameterize"
                              value))
       ((eq? (car value) 'box)
        (unless (null? (cdr value))
          (raise-conspire-error "invalid arguments to copy"
                                value))
        (inspect-test-info make-test-info))
       ((eq? (car value) 'replace)
        (cond
          ((null? (list-tail value 1))
           (raise-conspire-error "not enough arguments to replace"
                                 value))
          ((null? (list-tail value 2))
           (inspect-test-info (lambda (dto _)
                                (make-test-info dto
                                                (list-ref value 1)))))
          ((null? (list-tail value 3))
           (make-test-info (list-ref value 1) (list-ref value 2)))
          (else (raise-conspire-error "too many arguments to replace"
                                      value))))
       ((eq? (car value) 'operate)
        (call-with-values (lambda ()
                            (inspect-test-info (list-ref value 1)))
          make-test-info))
       (else (raise-conspire-error "unknown command" value))))))

;;; ;;;;;;;;;;;;
;;; Wrappers and semi-compatability with SRFI-64
;;; ;;;;;;;;;;;;

(define-syntax test-application
  (syntax-rules ()
    ((test-application test-name (name expr) ...)
     (call-as-test test-name (lambda ()
                               (test-set! (quote name) (quote expr)) ...
                               (let ((name expr) ...)
                                 (test-set! 'application (list name ...))
                                 (test-set! 'success? (name ...))))))))

(define-syntax with-test-assert
  (syntax-rules ()
    ((_ name body ...)
     (call-as-test name (lambda ()
                          (test-set! 'success?
                                     (let () body ...)))))))

(define-syntax test-equal
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure equal?)
                       (expected %expected)
                       (actual %actual)))))

(define-syntax test-eqv
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure eqv?)
                       (expected %expected)
                       (actual %actual)))))


(define-syntax test-eq
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure eq?)
                       (expected %expected)
                       (actual %actual)))))

(define (%test-approximate expected actual error)
  (<= (abs (- expected actual)) error))

(define-syntax test-approximate
  (syntax-rules ()
    ((_ name %expected %actual %error)
     (test-application name
                       (procedure %test-approximate)
                       (expected %expected)
                       (actual %actual)
                       (error %error)))))

(define (call-as-test-error name error-predicate thunk)
  (define (outer-thunk)
    (test-set! 'success?
               (call/cc
                (lambda (return)
                  (with-exception-handler (lambda (ex)
                                            (test-set! 'exception ex)
                                            (return (error-predicate ex)))
                    (lambda () (thunk) #f))))))
  (call-as-test name outer-thunk))

(define-syntax with-test-error
  (syntax-rules ()
    ((_ name error-predicate body ...)
     (call-as-test-error name error-predicate
                         (lambda () body ...)))))

(define (call-as-group name thunk)
  (when ((test-ref 'before-group) name)
    (let ((inside (lambda ()
                    ((test-ref 'setup-group) name)
                    (thunk)
                    (inspect-test-info values))))
      (call-with-values (lambda () (call-with-name name inside))
        (test-ref 'after-group)))))

(define-syntax test-skip-all
  (syntax-rules ()
    ((_ body ...)
     (parameterize ((test-info
                     (list 'replace
                           (test-set 'before-test
                                     (lambda (_) #f)))))
       body ...))))

(define-syntax test-group
  (syntax-rules ()
    ((_ name body ...)
     (call-as-group name (lambda () body ...)))))

(define-syntax with-test-group-cleanup
  (syntax-rules ()
    ((_ name body ... cleanup-expr)
     (test-group name
       (dynamic-wind
        (lambda () #f)
        (lambda () body ...)
        (lambda () cleanup-expr))))))

(define (test-exit)
  (exit (if (zero? (test-ref/default 'failed 0))
            0
            1)))