forked from syndicate-lang/preserves
Better record support; more test implementations; fixes
This commit is contained in:
parent
e90a790963
commit
adda505f45
|
@ -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 "<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*
|
||||
[(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)])))
|
||||
|
|
|
@ -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")))
|
|
@ -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}>
|
||||
|
|
Loading…
Reference in New Issue