WIP: write-preserve, preserve->string
This commit is contained in:
parent
6221bdf5c7
commit
467da29c56
|
@ -10,6 +10,8 @@
|
|||
read-preserve/no-annotations
|
||||
string->preserve
|
||||
string->preserve/no-annotations
|
||||
write-preserve
|
||||
preserve->string
|
||||
encode
|
||||
decode
|
||||
wire-value
|
||||
|
@ -19,8 +21,10 @@
|
|||
|
||||
(require racket/bytes)
|
||||
(require racket/dict)
|
||||
(require (only-in racket/format ~a))
|
||||
(require racket/generator)
|
||||
(require racket/match)
|
||||
(require (only-in racket/port with-output-to-string))
|
||||
(require racket/set)
|
||||
(require bitsyntax)
|
||||
(require "struct.rkt")
|
||||
|
@ -255,6 +259,8 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define PIPE #\|)
|
||||
|
||||
(define (skip-whitespace* i)
|
||||
(regexp-match? #px#"^(\\s|,)*" i)) ;; side effect: consumes matched portion of input
|
||||
|
||||
|
@ -327,8 +333,6 @@
|
|||
(lambda (acc) (or acc (hash)))
|
||||
#\}))
|
||||
|
||||
(define PIPE #\|)
|
||||
|
||||
(define (read-raw-symbol acc)
|
||||
(match (peek-char i)
|
||||
[(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 links (annotations-links h-anns))
|
||||
(make-do-sequence (lambda ()
|
||||
|
@ -788,5 +888,7 @@
|
|||
read-preserve)))
|
||||
(local-require racket/pretty)
|
||||
(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