2018-04-27 22:53:31 +00:00
|
|
|
#lang racket/base
|
|
|
|
;; Test drivers for Syndicate implementation.
|
|
|
|
|
|
|
|
(provide collected-events
|
|
|
|
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
|
2018-04-29 15:07:49 +00:00
|
|
|
expected-output-set
|
2018-04-27 22:53:31 +00:00
|
|
|
|
|
|
|
run-syndicate-test!
|
2018-04-29 10:55:32 +00:00
|
|
|
log-test-result!
|
|
|
|
|
|
|
|
(all-from-out racket/base)
|
2018-04-29 13:54:14 +00:00
|
|
|
(all-from-out "main.rkt"))
|
2018-04-29 10:55:32 +00:00
|
|
|
|
|
|
|
(module reader syntax/module-reader imperative-syndicate/test-implementation)
|
2018-04-27 22:53:31 +00:00
|
|
|
|
|
|
|
(require racket/exn)
|
|
|
|
(require racket/match)
|
2018-04-29 15:07:49 +00:00
|
|
|
(require racket/set)
|
2018-04-27 22:53:31 +00:00
|
|
|
(require (only-in racket/string string-split string-join string-contains?))
|
|
|
|
|
|
|
|
(require "bag.rkt")
|
2018-04-29 13:54:14 +00:00
|
|
|
(require "main.rkt")
|
2018-04-27 22:53:31 +00:00
|
|
|
|
|
|
|
(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)))))
|
|
|
|
(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 ()
|
|
|
|
[(_ line ...)
|
|
|
|
(quasisyntax/loc stx
|
|
|
|
(it "should produce correct output"
|
|
|
|
(equal? (collected-lines)
|
|
|
|
(list line ...))))]))
|
|
|
|
|
2018-04-29 15:07:49 +00:00
|
|
|
(define-syntax (expected-output-set stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ line ...)
|
|
|
|
(quasisyntax/loc stx
|
|
|
|
(it "should produce correct set of output lines"
|
|
|
|
(equal? (list->set (collected-lines))
|
|
|
|
(set line ...))))]))
|
|
|
|
|
2018-04-27 22:53:31 +00:00
|
|
|
(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
|
2018-05-02 17:20:33 +00:00
|
|
|
[(? procedure?) (format "~a" maybe-check)]
|
2018-04-27 22:53:31 +00:00
|
|
|
[(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))]))))
|