81 lines
3.0 KiB
Racket
81 lines
3.0 KiB
Racket
#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))
|