diff --git a/implementations/racket/preserves/main.rkt b/implementations/racket/preserves/main.rkt index b6ecde5..2d292db 100644 --- a/implementations/racket/preserves/main.rkt +++ b/implementations/racket/preserves/main.rkt @@ -2,7 +2,7 @@ ;; Preserve, as in Fruit Preserve, as in a remarkably weak pun on pickling/dehydration etc (provide (struct-out stream-of) - (struct-out record) + (all-from-out "record.rkt") (struct-out annotated) annotate strip-annotations @@ -30,9 +30,9 @@ (require (only-in racket/port with-output-to-string)) (require racket/set) (require bitsyntax) -(require "struct.rkt") +(require "record.rkt") (require "varint.rkt") -(require (only-in syntax/readerr raise-read-error)) +(require (only-in syntax/readerr raise-read-error raise-read-eof-error)) (struct stream-of (kind generator) #:transparent) @@ -49,12 +49,6 @@ (define (hash-proc a h) (h (annotated-item a))) (define (hash2-proc a h) (h (annotated-item a)))]) -(struct record (label fields) #:transparent) - -(define (build-record label fields) - (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))] - (apply make-prefab-struct label fields))) - (define (annotate v . as) (match v [(annotated annotations srcloc item) @@ -71,14 +65,11 @@ (match v [(annotated _ _ item) (match item - [(record label fields) (build-record (walk* label depth) (map walk fields))] - [(? non-object-struct?) - (error 'strip-annotations "Cannot strip-annotations from struct: ~v" v)] + [(record label fields) (record (walk* label depth) (map walk fields))] [(? list?) (map walk item)] [(? set?) (for/set [(i (in-set item))] (walk i))] [(? dict?) (for/hash [((k v) (in-dict item))] (values (walk* k depth) (walk v)))] - [(? annotated?) - (error 'strip-annotations "Improper annotation structure: ~v" v)] + [(? annotated?) (error 'strip-annotations "Improper annotation structure: ~v" v)] [_ item])] [_ v])))) @@ -157,9 +148,6 @@ (define (dict-keys-and-values d) (reverse (for/fold [(acc '())] [((k v) (in-dict d))] (cons v (cons k acc))))) -(define (encode-record key fields) - (encode-array-like 0 (cons key fields))) - (define (encode-value v) (match ((current-value->placeholder) v) [(? integer? n) @@ -192,15 +180,10 @@ [(? bytes?) (encode-binary-like 2 v)] [(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))] - [(record label fields) (encode-record label fields)] - [(? non-object-struct?) - (define key (prefab-struct-key v)) - (when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v)) - (encode-record key (cdr (vector->list (struct->vector v))))] - - [(? list?) (encode-array-like 1 v)] - [(? set?) (encode-array-like 2 (set->list v))] - [(? dict?) (encode-array-like 3 (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 (set->list v))] + [(? dict?) (encode-array-like 3 (dict-keys-and-values v))] [_ (error 'encode-value "Cannot encode value ~v" v)])])) @@ -232,7 +215,7 @@ (define (decode-compound minor vs rest ks kf) (match* (minor vs) - [(0 (list* label fields)) (ks (build-record label fields) rest)] + [(0 (list* label fields)) (ks (record label fields) rest)] [(0 '()) (kf)] [(1 _) (ks vs rest)] [(2 _) (ks (list->set vs) rest)] @@ -360,18 +343,18 @@ (define (skip-whitespace* i) (regexp-match? #px#"^(\\s|,)*" i)) ;; side effect: consumes matched portion of input -(define (parse-error* i fmt . args) +(define (parse-error* #:raise-proc [raise-proc raise-read-error] i source fmt . args) (define-values [line column pos] (port-next-location i)) - (raise-read-error (format "read-preserve: ~a" (apply format fmt args)) - (object-name i) - line - column - pos - #f)) + (raise-proc (format "read-preserve: ~a" (apply format fmt args)) + source + line + column + pos + #f)) (define (read-preserve [i (current-input-port)] #:read-syntax? [read-syntax? #f] - #:source [source #f]) + #:source [source (object-name i)]) (local-require net/base64) (local-require file/sha1) @@ -380,11 +363,12 @@ [(_ re pat) (app (lambda (v) (regexp-try-match re v)) pat)])) (define (parse-error fmt . args) - (apply parse-error* i fmt args)) + (apply parse-error* i source fmt args)) (define (eof-guard v) (match v - [(? eof-object?) (parse-error "Unexpected end of input")] + [(? eof-object?) + (parse-error* #:raise-proc raise-read-eof-error i source "Unexpected end of input")] [v v])) (define (peek/no-eof) (eof-guard (peek-char i))) @@ -395,6 +379,10 @@ (define (read-sequence terminator) (sequence-fold '() (lambda (acc v) (cons v acc)) reverse terminator)) + (define (set-add* s e) + (when (set-member? s e) (parse-error "Duplicate set element: ~v" e)) + (set-add s e)) + (define (read-dictionary-or-set seed) (sequence-fold seed (lambda (acc k) @@ -402,9 +390,11 @@ (match (peek-char i) [#\: (read-char i) (when (set? acc) (parse-error "Unexpected key/value separator in set")) - (hash-set (or acc (hash)) k (read-value))] + (let ((acc (or acc (hash)))) + (when (hash-has-key? acc k) (parse-error "Duplicate key: ~v" k)) + (hash-set acc k (read-value)))] [_ (when (hash? acc) (parse-error "Missing expected key/value separator")) - (set-add (or acc (set)) k)])) + (set-add* (or acc (set)) k)])) (lambda (acc) (or acc (hash))) #\})) @@ -415,7 +405,7 @@ #\" #\; #\, #\# #\: (== PIPE) (? char-whitespace?)))) (if (null? acc) - (parse-error "Invalid character ~v at start of value; skipping" (read-char i)) + (parse-error "Invalid character ~v at start of value" (peek-char i)) (string->symbol (list->string (reverse acc))))] [_ (read-raw-symbol (cons (read-char i) acc))])) @@ -592,13 +582,13 @@ [#\< (read-char i) (match (read-sequence #\>) ['() (parse-error "Missing record label")] - [(cons head fields) (build-record head fields)])] + [(cons head fields) (record head fields)])] [(or #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read-number)] [#\" (read-char i) (read-string #\")] [(== PIPE) (read-char i) (string->symbol (read-string PIPE))] [#\# (match i [(px #px#"^#set\\{" (list _)) - (sequence-fold (set) set-add values #\})] + (sequence-fold (set) set-add* values #\})] [(px #px#"^#value" (list _)) (define bs (read-preserve i #:read-syntax? #t)) (when (not (bytes? (annotated-item bs))) @@ -630,13 +620,14 @@ (define (string->preserve s #:read-syntax? [read-syntax? #f] #:track-position? [track-position? #t]) (define p (open-input-string s)) + (define source "") (when track-position? (port-count-lines! p)) - (define v (read-preserve p #:read-syntax? read-syntax? #:source "")) + (define v (read-preserve p #:read-syntax? read-syntax? #:source source)) (when (eof-object? v) - (parse-error* p "Unexpected end of input")) + (parse-error* #:raise-proc raise-read-eof-error p source "Unexpected end of input")) (skip-whitespace* p) (when (not (eof-object? (peek-char p))) - (parse-error* p "Unexpected text following preserve")) + (parse-error* p source "Unexpected text following preserve")) v) (define (string->preserve-syntax s) @@ -774,11 +765,6 @@ [_ (write-stringlike-char c)])) (! "|")))] [(record label fields) (write-record distance label fields)] - [(? non-object-struct?) - (define key (prefab-struct-key v)) - (when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v)) - (write-record distance key (cdr (vector->list (struct->vector v))))] - [(? list?) (write-sequence distance "[" "," "]" write-value v)] [(? set?) (write-sequence distance "#set{" "," "}" write-value (set->list v))] [(? dict?) (write-sequence distance "{" "," "}" write-key-value (dict->list v))] @@ -996,9 +982,11 @@ (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 t* - [(peel-annotations `#s(Test ,(strip-annotations binary-form) ,annotated-text-form)) + (match (peel-annotations t*) + [`#s(Test ,(strip-annotations binary-form) ,annotated-text-form) (define text-form (strip-annotations annotated-text-form)) (define-values (forward back) (match (hash-ref samples-txt-expected t-name text-form) @@ -1011,6 +999,21 @@ (check-equal? (d binary-form) annotated-text-form loc) (check-equal? (encode forward) binary-form loc) (check-equal? (encode annotated-text-form) binary-form loc)] + [`#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"))] [_ (write-preserve t* #:indent #f) (newline)]))) diff --git a/implementations/racket/preserves/record.rkt b/implementations/racket/preserves/record.rkt new file mode 100644 index 0000000..1712d2b --- /dev/null +++ b/implementations/racket/preserves/record.rkt @@ -0,0 +1,48 @@ +#lang racket/base + +(provide (prefix-out mirror: (struct-out record)) + (rename-out [record-expander record] + [record?* record?] + [record-label* record-label] + [record-fields* record-fields])) + +(require racket/match) +(require "struct.rkt") + +(struct record (label fields) #:transparent) + +(define (build-record label fields) + (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))] + (apply make-prefab-struct label fields))) + +(define (unrecord r) + (match r + [(record label fields) (values #t label fields)] + [(? non-object-struct?) + (define key (prefab-struct-key r)) + (when (not key) (error 'preserves "Cannot process non-prefab struct ~v" r)) + (values #t key (cdr (vector->list (struct->vector r))))] + [_ (values #f #f #f)])) + +(define-match-expander record-expander + (syntax-rules () [(_ lpat fpat) (app unrecord #t lpat fpat)]) + (syntax-rules () [(_ lval fval) (build-record lval fval)])) + +(define (record?* r) + (match r + [(record-expander _ _) #t] + [_ #f])) + +(define (record-label* r) + (match-define (record-expander l _) r) + l) + +(define (record-fields* r) + (match-define (record-expander _ f) r) + f) + +(module+ test + (require rackunit) + (check-true (record?* (build-record "label" (list 123 234)))) + (check-true (record?* (build-record 'label (list 123 234)))) + (check-false (record?* "string"))) diff --git a/tests/samples.txt b/tests/samples.txt index dcb6029..8651281 100644 --- a/tests/samples.txt +++ b/tests/samples.txt @@ -86,6 +86,7 @@ set1a: set2: @"Missing close brace" set2a: @"Missing close brace" + set3: @"Duplicate value" stream1: @"Chunk must be bytes" stream2: @"Chunk must be bytes" stream3: @"Chunk must be bytes"