Better record support; more test implementations; fixes

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))]
+             [(record label fields) (record (walk* label depth) (map walk fields))]
-             [(? non-object-struct?)
-              (error 'strip-annotations "Cannot strip-annotations from struct: ~v" v)]
              [(? 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?)
+             [(? annotated?) (error 'strip-annotations "Improper annotation structure: ~v" v)]
-              (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)]
+       [(record label fields) (encode-array-like 0 (cons label fields))]
-       [(? non-object-struct?)
+       [(? list?) (encode-array-like 1 v)]
-        (define key (prefab-struct-key v))
+       [(? set?) (encode-array-like 2 (set->list v))]
-        (when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v))
+       [(? dict?) (encode-array-like 3 (dict-keys-and-values 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))]
 
        [_ (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))
+  (raise-proc (format "read-preserve: ~a" (apply format fmt args))
-                    (object-name i)
+              source
-                    line
+              line
-                    column
+              column
-                    pos
+              pos
-                    #f))
+              #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 "<string>")
   (when track-position? (port-count-lines! p))
-  (define v (read-preserve p #:read-syntax? read-syntax? #:source "<string>"))
+  (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*
+        (match (peel-annotations t*)
-          [(peel-annotations `#s(Test ,(strip-annotations binary-form) ,annotated-text-form))
+          [`#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)])))

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")))

tests/samples.txt

@@ -86,6 +86,7 @@
   set1a: <NondeterministicTest #hex{a3313233} #set{1 2 3}>
   set2: @"Missing close brace" <ParseShort "#set{ 1 2 3 ">
   set2a: @"Missing close brace" <ParseShort "#set{">
+  set3: @"Duplicate value" <ParseError "#set{a a}">
   stream1: @"Chunk must be bytes" <DecodeError #hex{25516104}>
   stream2: @"Chunk must be bytes" <DecodeError #hex{25716104}>
   stream3: @"Chunk must be bytes" <DecodeError #hex{26516104}>