From e6efd03be72449d9504776b91329160c233b702c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 26 May 2021 21:09:06 +0200 Subject: [PATCH] Introduce explicit embedded wrapper --- .../racket/preserves/preserves/embedded.rkt | 5 +++ .../racket/preserves/preserves/main.rkt | 2 ++ .../preserves/preserves/read-binary.rkt | 3 +- .../racket/preserves/preserves/read-text.rkt | 7 ++-- .../preserves/preserves/tests/test-main.rkt | 33 ++++++++----------- .../racket/preserves/preserves/tool.rkt | 12 +++---- .../preserves/preserves/write-binary.rkt | 7 ++-- .../racket/preserves/preserves/write-text.rkt | 6 ++-- 8 files changed, 41 insertions(+), 34 deletions(-) create mode 100644 implementations/racket/preserves/preserves/embedded.rkt diff --git a/implementations/racket/preserves/preserves/embedded.rkt b/implementations/racket/preserves/preserves/embedded.rkt new file mode 100644 index 0000000..83c5984 --- /dev/null +++ b/implementations/racket/preserves/preserves/embedded.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out embedded)) + +(struct embedded (value) #:transparent) diff --git a/implementations/racket/preserves/preserves/main.rkt b/implementations/racket/preserves/preserves/main.rkt index 6808018..cbb85e6 100644 --- a/implementations/racket/preserves/preserves/main.rkt +++ b/implementations/racket/preserves/preserves/main.rkt @@ -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") diff --git a/implementations/racket/preserves/preserves/read-binary.rkt b/implementations/racket/preserves/preserves/read-binary.rkt index d2fc3ee..0ec1f28 100644 --- a/implementations/racket/preserves/preserves/read-binary.rkt +++ b/implementations/racket/preserves/preserves/read-binary.rkt @@ -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))] diff --git a/implementations/racket/preserves/preserves/read-text.rkt b/implementations/racket/preserves/preserves/read-text.rkt index c272210..37043b3 100644 --- a/implementations/racket/preserves/preserves/read-text.rkt +++ b/implementations/racket/preserves/preserves/read-text.rkt @@ -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 #\>) diff --git a/implementations/racket/preserves/preserves/tests/test-main.rkt b/implementations/racket/preserves/preserves/tests/test-main.rkt index d696c9f..31120b1 100644 --- a/implementations/racket/preserves/preserves/tests/test-main.rkt +++ b/implementations/racket/preserves/preserves/tests/test-main.rkt @@ -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)))] diff --git a/implementations/racket/preserves/preserves/tool.rkt b/implementations/racket/preserves/preserves/tool.rkt index 3f751d4..c44b27e 100644 --- a/implementations/racket/preserves/preserves/tool.rkt +++ b/implementations/racket/preserves/preserves/tool.rkt @@ -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 "")] - ['text (read-preserve/text #:read-syntax? #t #:decode-embedded embedded #:source "")] - ['binary (read-preserve/binary #:decode-embedded embedded #:read-syntax? #t)]))) + ['any (read-preserve #:read-syntax? #t #:decode-embedded values #:source "")] + ['text (read-preserve/text #:read-syntax? #t #:decode-embedded values #:source "")] + ['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)))))) diff --git a/implementations/racket/preserves/preserves/write-binary.rkt b/implementations/racket/preserves/preserves/write-binary.rkt index 0351cb8..664b433 100644 --- a/implementations/racket/preserves/preserves/write-binary.rkt +++ b/implementations/racket/preserves/preserves/write-binary.rkt @@ -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)) diff --git a/implementations/racket/preserves/preserves/write-text.rkt b/implementations/racket/preserves/preserves/write-text.rkt index 4ed996f..3bfb75d 100644 --- a/implementations/racket/preserves/preserves/write-text.rkt +++ b/implementations/racket/preserves/preserves/write-text.rkt @@ -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))