syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Better record support; more test implementations; fixes

This commit is contained in:
Tony Garnock-Jones 2019-08-22 09:57:57 +01:00
parent e90a790963
commit adda505f45
3 changed files with 104 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
implementations/racket/preserves/main.rkt
View File

@ -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)])))

48
implementations/racket/preserves/record.rkt Normal file
View File

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

1
tests/samples.txt
View File

@ -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}>