From 831f15099df2fd88affd90926de82944866578e6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 7 Nov 2023 09:02:05 +0100 Subject: [PATCH] Fixes and improvements wrt pexprs --- .../preserves/preserves/block-write.rkt | 22 ++++++---- .../racket/preserves/preserves/main.rkt | 12 ++++- .../racket/preserves/preserves/pexprs.rkt | 44 ++++++++++++------- .../preserves/preserves/read-text-generic.rkt | 4 +- 4 files changed, 55 insertions(+), 27 deletions(-) diff --git a/implementations/racket/preserves/preserves/block-write.rkt b/implementations/racket/preserves/preserves/block-write.rkt index bb8f754..fa94c52 100644 --- a/implementations/racket/preserves/preserves/block-write.rkt +++ b/implementations/racket/preserves/preserves/block-write.rkt @@ -37,8 +37,8 @@ (emit* v e indent mode) (loop vs #t)]))) -(define (emit-vertical vs sep ter e indent mode) - (display indent (emitter-port e)) +(define (emit-vertical print-indent-if-vertical? vs sep ter e indent mode) + (when print-indent-if-vertical? (display indent (emitter-port e))) (emit-seq vs (string-append (trim-delimiter sep) indent) (trim-delimiter ter) e indent mode)) (define (trim-delimiter s) @@ -49,15 +49,21 @@ (lambda (p) (emit-seq vs sep ter (emitter p (emitter-indentation e)) indent 'never)))) -(define (emit-separated vs sep ter e indent mode) +(define (emit-separated print-indent-if-vertical? 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 (emit-vertical print-indent-if-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])) + ['always (emit-vertical print-indent-if-vertical? vs sep ter e indent mode) #t] + ['extra-newline (emit-vertical print-indent-if-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)) @@ -66,10 +72,10 @@ [(? 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) + (when (emit-separated #t 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)] + [(separated vs sep ter) (emit-separated #f vs sep ter e indent mode)] [(vertical-mode new-mode v) (emit* v e indent new-mode)])) (define (emit v [o (current-output-port)] diff --git a/implementations/racket/preserves/preserves/main.rkt b/implementations/racket/preserves/preserves/main.rkt index 75f9fc2..3d140ce 100644 --- a/implementations/racket/preserves/preserves/main.rkt +++ b/implementations/racket/preserves/preserves/main.rkt @@ -21,7 +21,8 @@ port->preserves file->preserves port->pexprs - file->pexprs) + file->pexprs + string->pexprs) (require racket/dict) (require racket/match) @@ -115,3 +116,12 @@ (if read-syntax? vs (remove-trailer vs))) + +(define (string->pexprs s + #:read-syntax? [read-syntax? #f] + #:decode-embedded [decode-embedded #f] + #:source [source ""]) + (port->pexprs (open-input-string s) + #:read-syntax? read-syntax? + #:decode-embedded decode-embedded + #:source source)) diff --git a/implementations/racket/preserves/preserves/pexprs.rkt b/implementations/racket/preserves/preserves/pexprs.rkt index 63e4b0c..0be4399 100644 --- a/implementations/racket/preserves/preserves/pexprs.rkt +++ b/implementations/racket/preserves/preserves/pexprs.rkt @@ -6,6 +6,8 @@ pexpr->preserve preserve->pexpr + write-pexpr + COMMA SEMICOLON TRAILER-ANCHOR @@ -234,19 +236,29 @@ #: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)) + + (define (convert-inner vs) + (map convert vs)) + + (define (convert v) + (match v + [(annotated as _loc v) + (if (and (pair? as) write-annotations?) + (separated (append (map (lambda (a) (list "@" (convert a))) as) + (match v + [(TRAILER-ANCHOR) '()] + [_ (list (convert v))])) + " " + "") + (convert v))] + [(? list? ps) (grouped (convert-inner ps) " " "" "[" "]")] + [(RECORD ps ...) (grouped (convert-inner ps) " " "" "<" ">")] + [(GROUP ps ...) (grouped (convert-inner ps) " " "" "(" ")")] + [(BLOCK ps ...) (grouped (convert-inner ps) " " "" "{" "}")] + [(SET ps ...) (grouped (convert-inner ps) " " "" "#{" "}")] + [(TRAILER-ANCHOR) ""] + [(embedded v) (list "#!" (convert (encode-embedded0 v)))] + [(strip-annotations (record 'p (list s))) (symbol->string s)] + [v (preserve->string v)])) + + (emit (convert v0) o #:indentation indent-amount0)) diff --git a/implementations/racket/preserves/preserves/read-text-generic.rkt b/implementations/racket/preserves/preserves/read-text-generic.rkt index d66bccf..7e031ad 100644 --- a/implementations/racket/preserves/preserves/read-text-generic.rkt +++ b/implementations/racket/preserves/preserves/read-text-generic.rkt @@ -268,8 +268,8 @@ (define (read-comment-line) (define pos0 (pos)) (let loop ((acc '())) - (match (next-char*) - [(or #\newline #\return) + (match (read-char in-port) + [(or (? eof-object?) #\newline #\return) (wrap pos0 (list->string (reverse acc)))] [c (loop (cons c acc))])))