WIP: write-preserve, preserve->string
This commit is contained in:
parent
6221bdf5c7
commit
467da29c56
|
@ -10,6 +10,8 @@
|
||||||
read-preserve/no-annotations
|
read-preserve/no-annotations
|
||||||
string->preserve
|
string->preserve
|
||||||
string->preserve/no-annotations
|
string->preserve/no-annotations
|
||||||
|
write-preserve
|
||||||
|
preserve->string
|
||||||
encode
|
encode
|
||||||
decode
|
decode
|
||||||
wire-value
|
wire-value
|
||||||
|
@ -19,8 +21,10 @@
|
||||||
|
|
||||||
(require racket/bytes)
|
(require racket/bytes)
|
||||||
(require racket/dict)
|
(require racket/dict)
|
||||||
|
(require (only-in racket/format ~a))
|
||||||
(require racket/generator)
|
(require racket/generator)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require (only-in racket/port with-output-to-string))
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
(require "struct.rkt")
|
(require "struct.rkt")
|
||||||
|
@ -255,6 +259,8 @@
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define PIPE #\|)
|
||||||
|
|
||||||
(define (skip-whitespace* i)
|
(define (skip-whitespace* i)
|
||||||
(regexp-match? #px#"^(\\s|,)*" i)) ;; side effect: consumes matched portion of input
|
(regexp-match? #px#"^(\\s|,)*" i)) ;; side effect: consumes matched portion of input
|
||||||
|
|
||||||
|
@ -327,8 +333,6 @@
|
||||||
(lambda (acc) (or acc (hash)))
|
(lambda (acc) (or acc (hash)))
|
||||||
#\}))
|
#\}))
|
||||||
|
|
||||||
(define PIPE #\|)
|
|
||||||
|
|
||||||
(define (read-raw-symbol acc)
|
(define (read-raw-symbol acc)
|
||||||
(match (peek-char i)
|
(match (peek-char i)
|
||||||
[(or (? eof-object?)
|
[(or (? eof-object?)
|
||||||
|
@ -564,6 +568,102 @@
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (write-preserve v0 [o (current-output-port)])
|
||||||
|
(define-syntax-rule (! fmt arg ...) (fprintf o fmt arg ...))
|
||||||
|
|
||||||
|
(define (write-stringlike-char c)
|
||||||
|
(match c
|
||||||
|
[#\\ (! "\\\\")]
|
||||||
|
[#\u08 (! "\\b")]
|
||||||
|
[#\u0C (! "\\f")]
|
||||||
|
[#\u0A (! "\\n")]
|
||||||
|
[#\u0D (! "\\r")]
|
||||||
|
[#\u09 (! "\\t")]
|
||||||
|
[_ (! "~a" c)]))
|
||||||
|
|
||||||
|
(define (write-sequence opener comma closer item-writer vs)
|
||||||
|
(! "~a" opener)
|
||||||
|
(match vs
|
||||||
|
['() (void)]
|
||||||
|
[(cons v0 vs)
|
||||||
|
(item-writer v0)
|
||||||
|
(for [(v (in-list vs))]
|
||||||
|
(! "~a" comma)
|
||||||
|
(item-writer v))])
|
||||||
|
(! "~a" closer))
|
||||||
|
|
||||||
|
(define (write-record label fields)
|
||||||
|
(! "<")
|
||||||
|
(write-value label)
|
||||||
|
(for [(f (in-list fields))]
|
||||||
|
(! " ")
|
||||||
|
(write-value f))
|
||||||
|
(! ">"))
|
||||||
|
|
||||||
|
(define (write-key-value kv)
|
||||||
|
(match-define (cons k v) kv)
|
||||||
|
(write-value k)
|
||||||
|
(! ": ")
|
||||||
|
(write-value v))
|
||||||
|
|
||||||
|
(define (binunescaped? b)
|
||||||
|
(or (<= #x20 b #x21)
|
||||||
|
(<= #x23 b #x5b)
|
||||||
|
(<= #x5d b #x7e)))
|
||||||
|
|
||||||
|
(define (write-value v)
|
||||||
|
(match v
|
||||||
|
[#f (! "#false")]
|
||||||
|
[#t (! "#true")]
|
||||||
|
[(? single-flonum?) (! "~vf" v)]
|
||||||
|
[(? double-flonum?) (! "~v" v)]
|
||||||
|
[(? integer? x) (! "~v" v)]
|
||||||
|
[(? string?)
|
||||||
|
(! "\"")
|
||||||
|
(for [(c (in-string v))]
|
||||||
|
(match c
|
||||||
|
[#\" (! "\\\"")]
|
||||||
|
[_ (write-stringlike-char c)]))
|
||||||
|
(! "\"")]
|
||||||
|
[(? bytes?)
|
||||||
|
(! "#\"")
|
||||||
|
(for [(c (in-bytes v))]
|
||||||
|
(match c
|
||||||
|
[#x22 (! "\\\"")]
|
||||||
|
[#x5C (! "\\\\")]
|
||||||
|
[(? binunescaped?) (! "~a" (integer->char c))]
|
||||||
|
[_ (! "\\x~a" (~a #:min-width 2 #:align 'right #:left-pad-string "0" (number->string c 16)))]))
|
||||||
|
(! "\"")]
|
||||||
|
[(? symbol?)
|
||||||
|
(define s (symbol->string v))
|
||||||
|
;; FIXME: This regular expression is conservatively correct, but Anglo-chauvinistic.
|
||||||
|
(if (regexp-match #px"[a-zA-Z~!$%^&*?_=+/.][-a-zA-Z~!$%^&*?_=+/.0-9]*" s)
|
||||||
|
(! "~a" s)
|
||||||
|
(begin (! "|")
|
||||||
|
(for [(c (in-string s))]
|
||||||
|
(match c
|
||||||
|
[(== PIPE) (! "\\|")]
|
||||||
|
[_ (write-stringlike-char c)]))
|
||||||
|
(! "|")))]
|
||||||
|
[(record label fields) (write-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))
|
||||||
|
(write-record key (cdr (vector->list (struct->vector v))))]
|
||||||
|
|
||||||
|
[(? list?) (write-sequence "[" ", " "]" write-value v)]
|
||||||
|
[(? set?) (write-sequence "#set{" ", " "}" write-value (set->list v))]
|
||||||
|
[(? dict?) (write-sequence "{" ", " "}" write-key-value (dict->list v))]
|
||||||
|
|
||||||
|
[_ (error 'write-preserve "Cannot encode value ~v" v)]))
|
||||||
|
|
||||||
|
(write-value v0))
|
||||||
|
|
||||||
|
(define (preserve->string v0)
|
||||||
|
(with-output-to-string (lambda () (write-preserve v0))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
(define (in-hash/annotations h h-anns)
|
(define (in-hash/annotations h h-anns)
|
||||||
(define links (annotations-links h-anns))
|
(define links (annotations-links h-anns))
|
||||||
(make-do-sequence (lambda ()
|
(make-do-sequence (lambda ()
|
||||||
|
@ -788,5 +888,7 @@
|
||||||
read-preserve)))
|
read-preserve)))
|
||||||
(local-require racket/pretty)
|
(local-require racket/pretty)
|
||||||
(for [((t-name _t-name-anns t t-anns) (in-hash/annotations tests test-annotations))]
|
(for [((t-name _t-name-anns t t-anns) (in-hash/annotations tests test-annotations))]
|
||||||
(pretty-print (list t-name t t-anns))))
|
(pretty-print (list t-name t t-anns))
|
||||||
|
(write-preserve t)
|
||||||
|
(newline)))
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue