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

Remove placeholders from spec and implementations 5/5 

Update Racket implementation: remove placeholders; reject zero-length
streamed binary chunks.
This commit is contained in:
Tony Garnock-Jones 2020-05-28 23:21:51 +02:00
parent 83dce41092
commit c4f90ef86b
1 changed files with 93 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18,8 +18,6 @@
current-binary-display-heuristics
write-preserve
preserve->string
current-value->placeholder
current-placeholder->value
prepend-noop
encode
decode
@ -113,9 +111,6 @@
[(_ args ...) #'(peel-annotations-proc args ...)]
[_ #'peel-annotations-proc])))
(define current-value->placeholder (make-parameter (lambda (v) #f)))
(define current-placeholder->value (make-parameter (lambda (v) (void))))
(define (prepend-noop encoded-value)
(bit-string-append #"\xff" encoded-value))
@ -182,52 +177,48 @@
(define (encode-value v)
(define canonicalizing? (canonicalize-preserves?))
(match (and (not canonicalizing?) ((current-value->placeholder) v))
[(? integer? n)
(bit-string (#b0001 :: bits 4) (n :: (wire-length)))]
[#f
(let restart ((v v))
(match v
[#f (bytes #b00000000)]
[#t (bytes #b00000001)]
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
[(annotated annotations _ item)
(if canonicalizing?
(restart item)
(bit-string ((apply bit-string-append
(map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary)))
annotations)) :: binary)
((encode-value item) :: binary)))]
[(? stream-of?) #:when canonicalizing?
(restart (stream-of->preserve v))]
[(stream-of 'string p) (encode-stream 1 1 bytes? (p))]
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? (p))]
[(stream-of 'symbol p) (encode-stream 1 3 bytes? (p))]
[(stream-of 'sequence p) (encode-stream 2 1 (lambda (x) #t) (p))]
[(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) (p))]
[(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) (p))]
(let restart ((v v))
(match v
[#f (bytes #b00000000)]
[#t (bytes #b00000001)]
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
[(annotated annotations _ item)
(if canonicalizing?
(restart item)
(bit-string ((apply bit-string-append
(map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary)))
annotations)) :: binary)
((encode-value item) :: binary)))]
[(? stream-of?) #:when canonicalizing?
(restart (stream-of->preserve v))]
[(stream-of 'string p) (encode-stream 1 1 bytes? (p))]
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? (p))]
[(stream-of 'symbol p) (encode-stream 1 3 bytes? (p))]
[(stream-of 'sequence p) (encode-stream 2 1 (lambda (x) #t) (p))]
[(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) (p))]
[(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) (p))]
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))]
;; [0 (bytes #b10000000)]
[(? integer?)
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
(define byte-count (quotient (+ raw-bit-count 7) 8))
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
[(? string?) (encode-binary-like 1 (string->bytes/utf-8 v))]
[(? bytes?) (encode-binary-like 2 v)]
[(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))]
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))]
;; [0 (bytes #b10000000)]
[(? integer?)
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
(define byte-count (quotient (+ raw-bit-count 7) 8))
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
[(? string?) (encode-binary-like 1 (string->bytes/utf-8 v))]
[(? bytes?) (encode-binary-like 2 v)]
[(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))]
[(record label fields) (encode-array-like 0 (cons label fields))]
[(? list?) (encode-array-like 1 v)]
[(? set?) (encode-array-like 2 (if canonicalizing?
(canonical-set-elements v)
(set->list v)))]
[(? dict?) (encode-array-like 3 (if canonicalizing?
(canonical-dict-keys-and-values v)
(dict-keys-and-values v)))]
[(record label fields) (encode-array-like 0 (cons label fields))]
[(? list?) (encode-array-like 1 v)]
[(? set?) (encode-array-like 2 (if canonicalizing?
(canonical-set-elements v)
(set->list v)))]
[(? dict?) (encode-array-like 3 (if canonicalizing?
(canonical-dict-keys-and-values v)
(dict-keys-and-values v)))]
[_ (error 'encode-value "Cannot encode value ~v" v)]))]))
[_ (error 'encode-value "Cannot encode value ~v" v)])))
;;---------------------------------------------------------------------------
@ -317,10 +308,13 @@
(else
(decode-one rest accept-one kf)))))
(define bytes-chunk?
(define (valid-unwrapped-chunk? c)
(and (bytes? c) (positive? (bytes-length c))))
(define valid-chunk?
(if read-syntax?
(lambda (v) (bytes? (annotated-item v)))
bytes?))
(lambda (v) (valid-unwrapped-chunk? (annotated-item v)))
valid-unwrapped-chunk?))
(define bytes-chunk-append*
(if read-syntax?
@ -349,13 +343,11 @@
kf))
kf))
([ (= #b0001 :: bits 4) (placeholder :: (wire-length)) (rest :: binary) ]
(match ((current-placeholder->value) placeholder)
[(? void?) (error 'decode "Invalid Preserves placeholder: ~v" placeholder)]
[v ((nil-annotation ks bs) v rest)]))
([ (= #b0001 :: bits 4) (rest :: binary) ]
(kf))
([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ]
(decode-stream minor #f bytes-chunk? bytes-chunk-append* decode-binary rest ks kf))
(decode-stream minor #f valid-chunk? bytes-chunk-append* decode-binary rest ks kf))
([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ]
(decode-stream minor #t (lambda (x) #t) values decode-compound rest ks kf))
@ -979,13 +971,12 @@
(check-equal? (dwl (bytes 15 #b10101100 #b00000010)) 300)
(check-equal? (dwl (bytes 15 #b10101100)) 'short)
(define (d bs)
(define (d bs #:allow-invalid-prefix? [allow-invalid-prefix? #f])
(for [(i (in-range 0 (- (bytes-length bs) 1)))]
(when (not (eq? (decode (subbytes bs 0 i)
#:on-short (lambda () 'short)
void)
'short))
(error 'd "~a-byte prefix of ~v does not read as short" i bs)))
(define result (decode (subbytes bs 0 i) #: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)))
(decode-syntax bs
#:on-short (lambda () 'short)
void))
@ -1144,53 +1135,45 @@
(lambda (p)
(port-count-lines! p)
(read-preserve-syntax p #:source path)))))
(match-define (peel-annotations
`#s(TestCases
,(strip-annotations
`#s(ExpectedPlaceholderMapping ,placeholder->value-map))
,tests))
testfile)
(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*))))
(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(StreamingTest ,(strip-annotations binary-form) ,annotated-text-form)
(run-test-case 'streaming 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"))]
[`#s(ParseShort ,(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"))]
[`#s(DecodeShort ,(strip-annotations bs))
(check-eq? (d bs) 'short loc)]
[`#s(DecodeError ,(strip-annotations bs))
(check-true (void? (d bs)) loc)]
[_
(write-preserve t* #:indent #f)
(newline)])))
(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(StreamingTest ,(strip-annotations binary-form) ,annotated-text-form)
(run-test-case 'streaming 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 t* #:indent #f)
(newline)]))
)
)