bootstrap-sut test suite

((ran 9) (failed 0))

(module
  unittest
  *
  (import
    scheme
    (chicken base)
    (chicken condition)
    (chicken pretty-print)
    (chicken port)
    (chicken string)
    srfi-1
    srfi-19
    sxml-transforms)
  (define highlight-version "11.11.1")
  (define (sxml-tree title body)
    `((html (@ (xmlns "http://www.w3.org/1999/xhtml")
               (xml:lang "en")
               (lang "en"))
            (head (meta (@ (name "viewport")
                           (content "width=device-width,initial-scale=1")))
                  (link (@ (rel "stylesheet")
                           (href "https://www.w3schools.com/w3css/5/w3.css")
                           (type "text/css")))
                  (link (@ (rel "stylesheet")
                           (href "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/"
                                 ,highlight-version
                                 "/styles/default.min.css")
                           (type "text/css")))
                  (style "code, pre, tt, kbd, samp, .w3-code { font-family: Monaco, 'Ubuntu Mono', monospace; }"
                         "html, body, h1, h2, h3, h4, h5, h6 { font-family: 'Lucida Sans', 'Ubuntu Sans', sans-serif; }")
                  (script
                    (@ (src "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/"
                            ,highlight-version
                            "/highlight.min.js")))
                  ,@(map (lambda (lang)
                           `(script
                              (@ (src "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/"
                                      ,highlight-version
                                      "/languages/"
                                      ,lang
                                      ".min.js"))))
                         '(scheme python))
                  (script "hljs.highlightAll();")
                  (title ,title))
            (body (@ (class "w3-content") (style "max-width:61.8%"))
                  ,@body
                  (hr)
                  (footer
                    (@ (class "w3-container w3-center"))
                    (small (a (@ (rel "license")
                                 (href "http://creativecommons.org/licenses/by-sa/4.0/"))
                              (img (@ (alt "Creative Commons License")
                                      (style "border-width:0")
                                      (src "https://mirrors.creativecommons.org/presskit/icons/cc.svg"))))
                           (a (@ (rel "license")
                                 (href "http://creativecommons.org/licenses/by-sa/4.0/"))
                              (img (@ (alt "Creative Commons License")
                                      (style "border-width:0")
                                      (src "https://mirrors.creativecommons.org/presskit/icons/by.svg"))))
                           (a (@ (rel "license")
                                 (href "http://creativecommons.org/licenses/by-sa/4.0/"))
                              (img (@ (alt "Creative Commons License")
                                      (style "border-width:0")
                                      (src "https://mirrors.creativecommons.org/presskit/icons/sa.svg"))))
                           (br)
                           (p "This work is licensed under a "
                              (a (@ (rel "license")
                                    (href "http://creativecommons.org/licenses/by-sa/4.0/"))
                                 "Creative Commons Attribution-ShareAlike 4.0 International License")
                              (br)
                              (small ,(date->string (current-date))))))))))
  (define sxml-handler-container
    (lambda (tag body) `(div (@ (class "w3-container")) ,@body)))
  (define sxml-handler-code/lang
    (lambda (tag body)
      (let ((lang (car body)) (code (cdr body)))
        `(div (@ (class "w3-card w3-round"))
              (header
                (@ (class "w3-container w3-border w3-round w3-light-gray w3-right"))
                ,lang
                " code")
              (div (@ (class "w3-container"))
                   (pre (code (@ (class "w3-code w3-round language-" ,lang))
                              ,code)))))))
  (define sxml-handler-code/scheme
    (lambda (tag body)
      (let* ((expr (if (eq? (length body) 1) (car body) (cons 'begin body))))
        (sxml-handler-code/lang
          'code/lang
          (list 'scheme
                (call-with-output-string
                  (lambda (p) (pretty-print expr p))))))))
  (define sxml-handler-code/scheme-file
    (lambda (tag body)
      (sxml-handler-code/scheme
        'code/scheme
        (list (with-input-from-file (car body) (lambda () (read)))))))
  (define sxml-handler-di
    (lambda (tag body)
      (let ((dt (car body)) (dd (cdr body)))
        `(div (@ (class "w3-row")) (dt (@ (class "w3-bold")) ,dt) (dd ,@dd)))))
  (define sxml-handler-cite/a
    (lambda (tag body) `(cite (a (@ (href ,(car body))) ,@(cdr body)))))
  (define conversion-rules*
    (append
      `((container unquote sxml-handler-container)
        (code/lang unquote sxml-handler-code/lang)
        (code/scheme unquote sxml-handler-code/scheme)
        (code/scheme-file unquote sxml-handler-code/scheme-file)
        (cite/a unquote sxml-handler-cite/a)
        (di unquote sxml-handler-di))
      alist-conv-rules*))
  (define (SXML->HTML->file! tree filename)
    (with-output-to-file
      (conc filename ".html")
      (lambda ()
        (display "<!doctype html>")
        (SXML->HTML (pre-post-order* tree conversion-rules*)))))
  (define-record unittest/testcase name log)
  (define (unittest/wasrun name) (make-unittest/testcase name '()))
  (define (unittest/testcase-logcons! testcase msg)
    (unittest/testcase-log-set!
      testcase
      (cons msg (unittest/testcase-log testcase))))
  (define (unittest/testcase-run testcase result sut)
    (let* ((methods (cdr sut))
           (setup (alist-ref 'setup methods))
           (teardown (alist-ref 'teardown methods))
           (testcase-name (unittest/testcase-name testcase)))
      (unittest/result-started! result)
      (let-values
        ((args (if setup ((car setup) testcase) (values)))
         ((f code) (apply values (alist-ref testcase-name methods))))
        (let* ((witness (gensym))
               (no-outsrt "")
               (pair (condition-case
                       (let* ((res (void))
                              (outstr
                                (with-output-to-string
                                  (lambda () (set! res (apply f testcase args))))))
                         (cons res outstr))
                       (c (exn unittest-assert-equal)
                          (begin
                            (unittest/result-failed!
                              result
                              (cons testcase-name
                                    (get-condition-property
                                      c
                                      'unittest-assert-equal
                                      'comparison)))
                            (cons witness no-outsrt)))
                       (c (exn)
                          (begin
                            (unittest/result-failed!
                              result
                              (list testcase-name
                                    (call-with-output-string
                                      (lambda (port) (print-error-message c port)))))
                            (cons witness no-outsrt)))
                       (c ()
                          (begin
                            (unittest/result-failed!
                              result
                              (list testcase-name c))
                            (cons witness no-outsrt)))))
               (v (car pair))
               (outstr (cdr pair)))
          (when teardown (apply (car teardown) testcase args))
          `((h2 (code ,testcase-name)
                ": "
                ,(if (eq? v witness)
                   '(span (@ (class "w3-text-red")) fail)
                   '(span (@ (class "w3-text-green")) pass)))
            ,@(if (pair? v) v '())
            (code/scheme ,code)
            ,@(if (not (equal? outstr no-outsrt))
                `((div (@ (class "w3-container"))
                       (p "Captured stdout:")
                       (pre (code (@ (class "w3-code w3-round")) ,outstr))))
                '()))))))
  (define-syntax
    define-suite
    (syntax-rules
      ()
      ((_ sutname ((casename formal ...) body ...) ...)
       (define sutname
         `(sutname
            (casename
              ,(lambda (formal ...) body ...)
              ,'(define (casename formal ...) body ...))
            ...)))))
  (define-syntax
    lettest
    (syntax-rules
      ()
      ((_ ((test nameexp) ...) body ...)
       (let ((test (unittest/wasrun nameexp)) ...) body ...))))
  (define-record unittest/result ran failed)
  (define (unittest/result-summary result)
    `((ran ,(unittest/result-ran result))
      (failed
        ,(length (unittest/result-failed result))
        ,@(unittest/result-failed result))))
  (define (unittest/result-started! result)
    (unittest/result-ran-set! result (add1 (unittest/result-ran result))))
  (define (unittest/result-failed! result exn)
    (unittest/result-failed-set!
      result
      (cons exn (unittest/result-failed result))))
  (define (⊦ pred? a b)
    (unless (pred? a b) (signal (unittest/condition-expected-actual a b))))
  (define (⊦= a b) (⊦ equal? a b))
  (define (⊦≠ a b) (⊦ (complement equal?) a b))
  (define (⊨ a) (⊦= #t a))
  (define (⊭ a) (⊦= #f a))
  (define-syntax
    letsuite
    (syntax-rules
      ()
      ((_ ((name '(method ...)) ...) body ...)
       (letrec ((name (lettest ((method 'method) ...) (list method ...))) ...)
         body
         ...))))
  (define (unittest/testsuite-run suite r sut)
    (map (lambda (testcase) (unittest/testcase-run testcase r sut)) suite))
  (define (unittest/✓ sut)
    (let* ((r (make-unittest/result 0 '()))
           (sut-name (car sut))
           (sut-methods (cdr sut))
           (F (lambda (x)
                (let ((name (car x)))
                  (and (not (eq? name 'setup))
                       (not (eq? name 'teardown))
                       (not (eq? name 'doc))))))
           (methods (filter F sut-methods))
           (s (map (lambda (pair) (lettest ((t (car pair))) t)) methods)))
      (let ((docs (unittest/testsuite-run s r sut))
            (res (unittest/result-summary r))
            (sxml (alist-ref 'doc sut-methods)))
        (SXML->HTML->file!
          (sxml-tree
            sut-name
            `((h1 (code ,sut-name) " test suite")
              (code/scheme ,res)
              ,@(if sxml ((car sxml) r) '())
              (hr)
              ,@docs))
          (symbol-append 'testsuite- sut-name))
        (pretty-print res)
        r)))
  (define (unittest/condition-expected-actual a b)
    (condition
      `(exn message "assert-equal failed")
      `(unittest-assert-equal comparison ((expected ,a) (got ,b)))))
  (define-syntax
    ⊦⧳
    (syntax-rules
      ()
      ((_ ((exn ...) ...) body ...)
       (condition-case (begin body ...) ((exn ...) (void)) ...)))))

(define (test-running tc t r)
  (⊦= '() (unittest/testcase-log t))
  (unittest/testcase-run t r wasrun-sut)
  (⊦= '(teardown test-method setup) (unittest/testcase-log t))
  `((p "hello")))

(define (test-result tc t r)
  (unittest/testcase-run t r wasrun-sut)
  (⊦= '((ran 1) (failed 0)) (unittest/result-summary r)))

(define (test-failed tc _ r)
  (lettest
    ((t 'test-broken))
    (unittest/testcase-run t r wasrun-sut)
    (⊦= '((ran 1) (failed 1 (test-broken (expected useless) (got _))))
          (unittest/result-summary r))))

(define (test-unbound-variable tc _ r)
  (lettest
    ((t 'test-unbound-variable))
    (unittest/testcase-run t r wasrun-sut)
    (⊦= '((ran 1)
            (failed
              1
              (test-unbound-variable
                "\nError: unbound variable: unbound-v\n")))
          (unittest/result-summary r))))

(define (test-failed-result tc _ r)
  (unittest/result-started! r)
  (unittest/result-failed! r 'no-reason)
  (⊦= '((ran 1) (failed 1 no-reason)) (unittest/result-summary r)))

(define (test-suite tc _ r)
  (letsuite
    ((suite '(test-running test-failed)))
    (unittest/testsuite-run suite r bootstrap-sut)
    (⊦= '((ran 2) (failed 0)) (unittest/result-summary r))))

(define (test-⊨ tc _ _) (⊨ #t))

(define (test-⊭ tc _ _) (⊭ #f))

(define (test-should-signal tc _ _)
  (⊦⧳ ((exn)) (signal (condition '(exn message "useless"))))
  (⊦⧳ ((exn-a)) (signal (condition '(exn-a message "useless"))))
  (⊦⧳ ((exn) (exn-a)) (signal (condition '(exn-a message "useless"))))
  (condition-case
    (⊦⧳ ((exn)) (signal (condition '(exn-a message "useless"))))
    ((exn-a) (void)))
  (condition-case (⊦⧳ ((exn)) (signal 99)) (() (void)))
  (⊦⧳ () 99))