WIP: write-preserve, preserve->string

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