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