syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Racket blue implementation

This commit is contained in:
Tony Garnock-Jones 2022-06-12 22:36:25 +02:00
parent e72adf704e
commit 666f8e1643
6 changed files with 475 additions and 381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
implementations/racket/preserves/preserves/iolist.rkt Normal file
View File

@ -0,0 +1,69 @@
#lang racket/base
(provide counted-iolist?
counted-iolist-value
counted-iolist-length
count-iolist
iolist-length
iolist->bytes
write-iolist)
(struct counted-iolist (value length) #:prefab)
(define (bad-iolist who v)
(error who "Invalid iolist: ~v" v))
(define (iolist-length i [acc 0])
(cond [(byte? i) (+ acc 1)]
[(bytes? i) (+ acc (bytes-length i))]
[(pair? i) (iolist-length (cdr i) (iolist-length (car i) acc))]
[(null? i) acc]
[(void? i) acc]
[(counted-iolist? i) (+ acc (counted-iolist-length i))]
[else (bad-iolist 'iolist-length i)]))
(define (count-iolist i)
(if (counted-iolist? i)
i
(counted-iolist i (iolist-length i))))
(define (iolist->bytes i)
(if (bytes? i)
i
(let ((buffer (make-bytes (iolist-length i))))
(let walk ((i i) (offset 0))
(cond [(byte? i) (bytes-set! buffer offset i) (+ offset 1)]
[(bytes? i) (bytes-copy! buffer offset i) (+ offset (bytes-length i))]
[(pair? i) (walk (cdr i) (walk (car i) offset))]
[(null? i) offset]
[(void? i) offset]
[(counted-iolist? i) (walk (counted-iolist-value i) offset)]))
buffer)))
(define (write-iolist i [out-port (current-output-port)])
(cond [(byte? i) (write-byte i out-port)]
[(bytes? i) (write-bytes i out-port)]
[(pair? i) (write-iolist (car i) out-port) (write-iolist (cdr i) out-port)]
[(null? i) (void)]
[(void? i) (void)]
[(counted-iolist? i) (write-iolist (counted-iolist-value i) out-port)]
[else (bad-iolist 'write-iolist i)]))
(module+ test
(require rackunit)
(require (only-in racket/port with-output-to-bytes))
(check-equal? (iolist-length '((1 . 1) (1 . #"xxx") . 1)) 7)
(check-equal? (iolist-length '((1 . 1) (1 . #"xxx"))) 6)
(check-equal? (iolist-length 123) 1)
(check-equal? (iolist-length #"123") 3)
(check-equal? (iolist-length (cons 123 #"123")) 4)
(check-equal? (iolist->bytes '((1 . 1) (1 . #"xxx") . 1)) (bytes 1 1 1 120 120 120 1))
(check-equal? (iolist->bytes '((1 . 1) (1 . #"xxx"))) (bytes 1 1 1 120 120 120))
(check-equal? (iolist->bytes 123) (bytes 123))
(check-equal? (iolist->bytes #"123") (bytes 49 50 51))
(check-equal? (iolist->bytes (cons 123 #"123")) (bytes 123 49 50 51))
(check-equal? (with-output-to-bytes (lambda () (write-iolist '((1 . 1) (1 . #"xxx") . 1))))
(bytes 1 1 1 120 120 120 1)))

188
implementations/racket/preserves/preserves/read-binary.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(provide read-preserve/binary (provide read-preserve/binary
bytes->preserve) bytes->preserve
preserve-sequence-reader)
(require racket/match) (require racket/match)
(require "record.rkt") (require "record.rkt")
@ -10,7 +11,7 @@
(require "annotation.rkt") (require "annotation.rkt")
(require "varint.rkt") (require "varint.rkt")
(require racket/set) (require racket/set)
(require (only-in racket/port call-with-input-bytes)) (require (only-in racket/port call-with-input-bytes port->bytes))
(define (default-on-short) (error 'read-preserve/binary "Short Preserves binary")) (define (default-on-short) (error 'read-preserve/binary "Short Preserves binary"))
(define (default-on-fail message . args) (error 'read-preserve/binary (apply format message args))) (define (default-on-fail message . args) (error 'read-preserve/binary (apply format message args)))
@ -21,7 +22,8 @@
#:read-syntax? [read-syntax? #f] #:read-syntax? [read-syntax? #f]
#:decode-embedded [decode-embedded #f] #:decode-embedded [decode-embedded #f]
#:on-short [on-short default-on-short] #:on-short [on-short default-on-short]
[on-fail default-on-fail]) [on-fail default-on-fail]
[expected-input-length #f])
(call-with-input-bytes (call-with-input-bytes
bs bs
(lambda (p) (lambda (p)
@ -29,27 +31,43 @@
#:read-syntax? read-syntax? #:read-syntax? read-syntax?
#:decode-embedded decode-embedded #:decode-embedded decode-embedded
#:on-short on-short #:on-short on-short
on-fail) on-fail
expected-input-length)
[(? eof-object?) (on-short)] [(? eof-object?) (on-short)]
[v v])))) [v v]))))
(define ((between lo hi) v) (<= lo v hi))
(define (read-preserve/binary [in-port (current-input-port)] (define (read-preserve/binary [in-port (current-input-port)]
#:read-syntax? [read-syntax? #f] #:read-syntax? [read-syntax? #f]
#:decode-embedded [decode-embedded0 #f] #:decode-embedded [decode-embedded0 #f]
#:on-short [on-short default-on-short] #:on-short [on-short default-on-short]
[on-fail default-on-fail]) [on-fail default-on-fail]
[expected-input-length #f])
(define read-annotations? read-syntax?) (define read-annotations? read-syntax?)
(define decode-embedded (or decode-embedded0 default-decode-embedded)) (define decode-embedded (or decode-embedded0 default-decode-embedded))
(let/ec return (let/ec return
(define (next) (wrap (pos) (next* (next-byte)))) (define count expected-input-length)
(define (next* lead-byte) (define (eof-guard v)
(match (next** lead-byte) (if (eof-object? v)
['#:end (return (on-fail "Unexpected sequence end marker"))] (return (on-short))
[v v])) v))
(define (next-byte) (eof-guard (next-byte*)))
(define (next-byte*)
(cond [(not count) (read-byte in-port)]
[(zero? count) eof]
[else (begin0 (read-byte in-port) (set! count (- count 1)))]))
(define (remaining-bytes)
(if (not count)
(port->bytes in-port)
(let ((bs (eof-guard (read-bytes count in-port))))
(if (< (bytes-length bs) count)
(return (on-short))
(begin0 bs (set! count 0))))))
(define (next) (wrap (pos) (next* (next-byte))))
(define pos (define pos
(if read-syntax? (if read-syntax?
@ -66,61 +84,109 @@
(annotated '() (srcloc #f #f #f pos0 (- (pos) pos0)) v))) (annotated '() (srcloc #f #f #f pos0 (- (pos) pos0)) v)))
(lambda (pos0 v) v))) (lambda (pos0 v) v)))
(define (next** lead-byte) (define (next* tag)
(match lead-byte (match tag
[#x80 #f] [#xA0 #f]
[#x81 #t] [#xA1 #t]
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))] [#xA2 (let ((bs (remaining-bytes)))
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)] (match (bytes-length bs)
[#x84 '#:end] [4 (float (floating-point-bytes->real bs #t 0 4))]
[#x85 (let ((a (next))) [8 (floating-point-bytes->real bs #t 0 8)]
(if read-annotations? [n (return (on-fail "Invalid floating-point length: ~v" n))]))]
(annotate (next) a) [#xA3 (let* ((acc0 (initial-integer))
(next)))] (acc (if (< acc0 128) acc0 (- acc0 256))))
[#x86 (embedded (decode-embedded (next)))] (for/fold [(acc acc)] [(b (remaining-bytes))] (+ (* acc 256) b)))]
[(? (between #x90 #x9C) v) (- v #x90)] [#xA4 (let* ((bs (remaining-bytes))
[(? (between #x9D #x9F) v) (- v #xA0)] (n (bytes-length bs)))
[(? (between #xA0 #xAF) v) (next-integer (- v #xA0 -1))] (if (or (zero? n) (not (zero? (bytes-ref bs (- n 1)))))
[#xB0 (next-integer (next-varint))] (return (on-fail "String not NUL terminated"))
[#xB1 (bytes->string/utf-8 (next-bytes (next-varint)))] (bytes->string/utf-8 (subbytes bs 0 (- n 1)))))]
[#xB2 (next-bytes (next-varint))] [#xA5 (remaining-bytes)]
[#xB3 (string->symbol (bytes->string/utf-8 (next-bytes (next-varint))))] [#xA6 (string->symbol (bytes->string/utf-8 (remaining-bytes)))]
[#xB4 (apply (lambda (label . fields) (record label fields)) (next-items))] [#xA7 (apply (lambda (label . fields) (record label fields)) (next-items))]
[#xB5 (next-items)] [#xA8 (next-items)]
[#xB6 (list->set (next-items))] [#xA9 (list->set (next-items))]
[#xB7 (build-dictionary (next-items))] [#xAA (build-dictionary (next-items))]
[_ (return (on-fail "Invalid Preserves binary tag: ~v" lead-byte))])) [#xAB (embedded (decode-embedded (next)))]
[#xBF (if read-annotations?
(apply annotate (next-items))
(begin0 (next-item (next-byte)) (remaining-bytes)))]
[_ (return (on-fail "Invalid Preserves binary tag: ~v" tag))]))
(define (eof-guard v) (define (initial-integer)
(if (eof-object? v) (cond [(not count) (match (read-byte in-port) [(? eof-object?) 0] [n n])]
(return (on-short)) [(zero? count) 0]
v)) [else (next-byte)]))
(define (next-byte) (eof-guard (read-byte in-port))) (define (next-item first-varint-byte)
(define block-len (eof-guard (read-varint in-port first-varint-byte)))
(define (next-bytes n) (define next-count (and count (- count block-len)))
(define bs (eof-guard (read-bytes n in-port))) (set! count block-len)
(if (< (bytes-length bs) n) (return (on-short)) bs)) (begin0 (next) (set! count next-count)))
(define (next-varint) (eof-guard (read-varint in-port)))
(define (next-integer n)
(cond [(zero? n) 0]
[else (define acc0 (next-byte))
(define acc (if (< acc0 128) acc0 (- acc0 256)))
(for/fold [(acc acc)] [(n (in-range (- n 1)))] (+ (* acc 256) (next-byte)))]))
(define (next-items) (define (next-items)
(define pos0 (pos)) (cond [(not count) (match (read-byte in-port)
(match (next** (next-byte)) [(? eof-object?) '()]
['#:end '()] [n (cons (next-item n) (next-items))])]
[v (cons (wrap pos0 v) (next-items))])) [(zero? count) '()]
[else (cons (next-item (next-byte)) (next-items))]))
(define (build-dictionary items) (define (build-dictionary items)
(when (not (even? (length items))) (return (on-fail "Odd number of items in dictionary"))) (when (not (even? (length items))) (return (on-fail "Odd number of items in dictionary")))
(apply hash items)) (apply hash items))
(let ((pos0 (pos))) (if (not count)
(match (read-byte in-port) (let ((pos0 (pos)))
[(? eof-object?) eof] (match (next-byte*)
[lead-byte (wrap pos0 (next* lead-byte))])))) [(? eof-object?) eof]
[tag (wrap pos0 (next* tag))]))
(next))))
(define (read-preserve/binary/length-prefix [in-port (current-input-port)]
#:read-syntax? [read-syntax? #f]
#:decode-embedded [decode-embedded #f]
#:on-short [on-short default-on-short]
[on-fail default-on-fail])
(if (eof-object? (peek-byte in-port))
eof
(match (read-varint in-port)
[(? eof-object?) (on-short)]
[block-len (read-preserve/binary in-port
#:read-syntax? read-syntax?
#:decode-embedded decode-embedded
#:on-short on-short
on-fail
block-len)])))
(define (preserve-sequence-reader [in-port (current-input-port)]
#:read-syntax? [read-syntax? #f]
#:decode-embedded [decode-embedded #f]
#:on-short [on-short default-on-short]
[on-fail default-on-fail])
(if (eqv? (peek-byte in-port) #xA8)
(begin (read-byte in-port)
(lambda () (read-preserve/binary/length-prefix in-port
#:read-syntax? read-syntax?
#:decode-embedded decode-embedded
#:on-short on-short
on-fail)))
#f))
(module+ test
(require rackunit)
(require (only-in file/sha1 hex-string->bytes))
(let ((r (preserve-sequence-reader (open-input-bytes
(hex-string->bytes "a882a30182a30281a381")))))
(check-equal? (r) 1)
(check-equal? (r) 2)
(check-equal? (r) 0)
(check-exn #px"Short Preserves binary" (lambda () (r))))
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "82a301"))) 1)
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "82a302"))) 2)
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "81a3"))) 0)
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "81"))
#:on-short (lambda () 'short))
'short))

323
implementations/racket/preserves/preserves/tests/samples.pr
View File

@ -43,134 +43,132 @@
"13/14 and 16/17, depending on how they wish to treat end-of-stream conditions." "13/14 and 16/17, depending on how they wish to treat end-of-stream conditions."
]> ]>
<TestCases { <TestCases {
annotation1: <Test #x"85B10361626399" @"abc" 9> annotation1: <Test #x"BF 82A309 85A461626300" @"abc" 9>
annotation2: <Test #x"85B10361626385B103646566B5B58485B10178B58484" @"abc" @"def" [[] @"x" []]> annotation2: <Test #x"BF 8BA881A887BF81A883A47800 85A461626300 85A464656600" @"abc" @"def" [[] @"x" []]>
annotation3: <Test #x"858591928585939495" @@1 2 @@3 4 5> annotation3: <Test #x"BF 82A305 87BF82A30282A301 87BF82A30482A303" @@1 2 @@3 4 5>
annotation4: <NondeterministicTest #x"B7 85 B302616b B30161 85 B3026176 91 85 B302626b B30162 85 B3026276 92 84" annotation4: <NondeterministicTest #x"AA 88BF82A66183A6616B 88BF82A30183A66276 88BF82A66283A6626B 88BF82A30283A66276"
{@ak a: @av 1 @bk b: @bv 2}> {@ak a: @av 1 @bk b: @bv 2}>
annotation5: <Test #x"85B3026172B4B3015285B3026166B3016684" @ar <R @af f>> annotation5: <Test #x"BF8DA782A65288BF82A66683A6616683A66172" @ar <R @af f>>
annotation6: <Test #x"B485B3026172B3015285B3026166B3016684" <@ar R @af f>> annotation6: <Test #x"A788BF82A65283A6617288BF82A66683A66166" <@ar R @af f>>
annotation7: annotation7:
;Stop reading symbols at @ -- this test has three separate annotations ;Stop reading symbols at @ -- this test has three separate annotations
<Test #x"85B3016185B3016285B30163B584" @a@b@c[]> <Test #x"BF81A882A66182A66282A663" @a@b@c[]>
bytes2: <Test #x"B20568656c6c6f" #"hello"> bytes2: <Test #x"a568656c6c6f" #"hello">
bytes2a: <Test @"Internal whitespace is allowed, including commas!" #x"B2, 05, 68, 65, 6c, 6c, 6f" #"hello"> bytes2a: <Test @"Internal whitespace is allowed, including commas!" #x"a5, 68, 65, 6c, 6c, 6f" #"hello">
bytes3: <Test #x"B203414243" #"ABC"> bytes3: <Test #x"a5414243" #"ABC">
bytes4: <Test #x"B203414243" #x"414243"> bytes4: <Test #x"a5414243" #x"414243">
bytes5: <Test #x"B203414a4e" #x" 41 4A 4e "> bytes5: <Test #x"a5414a4e" #x" 41 4A 4e ">
bytes6: @"Bytes must be 2-digits entire" <ParseError "#x\"414 243\""> bytes6: @"Bytes must be 2-digits entire" <ParseError "#x\"414 243\"">
bytes7: <Test #"\xB2\x06corymb" #[Y29yeW1i]> bytes7: <Test #"\xa5corymb" #[Y29yeW1i]>
bytes8: <Test #"\xB2\x06corymb" #[Y29 yeW 1i]> bytes8: <Test #"\xa5corymb" #[Y29 yeW 1i]>
bytes9: <Test #"\xB2\x02Hi" #[SGk=]> bytes9: <Test #"\xa5Hi" #[SGk=]>
bytes10: <Test #"\xB2\x02Hi" #[SGk]> bytes10: <Test #"\xa5Hi" #[SGk]>
bytes11: <Test #"\xB2\x02Hi" #[S G k]> bytes11: <Test #"\xa5Hi" #[S G k]>
bytes12: @"Bytes syntax only supports \\x, not \\u" <ParseError "#\"\\u6c34\""> bytes12: @"Bytes syntax only supports \\x, not \\u" <ParseError "#\"\\u6c34\"">
bytes13: <Test #x"B2 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 #x"a5 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 #x"B784" {}> dict0: <Test #x"aa" {}>
dict1: <NondeterministicTest #x"b7 b10162 81 b30161 91 b591929384 b20163 b7 b30a66697273742d6e616d65 b109456c697a6162657468 84 b7 b3077375726e616d65 b109426c61636b77656c6c 84 84" { a: 1 "b": #t [1 2 3]: #"c" { first-name: "Elizabeth" }: { surname: "Blackwell" } }> dict1: <NondeterministicTest #x"aa 83a46200 81a1 82a661 82a301 8aa882a30182a30282a303 82a563 99aa8ba666697273742d6e616d658ba4456c697a616265746800 96aa88a67375726e616d658ba4426c61636b77656c6c00" { a: 1 "b": #t [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 }">
dict4: @"Unexpected close brace" <ParseError "}"> dict4: @"Unexpected close brace" <ParseError "}">
dict5: @"Missing value" <DecodeError #x"b7 91 92 93 84"> dict5: @"Missing value" <DecodeError #x"aa 82a301 82a302 82a303">
double1: <Test #x"833ff0000000000000" 1.0> double1: <Test #x"a23ff0000000000000" 1.0>
double2: <Test #x"83fe3cb7b759bf0426" -1.202e300> double2: <Test #x"a2fe3cb7b759bf0426" -1.202e300>
float1: <Test #x"823f800000" 1.0f> float1: <Test #x"a23f800000" 1.0f>
int-257: <Test #x"a1feff" -257> int-257: <Test #x"a3feff" -257>
int-256: <Test #x"a1ff00" -256> int-256: <Test #x"a3ff00" -256>
int-255: <Test #x"a1ff01" -255> int-255: <Test #x"a3ff01" -255>
int-254: <Test #x"a1ff02" -254> int-254: <Test #x"a3ff02" -254>
int-129: <Test #x"a1ff7f" -129> int-129: <Test #x"a3ff7f" -129>
int-128: <Test #x"a080" -128> int-128: <Test #x"a380" -128>
int-127: <Test #x"a081" -127> int-127: <Test #x"a381" -127>
int-4: <Test #x"a0fc" -4> int-4: <Test #x"a3fc" -4>
int-3: <Test #x"9d" -3> int-3: <Test #x"a3fd" -3>
int-2: <Test #x"9e" -2> int-2: <Test #x"a3fe" -2>
int-1: <Test #x"9f" -1> int-1: <Test #x"a3ff" -1>
int0: <Test #x"90" 0> int0: <Test #x"a3" 0>
int1: <Test #x"91" 1> int1: <Test #x"a301" 1>
int12: <Test #x"9c" 12> int12: <Test #x"a30c" 12>
int13: <Test #x"a00d" 13> int13: <Test #x"a30d" 13>
int127: <Test #x"a07f" 127> int127: <Test #x"a37f" 127>
int128: <Test #x"a10080" 128> int128: <Test #x"a30080" 128>
int255: <Test #x"a100ff" 255> int255: <Test #x"a300ff" 255>
int256: <Test #x"a10100" 256> int256: <Test #x"a30100" 256>
int32767: <Test #x"a17fff" 32767> int32767: <Test #x"a37fff" 32767>
int32768: <Test #x"a2008000" 32768> int32768: <Test #x"a3008000" 32768>
int65535: <Test #x"a200ffff" 65535> int65535: <Test #x"a300ffff" 65535>
int65536: <Test #x"a2010000" 65536> int65536: <Test #x"a3010000" 65536>
int131072: <Test #x"a2020000" 131072> int131072: <Test #x"a3020000" 131072>
int2500000000: <Test #x"a4009502f900" 2500000000> int2500000000: <Test #x"a3009502f900" 2500000000>
int87112285931760246646623899502532662132736: <Test #x"b012010000000000000000000000000000000000" 87112285931760246646623899502532662132736> int87112285931760246646623899502532662132736: <Test #x"a3010000000000000000000000000000000000" 87112285931760246646623899502532662132736>
list0: <Test #x"b584" []> list0: <Test #x"a8" []>
list4: <Test #x"b59192939484" [1 2 3 4]> list4: <Test #x"a882a30182a30282a30382a304" [1 2 3 4]>
list4a: <Test #x"b59192939484" [1, 2, 3, 4]> list4a: <Test #x"a882a30182a30282a30382a304" [1, 2, 3, 4]>
list5: <Test #x"b59e9f909184" [-2 -1 0 1]> list5: <Test #x"a882a3fe82a3ff81a382a301" [-2 -1 0 1]>
list6: <Test #x"b5 b10568656c6c6f b3057468657265 b205776f726c64 b584 b684 81 80 84" ["hello" there #"world" [] #{} #t #f]> list6: <Test #x"a8 87a468656c6c6f00 86a67468657265 86a5776f726c64 81a8 81a9 81a1 81a0" ["hello" there #"world" [] #{} #t #f]>
list7: <Test #x"b5 b303616263 b3032e2e2e b303646566 84" [abc ... def]> list7: <Test #x"a8 84a6616263 84a62e2e2e 84a6646566" [abc ... def]>
list8: @"Missing close bracket" <ParseShort "["> list8: @"Missing close bracket" <ParseShort "[">
list9: @"Unexpected close bracket" <ParseError "]"> list9: @"Unexpected close bracket" <ParseError "]">
list10: @"Missing end byte" <DecodeShort #x"b58080"> list10: @"Missing tag" <DecodeShort #x"a881">
noinput0: @"No input at all" <DecodeEOF #x""> noinput0: @"No input at all" <DecodeEOF #x"">
embed0: <Test #x"8690" #!0> embed0: <Test #x"aba3" #!0>
embed1: <Test #x"868690" #!#!0> embed1: <Test #x"ababa3" #!#!0>
embed2: <Test #x"b5869086b10568656c6c6f84" [#!0 #!"hello"]> embed2: <Test #x"a8 82aba3 88aba468656c6c6f00" [#!0 #!"hello"]>
record1: <Test #x"b4 b30763617074757265 b4 b30764697363617264 84 84" <capture <discard>>> record1: <Test #x"a7 88a663617074757265 8aa788a664697363617264" <capture <discard>>>
record2: <Test #x"b4 b3076f627365727665 b4 b305737065616b b4 b30764697363617264 84 b4 b30763617074757265 b4 b30764697363617264 84 84 84 84" <observe <speak <discard>, <capture <discard>>>>> record2: <Test #x"a7 88a66f627365727665 a9a7 86a6737065616b 8aa788a664697363617264 95a7 88a663617074757265 8aa788a664697363617264" <observe <speak <discard>, <capture <discard>>>>>
record3: <Test #x"b4 b5 b3067469746c6564 b306706572736f6e 92 b3057468696e67 91 84 a065 b109426c61636b77656c6c b4 b30464617465 a1071d 92 93 84 b1024472 84" <[titled person 2 thing 1] 101 "Blackwell" <date 1821 2 3> "Dr">> record3: <Test #x"a7 9e a8 87a67469746c6564 87a6706572736f6e 82a302 86a67468696e67 82a301 82a365 8ba4426c61636b77656c6c00 91a7 85a664617465 83a3071d 82a302 82a303 84a4447200" <[titled person 2 thing 1] 101 "Blackwell" <date 1821 2 3> "Dr">>
record4: <Test #x"b4 b30764697363617264 84" <discard>> record4: <Test #x"a788a664697363617264" <discard>>
record5: <Test #x"b497b58484" <7[]>> record5: <Test #x"a782a30781a8" <7[]>>
record6: <Test #x"b4b30764697363617264b308737572707269736584" <discard surprise>> record6: <Test #x"a788a66469736361726489a67375727072697365" <discard surprise>>
record7: <Test #x"b4b10761537472696e67939484" <"aString" 3 4>> record7: <Test #x"a789a461537472696e670082a30382a304" <"aString" 3 4>>
record8: <Test #x"b4b4b3076469736361726484939484" <<discard> 3 4>> record8: <Test #x"a78aa788a66469736361726482a30382a304" <<discard> 3 4>>
record9: @"Missing record label" <ParseError "<>"> record9: @"Missing record label" <ParseError "<>">
record10: @"Missing close-angle-bracket" <ParseShort "<"> record10: @"Missing close-angle-bracket" <ParseShort "<">
record11: @"Unexpected close-angle-bracket" <ParseError ">"> record11: @"Unexpected close-angle-bracket" <ParseError ">">
set0: <Test #x"b684" #{}> set0: <Test #x"a9" #{}>
set1: <NondeterministicTest #x"b691929384" #{1 2 3}> set1: <NondeterministicTest #x"a982a30182a30282a303" #{1 2 3}>
set2: @"Missing close brace" <ParseShort "#{ 1 2 3 "> set2: @"Missing close brace" <ParseShort "#{ 1 2 3 ">
set2a: @"Missing close brace" <ParseShort "#{"> set2a: @"Missing close brace" <ParseShort "#{">
set3: @"Duplicate value" <ParseError "#{a a}"> set3: @"Duplicate value" <ParseError "#{a a}">
string0: <Test #x"b100" ""> string0: <Test #x"a400" "">
string3: <Test #x"b10568656c6c6f" "hello"> string3: <Test #x"a468656c6c6f00" "hello">
string4: <Test #x"b1 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a" "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"> string4: <Test #x"a4616263e6b0b4e6b0b45c2f22080c0a0d0978797a00" "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
string5: <Test #x"b104f09d849e" "\uD834\uDD1E"> string5: <Test #x"a4f09d849e00" "\uD834\uDD1E">
symbol0: <Test #x"b300" ||> symbol0: <Test #x"a6" ||>
symbol2: <Test #x"b30568656c6c6f" hello> symbol2: <Test #x"a668656c6c6f" hello>
tag0: @"Unexpected end tag" <DecodeError #x"84">
tag1: @"Invalid tag" <DecodeError #x"10"> tag1: @"Invalid tag" <DecodeError #x"10">
tag2: @"Invalid tag" <DecodeError #x"61b10110"> tag2: @"Invalid tag" <DecodeError #x"61a30110">
whitespace0: @"Leading spaces have to eventually yield something" <ParseShort " "> whitespace0: @"Leading spaces have to eventually yield something" <ParseShort " ">
whitespace1: @"No input at all" <ParseEOF ""> whitespace1: @"No input at all" <ParseEOF "">
value1: <Test #"\xB2\x06corymb" #=#"\xB2\x06corymb"> value1: <Test #"\xA5corymb" #=#"\xA5corymb">
value2: <Test #"\x81" #=#"\x81"> value2: <Test #"\xA1" #=#"\xA1">
value3: <Test #"\x81" #=#[gQ]> value3: <Test #"\xA1" #=#[oQ]>
value4: <Test #"\x81" #=#[gQ==]> value4: <Test #"\xA1" #=#[oQ==]>
value5: <Test #"\x81" #= #[gQ==]> value5: <Test #"\xA1" #= #[oQ==]>
value6: <Test #x"b591929384" #=#x"b591929384"> value6: <Test #x"A882A30182A30282A303" #=#x"A882A30182A30282A303">
longlist14: <Test #x"b5808080808080808080808080808084" longlist14: <Test #x"a881a081a081a081a081a081a081a081a081a081a081a081a081a081a0"
[#f #f #f #f #f [#f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f
#f #f #f #f]> #f #f #f #f]>
longlist15: <Test #x"b580808080808080808080808080808084" longlist15: <Test #x"a881a081a081a081a081a081a081a081a081a081a081a081a081a081a081a0"
[#f #f #f #f #f [#f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f]> #f #f #f #f #f]>
longlist100: longlist100:
<Test #x"b5 <Test #x"a8
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0"
84"
[#f #f #f #f #f #f #f #f #f #f [#f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
@ -182,28 +180,27 @@
#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f]> #f #f #f #f #f #f #f #f #f #f]>
longlist200: longlist200:
<Test #x"b5 <Test #x"a8
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0
80808080808080808080 81a081a081a081a081a081a081a081a081a081a0"
84"
[#f #f #f #f #f #f #f #f #f #f [#f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
@ -226,35 +223,22 @@
#f #f #f #f #f #f #f #f #f #f]> #f #f #f #f #f #f #f #f #f #f]>
rfc8259-example1: <NondeterministicTest rfc8259-example1: <NondeterministicTest
#x"B7 #x"AA
B1 05 496d616765 87 A4 496D61676500
B7 01B7 AA
B1 03 494473 8A A4 416E696D6174656400 86 A6 66616C7365
B5 88 A4 48656967687400 83 A3 0258
A0 74 85 A4 49447300 91 A8
A1 03 AF 82 A3 74
A1 00 EA 83 A3 03AF
A2 00 97 89 83 A3 00EA
84 84 A3 009789
B1 05 5469746c65 8B A4 5468756D626E61696C00 C7 AA
B1 14 566965772066726f6d203135746820466c6f6f72 88 A4 48656967687400 82 A3 7D
B1 05 5769647468 85 A4 55726C00 A8 A4 687474703A2F2F7777772E6578616D706C652E636F6D2F696D6167652F34383139383939343300
A1 03 20 87 A4 576964746800 82 A3 64
B1 06 486569676874 87 A4 5469746C6500 96 A4 566965772066726F6D203135746820466C6F6F7200
A1 02 58 87 A4 576964746800 83 A3 0320"
B1 08 416e696d61746564
B3 05 66616c7365
B1 09 5468756d626e61696c
B7
B1 03 55726c
B1 26 687474703a2f2f7777772e6578616d706c652e636f6d2f696d6167652f343831393839393433
B1 05 5769647468
A0 64
B1 06 486569676874
A0 7D
84
84
84"
{ {
"Image": { "Image": {
"Width": 800, "Width": 800,
@ -271,28 +255,25 @@
}> }>
rfc8259-example2: <NondeterministicTest rfc8259-example2: <NondeterministicTest
#x"b5 #x"a8
b7 018c aa
b1 03 5a6970 b1 05 3934313037 89 a4 4164647265737300 82 a4 00
b1 04 43697479 b1 0d 53414e204652414e434953434f 86 a4 4369747900 8f a4 53414e204652414e434953434f00
b1 05 5374617465 b1 02 4341 89 a4 436f756e74727900 84 a4 555300
b1 07 41646472657373 b1 00 8a a4 4c6174697475646500 89 a2 4042e226809d4952
b1 07 436f756e747279 b1 02 5553 8b a4 4c6f6e67697475646500 89 a2 c05e99566cf41f21
b1 08 4c61746974756465 83 4042e226809d4952 87 a4 537461746500 84 a4 434100
b1 09 4c6f6e676974756465 83 c05e99566cf41f21 85 a4 5a697000 87 a4 393431303700
b1 09 707265636973696f6e b1 03 7a6970 8b a4 707265636973696f6e00 85 a4 7a697000
84 0188 aa
b7 89 a4 4164647265737300 82 a4 00
b1 03 5a6970 b1 05 3934303835 86 a4 4369747900 8b a4 53554e4e5956414c4500
b1 04 43697479 b1 09 53554e4e5956414c45 89 a4 436f756e74727900 84 a4 555300
b1 05 5374617465 b1 02 4341 8a a4 4c6174697475646500 89 a2 4042af9d66adb403
b1 07 41646472657373 b1 00 8b a4 4c6f6e67697475646500 89 a2 c05e81aa4fca42af
b1 07 436f756e747279 b1 02 5553 87 a4 537461746500 84 a4 434100
b1 08 4c61746974756465 83 4042af9d66adb403 85 a4 5a697000 87 a4 393430383500
b1 09 4c6f6e676974756465 83 c05e81aa4fca42af 8b a4 707265636973696f6e00 85 a4 7a697000"
b1 09 707265636973696f6e b1 03 7a6970
84
84"
[ [
{ {
"precision": "zip", "precision": "zip",

4
implementations/racket/preserves/preserves/tests/test-main.rkt
View File

@ -13,7 +13,9 @@
(for [(i (in-range 1 (- (bytes-length bs) 1)))] (for [(i (in-range 1 (- (bytes-length bs) 1)))]
(define result (bytes->preserve (subbytes bs 0 i) (define result (bytes->preserve (subbytes bs 0 i)
#:decode-embedded strip-annotations #:decode-embedded strip-annotations
#:on-short (lambda () 'short) void)) #:on-short (lambda () 'short)
void
(bytes-length bs)))
(when (and (not (eq? result 'short)) (when (and (not (eq? result 'short))
(not (and allow-invalid-prefix? (void? result)))) (not (and allow-invalid-prefix? (void? result))))
(error 'd "~a-byte prefix of ~v does not read as short; result: ~v" i bs result))) (error 'd "~a-byte prefix of ~v does not read as short; result: ~v" i bs result)))

80
implementations/racket/preserves/preserves/varint.rkt
View File

@ -1,33 +1,31 @@
#lang racket/base #lang racket/base
;; "varints" from Google Protocol Buffers,
;; https://developers.google.com/protocol-buffers/docs/encoding#varints
;;
;; "Each byte in a varint, except the last byte, has the most
;; significant bit (msb) set – this indicates that there are further
;; bytes to come. The lower 7 bits of each byte are used to store the
;; two's complement representation of the number in groups of 7 bits,
;; least significant group first."
(provide write-varint (provide varint->iolist
write-varint
read-varint read-varint
encode-varint encode-varint
decode-varint) decode-varint)
(require racket/port) (require racket/port)
(define (write-varint v out-port) (define (varint->iolist n)
(if (< v 128) (let wr ((n n) (d 128))
(write-byte v out-port) (if (< n 128)
(begin (write-byte (+ 128 (modulo v 128)) out-port) (+ d n)
(write-varint (quotient v 128) out-port)))) (cons (wr (quotient n 128) 0) (+ d (modulo n 128))))))
(define (read-varint in-port) (define (write-varint n out-port)
(let/ec return (let wr ((n n) (d 128))
(let loop () (if (< n 128)
(define b (read-byte in-port)) (write-byte (+ d n) out-port)
(cond [(eof-object? b) (return b)] (begin (wr (quotient n 128) 0)
[(< b 128) b] (write-byte (+ d (modulo n 128)) out-port)))))
[else (+ (* (loop) 128) (- b 128))]))))
(define (read-varint in-port [first-byte (read-byte in-port)])
(let rd ((acc 0) (b first-byte))
(cond [(eof-object? b) eof]
[(< b 128) (rd (+ (* acc 128) b) (read-byte in-port))]
[else (+ (* acc 128) (- b 128))])))
(define (encode-varint v) (define (encode-varint v)
(call-with-output-bytes (lambda (p) (write-varint v p)))) (call-with-output-bytes (lambda (p) (write-varint v p))))
@ -42,28 +40,28 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
(check-equal? (encode-varint 0) (bytes 0)) (check-equal? (encode-varint 0) (bytes 128))
(check-equal? (encode-varint 1) (bytes 1)) (check-equal? (encode-varint 1) (bytes 129))
(check-equal? (encode-varint 127) (bytes 127)) (check-equal? (encode-varint 127) (bytes 255))
(check-equal? (encode-varint 128) (bytes 128 1)) (check-equal? (encode-varint 128) (bytes 1 128))
(check-equal? (encode-varint 255) (bytes 255 1)) (check-equal? (encode-varint 255) (bytes 1 255))
(check-equal? (encode-varint 256) (bytes 128 2)) (check-equal? (encode-varint 256) (bytes 2 128))
(check-equal? (encode-varint 300) (bytes #b10101100 #b00000010)) (check-equal? (encode-varint 300) (bytes #b00000010 #b10101100))
(check-equal? (encode-varint 1000000000) (bytes 128 148 235 220 3)) (check-equal? (encode-varint 1000000000) (bytes 3 92 107 20 128))
(define (ks* v rest) (list v rest)) (define (ks* v rest) (list v rest))
(define (kf* [short? #f]) (if short? 'short (void))) (define (kf* [short? #f]) (if short? 'short (void)))
(check-equal? (decode-varint (bytes) ks* kf*) 'short) (check-equal? (decode-varint (bytes) ks* kf*) 'short)
(check-equal? (decode-varint (bytes 0) ks* kf*) (list 0 (bytes))) (check-equal? (decode-varint (bytes 128) ks* kf*) (list 0 (bytes)))
(check-equal? (decode-varint (bytes 0 99) ks* kf*) (list 0 (bytes 99))) (check-equal? (decode-varint (bytes 128 99) ks* kf*) (list 0 (bytes 99)))
(check-equal? (decode-varint (bytes 1) ks* kf*) (list 1 (bytes))) (check-equal? (decode-varint (bytes 129) ks* kf*) (list 1 (bytes)))
(check-equal? (decode-varint (bytes 127) ks* kf*) (list 127 (bytes))) (check-equal? (decode-varint (bytes 255) ks* kf*) (list 127 (bytes)))
(check-equal? (decode-varint (bytes 128) ks* kf*) 'short) (check-equal? (decode-varint (bytes 0) ks* kf*) 'short)
(check-equal? (decode-varint (bytes 128 1) ks* kf*) (list 128 (bytes))) (check-equal? (decode-varint (bytes 1 128) ks* kf*) (list 128 (bytes)))
(check-equal? (decode-varint (bytes 128 1 99) ks* kf*) (list 128 (bytes 99))) (check-equal? (decode-varint (bytes 1 128 99) ks* kf*) (list 128 (bytes 99)))
(check-equal? (decode-varint (bytes 255 1) ks* kf*) (list 255 (bytes))) (check-equal? (decode-varint (bytes 1 255) ks* kf*) (list 255 (bytes)))
(check-equal? (decode-varint (bytes 128 2) ks* kf*) (list 256 (bytes))) (check-equal? (decode-varint (bytes 2 128) ks* kf*) (list 256 (bytes)))
(check-equal? (decode-varint (bytes #b10101100 #b00000010) ks* kf*) (list 300 (bytes))) (check-equal? (decode-varint (bytes #b00000010 #b10101100) ks* kf*) (list 300 (bytes)))
(check-equal? (decode-varint (bytes 128 148 235 220 3) ks* kf*) (list 1000000000 (bytes))) (check-equal? (decode-varint (bytes 3 92 107 20 128) ks* kf*) (list 1000000000 (bytes)))
(check-equal? (decode-varint (bytes 128 148 235 220 3 99) ks* kf*) (list 1000000000 (bytes 99)))) (check-equal? (decode-varint (bytes 3 92 107 20 128 99) ks* kf*) (list 1000000000 (bytes 99))))

192
implementations/racket/preserves/preserves/write-binary.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(provide write-preserve/binary (provide preserve->iolist
preserve->bytes) preserve->bytes
write-preserve/binary)
(require racket/match) (require racket/match)
(require (only-in racket/port call-with-output-bytes)) (require (only-in racket/port call-with-output-bytes))
@ -11,120 +12,97 @@
(require "annotation.rkt") (require "annotation.rkt")
(require "varint.rkt") (require "varint.rkt")
(require "object-id.rkt") (require "object-id.rkt")
(require "iolist.rkt")
(require racket/set) (require racket/set)
(require racket/dict) (require racket/dict)
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
(define (preserve->iolist v
#:canonicalizing? [canonicalizing? #t]
#:encode-embedded [encode-embedded0 #f]
#:write-annotations? [write-annotations? (not canonicalizing?)])
(define encode-embedded (or encode-embedded0 object-id))
(define (prepare v)
(iolist->bytes (preserve->iolist v #:canonicalizing? #t #:encode-embedded encode-embedded0)))
(define (length-prefixed-iolist i)
(define c (count-iolist i))
(cons (varint->iolist (counted-iolist-length c)) c))
(define (length-prefixed v) (length-prefixed-iolist (encode v)))
(define (encode v)
(match v
[#f #xA0]
[#t #xA1]
[(float v) (cons #xA2 (real->floating-point-bytes v 4 #t))]
[(? flonum?) (cons #xA2 (real->floating-point-bytes v 8 #t))]
[(? integer?) (cons #xA3 (when (not (zero? v))
(define nbits (bitwise-and (+ (integer-length v) 8) -8))
(for/list [(shift (in-range nbits 0 -8))]
(bitwise-bit-field v (- shift 8) shift))))]
[(? string?) (list #xA4 (string->bytes/utf-8 v) 0)]
[(? bytes?) (cons #xA5 v)]
[(? symbol?) (cons #xA6 (string->bytes/utf-8 (symbol->string v)))]
[(record label fields) (list #xA7 (length-prefixed label) (map length-prefixed fields))]
[(? list?) (cons #xA8 (map length-prefixed v))]
[(? set?) (cons #xA9 (set->iolist v))]
[(? dict?) (cons #xAA (dict->iolist v))]
[(embedded value) (cons #xAB (encode (encode-embedded value)))]
[(annotated as _ v)
(if (and write-annotations? (pair? as))
(list #xBF (length-prefixed v) (map length-prefixed as))
(encode v))]
[other (error 'preserve->iolist "Attempt to serialize non-preserve: ~v" other)]))
(define set->iolist
(match* [canonicalizing? write-annotations?]
[[#t #f] (lambda (v)
(map length-prefixed-iolist
(sort (for/list [(e (in-set v))] (prepare e)) bytes<?)))]
[[#t #t] (lambda (v)
(map length-prefixed
(map cdr (sort (for/list [(e (in-set v))] (cons (prepare e) e))
bytes<? #:key car))))]
[[#f _] (lambda (v)
(for/list [(e (in-set v))] (length-prefixed e)))]))
(define (prepare-dict d)
(sort (for/list [((k v) (in-dict d))] (list (prepare k) k v)) bytes<? #:key car))
(define dict->iolist
(match* [canonicalizing? write-annotations?]
[[#t #f] (lambda (v)
(map (match-lambda [(list kb _ v) (cons (length-prefixed-iolist kb)
(length-prefixed v))])
(prepare-dict v)))]
[[#t #t] (lambda (v)
(map (match-lambda [(list _ k v) (cons (length-prefixed k)
(length-prefixed v))])
(prepare-dict v)))]
[[#f _] (lambda (v)
(for/list [((k v) (in-dict v))] (cons (length-prefixed k) (length-prefixed v))))]))
(encode v))
(define (preserve->bytes v (define (preserve->bytes v
#:canonicalizing? [canonicalizing? #t] #:canonicalizing? [canonicalizing? #t]
#:encode-embedded [encode-embedded #f] #:encode-embedded [encode-embedded #f]
#:write-annotations? [write-annotations? (not canonicalizing?)]) #:write-annotations? [write-annotations? (not canonicalizing?)])
(call-with-output-bytes (iolist->bytes (preserve->iolist v
(lambda (p) (write-preserve/binary v p #:canonicalizing? canonicalizing?
#:canonicalizing? canonicalizing? #:encode-embedded encode-embedded
#:encode-embedded encode-embedded #:write-annotations? write-annotations?)))
#:write-annotations? write-annotations?))))
(define (write-preserve/binary v [out-port (current-output-port)] (define (write-preserve/binary v [out-port (current-output-port)]
#:canonicalizing? [canonicalizing? #t] #:canonicalizing? [canonicalizing? #t]
#:encode-embedded [encode-embedded0 #f] #:encode-embedded [encode-embedded #f]
#:write-annotations? [write-annotations? (not canonicalizing?)]) #:write-annotations? [write-annotations? (not canonicalizing?)])
(define encode-embedded (or encode-embedded0 object-id)) (write-iolist (preserve->iolist v
#:canonicalizing? canonicalizing?
(define (output-byte b) #:encode-embedded encode-embedded
(write-byte b out-port)) #:write-annotations? write-annotations?)
out-port))
(define (output-bytes bs)
(write-bytes bs out-port))
(define (output-varint v)
(write-varint v out-port))
(define-syntax-rule (with-seq tag body ...)
(begin (output-byte (+ tag #xB0))
body ...
(output-byte #x84)))
(define (count-bytes tag bs)
(output-byte (+ tag #xB0))
(output-varint (bytes-length bs))
(output-bytes bs))
(define (prepare v) (preserve->bytes v #:canonicalizing? #t))
(define (output-all vs)
(for [(v (in-list vs))] (output v)))
(define output-set
(match* [canonicalizing? write-annotations?]
[[#t #f] (lambda (v)
(for-each output-bytes
(sort (for/list [(e (in-set v))] (prepare e)) bytes<?)))]
[[#t #t] (lambda (v)
(for-each output
(map cdr
(sort (for/list [(e (in-set v))] (cons (prepare e) e))
bytes<?
#:key car))))]
[[#f _] (lambda (v) (for [(e (in-set v))] (output e)))]))
(define (prepare-dict d)
(sort (for/list [((k v) (in-dict d))] (list (prepare k) k v)) bytes<? #:key car))
(define output-dict
(match* [canonicalizing? write-annotations?]
[[#t #f] (lambda (v)
(for-each (match-lambda [(list kb _ v) (output-bytes kb) (output v)])
(prepare-dict v)))]
[[#t #t] (lambda (v)
(for-each (match-lambda [(list _ k v) (output k) (output v)])
(prepare-dict v)))]
[[#f _] (lambda (v) (for [((k v) (in-dict v))] (output k) (output v)))]))
(define (output v)
(match v
[#f (output-byte #x80)]
[#t (output-byte #x81)]
[(float v)
(output-byte #x82)
(output-bytes (real->floating-point-bytes v 4 #t))]
[(? flonum?)
(output-byte #x83)
(output-bytes (real->floating-point-bytes v 8 #t))]
[(annotated as _ v)
(when write-annotations?
(for [(a (in-list as))]
(output-byte #x85)
(output a)))
(output v)]
[(? integer?)
(cond [(<= -3 v -1) (output-byte (+ v #xA0))]
[(<= 0 v 12) (output-byte (+ v #x90))]
[else (define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
(define byte-count (quotient (+ raw-bit-count 7) 8))
(if (<= byte-count 16)
(output-byte (+ byte-count #xA0 -1))
(begin (output-byte #xB0)
(output-varint byte-count)))
(for [(shift (in-range (* byte-count 8) 0 -8))]
(output-byte (bitwise-bit-field v (- shift 8) shift)))])]
[(? string?) (count-bytes 1 (string->bytes/utf-8 v))]
[(? bytes?) (count-bytes 2 v)]
[(? symbol?) (count-bytes 3 (string->bytes/utf-8 (symbol->string v)))]
[(record label fields) (with-seq 4 (output label) (output-all fields))]
[(? list?) (with-seq 5 (output-all v))]
[(? set?) (with-seq 6 (output-set v))]
[(? dict?) (with-seq 7 (output-dict v))]
[(embedded value)
(output-byte #x86)
(output (encode-embedded value))]
[other (error 'write-preserve/binary "Attempt to serialize non-preserve: ~v" other)]))
(output v))