#lang racket ;; ============================================================================= ;; Lazy (Fall 2020): test-support.rkt ;; ============================================================================= ;; DO NOT EDIT THIS FILE ======================================================= (require rackunit rackunit/text-ui racket/sandbox) (require/expose rackunit/private/check (refail-check raise-error-if-not-thunk make-check-actual make-check-expected)) (provide define-test-suite define/provide-test-suite run-tests ; rename-out is needed here since we're overriding some definitions ; already defined by rackunit and racket/sandbox. (rename-out [*quasiquote quasiquote] [*test-equal? test-equal?] [*test-not-equal? test-not-equal?] [*test-true test-true] [*test-false test-false] [*test-pred test-pred] [*test-exn test-exn]) test-raises-error-with-substring? test-raises-lazy-interp-error? test-raises-err-if-got-non-boolean? test-raises-err-bad-arg-to-un-op? test-raises-err-bad-arg-to-op? test-raises-err-unbound-id? test-raises-err-not-a-function?) ;; GENERAL TESTING UTILITIES =================================================== ; Author: zespirit ; Defines the global per-test-case time limit. (define time-limit 2) ; run-check-with-time-limit :: (-> Any) ; Helper macro for defining the `check-with-timeout-*` forms below. It runs the ; given `thunk-to-run` within a `call-with-limits` sandbox, which implements the ; timeout functionality. (define-syntax-rule (run-check-with-time-limit thunk-to-run) ((let/cc timeout-escape (with-handlers ([exn:fail? (lambda (exn) (timeout-escape (lambda () (with-default-check-info* (list (make-check-message (string-append "Timed out; took longer than " (number->string time-limit) " seconds")) (make-check-info 'exn-message (exn-message exn)) (make-check-info 'exn exn)) (lambda () (fail-check))))))]) (call-with-limits time-limit #f thunk-to-run))))) ; check-with-timeout-equal? :: (-> Any) Any ; Defines a Rackunit check similar to the Rackunit-native `check-equal?`, but ; with a timeout. The timeout is defined globally by `time-limit`. Unlike ; `check-equal?`, this check takes the "actual" value as a thunk—this allows the ; "actual" expression to be run in a `call-with-limits` sandbox that ; implements the timeout functionality. (define-check (check-with-timeout-equal? actual-thunk expected) (run-check-with-time-limit (lambda () (letrec ([actual (actual-thunk)] [custom-check-infos (list (make-check-actual actual) (make-check-expected expected))]) (if (equal? actual expected) (lambda () (with-default-check-info* custom-check-infos (lambda () #t))) (lambda () (with-default-check-info* custom-check-infos (lambda () (fail-check))))))))) ; check-with-timeout-pred :: (Any -> Boolean) (-> Any) ; Defines a Rackunit check similar to the Rackunit-native `check-pred`, but with ; a timeout. The timeout is defined globally by `time-limit`. Unlike ; `check-pred`, this check takes the "actual" value as a thunk—this allows the ; "actual" expression to be run in a `call-with-limits` sandbox that ; implements the timeout functionality. (define-check (check-with-timeout-pred pred actual-thunk) (run-check-with-time-limit (lambda () (let ([actual (actual-thunk)]) (if (pred actual) (lambda () (with-default-check-info* (list (make-check-message "Predicate was satisfied by actual value") (make-check-actual actual)) (lambda () #t))) (lambda () (with-default-check-info* (list (make-check-message "Predicate was not satisfied by actual value") (make-check-actual actual)) (lambda () (fail-check))))))))) ; check-with-timeout-exn :: (Any -> Boolean) (-> Any) ; Defines a Rackunit check similar to the Rackunit-native `check-exn`, but with ; a timeout. The timeout is defined globally by `time-limit`. (define-check (check-with-timeout-exn raw-pred thunk-body) (let ([pred (cond [(regexp? raw-pred) (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))] [(and (procedure? raw-pred) (procedure-arity-includes? raw-pred 1)) raw-pred] [else (raise-argument-error 'check-exn "(or/c (-> any/c any/c) regexp?)" raw-pred)])]) ; Do a quick check to see that thunk-body is actually a thunk (raise-error-if-not-thunk 'check-exn thunk-body) (run-check-with-time-limit (lambda () (let/ec inner-succeed (with-handlers (;; catch the exception we are looking for and ;; succeed [pred (lambda (exn) (inner-succeed (lambda () #t)))] ;; rethrow check failures if we aren't looking ;; for them [exn:test:check? (lambda (exn) (inner-succeed (lambda () (refail-check exn))))] ;; catch any other exception and raise an check ;; failure [exn:fail? (lambda (exn) (inner-succeed (lambda () (with-default-check-info* (list (make-check-message "Wrong exception raised") (make-check-info 'exn-message (exn-message exn)) (make-check-info 'exn exn)) (lambda () (fail-check))))))]) (thunk-body)) (inner-succeed (lambda () (with-default-check-info* (list (make-check-message "No exception raised")) (lambda () (fail-check)))))))))) ; *test-not-equal :: String Expression Expression ; Tests that `actual` and `expected` evaluate to the same value. (define-syntax-rule (*test-equal? name actual expected) (test-case name (check-with-timeout-equal? (thunk actual) expected))) ; *test-not-equal :: String Expression Expression ; Tests that `actual` and `expected` evaluate to disjoint values. (define-syntax-rule (*test-not-equal? name actual expected) (test-case name (check-with-timeout-pred (lambda (actual-value) (not (equal? actual-value expected))) (thunk actual)))) ; *test-false :: String Expression ; Tests that `expr` evaluates to #t. (define-syntax-rule (*test-true name expr) (test-case name (check-with-timeout-equal? (thunk expr) #t))) ; *test-false :: String Expression ; Tests that `expr` evaluates to #f. (define-syntax-rule (*test-false name expr) (test-case name (check-with-timeout-equal? (thunk expr) #f))) ; *test-pred :: String (Any -> Boolean) (-> Any) ; Tests that `expr` returns a value that satisfies the given `pred` predicate. (define-syntax-rule (*test-pred name pred expr) (test-case name (check-with-timeout-pred pred (thunk expr)))) ; *test-exn :: String (Any -> Boolean) (-> Any) ; Tests that `exn-thunk` raises an exception that satisfies the given `pred` ; predicate. (define-syntax-rule (*test-exn name pred exn-thunk) (test-case name (check-with-timeout-exn pred exn-thunk))) ; test-raises-error-with-substring? :: String (Expression ....) String ; Tests if the given `thunk-body` raises an error that contains the substring ; `error-string`. (define-syntax-rule (test-raises-error-with-substring? test-case-name thunk-body error-string) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) error-string)) (thunk thunk-body))) ;; ASSIGNMENT-SPECIFIC TESTING UTILITIES ======================================= ; Import of support code. (require "lazy-interp-support.rkt" (only-in plait s-exp)) ; Overrides Racket quasiquote to simulate Plait S-Exp. (define-syntax-rule (*quasiquote x) (s-exp 'x)) ; test-raises-lazy-interp-error? :: String (Expression ....) LazyInterpError ; Tests if the given `thunk-body` raises the input LazyInterpError. (define-syntax-rule (test-raises-lazy-interp-error? test-case-name thunk-body lazy-interp-error) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) (lazy-interp-error->string lazy-interp-error))) (thunk thunk-body))) ; test-raises-err-if-got-non-boolean? :: String (Expression ....) ; Tests if the given `thunk-body` raises any instance of ; `err-if-got-non-boolean`. (define-syntax-rule (test-raises-err-if-got-non-boolean? test-case-name thunk-body) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) "if got non-boolean value")) (thunk thunk-body))) ; test-raises-err-bad-arg-to-un-op? :: String (Expression ....) ; Tests if the given `thunk-body` raises any instance of `err-bad-arg-to-un-op`. (define-syntax-rule (test-raises-err-bad-arg-to-un-op? test-case-name thunk-body) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) "got bad unary arg")) (thunk thunk-body))) ; test-raises-err-bad-arg-to-op? :: String (Expression ....) ; Tests if the given `thunk-body` raises any instance of `err-bad-arg-to-op`. (define-syntax-rule (test-raises-err-bad-arg-to-op? test-case-name thunk-body) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) "got bad arg")) (thunk thunk-body))) ; test-raises-err-unbound-id? :: String (Expression ....) ; Tests if the given `thunk-body` raises any instance of `err-unbound-id`. (define-syntax-rule (test-raises-err-unbound-id? test-case-name thunk-body) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) "is unbound")) (thunk thunk-body))) ; test-raises-err-not-a-function? :: String (Expression ....) ; Tests if the given `thunk-body` raises any instance of `err-not-a-function`. (define-syntax-rule (test-raises-err-not-a-function? test-case-name thunk-body) (*test-exn test-case-name (lambda (exn) (string-contains? (exn-message exn) "is not a function")) (thunk thunk-body)))