ehmry
/
preserves
forked from syndicate-lang/preserves
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

First real running tests with the new design, and several concomitant fixes and new tests

This commit is contained in:
Tony Garnock-Jones 2019-08-21 22:18:21 +01:00
parent 27ac21bed1
commit e90a790963
2 changed files with 145 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

196
implementations/racket/preserves/main.rkt
View File

@ -4,8 +4,11 @@
(provide (struct-out stream-of) (provide (struct-out stream-of)
(struct-out record) (struct-out record)
(struct-out annotated) (struct-out annotated)
annotate
strip-annotations strip-annotations
strip-annotations-proc
peel-annotations peel-annotations
peel-annotations-proc
read-preserve read-preserve
read-preserve-syntax read-preserve-syntax
string->preserve string->preserve
@ -52,7 +55,14 @@
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))] (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
(apply make-prefab-struct 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)) (let walk* ((v v) (depth depth))
(define next-depth (- depth 1)) (define next-depth (- depth 1))
(define (walk v) (walk* v next-depth)) (define (walk v) (walk* v next-depth))
@ -72,8 +82,16 @@
[_ item])] [_ item])]
[_ v])))) [_ v]))))
(define (peel-annotations v) (define (peel-annotations-proc v)
(strip-annotations v #:depth 1)) (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-value->placeholder (make-parameter (lambda (v) #f)))
(define current-placeholder->value (make-parameter (lambda (v) (void)))) (define current-placeholder->value (make-parameter (lambda (v) (void))))
@ -96,7 +114,7 @@
(define (decode-syntax bs (define (decode-syntax bs
#:on-short [on-short (default-on-short bs)] #:on-short [on-short (default-on-short bs)]
[on-fail (default-on-fail 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 (define-syntax wire-value
(syntax-rules () (syntax-rules ()
@ -777,7 +795,7 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
(require racket/runtime-path) (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) (0 :: (wire-length)))) (bytes 0))
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3)) (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3))
@ -811,34 +829,37 @@
void) void)
'short)) 'short))
(error 'd "~a-byte prefix of ~v does not read as short" i bs))) (error 'd "~a-byte prefix of ~v does not read as short" i bs)))
(decode bs (decode-syntax bs
#:on-short (lambda () 'short) #:on-short (lambda () 'short)
void)) void))
(define-syntax (cross-check stx) (define (d-strip bs)
(syntax-case stx () (strip-annotations (d bs)))
((_ 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) ;; (define-syntax (cross-check stx)
(syntax-case stx () ;; (syntax-case stx ()
((_ text v (b ...)) ;; ((_ text v (b ...))
#'(let ((val v)) (cross-check/nondeterministic text v v (b ...)))) ;; #'(let ((val v)) (cross-check text v v (b ...))))
((_ text forward back (b ...)) ;; ((_ text forward back (b ...))
#`(let ((loc #,(source-location->string #'forward))) ;; #`(let ((loc #,(source-location->string #'forward)))
(check-equal? (string->preserve text) back loc) ;; (check-equal? (string->preserve text) back loc)
(check-equal? (d (encode forward)) back loc) ;; (check-equal? (d (encode forward)) back loc)
(check-equal? (d (encode back)) back loc) ;; (check-equal? (d (encode back)) back loc)
(check-equal? (d (expected b ...)) 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 discard () #:prefab)
(struct capture (detail) #:prefab) (struct capture (detail) #:prefab)
@ -852,7 +873,6 @@
(struct titled person (title) #:prefab) (struct titled person (title) #:prefab)
(struct asymmetric (forward back)) (struct asymmetric (forward back))
(struct nondeterministic (value))
(define samples-txt-expected (define samples-txt-expected
(hash 'record1 (capture (discard)) (hash 'record1 (capture (discard))
@ -898,7 +918,11 @@
'string4 "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz" 'string4 "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"
'bytes13 #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz" 'bytes13 #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
'string5 "\U0001D11E" '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)) 'record1 (capture (discard))
'record2 (observe (speak (discard) (capture (discard)))) 'record2 (observe (speak (discard) (capture (discard))))
'record3 (titled 101 "Blackwell" (date 1821 2 3) "Dr") 'record3 (titled 101 "Blackwell" (date 1821 2 3) "Dr")
@ -913,35 +937,41 @@
"b" #t "b" #t
'(1 2 3) #"c" '(1 2 3) #"c"
(hash 'first-name "Elizabeth") (hash 'surname "Blackwell")) (hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
'rfc8259-example1 (nondeterministic 'rfc8259-example1 (hash "Image"
(hash "Image" (hash "Width" 800
(hash "Width" 800 "Height" 600
"Height" 600 "Title" "View from 15th Floor"
"Title" "View from 15th Floor" "Thumbnail" (hash "Url" "http://www.example.com/image/481989943"
"Thumbnail" (hash "Url" "http://www.example.com/image/481989943" "Height" 125
"Height" 125 "Width" 100)
"Width" 100) "Animated" #f
"Animated" #f "IDs" (list 116 943 234 38793)))
"IDs" (list 116 943 234 38793)))) 'rfc8259-example2 (list (hash
'rfc8259-example2 (nondeterministic "precision" "zip"
(list (hash "Latitude" 37.7668
"precision" "zip" "Longitude" -122.3959
"Latitude" 37.7668 "Address" ""
"Longitude" -122.3959 "City" "SAN FRANCISCO"
"Address" "" "State" "CA"
"City" "SAN FRANCISCO" "Zip" "94107"
"State" "CA" "Country" "US")
"Zip" "94107" (hash
"Country" "US") "precision" "zip"
(hash "Latitude" 37.371991
"precision" "zip" "Longitude" -122.026020
"Latitude" 37.371991 "Address" ""
"Longitude" -122.026020 "City" "SUNNYVALE"
"Address" "" "State" "CA"
"City" "SUNNYVALE" "Zip" "94085"
"State" "CA" "Country" "US"))
"Zip" "94085" 'annotation1 (asymmetric (annotate 9 "abc") 9)
"Country" "US"))) '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") (define-runtime-path tests-path "../../../tests")
@ -951,12 +981,38 @@
(port-count-lines! p) (port-count-lines! p)
(read-preserve-syntax p #:source path))))) (read-preserve-syntax p #:source path)))))
(local-require racket/pretty) (local-require racket/pretty)
(for [((t-name t) (in-hash (annotated-item tests)))] (define placeholder->value-map
(newline) (or (for/or [(a* (annotated-annotations tests))]
(newline) (match (strip-annotations a*)
(write-preserve t #:indent #f) [`#s(ExpectedPlaceholderMapping ,p->v) p->v]
(newline) [_ #f]))
(newline) (hash)))
(pretty-print (list (peel-annotations t-name) (define value->placeholder-map
(peel-annotations t))))) (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)])))
)
) )

35
tests/samples.txt
View File

@ -1,15 +1,18 @@
@<EmacsMode "-*- preserves -*-"> @<EmacsMode "-*- preserves -*-">
@"Expects placeholder mapping of:" @<ExpectedPlaceholderMapping {
@"{ 0: discard, 1: capture, 2: observe }" 0: discard
1: capture
2: observe
}>
{ {
annotation1: <Test #hex{055361626339} @"abc" 9> annotation1: <Test #hex{055361626339} @"abc" 9>
annotation2: <Test #hex{05536162630553646566929005517890} @"abc" @"def" [[] @"x" []]> annotation2: <Test #hex{05536162630553646566929005517890} @"abc" @"def" [[] @"x" []]>
annotation3: <Test #hex{050531320505333435} @@1 2 @@3 4 5> 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} annotation4: <NondeterministicTest #hex{b4 05 72616b 7161 05 726176 31 05 72626b 7162 05 726276 32}
{@ak a: @av 1 @bk b: @bv 2}> {@ak a: @av 1 @bk b: @bv 2}>
annotation5: <Test #hex{05726172827152057261667166} @ar <R @af f>> annotation5: <Test #hex{05726172827152057261667166} @ar <R @af f>>
annotation6: <Test #hex{82057261727152057261667166} <@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"> bytes2: <Test #hex{6568656c6c6f} #"hello">
bytes3: <Test #hex{63414243} #"ABC"> bytes3: <Test #hex{63414243} #"ABC">
bytes4: <Test #hex{63414243} #hex{414243}> 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"> 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} {}> 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 "> dict2: @"Missing close brace" <ParseShort "{ a: b, c: d ">
dict2a: @"Missing close brace" <ParseShort "{"> dict2a: @"Missing close brace" <ParseShort "{">
dict3: @"Duplicate key" <ParseError "{ a: 1, a: 2 }"> dict3: @"Duplicate key" <ParseError "{ a: 1, a: 2 }">
@ -56,13 +59,13 @@
int65536: <Test #hex{43010000} 65536> int65536: <Test #hex{43010000} 65536>
int131072: <Test #hex{43020000} 131072> int131072: <Test #hex{43020000} 131072>
list0: <Test #hex{90} []> list0: <Test #hex{90} []>
list1: <Test #hex{293132333404} [1 2 3 4]> list1: <StreamingTest #hex{293132333404} [1 2 3 4]>
list2: <Test #hex{2925636162630425636465660404} ["abc" "def"]> list2: <StreamingTest #hex{2925636162630425636465660404} ["abc" "def"]>
list3: <Test #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]> list3: <StreamingTest #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]>
list4: <Test #hex{9431323334} [1 2 3 4]> list4: <Test #hex{9431323334} [1 2 3 4]>
list4a: <Test #hex{9431323334} [1, 2, 3, 4]> list4a: <Test #hex{9431323334} [1, 2, 3, 4]>
list5: <Test #hex{943e3f3031} [-2 -1 0 1]> 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]> list7: <Test #hex{93 73616263 732e2e2e 73646566} [abc ... def]>
list8: @"Missing close bracket" <ParseShort "["> list8: @"Missing close bracket" <ParseShort "[">
placeholder0: <Test #hex{10} discard> placeholder0: <Test #hex{10} discard>
@ -79,8 +82,8 @@
record9: @"Missing record label" <ParseError "<>"> record9: @"Missing record label" <ParseError "<>">
record10: @"Missing close-angle-bracket" <ParseShort "<"> record10: @"Missing close-angle-bracket" <ParseShort "<">
set0: <Test #hex{a0} #set{}> set0: <Test #hex{a0} #set{}>
set1: <Test #hex{a3313233} {1 2 3}> set1: <NondeterministicTest #hex{a3313233} {1 2 3}>
set1a: <Test #hex{a3313233} #set{1 2 3}> set1a: <NondeterministicTest #hex{a3313233} #set{1 2 3}>
set2: @"Missing close brace" <ParseShort "#set{ 1 2 3 "> set2: @"Missing close brace" <ParseShort "#set{ 1 2 3 ">
set2a: @"Missing close brace" <ParseShort "#set{"> set2a: @"Missing close brace" <ParseShort "#set{">
stream1: @"Chunk must be bytes" <DecodeError #hex{25516104}> stream1: @"Chunk must be bytes" <DecodeError #hex{25516104}>
@ -92,14 +95,14 @@
stream7: @"Missing end byte" <DecodeShort #hex{290000}> stream7: @"Missing end byte" <DecodeShort #hex{290000}>
stream8: @"Missing element" <DecodeShort #hex{930000}> stream8: @"Missing element" <DecodeShort #hex{930000}>
string0: <Test #hex{50} ""> string0: <Test #hex{50} "">
string0a: <Test #hex{2504} ""> string0a: <StreamingTest #hex{2504} "">
string1: <Test #hex{25626865626c6c616f04} "hello"> string1: <StreamingTest #hex{25626865626c6c616f04} "hello">
string2: <Test #hex{25626865636c6c6f04} "hello"> string2: <StreamingTest #hex{25626865636c6c6f04} "hello">
string3: <Test #hex{5568656c6c6f} "hello"> string3: <Test #hex{5568656c6c6f} "hello">
string4: <Test #hex{5f 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a} "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"> string4: <Test #hex{5f 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a} "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
string5: <Test #hex{54f09d849e} "\uD834\uDD1E"> string5: <Test #hex{54f09d849e} "\uD834\uDD1E">
symbol0: <Test #hex{70} ||> symbol0: <Test #hex{70} ||>
symbol1: <Test #hex{27626865626c6c616f04} hello> symbol1: <StreamingTest #hex{27626865626c6c616f04} hello>
symbol2: <Test #hex{7568656c6c6f} hello> symbol2: <Test #hex{7568656c6c6f} hello>
value1: <Test #"\x66corymb" #value#"fcorymb"> value1: <Test #"\x66corymb" #value#"fcorymb">
value2: <Test #"\x01" #value#"\x01"> value2: <Test #"\x01" #value#"\x01">