#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))