forked from syndicate-lang/preserves
First real running tests with the new design, and several concomitant fixes and new tests
This commit is contained in:
parent
27ac21bed1
commit
e90a790963
|
|
@ -4,8 +4,11 @@
|
|||
(provide (struct-out stream-of)
|
||||
(struct-out record)
|
||||
(struct-out annotated)
|
||||
annotate
|
||||
strip-annotations
|
||||
strip-annotations-proc
|
||||
peel-annotations
|
||||
peel-annotations-proc
|
||||
read-preserve
|
||||
read-preserve-syntax
|
||||
string->preserve
|
||||
|
|
@ -52,7 +55,14 @@
|
|||
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
|
||||
(apply make-prefab-struct label fields)))
|
||||
|
||||
(define (strip-annotations v #:depth [depth +inf.0])
|
||||
(define (annotate v . as)
|
||||
(match v
|
||||
[(annotated annotations srcloc item)
|
||||
(annotated (append as annotations) srcloc item)]
|
||||
[item
|
||||
(annotated as #f item)]))
|
||||
|
||||
(define (strip-annotations-proc v #:depth [depth +inf.0])
|
||||
(let walk* ((v v) (depth depth))
|
||||
(define next-depth (- depth 1))
|
||||
(define (walk v) (walk* v next-depth))
|
||||
|
|
@ -72,8 +82,16 @@
|
|||
[_ item])]
|
||||
[_ v]))))
|
||||
|
||||
(define (peel-annotations v)
|
||||
(strip-annotations v #:depth 1))
|
||||
(define (peel-annotations-proc v)
|
||||
(strip-annotations-proc v #:depth 1))
|
||||
|
||||
(define-match-expander strip-annotations
|
||||
(syntax-rules () [(_ pat extra ...) (app (lambda (v) (strip-annotations-proc v extra ...)) pat)])
|
||||
(syntax-rules () [(_ args ...) (strip-annotations-proc args ...)]))
|
||||
|
||||
(define-match-expander peel-annotations
|
||||
(syntax-rules () [(_ pat extra ...) (app (lambda (v) (peel-annotations-proc v extra ...)) pat)])
|
||||
(syntax-rules () [(_ args ...) (peel-annotations-proc args ...)]))
|
||||
|
||||
(define current-value->placeholder (make-parameter (lambda (v) #f)))
|
||||
(define current-placeholder->value (make-parameter (lambda (v) (void))))
|
||||
|
|
@ -96,7 +114,7 @@
|
|||
(define (decode-syntax bs
|
||||
#:on-short [on-short (default-on-short bs)]
|
||||
[on-fail (default-on-fail bs)])
|
||||
(decode #:read-syntax? #t #:on-short on-short #:on-fail on-fail))
|
||||
(decode bs on-fail #:read-syntax? #t #:on-short on-short))
|
||||
|
||||
(define-syntax wire-value
|
||||
(syntax-rules ()
|
||||
|
|
@ -777,7 +795,7 @@
|
|||
(module+ test
|
||||
(require rackunit)
|
||||
(require racket/runtime-path)
|
||||
(require (for-syntax racket syntax/srcloc))
|
||||
(require syntax/srcloc)
|
||||
|
||||
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (0 :: (wire-length)))) (bytes 0))
|
||||
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3))
|
||||
|
|
@ -811,34 +829,37 @@
|
|||
void)
|
||||
'short))
|
||||
(error 'd "~a-byte prefix of ~v does not read as short" i bs)))
|
||||
(decode bs
|
||||
#:on-short (lambda () 'short)
|
||||
void))
|
||||
(decode-syntax bs
|
||||
#:on-short (lambda () 'short)
|
||||
void))
|
||||
|
||||
(define-syntax (cross-check stx)
|
||||
(syntax-case stx ()
|
||||
((_ text v (b ...))
|
||||
#'(let ((val v)) (cross-check text v v (b ...))))
|
||||
((_ text forward back (b ...))
|
||||
#`(let ((loc #,(source-location->string #'forward)))
|
||||
(check-equal? (string->preserve text) back loc)
|
||||
(check-equal? (d (encode forward)) back loc)
|
||||
(check-equal? (d (encode back)) back loc)
|
||||
(check-equal? (d (expected b ...)) back loc)
|
||||
(check-equal? (encode forward) (expected b ...) loc)
|
||||
))))
|
||||
(define (d-strip bs)
|
||||
(strip-annotations (d bs)))
|
||||
|
||||
(define-syntax (cross-check/nondeterministic stx)
|
||||
(syntax-case stx ()
|
||||
((_ text v (b ...))
|
||||
#'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
|
||||
((_ text forward back (b ...))
|
||||
#`(let ((loc #,(source-location->string #'forward)))
|
||||
(check-equal? (string->preserve text) back loc)
|
||||
(check-equal? (d (encode forward)) back loc)
|
||||
(check-equal? (d (encode back)) back loc)
|
||||
(check-equal? (d (expected b ...)) back loc)
|
||||
))))
|
||||
;; (define-syntax (cross-check stx)
|
||||
;; (syntax-case stx ()
|
||||
;; ((_ text v (b ...))
|
||||
;; #'(let ((val v)) (cross-check text v v (b ...))))
|
||||
;; ((_ text forward back (b ...))
|
||||
;; #`(let ((loc #,(source-location->string #'forward)))
|
||||
;; (check-equal? (string->preserve text) back loc)
|
||||
;; (check-equal? (d (encode forward)) back loc)
|
||||
;; (check-equal? (d (encode back)) back loc)
|
||||
;; (check-equal? (d (expected b ...)) back loc)
|
||||
;; (check-equal? (encode forward) (expected b ...) loc)
|
||||
;; ))))
|
||||
|
||||
;; (define-syntax (cross-check/nondeterministic stx)
|
||||
;; (syntax-case stx ()
|
||||
;; ((_ text v (b ...))
|
||||
;; #'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
|
||||
;; ((_ text forward back (b ...))
|
||||
;; #`(let ((loc #,(source-location->string #'forward)))
|
||||
;; (check-equal? (string->preserve text) back loc)
|
||||
;; (check-equal? (d (encode forward)) back loc)
|
||||
;; (check-equal? (d (encode back)) back loc)
|
||||
;; (check-equal? (d (expected b ...)) back loc)
|
||||
;; ))))
|
||||
|
||||
(struct discard () #:prefab)
|
||||
(struct capture (detail) #:prefab)
|
||||
|
|
@ -852,7 +873,6 @@
|
|||
(struct titled person (title) #:prefab)
|
||||
|
||||
(struct asymmetric (forward back))
|
||||
(struct nondeterministic (value))
|
||||
|
||||
(define samples-txt-expected
|
||||
(hash 'record1 (capture (discard))
|
||||
|
|
@ -898,7 +918,11 @@
|
|||
'string4 "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"
|
||||
'bytes13 #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
|
||||
'string5 "\U0001D11E"
|
||||
'list2 '("abc" "def")
|
||||
'list2 (asymmetric (stream-of 'sequence
|
||||
(sequence->generator
|
||||
(list (stream-of 'string (sequence->generator '(#"abc")))
|
||||
(stream-of 'string (sequence->generator '(#"def"))))))
|
||||
'("abc" "def"))
|
||||
'record1 (capture (discard))
|
||||
'record2 (observe (speak (discard) (capture (discard))))
|
||||
'record3 (titled 101 "Blackwell" (date 1821 2 3) "Dr")
|
||||
|
|
@ -913,35 +937,41 @@
|
|||
"b" #t
|
||||
'(1 2 3) #"c"
|
||||
(hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
|
||||
'rfc8259-example1 (nondeterministic
|
||||
(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" #f
|
||||
"IDs" (list 116 943 234 38793))))
|
||||
'rfc8259-example2 (nondeterministic
|
||||
(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")))
|
||||
'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" #f
|
||||
"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))
|
||||
))
|
||||
|
||||
(define-runtime-path tests-path "../../../tests")
|
||||
|
|
@ -951,12 +981,38 @@
|
|||
(port-count-lines! p)
|
||||
(read-preserve-syntax p #:source path)))))
|
||||
(local-require racket/pretty)
|
||||
(for [((t-name t) (in-hash (annotated-item tests)))]
|
||||
(newline)
|
||||
(newline)
|
||||
(write-preserve t #:indent #f)
|
||||
(newline)
|
||||
(newline)
|
||||
(pretty-print (list (peel-annotations t-name)
|
||||
(peel-annotations t)))))
|
||||
(define placeholder->value-map
|
||||
(or (for/or [(a* (annotated-annotations tests))]
|
||||
(match (strip-annotations a*)
|
||||
[`#s(ExpectedPlaceholderMapping ,p->v) p->v]
|
||||
[_ #f]))
|
||||
(hash)))
|
||||
(define value->placeholder-map
|
||||
(for/hash [((k v) (in-hash placeholder->value-map))]
|
||||
(values v k)))
|
||||
(parameterize
|
||||
((current-value->placeholder (lambda (v) (hash-ref value->placeholder-map v #f)))
|
||||
(current-placeholder->value (lambda (p) (hash-ref placeholder->value-map p void))))
|
||||
(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*))))
|
||||
(displayln loc)
|
||||
(match t*
|
||||
[(peel-annotations `#s(Test ,(strip-annotations binary-form) ,annotated-text-form))
|
||||
(define text-form (strip-annotations annotated-text-form))
|
||||
(define-values (forward back)
|
||||
(match (hash-ref samples-txt-expected t-name text-form)
|
||||
[(asymmetric f b) (values f b)]
|
||||
[v (values v v)]))
|
||||
(check-equal? text-form back loc)
|
||||
(check-equal? (d-strip (encode text-form)) back loc)
|
||||
(check-equal? (d-strip (encode forward)) back loc)
|
||||
(check-equal? (d-strip binary-form) back loc)
|
||||
(check-equal? (d binary-form) annotated-text-form loc)
|
||||
(check-equal? (encode forward) binary-form loc)
|
||||
(check-equal? (encode annotated-text-form) binary-form loc)]
|
||||
[_
|
||||
(write-preserve t* #:indent #f)
|
||||
(newline)])))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,15 +1,18 @@
|
|||
@<EmacsMode "-*- preserves -*-">
|
||||
@"Expects placeholder mapping of:"
|
||||
@"{ 0: discard, 1: capture, 2: observe }"
|
||||
@<ExpectedPlaceholderMapping {
|
||||
0: discard
|
||||
1: capture
|
||||
2: observe
|
||||
}>
|
||||
{
|
||||
annotation1: <Test #hex{055361626339} @"abc" 9>
|
||||
annotation2: <Test #hex{05536162630553646566929005517890} @"abc" @"def" [[] @"x" []]>
|
||||
annotation3: <Test #hex{050531320505333435} @@1 2 @@3 4 5>
|
||||
annotation4: <Test #hex{b4 05 72616b 7161 05 726176 31 05 72626b 7162 05 726276 32}
|
||||
{@ak a: @av 1 @bk b: @bv 2}>
|
||||
annotation4: <NondeterministicTest #hex{b4 05 72616b 7161 05 726176 31 05 72626b 7162 05 726276 32}
|
||||
{@ak a: @av 1 @bk b: @bv 2}>
|
||||
annotation5: <Test #hex{05726172827152057261667166} @ar <R @af f>>
|
||||
annotation6: <Test #hex{82057261727152057261667166} <@ar R @af f>>
|
||||
bytes1: <Test #hex{26626865626c6c616f04} #"hello">
|
||||
bytes1: <StreamingTest #hex{26626865626c6c616f04} #"hello">
|
||||
bytes2: <Test #hex{6568656c6c6f} #"hello">
|
||||
bytes3: <Test #hex{63414243} #"ABC">
|
||||
bytes4: <Test #hex{63414243} #hex{414243}>
|
||||
|
|
@ -24,7 +27,7 @@
|
|||
bytes13: <Test #hex{6f 11 61 62 63 6c 34 f0 5c 2f 22 08 0c 0a 0d 09 78 79 7a} #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz">
|
||||
|
||||
dict0: <Test #hex{b0} {}>
|
||||
dict1: <Test #hex{b8 7161 31 5162 01 93313233 6163 b2 7a66697273742d6e616d65 59456c697a6162657468 b2 777375726e616d65 59426c61636b77656c6c} { a: 1 "b": #true [1 2 3]: c { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
|
||||
dict1: <NondeterministicTest #hex{b8 7161 31 5162 01 93313233 6163 b2 7a66697273742d6e616d65 59456c697a6162657468 b2 777375726e616d65 59426c61636b77656c6c} { a: 1 "b": #true [1 2 3]: #"c" { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
|
||||
dict2: @"Missing close brace" <ParseShort "{ a: b, c: d ">
|
||||
dict2a: @"Missing close brace" <ParseShort "{">
|
||||
dict3: @"Duplicate key" <ParseError "{ a: 1, a: 2 }">
|
||||
|
|
@ -56,13 +59,13 @@
|
|||
int65536: <Test #hex{43010000} 65536>
|
||||
int131072: <Test #hex{43020000} 131072>
|
||||
list0: <Test #hex{90} []>
|
||||
list1: <Test #hex{293132333404} [1 2 3 4]>
|
||||
list2: <Test #hex{2925636162630425636465660404} ["abc" "def"]>
|
||||
list3: <Test #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]>
|
||||
list1: <StreamingTest #hex{293132333404} [1 2 3 4]>
|
||||
list2: <StreamingTest #hex{2925636162630425636465660404} ["abc" "def"]>
|
||||
list3: <StreamingTest #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]>
|
||||
list4: <Test #hex{9431323334} [1 2 3 4]>
|
||||
list4a: <Test #hex{9431323334} [1, 2, 3, 4]>
|
||||
list5: <Test #hex{943e3f3031} [-2 -1 0 1]>
|
||||
list6: <Test #hex{97 5568656c6c6f 757468657265 65776f726c64 90 a0 01 00} ["hello" #"there" world [] #set{} #true #false]>
|
||||
list6: <Test #hex{97 5568656c6c6f 757468657265 65776f726c64 90 a0 01 00} ["hello" there #"world" [] #set{} #true #false]>
|
||||
list7: <Test #hex{93 73616263 732e2e2e 73646566} [abc ... def]>
|
||||
list8: @"Missing close bracket" <ParseShort "[">
|
||||
placeholder0: <Test #hex{10} discard>
|
||||
|
|
@ -79,8 +82,8 @@
|
|||
record9: @"Missing record label" <ParseError "<>">
|
||||
record10: @"Missing close-angle-bracket" <ParseShort "<">
|
||||
set0: <Test #hex{a0} #set{}>
|
||||
set1: <Test #hex{a3313233} {1 2 3}>
|
||||
set1a: <Test #hex{a3313233} #set{1 2 3}>
|
||||
set1: <NondeterministicTest #hex{a3313233} {1 2 3}>
|
||||
set1a: <NondeterministicTest #hex{a3313233} #set{1 2 3}>
|
||||
set2: @"Missing close brace" <ParseShort "#set{ 1 2 3 ">
|
||||
set2a: @"Missing close brace" <ParseShort "#set{">
|
||||
stream1: @"Chunk must be bytes" <DecodeError #hex{25516104}>
|
||||
|
|
@ -92,14 +95,14 @@
|
|||
stream7: @"Missing end byte" <DecodeShort #hex{290000}>
|
||||
stream8: @"Missing element" <DecodeShort #hex{930000}>
|
||||
string0: <Test #hex{50} "">
|
||||
string0a: <Test #hex{2504} "">
|
||||
string1: <Test #hex{25626865626c6c616f04} "hello">
|
||||
string2: <Test #hex{25626865636c6c6f04} "hello">
|
||||
string0a: <StreamingTest #hex{2504} "">
|
||||
string1: <StreamingTest #hex{25626865626c6c616f04} "hello">
|
||||
string2: <StreamingTest #hex{25626865636c6c6f04} "hello">
|
||||
string3: <Test #hex{5568656c6c6f} "hello">
|
||||
string4: <Test #hex{5f 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a} "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
|
||||
string5: <Test #hex{54f09d849e} "\uD834\uDD1E">
|
||||
symbol0: <Test #hex{70} ||>
|
||||
symbol1: <Test #hex{27626865626c6c616f04} hello>
|
||||
symbol1: <StreamingTest #hex{27626865626c6c616f04} hello>
|
||||
symbol2: <Test #hex{7568656c6c6f} hello>
|
||||
value1: <Test #"\x66corymb" #value#"fcorymb">
|
||||
value2: <Test #"\x01" #value#"\x01">
|
||||
|
|
|
|||
Loading…
Reference in New Issue