chibi-scheme/lib/chibi/show/show.scm

;; show.scm -- additional combinator formatters
;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;> Convenience library that exports all of \scheme{(chibi show base)}
;;> plus additional combinator formatters.

;;> \section{Formatters}

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Spacing

;;> Output a single newline.
(define nl (displayed "\n"))

;;> "Fresh line" - output a newline iff we're not at the start of a
;;> fresh line.
(define fl
  (fn (col) (if (zero? col) nothing nl)))

;;> Move to a given tab-stop (using spaces, not tabs).
(define (tab-to . o)
  (fn (col pad-char)
    (let* ((tab-width (if (pair? o) (car o) 8))
           (rem (modulo col tab-width)))
      (if (positive? rem)
          (displayed (make-string (- tab-width rem) pad-char))
          nothing))))

;;> Move to an explicit column.
(define (space-to where)
  (fn (col pad-char)
    (displayed (make-string (max 0 (- where col)) pad-char))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String transformations

(define (with-string-transformer proc . ls)
  (fn (output)
    (let ((output* (lambda (str) (fn () (output (proc str))))))
      (with ((output output*)) (each-in-list ls)))))

;;> Show each of \var{ls}, uppercasing all generated text.
(define (upcased . ls) (apply with-string-transformer string-upcase ls))

;;> Show each of \var{ls}, lowercasing all generated text.
(define (downcased . ls) (apply with-string-transformer string-downcase ls))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Padding and trimming

;;> Pad the result of \scheme{(each-in-list ls)} to at least
;;> \var{width} characters, equally applied to the left and right,
;;> with any extra odd padding applied to the right.  Uses the value
;;> of \scheme{pad-char} for padding, defaulting to \scheme{#\\space}.
(define (padded/both width . ls)
  (call-with-output
   (each-in-list ls)
   (lambda (str)
     (fn (string-width pad-char)
       (let ((diff (- width (string-width str))))
         (if (positive? diff)
             (let* ((diff/2 (quotient diff 2))
                    (left (make-string diff/2 pad-char))
                    (right (if (even? diff)
                               left
                               (make-string (+ 1 diff/2) pad-char))))
               (each right str left))
             (displayed str)))))))

;;> As \scheme{padded/both} but only applies padding on the right.
(define (padded width . ls)
  (fn ((col1 col))
    (each (each-in-list ls)
          (fn ((col2 col) pad-char)
            (displayed (make-string (max 0 (- width (- col2 col1)))
                                    pad-char))))))

;;> An alias for \scheme{padded}.
(define padded/right padded)

;;> As \scheme{padded/both} but only applies padding on the left.
(define (padded/left width . ls)
  (call-with-output
   (each-in-list ls)
   (lambda (str)
     (fn (string-width pad-char)
       (let ((diff (- width (string-width str))))
         (each (make-string diff pad-char) str))))))

;; General buffered trim - capture the output apply a trimmer.
(define (trimmed/buffered width producer proc)
  (call-with-output
   producer
   (lambda (str)
     (fn (string-width)
       (let* ((str-width (string-width str))
              (diff (- str-width width)))
         (displayed (if (positive? diff)
                        (proc str str-width diff)
                        str)))))))

;;> Trims the result of \scheme{(each-in-list ls)} to at most
;;> \var{width} characters, removed from the right.  If any characters
;;> are removed, then the value of \scheme{ellipsis} (default empty)
;;> is used in its place (trimming additional characters as needed to
;;> be sure the final output doesn't exceed \var{width}).
(define (trimmed width . ls)
  (trimmed/buffered
   width
   (each-in-list ls)
   (lambda (str str-width diff)
     (fn (ellipsis string-width col)
       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
              (ell-len (string-width ell))
              (diff (- (+ str-width ell-len) width)))
         (each (if (negative? diff)
                   nothing
                   (substring str 0 (- width ell-len)))
               ell))))))

;;> An alias for \scheme{trimmed}.
(define trimmed/right trimmed)

;;> As \scheme{trimmed} but removes from the left.
(define (trimmed/left width . ls)
  (trimmed/buffered
   width
   (each-in-list ls)
   (lambda (str str-width diff)
     (fn (ellipsis string-width)
       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
              (ell-len (string-width ell))
              (diff (- (+ str-width ell-len) width)))
         (each ell
               (if (negative? diff)
                   nothing
                   (substring str diff))))))))

;;> As \scheme{trimmed} but removes equally from both the left and the
;;> right, removing extra odd characters from the right, and inserting
;;> \scheme{ellipsis} on both sides.
(define (trimmed/both width . ls)
  (trimmed/buffered
   width
   (each-in-list ls)
   (lambda (str str-width diff)
     (fn (ellipsis string-width)
       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
              (ell-len (string-width ell))
              (diff (- (+ str-width ell-len ell-len) width))
              (left (quotient diff 2))
              (right (- (string-width str) (quotient (+ diff 1) 2))))
         (if (negative? diff)
             ell
             (each ell (substring str left right) ell)))))))

;;> A \scheme{trimmed}, but truncates and terminates immediately if
;;> more than \var{width} characters are generated by \var{ls}.  Thus
;;> \var{ls} may lazily generate an infinite amount of output safely
;;> (e.g. \scheme{write-simple} on an infinite list).  The nature of
;;> this procedure means only truncating on the right is meaningful.
(define (trimmed/lazy width . ls)
  (fn (orig-output string-width)
    (call-with-current-continuation
     (lambda (return)
       (let ((chars-written 0)
             (output (or orig-output output-default)))
         (define (output* str)
           (let ((len (string-width str)))
             (set! chars-written (+ chars-written len))
             (if (> chars-written width)
                 (let* ((end (max 0 (- len (- chars-written width))))
                        (s (substring str 0 end)))
                   (each (output s)
                         (update! (output orig-output))
                         (fn () (return nothing))))
                 (output str))))
         (with ((output output*))
           (each-in-list ls)))))))

;;> Fits the result of \scheme{(each-in-list ls)} to exactly
;;> \var{width} characters, padding or trimming on the right as
;;> needed.
(define (fitted width . ls)
  (padded width (trimmed width (each-in-list ls))))

;;> An alias for \scheme{fitted}.
(define fitted/right fitted)

;;> As \scheme{fitted} but pads/trims from the left.
(define (fitted/left width . ls)
  (padded/left width (trimmed/left width (each-in-list ls))))

;;> As \scheme{fitted} but pads/trims equally from both the left and
;;> the right.
(define (fitted/both width . ls)
  (padded/both width (trimmed/both width (each-in-list ls))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Joining and interspersing

(define (joined/general elt-f last-f dot-f init-ls sep)
  (fn ()
    (let lp ((ls init-ls))
      (cond
       ((pair? ls)
        (each (if (eq? ls init-ls) nothing sep)
              ((if (and last-f (null? (cdr ls))) last-f elt-f) (car ls))
              (lp (cdr ls))))
       ((and dot-f (not (null? ls)))
        (each (if (eq? ls init-ls) nothing sep) (dot-f ls)))
       (else
        nothing)))))

;;> \procedure{(joined elt-f ls [sep])}
;;>
;;> Joins the result of applying \var{elt-f} to each element of the
;;> list \var{ls} together with \var{sep}, which defaults to the empty
;;> string.
(define (joined elt-f ls . o)
  (joined/general elt-f #f #f ls (if (pair? o) (car o) "")))

;;> As \scheme{joined} but treats the separator as a prefix, inserting
;;> before every element instead of between.
(define (joined/prefix elt-f ls . o)
  (if (null? ls)
      nothing
      (let ((sep (if (pair? o) (car o) "")))
        (each sep (joined elt-f ls sep)))))

;;> As \scheme{joined} but treats the separator as a suffix, inserting
;;> after every element instead of between.
(define (joined/suffix elt-f ls . o)
  (if (null? ls)
      nothing
      (let ((sep (if (pair? o) (car o) "")))
        (each (joined elt-f ls sep) sep))))

;;> As \scheme{joined} but applies \var{last-f}, instead of
;;> \var{elt-f}, to the last element of \var{ls}, useful for
;;> e.g. commas separating a list with "and" before the final element.
(define (joined/last elt-f last-f ls . o)
  (joined/general elt-f last-f #f ls (if (pair? o) (car o) "")))

;;> As \scheme{joined} but if \var{ls} is a dotted list applies
;;> \var{dot-f} to the dotted tail as a final element.
(define (joined/dot elt-f dot-f ls . o)
  (joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))