Uniform annotations in syntax mode; WIP update binary codec
This commit is contained in:
parent
e84b4c5780
commit
3f0ec34d49
|
|
@ -3,21 +3,20 @@
|
|||
|
||||
(provide (struct-out stream-of)
|
||||
(struct-out record)
|
||||
(struct-out annotations)
|
||||
(struct-out key-annotation)
|
||||
(struct-out value-annotation)
|
||||
(struct-out annotated)
|
||||
strip-annotations
|
||||
read-preserve
|
||||
read-preserve/no-annotations
|
||||
read-preserve-syntax
|
||||
string->preserve
|
||||
string->preserve/no-annotations
|
||||
string->preserve-syntax
|
||||
write-preserve
|
||||
preserve->string
|
||||
current-value->placeholder
|
||||
current-placeholder->value
|
||||
encode
|
||||
decode
|
||||
wire-value
|
||||
in-hash/annotations
|
||||
in-set/annotations
|
||||
in-list/annotations)
|
||||
decode-syntax
|
||||
wire-value)
|
||||
|
||||
(require racket/bytes)
|
||||
(require racket/dict)
|
||||
|
|
@ -33,36 +32,68 @@
|
|||
|
||||
(struct stream-of (kind generator) #:transparent)
|
||||
|
||||
(struct annotations (here here-annotations links) #:transparent)
|
||||
(struct key-annotation (key) #:transparent)
|
||||
(struct value-annotation (key) #:transparent)
|
||||
|
||||
(define empty-annotations (annotations '() (hash) (hash)))
|
||||
|
||||
(define (empty-annotations? anns)
|
||||
(and (null? (annotations-here anns))
|
||||
(hash-empty? (annotations-here-annotations anns))
|
||||
(hash-empty? (annotations-links anns))))
|
||||
;; Syntax properties and syntax objects would be almost perfect for
|
||||
;; representing annotations, plus position/source tracking as
|
||||
;; lagniappe, but unfortunately they don't play nicely with data much
|
||||
;; outside of ordinary S-expressions as found in Racket source.
|
||||
;;
|
||||
;; So we do our own thing, for now.
|
||||
;;
|
||||
(struct annotated (annotations srcloc item) #:transparent
|
||||
#:methods gen:equal+hash
|
||||
[(define (equal-proc a b =?) (=? (annotated-item a) (annotated-item b)))
|
||||
(define (hash-proc a h) (h (annotated-item a)))
|
||||
(define (hash2-proc a h) (h (annotated-item a)))])
|
||||
|
||||
(struct record (label fields) #:transparent)
|
||||
|
||||
(define short-form-labels
|
||||
(make-parameter (vector 'discard 'capture 'observe)))
|
||||
(define (build-record label fields)
|
||||
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
|
||||
(apply make-prefab-struct label fields)))
|
||||
|
||||
(define (strip-annotations v)
|
||||
(let walk ((v v))
|
||||
(match v
|
||||
[(annotated _ _ item)
|
||||
(match item
|
||||
[(record label fields) (build-record (walk label) (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) (walk v)))]
|
||||
[(? annotated?)
|
||||
(error 'strip-annotations "Improper annotation structure: ~v" v)]
|
||||
[_ item])]
|
||||
[_ v])))
|
||||
|
||||
(define current-value->placeholder (make-parameter (lambda (v) #f)))
|
||||
(define current-placeholder->value (make-parameter (lambda (v) (void))))
|
||||
|
||||
(define (encode v)
|
||||
(bit-string->bytes (bit-string (v :: (wire-value)))))
|
||||
|
||||
(define ((default-on-short bs)) (error 'decode "Short encoding: ~v" bs))
|
||||
(define ((default-on-fail bs)) (error 'decode "Invalid encoding: ~v" bs))
|
||||
|
||||
(define (decode bs
|
||||
#:on-short [on-short (lambda () (error 'decode "Short encoding: ~v" bs))]
|
||||
[on-fail (lambda () (error 'decode "Invalid encoding: ~v" bs))])
|
||||
#:read-syntax? [read-syntax? #f]
|
||||
#:on-short [on-short (default-on-short bs)]
|
||||
[on-fail (default-on-fail bs)])
|
||||
(bit-string-case bs
|
||||
#:on-short (lambda (fail) (on-short))
|
||||
([ (v :: (wire-value)) ] v)
|
||||
([ (v :: (wire-value #:read-syntax? read-syntax?)) ] v)
|
||||
(else (on-fail))))
|
||||
|
||||
(define (decode-syntax bs
|
||||
#:on-short [on-short (default-on-short bs)]
|
||||
[on-fail (default-on-fail bs)])
|
||||
(decode #:read-syntax? #t #:on-short on-short #:on-fail on-fail))
|
||||
|
||||
(define-syntax wire-value
|
||||
(syntax-rules ()
|
||||
[(_ #t input ks kf) (decode-value input ks kf)]
|
||||
[(_ #t input ks kf) (decode-value input ks kf #:read-syntax? #f)]
|
||||
[(_ #t input ks kf #:read-syntax? rs) (decode-value input ks kf #:read-syntax? rs)]
|
||||
[(_ #f v) (encode-value v)]))
|
||||
|
||||
(define-syntax wire-length
|
||||
|
|
@ -76,48 +107,32 @@
|
|||
(bit-string (v :: bits 4))
|
||||
(bit-string (#b1111 :: bits 4) ((encode-varint v) :: binary))))
|
||||
|
||||
(define (encode-array-like major minor fields)
|
||||
(bit-string (major :: bits 2)
|
||||
(define (encode-array-like minor fields)
|
||||
(bit-string (2 :: bits 2)
|
||||
(minor :: bits 2)
|
||||
((length fields) :: (wire-length))
|
||||
((apply bit-string-append (map encode-value fields)) :: binary)))
|
||||
|
||||
(define (encode-binary-like major minor bs)
|
||||
(bit-string (major :: bits 2)
|
||||
(define (encode-binary-like minor bs)
|
||||
(bit-string (1 :: bits 2)
|
||||
(minor :: bits 2)
|
||||
((bytes-length bs) :: (wire-length))
|
||||
(bs :: binary)))
|
||||
|
||||
(define (encode-start-byte major minor)
|
||||
(bit-string (#b0010 :: bits 4) (major :: bits 2) (minor :: bits 2)))
|
||||
|
||||
(define (encode-end-byte major minor)
|
||||
(bit-string (#b0011 :: bits 4) (major :: bits 2) (minor :: bits 2)))
|
||||
|
||||
(define (encode-stream major minor chunk-ok? generator)
|
||||
(bit-string-append (encode-start-byte major minor)
|
||||
(bit-string-append (bit-string (#b0010 :: bits 4) (major :: bits 2) (minor :: bits 2))
|
||||
(let loop ()
|
||||
(match (generator)
|
||||
[(? void?) #""]
|
||||
[(? chunk-ok? v) (bit-string-append (encode-value v) (loop))]
|
||||
[bad (error 'encode-stream "Cannot encode chunk: ~v" bad)]))
|
||||
(encode-end-byte major minor)))
|
||||
(bit-string #b00000100)))
|
||||
|
||||
(define (dict-keys-and-values d)
|
||||
(reverse (for/fold [(acc '())] [((k v) (in-dict d))] (cons v (cons k acc)))))
|
||||
|
||||
(define (short-form-for-label key)
|
||||
(let ((labels (short-form-labels)))
|
||||
(let loop ((i 0))
|
||||
(cond [(= i 3) #f]
|
||||
[(equal? (vector-ref labels i) key) i]
|
||||
[else (loop (+ i 1))]))))
|
||||
|
||||
(define (encode-record key fields)
|
||||
(define short (short-form-for-label key))
|
||||
(if short
|
||||
(encode-array-like 2 short fields)
|
||||
(encode-array-like 2 3 (cons key fields))))
|
||||
(encode-array-like 0 (cons key fields)))
|
||||
|
||||
(define (encode-value v)
|
||||
(match v
|
||||
|
|
@ -125,22 +140,26 @@
|
|||
[#t (bytes #b00000001)]
|
||||
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
|
||||
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
|
||||
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0001 :: bits 4) (x :: bits 4))]
|
||||
[(annotated annotations _ item)
|
||||
(apply bit-string-append
|
||||
(map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary))) annotations)
|
||||
(encode-value item))]
|
||||
[(stream-of 'string p) (encode-stream 1 1 bytes? p)]
|
||||
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? p)]
|
||||
[(stream-of 'symbol p) (encode-stream 1 3 bytes? p)]
|
||||
[(stream-of 'sequence p) (encode-stream 3 0 (lambda (x) #t) p)]
|
||||
[(stream-of 'set p) (encode-stream 3 1 (lambda (x) #t) p)]
|
||||
[(stream-of 'dictionary p) (encode-stream 3 2 (lambda (x) #t) p)]
|
||||
[(stream-of 'sequence p) (encode-stream 2 1 (lambda (x) #t) p)]
|
||||
[(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) p)]
|
||||
[(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) p)]
|
||||
|
||||
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))]
|
||||
;; [0 (bytes #b10000000)]
|
||||
[(? integer?)
|
||||
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
|
||||
(define byte-count (quotient (+ raw-bit-count 7) 8))
|
||||
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
|
||||
[(? string?) (encode-binary-like 1 1 (string->bytes/utf-8 v))]
|
||||
[(? bytes?) (encode-binary-like 1 2 v)]
|
||||
[(? symbol?) (encode-binary-like 1 3 (string->bytes/utf-8 (symbol->string v)))]
|
||||
[(? string?) (encode-binary-like 1 (string->bytes/utf-8 v))]
|
||||
[(? 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?)
|
||||
|
|
@ -148,9 +167,9 @@
|
|||
(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 3 0 v)]
|
||||
[(? set?) (encode-array-like 3 1 (set->list v))]
|
||||
[(? dict?) (encode-array-like 3 2 (dict-keys-and-values 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)]))
|
||||
|
||||
|
|
@ -169,15 +188,6 @@
|
|||
([ (v :: bits 4) (rest :: binary) ] (ks v rest))
|
||||
(else (kf))))
|
||||
|
||||
(define (decode-values n acc-rev bs ks kf)
|
||||
(if (zero? n)
|
||||
(ks (reverse acc-rev) bs)
|
||||
(bit-string-case bs
|
||||
#:on-short (lambda (fail) (kf #t))
|
||||
([ (v :: (wire-value)) (rest :: binary) ]
|
||||
(decode-values (- n 1) (cons v acc-rev) rest ks kf))
|
||||
(else (kf)))))
|
||||
|
||||
(define (decode-binary minor bs rest ks kf)
|
||||
(match minor
|
||||
[0 (if (positive? (bit-string-length bs))
|
||||
|
|
@ -189,73 +199,128 @@
|
|||
(define s (bytes->string/utf-8 bs))
|
||||
(lambda () (ks (if (= minor 3) (string->symbol s) s) rest))))]))
|
||||
|
||||
(define (build-record label fields)
|
||||
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
|
||||
(apply make-prefab-struct label fields)))
|
||||
(define (decode-compound minor vs rest ks kf)
|
||||
(match* (minor vs)
|
||||
[(0 (list* label fields)) (ks (build-record label fields) rest)]
|
||||
[(0 '()) (kf)]
|
||||
[(1 _) (ks vs rest)]
|
||||
[(2 _) (ks (list->set vs) rest)]
|
||||
[(3 _) (if (even? (length vs))
|
||||
(ks (apply hash vs) rest)
|
||||
(kf))]))
|
||||
|
||||
(define (decode-record minor fields rest ks kf)
|
||||
(match* (minor fields)
|
||||
[(3 (list* key fs)) (ks (build-record key fs) rest)]
|
||||
[(3 '()) (kf)]
|
||||
[(n fs) (ks (build-record (vector-ref (short-form-labels) n) fs) rest)]))
|
||||
(define (decode-value input ks kf #:read-syntax? read-syntax?)
|
||||
|
||||
(define (decode-collection minor vs rest ks kf)
|
||||
(match minor
|
||||
[0 (ks vs rest)]
|
||||
[1 (ks (list->set vs) rest)]
|
||||
[2 (if (even? (length vs))
|
||||
(ks (apply hash vs) rest)
|
||||
(kf))]
|
||||
[_ (kf)]))
|
||||
(define (position rest)
|
||||
(- (bytes-length input) (arithmetic-shift (bit-string-length rest) -3)))
|
||||
|
||||
(define (decode-stream major minor chunk-ok? join-chunks decode rest ks kf)
|
||||
(let loop ((acc-rev '()) (rest rest))
|
||||
(bit-string-case rest
|
||||
(define nil-annotation
|
||||
(if read-syntax?
|
||||
(lambda (ks bs)
|
||||
(lambda (result rest)
|
||||
(define pos0 (position bs))
|
||||
(define pos1 (position rest))
|
||||
(ks (annotated '()
|
||||
(srcloc #f #f #f (+ pos0 1) (- pos1 pos0))
|
||||
result)
|
||||
rest)))
|
||||
(lambda (ks bs) ks)))
|
||||
|
||||
(define cons-annotation
|
||||
(if read-syntax?
|
||||
(lambda (ks a v rest)
|
||||
(match-define (annotated annotations srcloc item) v)
|
||||
(ks (annotated (cons a annotations) srcloc item) rest))
|
||||
(lambda (ks a v rest)
|
||||
(ks v rest))))
|
||||
|
||||
(define (decode-values n bs ks kf)
|
||||
(let loop ((n n) (acc-rev '()) (bs bs))
|
||||
(if (zero? n)
|
||||
(ks (reverse acc-rev) bs)
|
||||
(decode-one bs (lambda (v rest) (loop (- n 1) (cons v acc-rev) rest)) kf))))
|
||||
|
||||
(define (decode-stream minor annotations-ok chunk-ok? join-chunks decode bs ks kf)
|
||||
(let loop ((acc-rev '()) (rest bs))
|
||||
(define (accept-one chunk rest)
|
||||
(if (chunk-ok? chunk)
|
||||
(loop (cons chunk acc-rev) rest)
|
||||
(kf)))
|
||||
(bit-string-case rest
|
||||
#:on-short (lambda (fail) (kf #t))
|
||||
([ (= #b00000100 :: bits 8) (rest :: binary) ]
|
||||
(decode minor
|
||||
(join-chunks (reverse acc-rev))
|
||||
rest
|
||||
(nil-annotation ks bs)
|
||||
kf))
|
||||
([ (= #b00000101 :: bits 8) (rest1 :: binary) ]
|
||||
(if annotations-ok
|
||||
(decode-one rest accept-one kf)
|
||||
(kf)))
|
||||
(else
|
||||
(decode-one rest accept-one kf)))))
|
||||
|
||||
(define bytes-chunk?
|
||||
(if read-syntax?
|
||||
(lambda (v) (bytes? (annotated-item v)))
|
||||
bytes?))
|
||||
|
||||
(define bytes-chunk-append*
|
||||
(if read-syntax?
|
||||
(lambda (vs) (bytes-append* (map annotated-item vs)))
|
||||
bytes-append*))
|
||||
|
||||
(define (decode-one bs ks kf)
|
||||
(bit-string-case bs
|
||||
#:on-short (lambda (fail) (kf #t))
|
||||
([ (= #b0011 :: bits 4) (emajor :: bits 2) (eminor :: bits 2) (rest :: binary) ]
|
||||
(if (and (= major emajor) (= minor eminor))
|
||||
(decode minor (join-chunks (reverse acc-rev)) rest ks kf)
|
||||
(kf)))
|
||||
(else
|
||||
(decode-value rest
|
||||
(lambda (chunk rest)
|
||||
(if (chunk-ok? chunk)
|
||||
(loop (cons chunk acc-rev) rest)
|
||||
(kf)))
|
||||
kf)))))
|
||||
([ (= #b00000000 :: bits 8) (rest :: binary) ]
|
||||
((nil-annotation ks bs) #f rest))
|
||||
([ (= #b00000001 :: bits 8) (rest :: binary) ]
|
||||
((nil-annotation ks bs) #t rest))
|
||||
|
||||
(define (decode-value bs ks kf)
|
||||
(bit-string-case bs
|
||||
#:on-short (lambda (fail) (kf #t))
|
||||
([ (= #b00000000 :: bits 8) (rest :: binary) ] (ks #f rest))
|
||||
([ (= #b00000001 :: bits 8) (rest :: binary) ] (ks #t rest))
|
||||
([ (= #b00000010 :: bits 8) (v :: float bits 32) (rest :: binary) ] (ks (real->single-flonum v) rest))
|
||||
([ (= #b00000011 :: bits 8) (v :: float bits 64) (rest :: binary) ] (ks v rest))
|
||||
([ (= #b0001 :: bits 4) (x :: bits 4) (rest :: binary) ] (ks (if (> x 12) (- x 16) x) rest))
|
||||
([ (= #b00000010 :: bits 8) (v :: float bits 32) (rest :: binary) ]
|
||||
((nil-annotation ks bs) (real->single-flonum v) rest))
|
||||
([ (= #b00000011 :: bits 8) (v :: float bits 64) (rest :: binary) ]
|
||||
((nil-annotation ks bs) v rest))
|
||||
|
||||
([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
||||
(decode-stream 1 minor bytes? bytes-append* decode-binary rest ks kf))
|
||||
([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
||||
(decode-stream 2 minor (lambda (x) #t) values decode-record rest ks kf))
|
||||
([ (= #b001011 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
||||
(decode-stream 3 minor (lambda (x) #t) values decode-collection rest ks kf))
|
||||
([ (= #b00000101 :: bits 8) (rest :: binary) ]
|
||||
(decode-one rest
|
||||
(lambda (a rest)
|
||||
(decode-one rest
|
||||
(lambda (v rest)
|
||||
(cons-annotation ks a v rest))
|
||||
kf))
|
||||
kf))
|
||||
|
||||
([ (= #b01 :: bits 2) (minor :: bits 2) (byte-count :: (wire-length))
|
||||
(bits :: binary bytes byte-count)
|
||||
(rest :: binary) ]
|
||||
(decode-binary minor (bit-string->bytes bits) rest ks kf))
|
||||
([ (= #b0001 :: bits 4) (placeholder :: (wire-length)) (rest :: binary) ]
|
||||
(match ((current-placeholder->value) placeholder)
|
||||
[(? void?) (error 'decode "Invalid Preserves placeholder: ~v" placeholder)]
|
||||
[v ((nil-annotation ks bs) v rest)]))
|
||||
|
||||
([ (= #b10 :: bits 2) (minor :: bits 2) (field-count :: (wire-length)) (rest :: binary) ]
|
||||
(decode-values field-count '() rest
|
||||
(lambda (fields rest) (decode-record minor fields rest ks kf))
|
||||
kf))
|
||||
([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
||||
(decode-stream minor #f bytes-chunk? bytes-chunk-append* decode-binary rest ks kf))
|
||||
([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
||||
(decode-stream minor #t (lambda (x) #t) values decode-compound rest ks kf))
|
||||
|
||||
([ (= #b11 :: bits 2) (minor :: bits 2) (count :: (wire-length)) (rest :: binary) ]
|
||||
(decode-values count '() rest
|
||||
(lambda (vs rest) (decode-collection minor vs rest ks kf))
|
||||
kf))
|
||||
([ (= #b0011 :: bits 4) (x :: bits 4) (rest :: binary) ]
|
||||
((nil-annotation ks bs) (if (> x 12) (- x 16) x) rest))
|
||||
|
||||
(else (kf))))
|
||||
([ (= #b01 :: bits 2) (minor :: bits 2) (byte-count :: (wire-length))
|
||||
(bits :: binary bytes byte-count)
|
||||
(rest :: binary) ]
|
||||
(decode-binary minor (bit-string->bytes bits) rest (nil-annotation ks bs) kf))
|
||||
|
||||
([ (= #b10 :: bits 2) (minor :: bits 2) (field-count :: (wire-length)) (rest :: binary) ]
|
||||
(decode-values field-count
|
||||
rest
|
||||
(lambda (fields rest)
|
||||
(decode-compound minor fields rest (nil-annotation ks bs) kf))
|
||||
kf))
|
||||
|
||||
(else (kf))))
|
||||
|
||||
(decode-one input ks kf))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -273,25 +338,12 @@
|
|||
pos
|
||||
#f))
|
||||
|
||||
(define (read-preserve [i (current-input-port)] #:skip-annotations? [skip-annotations #f])
|
||||
(define (read-preserve [i (current-input-port)]
|
||||
#:read-syntax? [read-syntax? #f]
|
||||
#:source [source #f])
|
||||
(local-require net/base64)
|
||||
(local-require file/sha1)
|
||||
|
||||
(define *here-annotations* '())
|
||||
(define *here-annotation-annotations* '())
|
||||
(define *child-annotations* (hash))
|
||||
|
||||
(define (push-here-annotation! a aa v)
|
||||
(unless skip-annotations
|
||||
(set! *here-annotations* (cons a *here-annotations*))
|
||||
(set! *here-annotation-annotations* (cons aa *here-annotation-annotations*)))
|
||||
v)
|
||||
|
||||
(define (push-child-annotation! k aa)
|
||||
(unless skip-annotations
|
||||
(unless (empty-annotations? aa)
|
||||
(set! *child-annotations* (hash-set *child-annotations* k aa)))))
|
||||
|
||||
(define-match-expander px
|
||||
(syntax-rules ()
|
||||
[(_ re pat) (app (lambda (v) (regexp-try-match re v)) pat)]))
|
||||
|
|
@ -310,9 +362,7 @@
|
|||
(define (skip-whitespace) (skip-whitespace* i))
|
||||
|
||||
(define (read-sequence terminator)
|
||||
(define i 0)
|
||||
(define (next-key _acc _v) (begin0 i (set! i (+ i 1))))
|
||||
(sequence-fold '() (lambda (acc v) (cons v acc)) next-key reverse terminator))
|
||||
(sequence-fold '() (lambda (acc v) (cons v acc)) reverse terminator))
|
||||
|
||||
(define (read-dictionary-or-set seed)
|
||||
(sequence-fold seed
|
||||
|
|
@ -321,15 +371,9 @@
|
|||
(match (peek-char i)
|
||||
[#\: (read-char i)
|
||||
(when (set? acc) (parse-error "Unexpected key/value separator in set"))
|
||||
(define-values (v v-anns) (read-value/annotations))
|
||||
(push-child-annotation! (value-annotation k) v-anns)
|
||||
(hash-set (or acc (hash)) k v)]
|
||||
(hash-set (or acc (hash)) k (read-value))]
|
||||
[_ (when (hash? acc) (parse-error "Missing expected key/value separator"))
|
||||
(set-add (or acc (set)) k)]))
|
||||
(lambda (new-acc k)
|
||||
(if (hash? new-acc)
|
||||
(key-annotation k)
|
||||
k))
|
||||
(lambda (acc) (or acc (hash)))
|
||||
#\}))
|
||||
|
||||
|
|
@ -473,107 +517,108 @@
|
|||
[#\- (read-intpart (list (read-char i)))]
|
||||
[_ (read-intpart (list))]))
|
||||
|
||||
(define (sequence-fold acc accumulate-one compute-key finish terminator-char)
|
||||
(define (sequence-fold acc accumulate-one finish terminator-char)
|
||||
(let loop ((acc acc))
|
||||
(skip-whitespace)
|
||||
(match (peek/no-eof)
|
||||
[(== terminator-char) (read-char i) (finish acc)]
|
||||
[_ (define-values (next next-anns) (read-value/annotations))
|
||||
(define new-acc (accumulate-one acc next))
|
||||
(push-child-annotation! (compute-key acc next) next-anns)
|
||||
(loop new-acc)])))
|
||||
[_ (loop (accumulate-one acc (read-value)))])))
|
||||
|
||||
(define (read-value/annotations)
|
||||
(if skip-annotations
|
||||
(values (eof-guard (read-value)) empty-annotations)
|
||||
(let ((old-here-annotations *here-annotations*)
|
||||
(old-here-annotation-annotations *here-annotation-annotations*)
|
||||
(old-child-annotations *child-annotations*))
|
||||
(set! *here-annotations* '())
|
||||
(set! *here-annotation-annotations* '())
|
||||
(set! *child-annotations* (hash))
|
||||
(let* ((v (eof-guard (read-value)))
|
||||
(a (annotations *here-annotations*
|
||||
(for/hash [(i (in-naturals))
|
||||
(aa (in-list *here-annotation-annotations*))
|
||||
#:when (not (empty-annotations? aa))]
|
||||
(values i aa))
|
||||
*child-annotations*)))
|
||||
(set! *here-annotations* old-here-annotations)
|
||||
(set! *here-annotation-annotations* old-here-annotation-annotations)
|
||||
(set! *child-annotations* old-child-annotations)
|
||||
(values v a)))))
|
||||
(define nil-annotation
|
||||
(if read-syntax?
|
||||
(lambda (thunk)
|
||||
(define-values (line0 col0 pos0) (port-next-location i))
|
||||
(define v (thunk))
|
||||
(define-values (line1 col1 pos1) (port-next-location i))
|
||||
(define loc (and line0 col0 pos0 pos1 (srcloc source line0 col0 pos0 (- pos1 pos0))))
|
||||
(match v
|
||||
[(annotated annotations _ item) (annotated annotations loc item)]
|
||||
[item (annotated '() loc item)]))
|
||||
(lambda (thunk) (thunk))))
|
||||
|
||||
(define cons-annotation
|
||||
(if read-syntax?
|
||||
(lambda (a v)
|
||||
(match-define (annotated annotations srcloc item) v)
|
||||
(annotated (cons a annotations) srcloc item))
|
||||
(lambda (a v) v)))
|
||||
|
||||
(define (read-value)
|
||||
(skip-whitespace)
|
||||
(match (peek-char i)
|
||||
(define sigil (peek-char i))
|
||||
(match sigil
|
||||
[(? eof-object? o) o]
|
||||
[#\{ (read-char i) (read-dictionary-or-set #f)]
|
||||
[#\[ (read-char i) (read-sequence #\])]
|
||||
[#\< (read-char i)
|
||||
(match (read-sequence #\>)
|
||||
['() (parse-error "Missing record label")]
|
||||
[(cons head fields) (build-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))]
|
||||
[#\@ (read-char i)
|
||||
(define-values (a aa) (read-value/annotations))
|
||||
(define a (eof-guard (read-value)))
|
||||
(define v (eof-guard (read-value)))
|
||||
(push-here-annotation! a aa v)]
|
||||
[#\# (match i
|
||||
[(px #px#"^#set\\{" (list _))
|
||||
(sequence-fold (set) set-add (lambda (acc v) v) values #\})]
|
||||
[(px #px#"^#value" (list _))
|
||||
(define-values (bs anns) (read-value/annotations))
|
||||
(when (not (bytes? bs)) (parse-error "ByteString must follow #value"))
|
||||
(when (not (empty-annotations? anns))
|
||||
(parse-error "Annotations not permitted after #value"))
|
||||
(decode bs)]
|
||||
[(px #px#"^#true" (list _))
|
||||
#t]
|
||||
[(px #px#"^#false" (list _))
|
||||
#f]
|
||||
[(px #px#"^#\"" (list _))
|
||||
(read-literal-binary)]
|
||||
[(px #px#"^#hex\\{" (list _))
|
||||
(read-hex-binary '())]
|
||||
[(px #px#"^#base64\\{" (list _))
|
||||
(read-base64-binary '())]
|
||||
[_
|
||||
(read-char i)
|
||||
(parse-error "Invalid preserve value")])]
|
||||
[#\: (read-char i) (parse-error "Unexpected key/value separator between items")]
|
||||
[_ (read-raw-symbol '())]))
|
||||
(cons-annotation a v)]
|
||||
[_
|
||||
(nil-annotation
|
||||
(lambda ()
|
||||
(match sigil
|
||||
[#\{ (read-char i) (read-dictionary-or-set #f)]
|
||||
[#\[ (read-char i) (read-sequence #\])]
|
||||
[#\< (read-char i)
|
||||
(match (read-sequence #\>)
|
||||
['() (parse-error "Missing record label")]
|
||||
[(cons head fields) (build-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 #\})]
|
||||
[(px #px#"^#value" (list _))
|
||||
(define bs (read-preserve i #:read-syntax? #t))
|
||||
(when (not (bytes? (annotated-item bs)))
|
||||
(parse-error "ByteString must follow #value"))
|
||||
(when (not (null? (annotated-annotations bs)))
|
||||
(parse-error "Annotations not permitted after #value"))
|
||||
(decode (annotated-item bs) #:read-syntax? read-syntax?)]
|
||||
[(px #px#"^#true" (list _))
|
||||
#t]
|
||||
[(px #px#"^#false" (list _))
|
||||
#f]
|
||||
[(px #px#"^#\"" (list _))
|
||||
(read-literal-binary)]
|
||||
[(px #px#"^#hex\\{" (list _))
|
||||
(read-hex-binary '())]
|
||||
[(px #px#"^#base64\\{" (list _))
|
||||
(read-base64-binary '())]
|
||||
[_
|
||||
(read-char i)
|
||||
(parse-error "Invalid preserve value")])]
|
||||
[#\: (read-char i) (parse-error "Unexpected key/value separator between items")]
|
||||
[_ (read-raw-symbol '())])))]))
|
||||
|
||||
(read-value/annotations))
|
||||
(read-value))
|
||||
|
||||
(define (read-preserve/no-annotations [i (current-input-port)])
|
||||
(define-values (v _v-anns) (read-preserve i #:skip-annotations? #t))
|
||||
v)
|
||||
(define (read-preserve-syntax [i (current-input-port)]
|
||||
#:source [source #f])
|
||||
(read-preserve i #:read-syntax? #t #:source source))
|
||||
|
||||
(define (string->preserve s #:skip-annotations? [skip-annotations #f])
|
||||
(define (string->preserve s #:read-syntax? [read-syntax? #f] #:track-position? [track-position? #t])
|
||||
(define p (open-input-string s))
|
||||
(define-values (v v-anns) (read-preserve p #:skip-annotations? skip-annotations))
|
||||
(when track-position? (port-count-lines! p))
|
||||
(define v (read-preserve p #:read-syntax? read-syntax? #:source "<string>"))
|
||||
(when (eof-object? v)
|
||||
(parse-error* p "Unexpected end of input"))
|
||||
(skip-whitespace* p)
|
||||
(when (not (eof-object? (peek-char p)))
|
||||
(parse-error* p "Unexpected text following preserve"))
|
||||
(values v v-anns))
|
||||
|
||||
(define (string->preserve/no-annotations s)
|
||||
(define-values (v _v-anns) (string->preserve s #:skip-annotations? #t))
|
||||
v)
|
||||
|
||||
(define (string->preserve-syntax s)
|
||||
(string->preserve s #:read-syntax? #t))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (write-preserve v0 [o (current-output-port)] #:indent [indent-amount0 #f])
|
||||
(define indent-amount (match indent-amount0
|
||||
[#f #f]
|
||||
[#f 0]
|
||||
[#t 2] ;; a default
|
||||
[other other]))
|
||||
(define indenting? (and indent-amount #t))
|
||||
(define indenting? (and indent-amount0 #t))
|
||||
|
||||
(define-syntax-rule (! fmt arg ...) (fprintf o fmt arg ...))
|
||||
|
||||
|
|
@ -656,6 +701,12 @@
|
|||
|
||||
(define (write-value distance v)
|
||||
(match v
|
||||
[(annotated annotations _ item)
|
||||
(for [(a (in-list annotations))]
|
||||
(! "@")
|
||||
(write-value (+ distance 1) a)
|
||||
(!indent* distance))
|
||||
(write-value distance item)]
|
||||
[#f (! "#false")]
|
||||
[#t (! "#true")]
|
||||
[(? single-flonum?) (! "~vf" v)]
|
||||
|
|
@ -710,55 +761,6 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (in-hash/annotations h h-anns)
|
||||
(define links (annotations-links h-anns))
|
||||
(make-do-sequence (lambda ()
|
||||
(values
|
||||
(lambda (pos)
|
||||
(define-values (k v) (hash-iterate-key+value h pos))
|
||||
(define k-anns (hash-ref links (key-annotation k) empty-annotations))
|
||||
(define v-anns (hash-ref links (value-annotation k) empty-annotations))
|
||||
(values k k-anns v v-anns))
|
||||
(lambda (pos)
|
||||
(hash-iterate-next h pos))
|
||||
(hash-iterate-first h)
|
||||
values
|
||||
#f
|
||||
#f))))
|
||||
|
||||
(define (in-set/annotations s s-anns)
|
||||
(define links (annotations-links s-anns))
|
||||
(make-do-sequence (lambda ()
|
||||
(values
|
||||
(lambda (xs)
|
||||
(define x (car xs))
|
||||
(define x-anns (hash-ref links x empty-annotations))
|
||||
(values x x-anns))
|
||||
cdr
|
||||
(set->list s)
|
||||
pair?
|
||||
#f
|
||||
#f))))
|
||||
|
||||
(define (in-list/annotations xs xs-anns)
|
||||
(define links (annotations-links xs-anns))
|
||||
(make-do-sequence (lambda ()
|
||||
(define i 0)
|
||||
(values
|
||||
(lambda (xs)
|
||||
(define x (car xs))
|
||||
(define x-anns (hash-ref links
|
||||
(begin0 i (set! i (+ i 1)))
|
||||
empty-annotations))
|
||||
(values x x-anns))
|
||||
cdr
|
||||
xs
|
||||
pair?
|
||||
#f
|
||||
#f))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require racket/runtime-path)
|
||||
|
|
@ -870,6 +872,7 @@
|
|||
'value3 #t
|
||||
'value4 #t
|
||||
'value5 #t
|
||||
'value6 (list 1 2 3)
|
||||
'list0 '()
|
||||
'dict0 (hash)
|
||||
'string0 ""
|
||||
|
|
@ -929,15 +932,19 @@
|
|||
))
|
||||
|
||||
(define-runtime-path tests-path "../../../tests")
|
||||
(let-values (((tests test-annotations)
|
||||
(with-input-from-file (build-path tests-path "samples.txt")
|
||||
read-preserve)))
|
||||
(let* ((path (build-path tests-path "samples.txt"))
|
||||
(tests (call-with-input-file path
|
||||
(lambda (p)
|
||||
(port-count-lines! p)
|
||||
(read-preserve-syntax p #:source path)))))
|
||||
(local-require racket/pretty)
|
||||
(for [((t-name _t-name-anns t t-anns) (in-hash/annotations tests test-annotations))]
|
||||
(for [((t-name t) (in-hash (annotated-item tests)))]
|
||||
(newline)
|
||||
(newline)
|
||||
(write-preserve t #:indent #t)
|
||||
(write-preserve t #:indent #f)
|
||||
(newline)
|
||||
(write-preserve (strip-annotations t) #:indent #t)
|
||||
(newline)
|
||||
(newline)
|
||||
(pretty-print (list t-name t t-anns))))
|
||||
(pretty-print (list t-name t))))
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue