89 lines
3.4 KiB
Racket
89 lines
3.4 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 (items separator terminator opener closer) #:transparent)
|
|
|
|
(struct emitter (port indentation) #:transparent)
|
|
|
|
(define (emit-seq op vs sep ter cl e indent mode)
|
|
(define p (emitter-port e))
|
|
(when op (display op p))
|
|
(let loop ((vs vs) (need-sep #f))
|
|
(match vs
|
|
['()
|
|
(when need-sep (display ter p))
|
|
(when cl (display cl p))]
|
|
[(cons v vs)
|
|
(when need-sep (display sep p))
|
|
(emit* v e indent mode)
|
|
(loop vs #t)])))
|
|
|
|
(define (emit-vertical op vs sep ter cl e indent mode)
|
|
(define inner-indent (if op (string-append indent (emitter-indentation e)) indent))
|
|
(let ((sep (string-append (trim-delimiter-right sep) inner-indent))
|
|
(ter (trim-delimiter-right ter))
|
|
(op (and op (string-append (trim-delimiter-right op) inner-indent)))
|
|
(cl (and cl (string-append indent (trim-delimiter-left cl)))))
|
|
(emit-seq op vs sep ter cl e inner-indent mode)))
|
|
|
|
(define (trim-delimiter-right s)
|
|
(string-trim #:left? #f s #px"[ \t\f\v]+"))
|
|
|
|
(define (trim-delimiter-left s)
|
|
(string-trim #:right? #f s #px"[ \t\f\v]+"))
|
|
|
|
(define (try-horizontal op vs sep ter cl e indent mode)
|
|
(call-with-output-string
|
|
(lambda (p)
|
|
(emit-seq op vs sep ter cl (emitter p (emitter-indentation e)) indent 'never))))
|
|
|
|
(define (emit-separated op vs sep ter cl e indent mode)
|
|
(match mode
|
|
['never (emit-seq op vs sep ter cl e indent mode)]
|
|
['variable (let ((s (try-horizontal op vs sep ter cl e indent mode)))
|
|
(if (> (string-length s) (pretty-print-columns))
|
|
(emit-vertical op vs sep ter cl e indent mode)
|
|
(display s (emitter-port e))))]
|
|
['always (emit-vertical op vs sep ter cl e indent mode)]
|
|
['extra-newline (let ((sep (string-append sep "\n")))
|
|
(emit-vertical op vs sep ter cl e indent mode))]))
|
|
|
|
(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)]
|
|
[(separated vs sep ter) (emit-separated #f vs sep ter #f e indent mode)]
|
|
[(grouped vs sep ter op cl) (emit-separated op vs sep ter cl 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"])
|
|
;; (local-require racket/pretty) (pretty-write v)
|
|
(define indentation (if (number? indentation0) (make-string indentation0 #\space) indentation0))
|
|
(emit* v (emitter o indentation) initial-indent initial-mode))
|