#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))]))))