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