;;; -*- Mode: Scheme; scheme48-package: output-combinators -*-

;;;; Output by Combinators

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (item->output-procedure item)
  (cond ((string? item)
         (lambda (port)
           (write-string item port)))
        ((char? item)
         (lambda (port)
           (write-char item port)))
        ((procedure? item)
         item)
        (else
         ;++ Default to DISPLAY or something?
         (error "invalid item for output procedure" item))))

(define (sequence . elements)
  (list-sequence elements))

(define (list-sequence list)
  (reduce-right binary-sequence (empty-sequence)
                (map item->output-procedure list)))

(define (binary-sequence first second)
  (lambda (port)
    (first port)
    (second port)))

(define (empty-sequence)
  (lambda (port)
    port
    (values)))

(define (decorated-list-sequence prefix infix suffix list)
  (sequence prefix
            (list-sequence
             (fold-right (lambda (element tail)
                           (cons element
                                 (if (null? tail)
                                     '()
                                     (cons infix tail))))
                         '()
                         list))
            suffix))

(define (line . contents)
  (let ((write-contents (list-sequence contents)))
    (lambda (port)
      (fresh-line port)
      (write-contents port)
      (fresh-line port))))

(define (stringify item)
  (sequence #\"
            (let ((write-item (item->output-procedure item)))
              (lambda (port)
                (write-item (char-sink->output-port
                             (let ((previous #f))
                               (lambda (char)
                                 (if (or (char=? char #\")
                                         (char=? char #\\))
                                     (write-char #\\ port))
                                 (write-char char port)))))))
            #\"))

(define (writer obj)
  (lambda (port)
    (write obj port)))

(define (displayer obj)
  (lambda (port)
    (display obj port)))

(define (pad-right width char require-padding? item)
  (let ((write-item (item->output-procedure item)))
    (lambda (port)
      (let ((chars 0))
        (write-item (char-sink->output-port
                     (lambda (char)
                       (set! chars (+ chars 1))
                       (write-char char port))))
        (cond ((< chars width)
               (write-string (make-string (- width chars) char)
                             port))
              ((and require-padding?
                    (= chars width))
               (write-char char port)))))))