;;; -*- Mode: Scheme -*-

;;;; Output Combinators

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

;;; The next four definitions seem to be the crux of the output system.
;;; But they're actually not essential.  The idiom is the real crux;
;;; the rest is merely quux.

;;; This code uses Scheme48's EXTENDED-PORTS library.

(define (output-sequence . items)
  (output-list items))

(define (output-list list)
  (reduce-map output-sequence-2
              output-item
              (output-nothing)
              list))

(define (output-sequence-2 write-first write-second)
  (lambda (port)
    (write-first port)
    (write-second port)))

(define (output-nothing)
  (lambda (port)
    port
    (values)))

(define (output-item item)
  (cond ((procedure? item) item)
        ((list? item) (output-list item))
        (else
         (let ((outputter (cond ((char? item) write-char)
                                ((string? item) write-string)
                                (else display))))
           (lambda (port)
             (outputter item port))))))

(define (output-decorated-list prefix infix suffix list . empty-option)
  (output-sequence prefix
                   (reduce-map (let ((write-infix (output-item infix)))
                                 (lambda (write-left write-right)
                                   (lambda (port)
                                     (write-left port)
                                     (write-infix port)
                                     (write-right port))))
                               output-item
                               (if (null? empty-option)
                                   (output-nothing)
                                   (car empty-option))
                               list)
                   suffix))

(define (reduce-map operator mapper right-identity list)
  (if (pair? list)
      (let loop ((list (cdr list)) (result (mapper (car list))))
        (if (pair? list)
            (loop (cdr list)
                  (operator result (mapper (car list))))
            result))
      right-identity))

(define (output-written obj)
  (lambda (port)
    (write obj port)))

(define (output-line . items)
  (let ((write-items (output-list items)))
    (lambda (port)
      (fresh-line port)
      (write-items port)
      (fresh-line port))))

(define (output-lines . lines)
  (reduce-map output-sequence-2
              output-line
              (output-nothing)
              lines))

(define (output-escaped-string item)
  (output-sequence #\"
                   (let ((write-item (output-item item)))
                     (lambda (port)
                       (write-item
                        (char-sink->output-port
                         (lambda (char)
                           (write-escaped-char char port))))))
                   #\"))

(define (write-escaped-char char port)
  (if (or (char=? char #\")
          (char=? char #\\))
      (write-char #\\ port))
  (write-char char port))

(define (with-output-left-padded width require? char item)
  (let ((write-item (output-item item)))
    (lambda (port)
      (let ((output (call-with-string-output-port write-item)))
        (write-padding (string-length output) width require? char port)
        (write-string output port)))))

(define (with-output-right-padded width require? char item)
  (let ((write-item (output-item item)))
    (lambda (port)
      (let ((count 0))
        (write-item (char-sink->output-port (lambda (char)
                                              (set! count (+ count 1))
                                              (write-char char port))))
        (write-padding count width require? char port)))))

(define (write-padding output-width padding-width require? char port)
  (cond ((< output-width padding-width)
         (write-string (make-string (- padding-width output-width)
                                    char)
                       port))
        (require?
         (write-char char port))))

(define (with-output-truncated width item)
  (let ((write-item (output-item item)))
    (lambda (port)
      (limit-output port width write-item))))

;;;; Extended Ports

;;; This page briefly describes the output utilities provided by
;;; Scheme48's EXTENDED-PORTS library.  These are easy to provide in
;;; most Scheme systems; LIMIT-OUTPUT can also be defined in terms of
;;; CHAR-SINK->OUTPUT-PORT.

;;; (FRESH-LINE <output-port>)
;;;   Creates a new line of output if it cannot be determined that the
;;;   output is already at the beginning of a line.
;;;
;;; (CHAR-SINK->OUTPUT-PORT <sink>) -> output-port
;;;   <Sink> is a procedure of one parameter, a character.  This
;;;   returns an output port whose output, character by character, is
;;;   passed to <sink>.  Closing the output port has no effect.
;;;
;;; (CALL-WITH-STRING-OUTPUT-PORT <receiver>) -> string
;;;   Calls <receiver> with an output port that collects its output as
;;;   a string, and returns it.
;;;
;;; (LIMIT-OUTPUT <output-port> <count> <receiver>)
;;;   Calls <receiver> with a new output port.  This output port sends
;;;   any characters written to it to <output-port>, until at most
;;;   <count> characters have been written, at which point LIMIT-OUTPUT
;;;   returns by a throw.
;;;
;;;     (define (limit-output output-port count receiver)
;;;       (call-with-current-continuation
;;;         (lambda (truncate)
;;;           (receiver (char-sink->output-port
;;;                      (lambda (char)
;;;                        (write-char char port)
;;;                        (set! count (- count 1))
;;;                        (if (<= count 0)
;;;                            (truncate))))))))