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

Introduce explicit embedded wrapper

This commit is contained in:
Tony Garnock-Jones 2021-05-26 21:09:06 +02:00
parent 351cafddb4
commit e6efd03be7
8 changed files with 41 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
implementations/racket/preserves/preserves/embedded.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(provide (struct-out embedded))
(struct embedded (value) #:transparent)

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

@ -5,6 +5,7 @@
(all-from-out "float.rkt") (all-from-out "float.rkt")
(all-from-out "annotation.rkt") (all-from-out "annotation.rkt")
(all-from-out "order.rkt") (all-from-out "order.rkt")
(all-from-out "embedded.rkt")
(all-from-out "read-binary.rkt") (all-from-out "read-binary.rkt")
(all-from-out "read-text.rkt") (all-from-out "read-text.rkt")
@ -24,6 +25,7 @@
(require "float.rkt") (require "float.rkt")
(require "annotation.rkt") (require "annotation.rkt")
(require "order.rkt") (require "order.rkt")
(require "embedded.rkt")
(require "read-binary.rkt") (require "read-binary.rkt")
(require "read-text.rkt") (require "read-text.rkt")

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

@ -5,6 +5,7 @@
(require racket/match) (require racket/match)
(require "record.rkt") (require "record.rkt")
(require "embedded.rkt")
(require "float.rkt") (require "float.rkt")
(require "annotation.rkt") (require "annotation.rkt")
(require "varint.rkt") (require "varint.rkt")
@ -76,7 +77,7 @@
(if read-annotations? (if read-annotations?
(annotate (next) a) (annotate (next) a)
(next)))] (next)))]
[#x86 (decode-embedded (next))] [#x86 (embedded (decode-embedded (next)))]
[(? (between #x90 #x9C) v) (- v #x90)] [(? (between #x90 #x9C) v) (- v #x90)]
[(? (between #x9D #x9F) v) (- v #xA0)] [(? (between #x9D #x9F) v) (- v #xA0)]
[(? (between #xA0 #xAF) v) (next-integer (- v #xA0 -1))] [(? (between #xA0 #xAF) v) (next-integer (- v #xA0 -1))]

7
implementations/racket/preserves/preserves/read-text.rkt
View File

@ -5,6 +5,7 @@
(require racket/match) (require racket/match)
(require racket/set) (require racket/set)
(require "embedded.rkt")
(require "annotation.rkt") (require "annotation.rkt")
(require "read-binary.rkt") (require "read-binary.rkt")
(require "record.rkt") (require "record.rkt")
@ -93,10 +94,10 @@
(bytes->preserve (bytes->preserve
(annotated-item bs) (annotated-item bs)
(lambda (message . args) (lambda (message . args)
(apply parse-error (string-append "Embedded binary value: " message) args)) (apply parse-error (string-append "Inline binary value: " message) args))
#:read-syntax? read-syntax? #:read-syntax? read-syntax?
#:on-short (lambda () (parse-error "Incomplete embedded binary value")))] #:on-short (lambda () (parse-error "Incomplete inline binary value")))]
[#\! (decode-embedded (next))] [#\! (embedded (decode-embedded (next)))]
[c (parse-error "Invalid # syntax: ~v" c)])] [c (parse-error "Invalid # syntax: ~v" c)])]
[#\< (match (read-sequence #\>) [#\< (match (read-sequence #\>)

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

@ -9,22 +9,17 @@
(require racket/runtime-path) (require racket/runtime-path)
(require syntax/srcloc) (require syntax/srcloc)
(struct embedded (value) #:transparent)
(define (embedded/no-annotations v)
(embedded (strip-annotations v)))
(define (d bs #:allow-invalid-prefix? [allow-invalid-prefix? #f]) (define (d bs #:allow-invalid-prefix? [allow-invalid-prefix? #f])
(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 embedded/no-annotations #:decode-embedded strip-annotations
#:on-short (lambda () 'short) void)) #:on-short (lambda () 'short) void))
(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)))
(bytes->preserve bs (bytes->preserve bs
#:read-syntax? #t #:read-syntax? #t
#:decode-embedded embedded/no-annotations #:decode-embedded strip-annotations
#:on-short (lambda () 'short) #:on-short (lambda () 'short)
void)) void))
@ -134,28 +129,28 @@
[(asymmetric f b) (values f b #f)] ;; #f because e.g. annotation4 includes annotations [(asymmetric f b) (values f b #f)] ;; #f because e.g. annotation4 includes annotations
[v (values v v #t)])) [v (values v v #t)]))
(check-equal? text-form back loc) ;; expectation 1 (check-equal? text-form back loc) ;; expectation 1
(check-equal? (d-strip (preserve->bytes #:encode-embedded embedded-value text-form)) (check-equal? (d-strip (preserve->bytes #:encode-embedded values text-form))
back back
loc) ;; expectation 2 loc) ;; expectation 2
(check-equal? (d-strip (preserve->bytes #:encode-embedded embedded-value forward)) (check-equal? (d-strip (preserve->bytes #:encode-embedded values forward))
back back
loc) ;; expectation 3 loc) ;; expectation 3
(check-equal? (d-strip binary-form) back loc) ;; expectation 4 (check-equal? (d-strip binary-form) back loc) ;; expectation 4
(check-equal? (d binary-form) annotated-text-form loc) ;; expectation 5 (check-equal? (d binary-form) annotated-text-form loc) ;; expectation 5
(check-equal? (d (preserve->bytes #:encode-embedded embedded-value annotated-text-form)) (check-equal? (d (preserve->bytes #:encode-embedded values annotated-text-form))
annotated-text-form annotated-text-form
loc) ;; expectation 6 loc) ;; expectation 6
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations (check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded embedded-value text-form)) (preserve->string #:encode-embedded values text-form))
back back
loc) ;; expectation 7 loc) ;; expectation 7
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations (check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded embedded-value forward)) (preserve->string #:encode-embedded values forward))
back back
loc) ;; expectation 8 loc) ;; expectation 8
;; similar to 8: ;; similar to 8:
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations (check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded embedded-value (preserve->string #:encode-embedded values
annotated-text-form) annotated-text-form)
#:read-syntax? #t) #:read-syntax? #t)
annotated-text-form annotated-text-form
@ -165,7 +160,7 @@
(and can-execute-nondet-with-canonicalization?))) (and can-execute-nondet-with-canonicalization?)))
;; expectations 9 and 10 ;; expectations 9 and 10
(check-equal? (preserve->bytes forward (check-equal? (preserve->bytes forward
#:encode-embedded embedded-value #:encode-embedded values
#:canonicalizing? #t #:canonicalizing? #t
#:write-annotations? #t) #:write-annotations? #t)
binary-form binary-form
@ -173,7 +168,7 @@
(unless (memq variety '(decode nondeterministic)) (unless (memq variety '(decode nondeterministic))
;; expectation 11 ;; expectation 11
(check-equal? (preserve->bytes annotated-text-form (check-equal? (preserve->bytes annotated-text-form
#:encode-embedded embedded-value #:encode-embedded values
#:write-annotations? #t) #:write-annotations? #t)
binary-form binary-form
loc))) loc)))
@ -185,7 +180,7 @@
(port-count-lines! p) (port-count-lines! p)
(read-preserve p (read-preserve p
#:read-syntax? #t #:read-syntax? #t
#:decode-embedded embedded/no-annotations #:decode-embedded strip-annotations
#:source path))))) #:source path)))))
(match-define (peel-annotations `#s(TestCases ,tests)) testfile) (match-define (peel-annotations `#s(TestCases ,tests)) testfile)
(for [((t-name* t*) (in-hash (annotated-item tests)))] (for [((t-name* t*) (in-hash (annotated-item tests)))]

12
implementations/racket/preserves/preserves/tool.rkt
View File

@ -43,21 +43,19 @@
["--no-annotations" "Strip annotations" ["--no-annotations" "Strip annotations"
(set! annotations? #f)]) (set! annotations? #f)])
(struct embedded (value) #:transparent)
(let loop ((count count)) (let loop ((count count))
(when (positive? count) (when (positive? count)
(define v ((if annotations? values strip-annotations) (define v ((if annotations? values strip-annotations)
(match input-format (match input-format
['any (read-preserve #:read-syntax? #t #:decode-embedded embedded #:source "<stdin>")] ['any (read-preserve #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['text (read-preserve/text #:read-syntax? #t #:decode-embedded embedded #:source "<stdin>")] ['text (read-preserve/text #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['binary (read-preserve/binary #:decode-embedded embedded #:read-syntax? #t)]))) ['binary (read-preserve/binary #:decode-embedded values #:read-syntax? #t)])))
(when (not (eof-object? v)) (when (not (eof-object? v))
(void (match output-format (void (match output-format
['text ['text
(write-preserve/text v #:indent indent? #:encode-embedded embedded-value) (write-preserve/text v #:indent indent? #:encode-embedded values)
(newline)] (newline)]
['binary ['binary
(write-preserve/binary v #:encode-embedded embedded-value #:write-annotations? #t)])) (write-preserve/binary v #:encode-embedded values #:write-annotations? #t)]))
(flush-output) (flush-output)
(loop (- count 1)))))) (loop (- count 1))))))

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

@ -6,6 +6,7 @@
(require racket/match) (require racket/match)
(require (only-in racket/port call-with-output-bytes)) (require (only-in racket/port call-with-output-bytes))
(require "record.rkt") (require "record.rkt")
(require "embedded.rkt")
(require "float.rkt") (require "float.rkt")
(require "annotation.rkt") (require "annotation.rkt")
(require "varint.rkt") (require "varint.rkt")
@ -120,8 +121,10 @@
[(? set?) (with-seq 6 (output-set v))] [(? set?) (with-seq 6 (output-set v))]
[(? dict?) (with-seq 7 (output-dict v))] [(? dict?) (with-seq 7 (output-dict v))]
[other [(embedded value)
(output-byte #x86) (output-byte #x86)
(output (encode-embedded other))])) (output (encode-embedded value))]
[other (error 'write-preserve/binary "Attempt to serialize non-preserve: ~v" other)]))
(output v)) (output v))

6
implementations/racket/preserves/preserves/write-text.rkt
View File

@ -9,6 +9,7 @@
(require racket/match) (require racket/match)
(require racket/format) (require racket/format)
(require net/base64) (require net/base64)
(require "embedded.rkt")
(require "annotation.rkt") (require "annotation.rkt")
(require "float.rkt") (require "float.rkt")
(require "record.rkt") (require "record.rkt")
@ -168,9 +169,10 @@
[(? list?) (write-sequence distance "[" (if commas? "," "") "]" write-value v)] [(? list?) (write-sequence distance "[" (if commas? "," "") "]" write-value v)]
[(? set?) (write-sequence distance "#{" (if commas? "," "") "}" write-value (set->list v))] [(? set?) (write-sequence distance "#{" (if commas? "," "") "}" write-value (set->list v))]
[(? dict?) (write-sequence distance "{" (if commas? "," "") "}" write-key-value (dict->list v))] [(? dict?) (write-sequence distance "{" (if commas? "," "") "}" write-key-value (dict->list v))]
[other [(embedded value)
(! "#!") (! "#!")
(write-value distance (encode-embedded other))])) (write-value distance (encode-embedded value))]
[other (error 'write-preserve/text "Attempt to serialize non-preserve: ~v" other)]))
(write-value 0 v0)) (write-value 0 v0))