229 lines
10 KiB
Racket
229 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(require "../main.rkt")
|
|
|
|
(require racket/match)
|
|
(require racket/set)
|
|
|
|
(require rackunit)
|
|
(require racket/runtime-path)
|
|
(require syntax/srcloc)
|
|
|
|
(struct embedded (value) #:transparent)
|
|
|
|
(define (embedded/no-annotations v)
|
|
(embedded (strip-annotations v)))
|
|
|
|
(define (d 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 embedded/no-annotations
|
|
#:on-short (lambda () 'short) void))
|
|
(when (and (not (eq? result 'short))
|
|
(not (and allow-invalid-prefix? (void? result))))
|
|
(error 'd "~a-byte prefix of ~v does not read as short; result: ~v" i bs result)))
|
|
(bytes->preserve bs
|
|
#:read-syntax? #t
|
|
#:decode-embedded embedded/no-annotations
|
|
#:on-short (lambda () 'short)
|
|
void))
|
|
|
|
(define (d-strip bs) (strip-annotations (d bs)))
|
|
|
|
(struct discard () #:prefab)
|
|
(struct capture (detail) #:prefab)
|
|
(struct observe (specification) #:prefab)
|
|
|
|
(struct speak (who what) #:prefab)
|
|
|
|
(struct date (year month day) #:prefab)
|
|
(struct thing (id) #:prefab)
|
|
(struct person thing (name date-of-birth) #:prefab)
|
|
(struct titled person (title) #:prefab)
|
|
|
|
(struct asymmetric (forward back))
|
|
|
|
(define samples-txt-expected
|
|
(hash 'record1 (capture (discard))
|
|
'record2 (observe (speak (discard) (capture (discard))))
|
|
'list4a '(1 2 3 4)
|
|
'list5 '(-2 -1 0 1)
|
|
'string3 "hello"
|
|
'list6 `("hello" there #"world" () ,(set) #t #f)
|
|
'bytes2 #"hello"
|
|
'bytes3 #"ABC"
|
|
'bytes4 #"ABC"
|
|
'bytes5 #"AJN"
|
|
'bytes7 #"corymb"
|
|
'bytes8 #"corymb"
|
|
'bytes9 #"Hi"
|
|
'bytes10 #"Hi"
|
|
'bytes11 #"Hi"
|
|
'value1 #"corymb"
|
|
'value2 #t
|
|
'value3 #t
|
|
'value4 #t
|
|
'value5 #t
|
|
'value6 (list 1 2 3)
|
|
'list0 '()
|
|
'dict0 (hash)
|
|
'string0 ""
|
|
'symbol0 '||
|
|
'set0 (set)
|
|
'set1 (set 1 2 3)
|
|
'set1a (set 1 2 3)
|
|
'string4 "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"
|
|
'bytes13 #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
|
|
'string5 "\U0001D11E"
|
|
'record1 (capture (discard))
|
|
'record2 (observe (speak (discard) (capture (discard))))
|
|
'record3 (titled 101 "Blackwell" (date 1821 2 3) "Dr")
|
|
'record4 (asymmetric (record 'discard '()) (discard))
|
|
'record5 (record 7 '(()))
|
|
'record6 (asymmetric (record 'discard '(surprise))
|
|
'#s(discard surprise))
|
|
'record7 (record "aString" '(3 4))
|
|
'record8 (record (discard) '(3 4))
|
|
'list7 (list 'abc '|...| 'def)
|
|
'dict1 (hash 'a 1
|
|
"b" #t
|
|
'(1 2 3) #"c"
|
|
(hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
|
|
'rfc8259-example1 (hash "Image"
|
|
(hash "Width" 800
|
|
"Height" 600
|
|
"Title" "View from 15th Floor"
|
|
"Thumbnail" (hash "Url" "http://www.example.com/image/481989943"
|
|
"Height" 125
|
|
"Width" 100)
|
|
"Animated" 'false
|
|
"IDs" (list 116 943 234 38793)))
|
|
'rfc8259-example2 (list (hash
|
|
"precision" "zip"
|
|
"Latitude" 37.7668
|
|
"Longitude" -122.3959
|
|
"Address" ""
|
|
"City" "SAN FRANCISCO"
|
|
"State" "CA"
|
|
"Zip" "94107"
|
|
"Country" "US")
|
|
(hash
|
|
"precision" "zip"
|
|
"Latitude" 37.371991
|
|
"Longitude" -122.026020
|
|
"Address" ""
|
|
"City" "SUNNYVALE"
|
|
"State" "CA"
|
|
"Zip" "94085"
|
|
"Country" "US"))
|
|
'annotation1 (asymmetric (annotate 9 "abc") 9)
|
|
'annotation2 (asymmetric (annotate (list '() (annotate '() "x")) "abc" "def") '(() ()))
|
|
'annotation3 (asymmetric (annotate 5 (annotate 2 1) (annotate 4 3)) 5)
|
|
'annotation4 (asymmetric (hash (annotate 'a 'ak) (annotate 1 'av)
|
|
(annotate 'b 'bk) (annotate 2 'bv))
|
|
(hash 'a 1 'b 2))
|
|
'annotation5 (asymmetric (annotate `#s(R ,(annotate 'f 'af)) 'ar) `#s(R f))
|
|
'annotation6 (asymmetric (record (annotate 'R 'ar) (list (annotate 'f 'af))) `#s(R f))
|
|
'annotation7 (asymmetric (annotate '() 'a 'b 'c) '())
|
|
))
|
|
|
|
(define (run-test-case variety t-name loc binary-form annotated-text-form)
|
|
(define text-form (strip-annotations annotated-text-form))
|
|
(define-values (forward back can-execute-nondet-with-canonicalization?)
|
|
(match (hash-ref samples-txt-expected t-name text-form)
|
|
[(asymmetric f b) (values f b #f)] ;; #f because e.g. annotation4 includes annotations
|
|
[v (values v v #t)]))
|
|
(check-equal? text-form back loc) ;; expectation 1
|
|
(check-equal? (d-strip (preserve->bytes #:encode-embedded embedded-value text-form))
|
|
back
|
|
loc) ;; expectation 2
|
|
(check-equal? (d-strip (preserve->bytes #:encode-embedded embedded-value forward))
|
|
back
|
|
loc) ;; expectation 3
|
|
(check-equal? (d-strip binary-form) back loc) ;; expectation 4
|
|
(check-equal? (d binary-form) annotated-text-form loc) ;; expectation 5
|
|
(check-equal? (d (preserve->bytes #:encode-embedded embedded-value annotated-text-form))
|
|
annotated-text-form
|
|
loc) ;; expectation 6
|
|
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
|
|
(preserve->string #:encode-embedded embedded-value text-form))
|
|
back
|
|
loc) ;; expectation 7
|
|
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
|
|
(preserve->string #:encode-embedded embedded-value forward))
|
|
back
|
|
loc) ;; expectation 8
|
|
;; similar to 8:
|
|
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
|
|
(preserve->string #:encode-embedded embedded-value
|
|
annotated-text-form)
|
|
#:read-syntax? #t)
|
|
annotated-text-form
|
|
loc)
|
|
(when (and (not (memq variety '(decode)))
|
|
(or (not (memq variety '(nondeterministic)))
|
|
(and can-execute-nondet-with-canonicalization?)))
|
|
;; expectations 9 and 10
|
|
(check-equal? (preserve->bytes forward
|
|
#:encode-embedded embedded-value
|
|
#:canonicalizing? #t
|
|
#:write-annotations? #t)
|
|
binary-form
|
|
loc))
|
|
(unless (memq variety '(decode nondeterministic))
|
|
;; expectation 11
|
|
(check-equal? (preserve->bytes annotated-text-form
|
|
#:encode-embedded embedded-value
|
|
#:write-annotations? #t)
|
|
binary-form
|
|
loc)))
|
|
|
|
(define-runtime-path tests-path "../../../../../tests")
|
|
(let* ((path (build-path tests-path "samples.pr"))
|
|
(testfile (call-with-input-file path
|
|
(lambda (p)
|
|
(port-count-lines! p)
|
|
(read-preserve p
|
|
#:read-syntax? #t
|
|
#:decode-embedded embedded/no-annotations
|
|
#:source 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))))
|
|
(displayln loc)
|
|
(match (peel-annotations t*)
|
|
[`#s(Test ,(strip-annotations binary-form) ,annotated-text-form)
|
|
(run-test-case 'normal t-name loc binary-form annotated-text-form)]
|
|
[`#s(NondeterministicTest ,(strip-annotations binary-form) ,annotated-text-form)
|
|
(run-test-case 'nondeterministic t-name loc binary-form annotated-text-form)]
|
|
[`#s(DecodeTest ,(strip-annotations binary-form) ,annotated-text-form)
|
|
(run-test-case 'decode t-name loc binary-form annotated-text-form)]
|
|
[`#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? (d bs) 'short loc)]
|
|
[`#s(DecodeError ,(strip-annotations bs))
|
|
(check-true (void? (d bs #:allow-invalid-prefix? #t)) loc)]
|
|
[_
|
|
(write-preserve/text t* #:indent #f)
|
|
(newline)]))
|
|
)
|