Pretty printing sequences with indentation and without any delimiters.

pretty-printing.rkt

#lang racket/base


(require racket/contract/base)


(provide
 (contract-out
  [sequence-markup? predicate/c]
  [sequence-markup
   (->* ((sequence/c any/c)) (#:indentation exact-nonnegative-integer?) sequence-markup?)]))


(require racket/pretty
         racket/sequence
         rebellion/private/guarded-block)


;@----------------------------------------------------------------------------------------------------


(struct sequence-markup (elements indentation)
  #:omit-define-syntaxes
  #:constructor-name constructor:sequence-markup
  #:transparent
  #:guard (λ (elements indentation _) (values (sequence->list elements) indentation))

  #:methods gen:custom-write
  [(define/guard (write-proc this out mode)
     (define elements (sequence-markup-elements this))
     (guard (pretty-printing-with-finite-columns?) else
       (custom-write (inline-sequence-markup elements) out mode))
     (unless (try-pretty-print-single-line (inline-sequence-markup elements) out mode)
       (define multiline
         (multiline-sequence-markup elements #:indentation (sequence-markup-indentation this)))
       (custom-write multiline out mode)))])


(define (sequence-markup elements #:indentation [indentation 2])
  (constructor:sequence-markup elements indentation))


(struct inline-sequence-markup (elements)
  #:transparent
  #:guard (λ (elements _) (sequence->list elements))

  #:methods gen:custom-write
  [(define (write-proc this out mode)
     (for ([element (in-list (inline-sequence-markup-elements this))]
           [i (in-naturals)])
       (unless (zero? i)
         (write-string " " out))
       (custom-write element out mode #:recursive? #true)))])


(struct multiline-sequence-markup (elements indentation)
  #:omit-define-syntaxes
  #:constructor-name constructor:multiline-sequence-markup
  #:transparent
  #:guard (λ (elements indentation _) (values (sequence->list elements) indentation))

  #:methods gen:custom-write
  [(define (write-proc this out mode)
     (define leading-indentation-amount
       (+ (port-next-column out) (multiline-sequence-markup-indentation this)))
     (define leading-spaces (make-string leading-indentation-amount #\space))
     (for ([element (in-list (multiline-sequence-markup-elements this))]
           [i (in-naturals)])
       (unless (zero? i)
         (pretty-print-newline out (pretty-print-columns))
         (write-string leading-spaces out))
       (custom-write element out mode #:recursive? #true)))])


(define (multiline-sequence-markup elements #:indentation [indentation 2])
  (constructor:multiline-sequence-markup elements indentation))


(define (pretty-printing-with-finite-columns?)
  (and (pretty-printing) (integer? (pretty-print-columns))))


;; Any OutputPort PrintMode -> Boolean
;; Tries to print `v` to the output port on a single line. If `v` takes up more than one line, nothing
;; is printed to `out` and false is returned. If printing succeeds, true is returned.
(define (try-pretty-print-single-line v out mode)
  (let/ec escape
    (define (on-overflow)
      (tentative-pretty-print-port-cancel tentative-port)
      ;; We have to escape because make-tentative-pretty-print-output-port calls the overflow thunk
      ;; *each time* the content exceeds the column limit; it doesn't actually *stop* printing. The
      ;; only way to stop the print operation while inside the overflow thunk is to escape from the
      ;; thunk with a continuation jump.
      (escape #false))
    (define tentative-port
      (make-tentative-pretty-print-output-port out (pretty-print-columns) on-overflow))

    ;; If this exceeds the column width, the on-overflow thunk is called which aborts out using the
    ;; escape continuation.
    (custom-write v tentative-port mode)

    ;; If evaluation reaches this point, printing v did not exceed the column limit and we can commit
    ;; the tentative port's output, sending it to the original port.
    (tentative-pretty-print-port-transfer tentative-port out)
    
    #true))


(define (custom-write v out mode #:recursive? [recursive? #false])
  (if recursive?
      (case mode
        [(#t) (write v out)]
        [(#f) (display v out)]
        [(0 1) (print v out mode)])
      ((custom-write-accessor v) v out mode)))


(define (port-next-column out)
  (define-values (unused-line col unused-pos) (port-next-location out))
  col)


(module+ main
  (pretty-print (sequence-markup (list "foo" "bar" "baz")))
  (pretty-print
   (sequence-markup
    (list "fooooooooooooooooooooooooooooooooo"
          "baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar"
          "baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaz"))))