syndicate-rkt/syndicate/test-implementation.rkt

#lang racket
;; Test drivers for Syndicate implementation.

(provide collected-events
         collected-exns
         collected-output
         collected-lines
         final-dataspace
         final-assertions
         test-run-time
         test-gc-time

         asserted?
         emitted?
         actor-died?
         emit!
         test-case
         it

         no-crashes
         expected-output
         expected-output?

         run-syndicate-test!
         log-test-result!

         (except-out (all-from-out racket) sleep)
         (all-from-out "main.rkt"))

(module reader syntax/module-reader syndicate/test-implementation)

(require racket/exn)

(require "bag.rkt")
(require "main.rkt")
(require (only-in "lang.rkt" current-activated-modules))

(require (for-syntax racket/base))
(require (for-syntax syntax/srcloc))

(define-logger syndicate/test)

(define event-accumulator (make-parameter #f))
(define exn-accumulator (make-parameter #f))
(define failure-detected? (make-parameter #f))

(define collected-events (make-parameter '()))
(define collected-exns (make-parameter '()))
(define collected-output (make-parameter ""))
(define collected-lines (make-parameter '()))
(define final-dataspace (make-parameter #f))
(define test-run-time (make-parameter 0))
(define test-gc-time (make-parameter 0))

(define (asserted? v)
  (bag-member? (dataspace-assertions (final-dataspace)) v))

(define (final-assertions)
  (bag->set (dataspace-assertions (final-dataspace))))

(define (emitted? v)
  (member v (collected-events)))

(define (actor-died? name [substr-or-regex ""])
  (define entry (findf (lambda (e) (equal? name (actor-name (car e)))) (collected-exns)))
  (and entry
       (let ((message (exn-message (cadr entry))))
         (match substr-or-regex
           [(? string? substr) (string-contains? message substr)]
           [(? regexp? re) (regexp-match? re message)]))))

(define (emit! event)
  (define b (event-accumulator))
  (set-box! b (cons event (unbox b))))

(define-syntax (test-case stx)
  (syntax-case stx ()
    [(_ [body ...] checks ...)
     (quasisyntax/loc stx
       (run-syndicate-test!
        #,(source-location->string stx)
        (lambda () body ...)
        (list checks ...)))]))

(define (not-break? e)
  (not (exn:break? e)))

(struct check (location description thunk) #:prefab)

(define (run-syndicate-test! location-str body-thunk list-of-checks)
  (parameterize ((failure-detected? #f))
    (define events-box (box '()))
    (define exns-box (box '()))
    (define (get-items b) (reverse (unbox b)))
    (define op (open-output-string))
    (with-handlers ([not-break? (lambda (e) (log-test-result! location-str #f e))])
      (log-syndicate/test-info "~a--- Running test at ~a~a"
                               (color YELLOW)
                               location-str
                               (color NORMAL))
      (define ds (make-dataspace
                  (lambda ()
                    (schedule-script! (current-actor) body-thunk))))
      (define-values (_results cpu-ms _wall-ms gc-ms)
        (parameterize ((current-output-port op)
                       (current-actor-crash-logger
                        (lambda (a e)
                          (set-box! exns-box (cons (list a e) (unbox exns-box)))))
                       (current-activated-modules (make-hasheq))
                       (event-accumulator events-box))
          (time-apply (lambda () (let loop () (when (run-scripts! ds) (loop))))
                      '())))
      (define op-string (get-output-string op))
      (parameterize ((collected-events (get-items events-box))
                     (collected-exns (get-items exns-box))
                     (collected-output op-string)
                     (collected-lines (string-split op-string "\n"))
                     (final-dataspace ds)
                     (test-run-time cpu-ms)
                     (test-gc-time gc-ms))
        (for [(check (in-list list-of-checks))]
          (with-handlers ([not-break? (lambda (e) (log-test-result! location-str check e))])
            (match check
              [(? procedure?)
               (log-test-result! location-str check (check))]
              [(? check?)
               (log-test-result! location-str check ((check-thunk check)))])))))
    (when (failure-detected?)
      (log-syndicate/test-debug "Collected events:")
      (for [(e (get-items events-box))]
        (log-syndicate/test-debug "  ~v" e))
      (log-syndicate/test-debug "Collected output:")
      (for [(l (string-split (get-output-string op) "\n"))]
        (log-syndicate/test-debug "  ~a" l))
      (log-syndicate/test-debug "Crashed actors:")
      (for [(entry (get-items exns-box))]
        (match-define (list a e) entry)
        (log-syndicate/test-debug "  ~a\n    ~a"
                                  a
                                  (string-join (string-split (exn->string e) "\n")
                                               "    \n"))))))

(define-syntax (it stx)
  (syntax-case stx ()
    [(_ description body ...)
     (quasisyntax/loc stx
       (check #,(source-location->string stx)
              description
              (lambda ()
                (and body ...))))]))

(define no-crashes (it "shouldn't involve any crashing actors"
                       (null? (collected-exns))))

(define-syntax (expected-output stx)
  (syntax-case stx ()
    [(_ list-or-set-of-strings-expr ...)
     (quasisyntax/loc stx
       (it "should produce correct output"
           (expected-output? (collected-lines)
                             (list list-or-set-of-strings-expr ...))))]))

(define (take-at-most xs n)
  (cond [(zero? n) '()]
        [(null? xs) '()]
        [else (cons (car xs) (take-at-most (cdr xs) (- n 1)))]))

(define (expected-output? lines checks)
  (match checks
    ['()
     (null? lines)]
    [(cons (? list? expected-lines) rest)
     (define actual-lines (take-at-most lines (length expected-lines)))
     (and (equal? actual-lines expected-lines)
          (expected-output? (drop lines (length expected-lines)) rest))]
    [(cons (? set? expected-lines) rest)
     (define actual-lines (list->set (take-at-most lines (set-count expected-lines))))
     (and (equal? actual-lines expected-lines)
          (expected-output? (drop lines (set-count expected-lines)) rest))]))

(define RED ";31")
(define BRIGHT-RED ";1;31")
(define GREEN ";32")
(define BRIGHT-GREEN ";1;32")
(define YELLOW ";33")
(define NORMAL "")

(define (color c) (format "\e[0~am" c))

(define (log-test-result! test-loc maybe-check result)
  (if (not maybe-check)
      (begin
        (failure-detected? #t)
        (log-syndicate/test-error "~a  ✗ Exception running program under test:\n~a~a"
                                  (color BRIGHT-RED)
                                  (exn->string result)
                                  (color NORMAL)))
      (let ((description
             (match maybe-check
               [(? procedure?) (format "~a" maybe-check)]
               [(check #f description _thunk) (format "~a" description)]
               [(check check-loc description _thunk) (format "~a (~a)" description check-loc)])))
        (match result
          [(? exn?)
           (failure-detected? #t)
           (log-syndicate/test-error "~a  ✗ ... ~a:\n~a~a"
                                     (color RED)
                                     description
                                     (exn->string result)
                                     (color NORMAL))]
          [#f
           (failure-detected? #t)
           (log-syndicate/test-error "~a  ✗ ... ~a~a"
                                     (color RED)
                                     description
                                     (color NORMAL))]
          [_
           (log-syndicate/test-info "~a  ✓ ... ~a~a"
                                    (color GREEN)
                                    description
                                    (color NORMAL))]))))