101 lines
4.7 KiB
Racket
101 lines
4.7 KiB
Racket
#lang racket/base
|
|
|
|
(require "../main.rkt")
|
|
|
|
(require racket/match)
|
|
(require racket/set)
|
|
|
|
(require rackunit)
|
|
(require racket/runtime-path)
|
|
(require syntax/srcloc)
|
|
|
|
(define (encodeBinary v)
|
|
(preserve->bytes v #:encode-embedded values #:canonicalizing? #t))
|
|
(define (looseEncodeBinary v)
|
|
(preserve->bytes v #:encode-embedded values #:canonicalizing? #f #:write-annotations? #t))
|
|
(define (annotatedBinary v)
|
|
(preserve->bytes v #:encode-embedded values #:canonicalizing? #t #:write-annotations? #t))
|
|
|
|
(define (decodeBinary bs #:allow-invalid-prefix? [allow-invalid-prefix? #f])
|
|
(for [(i (in-range 1 (- (bytes-length bs) 1)))]
|
|
(define result (bytes->preserve (subbytes bs 0 i)
|
|
#:decode-embedded strip-annotations
|
|
#:on-short (lambda () 'short) void))
|
|
(when (and (not (eq? result 'short))
|
|
(not (and allow-invalid-prefix? (void? result))))
|
|
(error 'decodeBinary "~a-byte prefix of ~v does not read as short; result: ~v" i bs result)))
|
|
(bytes->preserve bs
|
|
#:read-syntax? #t
|
|
#:decode-embedded strip-annotations
|
|
#:on-short (lambda () 'short)
|
|
void))
|
|
|
|
(define (decodeBinary/strip bs)
|
|
(strip-annotations (decodeBinary bs)))
|
|
|
|
(define (encodeText v)
|
|
(preserve->string v #:encode-embedded values))
|
|
(define (decodeText s)
|
|
(string->preserve s #:read-syntax? #t #:decode-embedded strip-annotations))
|
|
|
|
(define (run-test-case nondet? t-name loc binary annotatedValue)
|
|
(define stripped (strip-annotations annotatedValue))
|
|
(let ((roundtripped (decodeBinary (encodeBinary annotatedValue)))) ;; expectation 1
|
|
(check-false (has-any-annotations? roundtripped) loc)
|
|
(check-equal? (strip-annotations roundtripped) stripped loc))
|
|
(check-equal? (decodeBinary/strip binary) stripped loc) ;; expectation 2
|
|
(check-equal? (decodeBinary binary) annotatedValue loc) ;; expectation 3
|
|
(check-equal? (decodeBinary (annotatedBinary annotatedValue)) annotatedValue loc) ;; expectation 4
|
|
(let ((roundtripped (decodeText (encodeText stripped)))) ;; expectation 5
|
|
(check-false (has-any-annotations? roundtripped) loc)
|
|
(check-equal? (strip-annotations roundtripped) stripped loc))
|
|
(check-equal? (decodeText (encodeText annotatedValue)) annotatedValue loc) ;; expectation 6
|
|
(check-equal? (annotatedBinary annotatedValue) binary loc) ;; expectation 7
|
|
(unless nondet? (check-equal? (looseEncodeBinary annotatedValue) binary loc)) ;; expectation 8
|
|
)
|
|
|
|
(define-runtime-path samples-pr-path "./samples.pr")
|
|
(let* ((testfile (call-with-input-file samples-pr-path
|
|
(lambda (p)
|
|
(port-count-lines! p)
|
|
(read-preserve p
|
|
#:read-syntax? #t
|
|
#:decode-embedded strip-annotations
|
|
#:source samples-pr-path)))))
|
|
(match-define (peel-annotations `#s(TestCases ,tests)) testfile)
|
|
(for [((t-name* t*) (in-hash (annotated-item tests)))]
|
|
(define t-name (strip-annotations t-name*))
|
|
(define loc (format "Test case '~a' (~a)" t-name (source-location->string (annotated-srcloc t*))))
|
|
(define (fail-test fmt . args)
|
|
(fail (format "~a: ~a" loc (apply format fmt args))))
|
|
(log-debug "~a" loc)
|
|
(match (peel-annotations t*)
|
|
[`#s(Test ,(strip-annotations binary) ,annotatedValue)
|
|
(run-test-case #f t-name loc binary annotatedValue)]
|
|
[`#s(NondeterministicTest ,(strip-annotations binary) ,annotatedValue)
|
|
(run-test-case #t t-name loc binary annotatedValue)]
|
|
[`#s(ParseError ,(strip-annotations str))
|
|
(with-handlers [(exn:fail:read:eof?
|
|
(lambda (e) (fail-test "Unexpected EOF: ~e" e)))
|
|
(exn:fail:read?
|
|
(lambda (e) 'ok))
|
|
((lambda (e) #t)
|
|
(lambda (e) (fail-test "Unexpected exception: ~e" e)))]
|
|
(string->preserve str)
|
|
(fail-test "Unexpected success"))]
|
|
[(or `#s(ParseShort ,(strip-annotations str))
|
|
`#s(ParseEOF ,(strip-annotations str)))
|
|
(with-handlers [(exn:fail:read:eof? (lambda (e) 'ok))
|
|
((lambda (e) #t)
|
|
(lambda (e) (fail-test "Unexpected exception: ~e" e)))]
|
|
(string->preserve str)
|
|
(fail-test "Unexpected success"))]
|
|
[(or `#s(DecodeShort ,(strip-annotations bs))
|
|
`#s(DecodeEOF ,(strip-annotations bs)))
|
|
(check-eq? (decodeBinary bs) 'short loc)]
|
|
[`#s(DecodeError ,(strip-annotations bs))
|
|
(check-true (void? (decodeBinary bs #:allow-invalid-prefix? #t)) loc)]
|
|
[_
|
|
(fail-test "Unknown test case kind")]))
|
|
)
|