write-pexpr (not quite right yet)

implementations/racket/preserves/preserves/block-write.rkt

@@ -0,0 +1,80 @@
+#lang racket/base
+
+(provide emit
+         (struct-out vertical-mode)
+         (struct-out separated)
+         (struct-out grouped))
+
+(require racket/match)
+(require (only-in racket/string string-trim))
+(require (only-in racket/pretty pretty-print-columns))
+(require (only-in racket/port call-with-output-string))
+
+;; mode ∈ {'never, 'variable, 'always, 'extra-newline}
+;;
+;; Things that don't know how to write themselves vertically always write horizontally.
+;; Otherwise, mode is relevant:
+;;
+;;  - 'never: always horizontally
+;;  - 'variable: horizontally, unless it doesn't fit, in which case vertically
+;;  - 'always: always vertically
+;;  - 'extra-newline: as 'normal, but with extra newlines separating items
+;;
+(struct vertical-mode (mode item) #:transparent)
+
+(struct separated (items separator terminator) #:transparent)
+(struct grouped separated (opener closer) #:transparent)
+
+(struct emitter (port indentation) #:transparent)
+
+(define (emit-seq vs sep ter e indent mode)
+  (let loop ((vs vs) (need-sep #f))
+    (match vs
+      ['()
+       (when need-sep (display ter (emitter-port e)))]
+      [(cons v vs)
+       (when need-sep (display sep (emitter-port e)))
+       (emit* v e indent mode)
+       (loop vs #t)])))
+
+(define (emit-vertical vs sep ter e indent mode)
+  (display indent (emitter-port e))
+  (emit-seq vs (string-append (trim-delimiter sep) indent) (trim-delimiter ter) e indent mode))
+
+(define (trim-delimiter s)
+  (string-trim #:left? #f s #px"[ \t\f\v]+"))
+
+(define (try-horizontal vs sep ter e indent mode)
+  (call-with-output-string
+   (lambda (p)
+     (emit-seq vs sep ter (emitter p (emitter-indentation e)) indent 'never))))
+
+(define (emit-separated vs sep ter e indent mode)
+  (match mode
+    ['never (emit-seq vs sep ter e indent mode) #f]
+    ['variable (let ((s (try-horizontal vs sep ter e indent mode)))
+                 (if (> (string-length s) (pretty-print-columns))
+                     (begin (emit-vertical vs sep ter e indent mode) #t)
+                     (begin (display s (emitter-port e)) #f)))]
+    ['always (emit-vertical vs sep ter e indent mode) #t]
+    ['extra-newline (emit-vertical vs (and sep (string-append sep "\n")) ter e indent mode) #t]))
+
+(define (emit* v e indent mode)
+  (define (w v) (emit* v e indent mode))
+  (match v
+    [(? string? s) (display s (emitter-port e))]
+    [(? list? vs) (map w vs)]
+    [(grouped vs sep ter op cl)
+     (display op (emitter-port e))
+     (when (emit-separated vs sep ter e (string-append indent (emitter-indentation e)) mode)
+       (display indent (emitter-port e)))
+     (display cl (emitter-port e))]
+    [(separated vs sep ter) (emit-separated vs sep ter e indent mode)]
+    [(vertical-mode new-mode v) (emit* v e indent new-mode)]))
+
+(define (emit v [o (current-output-port)]
+              #:mode [initial-mode 'variable]
+              #:indentation [indentation0 "    "]
+              #:initial-indent [initial-indent "\n"])
+  (define indentation (if (number? indentation0) (make-string indentation0 #\space) indentation0))
+  (emit* v (emitter o indentation) initial-indent initial-mode))

implementations/racket/preserves/preserves/pexprs.rkt

@@ -227,3 +227,26 @@
       [(embedded v) (map-embedded walk v)]
       [(annotated as loc v) (annotated (map walk as) loc (walk v))]
       [v v])))
+
+(define (write-pexpr v0 [o (current-output-port)]
+                     #:indent [indent-amount0 4]
+                     #:encode-embedded [encode-embedded0 #f]
+                     #:write-annotations? [write-annotations? #t])
+  (local-require "block-write.rkt")
+  (local-require "write-text.rkt")
+  (define block
+    (let walk ((v v0))
+      (match v
+        [(? list? ps) (grouped (map walk ps) " " "" "[" "]")]
+        [(RECORD ps ...) (grouped (map walk ps) " " "" "<" ">")]
+        [(GROUP ps ...) (grouped (map walk ps) " " "" "(" ")")]
+        [(BLOCK ps ...) (grouped (map walk ps) " " "" "{" "}")]
+        [(SET ps ...) (grouped (map walk ps) " " "" "#{" "}")]
+        [(embedded v) (list "#!" (walk (encode-embedded0 v)))]
+        [(annotated as _loc v)
+         (if write-annotations?
+             (separated (append (map (lambda (a) (list "@" (walk a))) as) v) " " "")
+             (walk v))]
+        [(strip-annotations (record 'p (list s))) (symbol->string s)]
+        [v (preserve->string v)])))
+  (emit block o #:indentation indent-amount0))

preserves-expressions.md

@@ -61,10 +61,16 @@ in that uses of `Value` are replaced with `SimpleExpr`.
          Annotation = "@" SimpleExpr / "#" [(%x20 / %x09) linecomment] (CR / LF)
         linecomment = *<any unicode scalar value except CR or LF>
 
-P-expression special punctuation marks are comma, semicolon, and sequences of one or more colons.
+P-expression special punctuation marks are comma, semicolon, and
+sequences of one or more colons.[^greedy-colons]
 
              Punct = "," / ";" / 1*":"
 
+[^greedy-colons]: Colon matching is greedy: when reading, all adjacent
+    colons are always taken into a single token, and when writing,
+    adjacent colon-sequence punctuation marks must be written with
+    whitespace separating them.
+
 Compound expressions are sequences of `Expr`s with optional trailing
 `Annotation`s, surrounded by various kinds of parentheses.