diff --git a/implementations/racket/preserves/main.rkt b/implementations/racket/preserves/main.rkt index 2fffdec..7261581 100644 --- a/implementations/racket/preserves/main.rkt +++ b/implementations/racket/preserves/main.rkt @@ -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))) )