1;; show.scm -- additional combinator formatters
2;; Copyright (c) 2013-2020 Alex Shinn.  All rights reserved.
3;; BSD-style license: http://synthcode.com/license.txt
4
5;;> A library of procedures for formatting Scheme objects to text in
6;;> various ways, and for easily concatenating, composing and
7;;> extending these formatters.
8
9;;> \section{Background}
10;;>
11;;> There are several approaches to text formatting.  Building strings
12;;> to \scheme{display} is not acceptable, since it doesn't scale to
13;;> very large output.  The simplest realistic idea, and what people
14;;> resort to in typical portable Scheme, is to interleave
15;;> \scheme{display} and \scheme{write} and manual loops, but this is
16;;> both extremely verbose and doesn't compose well.  A simple concept
17;;> such as padding space can't be achieved directly without somehow
18;;> capturing intermediate output.
19;;>
20;;> The traditional approach is to use templates - typically strings,
21;;> though in theory any object could be used and indeed Emacs'
22;;> mode-line format templates allow arbitrary sexps.  Templates can
23;;> use either escape sequences (as in C's \cfun{printf} and
24;;> \hyperlink["http://en.wikipedia.org/wiki/Format_(Common_Lisp)"]{CL's}
25;;> \scheme{format}) or pattern matching (as in Visual Basic's
26;;> \cfun{Format},
27;;> \hyperlink["http://search.cpan.org/~dconway/Perl6-Form-0.04/Form.pm"}{Perl6's}
28;;> \cfun{form}, and SQL date formats).  The primary disadvantage of
29;;> templates is the relative difficulty (usually impossibility) of
30;;> extending them, their opaqueness, and the unreadability that
31;;> arises with complex formats.  Templates are not without their
32;;> advantages, but they are already addressed by other libraries such
33;;> as
34;;> \hyperlink["http://srfi.schemers.org/srfi-28/srfi-28.html"]{SRFI-28}
35;;> and
36;;> \hyperlink["http://srfi.schemers.org/srfi-48/srfi-48.html"]{SRFI-48}.
37;;>
38;;> This library takes a combinator approach.  Formats are nested chains
39;;> of closures, which are called to produce their output as needed.
40;;> The primary goal of this library is to have, first and foremost, a
41;;> maximally expressive and extensible formatting library.  The next
42;;> most important goal is scalability - to be able to handle
43;;> arbitrarily large output and not build intermediate results except
44;;> where necessary.  The third goal is brevity and ease of use.
45
46;;> \section{Interface}
47
48;;> \procedure{(show out [args ...])}
49;;>
50;;> The primary interface.  Analogous to CL's \scheme{format}, the first
51;;> argument is either an output port or a boolean, with \scheme{#t}
52;;> indicating \scheme{current-output-port} and \scheme{#f} indicating a
53;;> string port.  The remaining arguments are formatters, combined as with
54;;> \scheme{each}, run with output to the given destination.  If \var{out}
55;;> is \scheme{#f} then the accumulated output is returned, otherwise
56;;> the result is unspecified.
57
58;;> \section{Formatters}
59
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;; Spacing
62
63;;> Output a single newline.
64(define nl (displayed "\n"))
65
66;;> "Fresh line" - output a newline iff we're not at the start of a
67;;> fresh line.
68(define fl
69  (fn (col) (if (zero? col) nothing nl)))
70
71;;> Move to a given tab-stop (using spaces, not tabs).
72(define (tab-to . o)
73  (fn (col pad-char)
74    (let* ((tab-width (if (pair? o) (car o) 8))
75           (rem (modulo col tab-width)))
76      (if (positive? rem)
77          (displayed (make-string (- tab-width rem) pad-char))
78          nothing))))
79
80;;> Move to an explicit column.
81(define (space-to where)
82  (fn (col pad-char)
83    (displayed (make-string (max 0 (- where col)) pad-char))))
84
85;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86;; Padding and trimming
87
88;;> Pad the result of \scheme{(each-in-list ls)} to at least
89;;> \var{width} characters, equally applied to the left and right,
90;;> with any extra odd padding applied to the right.  Uses the value
91;;> of \scheme{pad-char} for padding, defaulting to \scheme{#\\space}.
92(define (padded/both width . ls)
93  (call-with-output
94   (each-in-list ls)
95   (lambda (str)
96     (fn (string-width pad-char)
97       (let ((diff (- width (string-width str))))
98         (if (positive? diff)
99             (let* ((diff/2 (quotient diff 2))
100                    (left (make-string diff/2 pad-char))
101                    (right (if (even? diff)
102                               left
103                               (make-string (+ 1 diff/2) pad-char))))
104               (each left str right))
105             (displayed str)))))))
106
107;;> As \scheme{padded/both} but only applies padding on the right.
108(define (padded/right width . ls)
109  (fn ((col1 col))
110    (each (each-in-list ls)
111          (fn ((col2 col) pad-char)
112            (displayed (make-string (max 0 (- width (- col2 col1)))
113                                    pad-char))))))
114
115;;> As \scheme{padded/both} but only applies padding on the left.
116(define (padded/left width . ls)
117  (call-with-output
118   (each-in-list ls)
119   (lambda (str)
120     (fn (string-width pad-char)
121       (let ((diff (- width (string-width str))))
122         (each (make-string (max 0 diff) pad-char) str))))))
123
124;;> An alias for \scheme{padded/left}.
125(define padded padded/left)
126
127;; General buffered trim - capture the output apply a trimmer.
128(define (trimmed/buffered width producer proc)
129  (call-with-output
130   producer
131   (lambda (str)
132     (fn (string-width)
133       (let* ((str-width (string-width str))
134              (diff (- str-width width)))
135         (displayed (if (positive? diff)
136                        (proc str str-width diff)
137                        str)))))))
138
139;;> Trims the result of \scheme{(each-in-list ls)} to at most
140;;> \var{width} characters, removed from the right.  If any characters
141;;> are removed, then the value of \scheme{ellipsis} (default empty)
142;;> is used in its place (trimming additional characters as needed to
143;;> be sure the final output doesn't exceed \var{width}).
144(define (trimmed/right width . ls)
145  (trimmed/buffered
146   width
147   (each-in-list ls)
148   (lambda (str str-width diff)
149     (fn (ellipsis string-width substring/width substring/preserve)
150       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
151              (ell-len (string-width ell))
152              (diff (- (+ str-width ell-len) width))
153              (end (- width ell-len)))
154         (each (if substring/preserve
155                   (substring/preserve (substring/width str -1 0))
156                   nothing)
157               (if (negative? diff)
158                   nothing
159                   (substring/width str 0 end))
160               ell
161               (if (and substring/preserve (< end str-width))
162                   (substring/preserve (substring/width str end str-width))
163                   nothing)))))))
164
165;;> As \scheme{trimmed/right} but removes from the left.
166(define (trimmed/left width . ls)
167  (trimmed/buffered
168   width
169   (each-in-list ls)
170   (lambda (str str-width diff)
171     (fn (ellipsis string-width substring/width substring/preserve)
172       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
173              (ell-len (string-width ell))
174              (diff (- (+ str-width ell-len) width)))
175         (each (if (and substring/preserve (positive? diff))
176                   (substring/preserve (substring/width str 0 diff))
177                   nothing)
178               ell
179               (if (negative? diff)
180                   nothing
181                   (substring/width str diff str-width))))))))
182
183;;> An alias for \scheme{trimmed/left}.
184(define trimmed trimmed/left)
185
186;;> As \scheme{trimmed} but removes equally from both the left and the
187;;> right, removing extra odd characters from the right, and inserting
188;;> \scheme{ellipsis} on both sides.
189(define (trimmed/both width . ls)
190  (trimmed/buffered
191   width
192   (each-in-list ls)
193   (lambda (str str-width diff)
194     (fn (ellipsis string-width substring/width substring/preserve)
195       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
196              (ell-len (string-width ell))
197              (diff (- (+ str-width ell-len ell-len) width))
198              (left (quotient diff 2))
199              (right (- str-width (quotient (+ diff 1) 2))))
200         (each
201          (if substring/preserve
202              (substring/preserve (substring/width str 0 left))
203              nothing)
204          (if (negative? diff)
205              ell
206              (each ell (substring/width str left right) ell))
207          (if substring/preserve
208              (substring/preserve (substring/width str right str-width))
209              nothing)))))))
210
211;;> A \scheme{trimmed}, but truncates and terminates immediately if
212;;> more than \var{width} characters are generated by \var{ls}.  Thus
213;;> \var{ls} may lazily generate an infinite amount of output safely
214;;> (e.g. \scheme{write-simple} on an infinite list).  The nature of
215;;> this procedure means only truncating on the right is meaningful.
216(define (trimmed/lazy width . ls)
217  (fn ((orig-output output) string-width substring/width)
218    (call-with-current-continuation
219     (lambda (return)
220       (let ((chars-written 0)
221             (orig-output (or orig-output output-default)))
222         (define (output* str)
223           (let ((len (string-width str)))
224             (set! chars-written (+ chars-written len))
225             (if (> chars-written width)
226                 (let* ((end (max 0 (- len (- chars-written width))))
227                        (s (substring/width str 0 end)))
228                   (each (orig-output s)
229                         (with! (output orig-output))
230                         (fn () (return nothing))))
231                 (orig-output str))))
232         (with ((output output*))
233           (each-in-list ls)))))))
234
235;;> Fits the result of \scheme{(each-in-list ls)} to exactly
236;;> \var{width} characters, padding or trimming on the right as
237;;> needed.
238(define (fitted/right width . ls)
239  (padded/right width (trimmed/right width (each-in-list ls))))
240
241;;> As \scheme{fitted} but pads/trims from the left.
242(define (fitted/left width . ls)
243  (padded/left width (trimmed/left width (each-in-list ls))))
244
245;;> An alias for \scheme{fitted/left}.
246(define fitted fitted/left)
247
248;;> As \scheme{fitted} but pads/trims equally from both the left and
249;;> the right.
250(define (fitted/both width . ls)
251  (padded/both width (trimmed/both width (each-in-list ls))))
252
253;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254;; Joining and interspersing
255
256(define (joined/general elt-f last-f dot-f init-ls sep)
257  (fn ()
258    (let lp ((ls init-ls))
259      (cond
260       ((pair? ls)
261        (each (if (eq? ls init-ls) nothing sep)
262              ((if (and last-f (null? (cdr ls))) last-f elt-f) (car ls))
263              (lp (cdr ls))))
264       ((and dot-f (not (null? ls)))
265        (each (if (eq? ls init-ls) nothing sep) (dot-f ls)))
266       (else
267        nothing)))))
268
269;;> \procedure{(joined elt-f ls [sep])}
270;;>
271;;> Joins the result of applying \var{elt-f} to each element of the
272;;> list \var{ls} together with \var{sep}, which defaults to the empty
273;;> string.
274(define (joined elt-f ls . o)
275  (joined/general elt-f #f #f ls (if (pair? o) (car o) "")))
276
277;;> As \scheme{joined} but treats the separator as a prefix, inserting
278;;> before every element instead of between.
279(define (joined/prefix elt-f ls . o)
280  (if (null? ls)
281      nothing
282      (let ((sep (if (pair? o) (car o) "")))
283        (each sep (joined elt-f ls sep)))))
284
285;;> As \scheme{joined} but treats the separator as a suffix, inserting
286;;> after every element instead of between.
287(define (joined/suffix elt-f ls . o)
288  (if (null? ls)
289      nothing
290      (let ((sep (if (pair? o) (car o) "")))
291        (each (joined elt-f ls sep) sep))))
292
293;;> As \scheme{joined} but applies \var{last-f}, instead of
294;;> \var{elt-f}, to the last element of \var{ls}, useful for
295;;> e.g. commas separating a list with "and" before the final element.
296(define (joined/last elt-f last-f ls . o)
297  (joined/general elt-f last-f #f ls (if (pair? o) (car o) "")))
298
299;;> As \scheme{joined} but if \var{ls} is a dotted list applies
300;;> \var{dot-f} to the dotted tail as a final element.
301(define (joined/dot elt-f dot-f ls . o)
302  (joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))
303
304;;> As \scheme{joined} but counts from \var{start} to \var{end}
305;;> (exclusive), formatting each integer in the range.  If \var{end}
306;;> is \scheme{#f} or unspecified, produces an infinite stream of
307;;> output.
308(define (joined/range elt-f start . o)
309  (let ((end (and (pair? o) (car o)))
310        (sep (if (and (pair? o) (pair? (cdr o))) (cadr o) "")))
311    (let lp ((i start))
312      (if (and end (>= i end))
313          nothing
314          (each (if (> i start) sep nothing)
315                (elt-f i)
316                (fn () (lp (+ i 1))))))))
317