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 "annotation.rkt")
(all-from-out "order.rkt")
(all-from-out "embedded.rkt")
(all-from-out "read-binary.rkt")
(all-from-out "read-text.rkt")
@ -24,6 +25,7 @@
(require "float.rkt")
(require "annotation.rkt")
(require "order.rkt")
(require "embedded.rkt")
(require "read-binary.rkt")
(require "read-text.rkt")

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

@ -5,6 +5,7 @@
(require racket/match)
(require "record.rkt")
(require "embedded.rkt")
(require "float.rkt")
(require "annotation.rkt")
(require "varint.rkt")
@ -76,7 +77,7 @@
(if read-annotations?
(annotate (next) a)
(next)))]
[#x86 (decode-embedded (next))]
[#x86 (embedded (decode-embedded (next)))]
[(? (between #x90 #x9C) v) (- v #x90)]
[(? (between #x9D #x9F) v) (- v #xA0)]
[(? (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/set)
(require "embedded.rkt")
(require "annotation.rkt")
(require "read-binary.rkt")
(require "record.rkt")
@ -93,10 +94,10 @@
(bytes->preserve
(annotated-item bs)
(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?
#:on-short (lambda () (parse-error "Incomplete embedded binary value")))]
[#\! (decode-embedded (next))]
#:on-short (lambda () (parse-error "Incomplete inline binary value")))]
[#\! (embedded (decode-embedded (next)))]
[c (parse-error "Invalid # syntax: ~v" c)])]
[#\< (match (read-sequence #\>)

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

@ -9,22 +9,17 @@
(require racket/runtime-path)
(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])
(for [(i (in-range 1 (- (bytes-length bs) 1)))]
(define result (bytes->preserve (subbytes bs 0 i)
#:decode-embedded embedded/no-annotations
#:decode-embedded strip-annotations
#: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)))
(bytes->preserve bs
#:read-syntax? #t
#:decode-embedded embedded/no-annotations
#:decode-embedded strip-annotations
#:on-short (lambda () 'short)
void))
@ -134,28 +129,28 @@
[(asymmetric f b) (values f b #f)] ;; #f because e.g. annotation4 includes annotations
[v (values v v #t)]))
(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
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
loc) ;; expectation 3
(check-equal? (d-strip binary-form) back loc) ;; expectation 4
(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
loc) ;; expectation 6
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
(preserve->string #:encode-embedded embedded-value text-form))
(check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded values text-form))
back
loc) ;; expectation 7
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
(preserve->string #:encode-embedded embedded-value forward))
(check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded values forward))
back
loc) ;; expectation 8
;; similar to 8:
(check-equal? (string->preserve #:decode-embedded embedded/no-annotations
(preserve->string #:encode-embedded embedded-value
(check-equal? (string->preserve #:decode-embedded strip-annotations
(preserve->string #:encode-embedded values
annotated-text-form)
#:read-syntax? #t)
annotated-text-form
@ -165,7 +160,7 @@
(and can-execute-nondet-with-canonicalization?)))
;; expectations 9 and 10
(check-equal? (preserve->bytes forward
#:encode-embedded embedded-value
#:encode-embedded values
#:canonicalizing? #t
#:write-annotations? #t)
binary-form
@ -173,7 +168,7 @@
(unless (memq variety '(decode nondeterministic))
;; expectation 11
(check-equal? (preserve->bytes annotated-text-form
#:encode-embedded embedded-value
#:encode-embedded values
#:write-annotations? #t)
binary-form
loc)))
@ -185,7 +180,7 @@
(port-count-lines! p)
(read-preserve p
#:read-syntax? #t
#:decode-embedded embedded/no-annotations
#:decode-embedded strip-annotations
#:source path)))))
(match-define (peel-annotations `#s(TestCases ,tests)) testfile)
(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"
(set! annotations? #f)])
(struct embedded (value) #:transparent)
(let loop ((count count))
(when (positive? count)
(define v ((if annotations? values strip-annotations)
(match input-format
['any (read-preserve #:read-syntax? #t #:decode-embedded embedded #:source "<stdin>")]
['text (read-preserve/text #:read-syntax? #t #:decode-embedded embedded #:source "<stdin>")]
['binary (read-preserve/binary #:decode-embedded embedded #:read-syntax? #t)])))
['any (read-preserve #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['text (read-preserve/text #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['binary (read-preserve/binary #:decode-embedded values #:read-syntax? #t)])))
(when (not (eof-object? v))
(void (match output-format
['text
(write-preserve/text v #:indent indent? #:encode-embedded embedded-value)
(write-preserve/text v #:indent indent? #:encode-embedded values)
(newline)]
['binary
(write-preserve/binary v #:encode-embedded embedded-value #:write-annotations? #t)]))
(write-preserve/binary v #:encode-embedded values #:write-annotations? #t)]))
(flush-output)
(loop (- count 1))))))

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

@ -6,6 +6,7 @@
(require racket/match)
(require (only-in racket/port call-with-output-bytes))
(require "record.rkt")
(require "embedded.rkt")
(require "float.rkt")
(require "annotation.rkt")
(require "varint.rkt")
@ -120,8 +121,10 @@
[(? set?) (with-seq 6 (output-set v))]
[(? dict?) (with-seq 7 (output-dict v))]
[other
[(embedded value)
(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))

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

@ -9,6 +9,7 @@
(require racket/match)
(require racket/format)
(require net/base64)
(require "embedded.rkt")
(require "annotation.rkt")
(require "float.rkt")
(require "record.rkt")
@ -168,9 +169,10 @@
[(? list?) (write-sequence distance "[" (if commas? "," "") "]" write-value v)]
[(? set?) (write-sequence distance "#{" (if commas? "," "") "}" write-value (set->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))