From 5afb17062aa04b674e41dc93b470bfdb1997f19b Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Sun, 15 Sep 2024 13:47:04 +0200 Subject: [PATCH] Add SRFIs 165 and 166 (monadic formatting) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Also patches 130 to support string-copy with optional arguments, as in the spec. The SRFI 166 test suite is included but it depends on Alex Shinn’s `(chibi test)`. This is available for Chez here: but as it’s not (yet) a SRFI of its own, I’ve excluded it from here and left the tests in the SRFI directory rather than putting them in tests/. For me on Chez 10.0.0, all of the tests pass except for two spurious failures (the test expects lowercase hex digits where Chez gives uppercase ones, but this is not actually specified by the SRFI so either is okay). --- %3a130/string-cursors.sls | 5 +- %3a165.sls | 46 +++ %3a165/implementation.scm | 283 +++++++++++++ %3a166.sls | 74 ++++ %3a166/base.scm | 131 ++++++ %3a166/base.sls | 61 +++ %3a166/color.scm | 112 +++++ %3a166/color.sls | 22 + %3a166/column.scm | 483 ++++++++++++++++++++++ %3a166/columnar.sls | 36 ++ %3a166/pretty.scm | 430 ++++++++++++++++++++ %3a166/pretty.sls | 16 + %3a166/show-shared.sls | 77 ++++ %3a166/show.scm | 316 +++++++++++++++ %3a166/test.scm | 829 ++++++++++++++++++++++++++++++++++++++ %3a166/unicode.scm | 172 ++++++++ %3a166/unicode.sls | 14 + %3a166/width.scm | 9 + %3a166/write.scm | 509 +++++++++++++++++++++++ 19 files changed, 3623 insertions(+), 2 deletions(-) create mode 100644 %3a165.sls create mode 100644 %3a165/implementation.scm create mode 100644 %3a166.sls create mode 100644 %3a166/base.scm create mode 100644 %3a166/base.sls create mode 100644 %3a166/color.scm create mode 100644 %3a166/color.sls create mode 100644 %3a166/column.scm create mode 100644 %3a166/columnar.sls create mode 100644 %3a166/pretty.scm create mode 100644 %3a166/pretty.sls create mode 100644 %3a166/show-shared.sls create mode 100644 %3a166/show.scm create mode 100644 %3a166/test.scm create mode 100644 %3a166/unicode.scm create mode 100644 %3a166/unicode.sls create mode 100644 %3a166/width.scm create mode 100644 %3a166/write.scm diff --git a/%3a130/string-cursors.sls b/%3a130/string-cursors.sls index 3baae98..d925654 100644 --- a/%3a130/string-cursors.sls +++ b/%3a130/string-cursors.sls @@ -24,8 +24,9 @@ string-reverse string-concatenate string-concatenate-reverse string-fold string-fold-right string-for-each-cursor string-replicate string-count string-replace string-split string-filter string-remove) - (import (rnrs) - (rename (only (srfi :13) string-index string-index-right + (import (except (rnrs) string-copy) + (rename (only (srfi :13) string-copy + string-index string-index-right string-contains string-filter string-replace string-count string-fold-right string-fold string-concatenate-reverse string-concatenate diff --git a/%3a165.sls b/%3a165.sls new file mode 100644 index 0000000..167a6fb --- /dev/null +++ b/%3a165.sls @@ -0,0 +1,46 @@ +;; Copyright (C) Marc Nieper-Wißkirchen (2019). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice (including +;; the next paragraph) shall be included in all copies or substantial +;; portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(library (srfi :165) + (export make-computation-environment-variable + make-computation-environment computation-environment-ref + computation-environment-update + computation-environment-update! computation-environment-copy + make-computation computation-each computation-each-in-list + computation-pure computation-bind computation-sequence + computation-run computation-ask computation-local + computation-fn computation-with computation-with! + computation-forked computation-bind/forked + default-computation + define-computation-type) + (import (except (rnrs) + define-record-type) + (srfi :9) + (srfi :111) + (srfi :125) + (srfi :128) + (only (srfi :133 vectors) vector-copy) + (srfi :146) + (srfi :244) + (srfi private include)) + (include/resolve ("srfi" "%3a165") "implementation.scm")) diff --git a/%3a165/implementation.scm b/%3a165/implementation.scm new file mode 100644 index 0000000..00b3b0b --- /dev/null +++ b/%3a165/implementation.scm @@ -0,0 +1,283 @@ +;; Copyright (C) Marc Nieper-Wißkirchen (2019). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice (including +;; the next paragraph) shall be included in all copies or substantial +;; portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-record-type Computation-Environment-Variable + (make-environment-variable name default immutable? id) + environment-variable? + (name environment-variable-name) + (default environment-variable-default) + (immutable? environment-variable-immutable?) + (id environment-variable-id)) + +(define make-computation-environment-variable + (let ((count 0)) + (lambda (name default immutable?) + (set! count (+ count 1)) + (make-environment-variable name default immutable? (- count))))) + +(define (predefined? var) + (not (negative? (environment-variable-id var)))) + +(define variable-comparator + (make-comparator environment-variable? + eq? + (lambda (x y) + (< (environment-variable-id x) + (environment-variable-id y))) + (lambda (x . y) + (environment-variable-id x)))) + +(define default-computation + (make-computation-environment-variable 'default-computation #f #f)) + +(define (environment-global env) + (vector-ref env 0)) + +(define (environment-local env) + (vector-ref env 1)) + +(define (environment-set-global! env global) + (vector-set! env 0 global)) + +(define (environment-set-local! env local) + (vector-set! env 1 local)) + +(define (environment-cell-set! env var box) + (vector-set! env (+ 2 (environment-variable-id var)) box)) + +(define (environment-cell env var) + (vector-ref env (+ 2 (environment-variable-id var)))) + +(define-syntax define-computation-type + (syntax-rules () + ((define-computation-type make-environment run var ...) + (%define-computation-type make-environment run (var ...) 0 ())))) + +(define-syntax %define-computation-type + (syntax-rules () + ((_ make-environment run () n ((var default e immutable i) ...)) + (begin + (define-values (e ...) (values default ...)) + (define var (make-environment-variable 'var e immutable i)) + ... + (define (make-environment) + (let ((env (make-vector (+ n 2)))) + (environment-set-global! env (hash-table variable-comparator)) + (environment-set-local! env (mapping variable-comparator)) + (vector-set! env (+ i 2) (box e)) + ... + env)) + (define (run computation) + (execute computation (make-environment))))) + ((_ make-environment run ((v d) . v*) n (p ...)) + (%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #f n)))) + ((_ make-environment run ((v d "immutable") . v*) n (p ...)) + (%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #t n)))) + ((_ make-environment run (v . v*) n (p ...)) + (%define-computation-type make-environment run v* (+ n 1) (p ... (v #f e #f n)))))) + +(define-computation-type make-computation-environment computation-run) + +(define (computation-environment-ref env var) + (if (predefined? var) + (unbox (environment-cell env var)) + (mapping-ref + (environment-local env) + var + (lambda () + (hash-table-ref/default (environment-global env) + var + (environment-variable-default var))) + unbox))) + +(define (computation-environment-update env . arg*) + (let ((new-env (vector-copy env))) + (let loop ((arg* arg*) + (local (environment-local env))) + (if (null? arg*) + (begin + (environment-set-local! new-env local) + new-env) + (let ((var (car arg*)) + (val (cadr arg*))) + (if (predefined? var) + (begin + (environment-cell-set! new-env var (box val)) + (loop (cddr arg*) local)) + (loop (cddr arg*) (mapping-set local var (box val))))))))) + +(define (computation-environment-update! env var val) + (if (predefined? var) + (set-box! (environment-cell env var) val) + (mapping-ref (environment-local env) + var + (lambda () + (hash-table-set! (environment-global env) var val)) + (lambda (cell) + (set-box! cell val))))) + +(define (computation-environment-copy env) + (let ((global (hash-table-copy (environment-global env) #t))) + (mapping-for-each (lambda (var cell) + (hash-table-set! global var (unbox cell))) + (environment-local env)) + (let ((new-env (make-vector (vector-length env)))) + (environment-set-global! new-env global) + (environment-set-local! new-env (mapping variable-comparator)) + (do ((i (- (vector-length env) 1) (- i 1))) + ((< i 2) + new-env) + (vector-set! new-env i (box (unbox (vector-ref env i)))))))) + +(define (execute computation env) + (let ((coerce (if (procedure? computation) + values + (or (computation-environment-ref env default-computation) + (error "not a computation" computation))))) + ((coerce computation) env))) + +(define (make-computation proc) + (lambda (env) + (proc (lambda (c) (execute c env))))) + +(define (computation-pure . args) + (make-computation + (lambda (compute) + (apply values args)))) + +(define (computation-each a . a*) + (computation-each-in-list (cons a a*))) + +(define (computation-each-in-list a*) + (make-computation + (lambda (compute) + (let loop ((a (car a*)) (a* (cdr a*))) + (if (null? a*) + (compute a) + (begin + (compute a) + (loop (car a*) (cdr a*)))))))) + +(define (computation-bind a . f*) + (make-computation + (lambda (compute) + (let loop ((a a) (f* f*)) + (if (null? f*) + (compute a) + (loop (call-with-values + (lambda () (compute a)) + (car f*)) + (cdr f*))))))) + +(define (computation-ask) + (lambda (env) + env)) + +(define (computation-local updater computation) + (lambda (env) + (computation (updater env)))) + +(define-syntax computation-fn + (syntax-rules () + ((_ (clause ...) expr ... computation) + (%fn (clause ...) () expr ... computation)))) + +(define-syntax %fn + (syntax-rules () + ((_ () ((id var tmp) ...) expr ... computation) + (let ((tmp var) ...) + (computation-bind + (computation-ask) + (lambda (env) + (let ((id (computation-environment-ref env tmp)) ...) + expr ... + computation))))) + ((_ ((id var) . rest) (p ...) expr ... computation) + (%fn rest (p ... (id var tmp)) expr ... computation)) + ((_ (id . rest) (p ...) expr ... computation) + (%fn rest (p ... (id id tmp)) expr ... computation)))) + +(define-syntax computation-with + (syntax-rules () + ((_ ((var val) ...) a* ... a) + (%with ((var val) ...) () () a* ... a)))) + +(define-syntax %with + (syntax-rules () + ((_ () ((x u) ...) ((a b) ...)) + (let ((u x) ... (b a) ...) + (computation-local + (lambda (env) + (computation-environment-update env u ...) ) + (computation-each b ...)))) + ((_ ((var val) . rest) (p ...) () a* ...) + (%with rest (p ... (var u) (val v)) () a* ...)) + ((_ () p* (q ...) a . a*) + (%with () p* (q ... (a b)) . a*)))) + +(define-syntax computation-with! + (syntax-rules () + ((_ (var val) ...) + (%with! (var val) ... ())))) + +(define-syntax %with! + (syntax-rules () + ((_ ((var u val v) ...)) + (let ((u var) ... (v val) ...) + (computation-bind + (computation-ask) + (lambda (env) + (computation-environment-update! env u v) ... + (computation-pure (if #f #f)))))) + ((_ (var val) r ... (p ...)) + (%with! r ... (p ... (var u val v)))))) + +(define (computation-forked a . a*) + (make-computation + (lambda (compute) + (let loop ((a a) (a* a*)) + (if (null? a*) + (compute a) + (begin + (compute (computation-local + (lambda (env) + (computation-environment-copy env)) + a)) + (loop (car a*) (cdr a*)))))))) + +(define (computation-bind/forked computation . proc*) + (apply computation-bind + (computation-local computation-environment-copy computation) + proc*)) + +(define (computation-sequence fmt*) + (fold-right + (lambda (fmt res) + (computation-bind + res + (lambda (vals) + (computation-bind + fmt + (lambda (val) + (computation-pure (cons val vals))))))) + (computation-pure '()) fmt*)) diff --git a/%3a166.sls b/%3a166.sls new file mode 100644 index 0000000..b5e0f62 --- /dev/null +++ b/%3a166.sls @@ -0,0 +1,74 @@ +;; The following notice applies to this file and all files associated +;; with SRFI 166. +;; --- +;; Copyright (c) 2009-2021 Alex Shinn +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. The name of the author may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;; --- + +(library (srfi :166) + (export + ;; basic + show displayed written written-shared written-simply escaped maybe-escaped + numeric numeric/comma numeric/si numeric/fitted + nl fl space-to tab-to nothing each each-in-list + joined joined/prefix joined/suffix joined/last joined/dot + joined/range padded padded/right padded/both + trimmed trimmed/right trimmed/both trimmed/lazy + fitted fitted/right fitted/both output-default + ;; computations + fn with with! forked call-with-output + ;; state variables + make-state-variable + port row col width output writer pad-char ellipsis + string-width substring/width substring/preserve + radix precision decimal-sep decimal-align sign-rule + comma-sep comma-rule word-separator? ambiguous-is-wide? + pretty-environment + ;; pretty + pretty pretty-shared pretty-simply pretty-with-color + ;; columnar + columnar tabular wrapped wrapped/list wrapped/char + justified from-file line-numbers + ;; unicode + terminal-aware + string-terminal-width string-terminal-width/wide + substring-terminal-width substring-terminal-width/wide + substring-terminal-width substring-terminal-width/wide + substring-terminal-preserve + upcased downcased + ;; color + as-red as-blue as-green as-cyan as-yellow + as-magenta as-white as-black + as-bold as-italic as-underline + as-color as-true-color + on-red on-blue on-green on-cyan on-yellow + on-magenta on-white on-black + on-color on-true-color + ) + (import (srfi :166 base) + (srfi :166 pretty) + (srfi :166 columnar) + (srfi :166 unicode) + (srfi :166 color))) diff --git a/%3a166/base.scm b/%3a166/base.scm new file mode 100644 index 0000000..eb34163 --- /dev/null +++ b/%3a166/base.scm @@ -0,0 +1,131 @@ + +;;> The minimal base formatting combinators and show interface. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax fn + (syntax-rules () + ((fn . x) + (computation-fn . x)))) + +;; The base formatting handles outputting raw strings and a simple, +;; configurable handler for formatting objects. + +;; Utility - default value of string-width. +(define (substring-length str . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (- end start))) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +;;> Raw output - displays str to the formatter output port and updates +;;> row and col. +(define (output-default str) + (fn (port (r row) (c col) string-width) + (let ((nl-index (string-index-right str #\newline))) + (write-string str port) + (if (string-cursor>? nl-index (string-cursor-start str)) + (with! (row (+ r (string-count str (lambda (ch) (eqv? ch #\newline))))) + (col (string-width str (string-cursor->index str nl-index)))) + (with! (col (+ c (string-width str)))))))) + +(define-computation-type make-show-env show-run + (port (current-output-port)) + (col 0) + (row 0) + (width 78) + (radix 10) + (pad-char #\space) + (output output-default) + (string-width substring-length) + (substring/width substring) + (substring/preserve #f) + (word-separator? char-whitespace?) + (ambiguous-is-wide? #f) + (ellipsis "") + (decimal-align #f) + (decimal-sep #f) + (comma-sep #f) + (comma-rule #f) + (sign-rule #f) + (precision #f) + (writer #f) + (pretty-environment (interaction-environment)) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> \procedure{(show out [args ...])} +;;> +;;> Run the combinators \var{args}, accumulating the output to +;;> \var{out}, which is either an output port or a boolean, with +;;> \scheme{#t} indicating \scheme{current-output-port} and +;;> \scheme{#f} to collect the output as a string. +(define (show out . args) + (let ((proc (each-in-list args))) + (cond + ((output-port? out) + (show-run (sequence (with! (port out)) proc))) + ((eq? #t out) + (show-run (sequence (with! (port (current-output-port))) proc))) + ((eq? #f out) + (call-with-output-string + (lambda (out) + (show-run (sequence (with! (port out)) proc))))) + (else + (error "unknown output to show" out))))) + + +;;> Temporarily bind the parameters in the body \var{x}. + +(define-syntax with + (syntax-rules () + ((with params x ... y) + (computation-with params (each x ... y))))) + +;;> The noop formatter. Generates no output and leaves the state +;;> unmodified. +(define nothing (fn () (with!))) + +;;> Formats a displayed version of x - if a string or char, outputs the +;;> raw characters (as with `display'), if x is already a formatter +;;> defers to that, otherwise outputs a written version of x. +(define (displayed x) + (cond + ((procedure? x) x) + ((string? x) (fn ((output1 output)) (output1 x))) + ((char? x) (displayed (string x))) + (else (written x)))) + +;;> Formats a written version of x, as with `write'. The formatting +;;> can be updated with the \scheme{'writer} field. +(define (written x) + (fn (writer) ((or writer written-default) x))) + +;;> Takes a single list of formatters, combined in sequence with +;;> \scheme{each}. +(define (each-in-list args) + (if (pair? args) + (if (pair? (cdr args)) + (sequence (displayed (car args)) (each-in-list (cdr args))) + (fn () (displayed (car args)))) + nothing)) + +;;> Combines each of the formatters in a sequence using +;;> \scheme{displayed}, so that strings and chars will be output +;;> directly and other objects will be \scheme{written}. +(define (each . args) + (each-in-list args)) + +;;> Captures the output of \var{producer} and formats the result with +;;> \var{consumer}. +(define (call-with-output producer consumer) + (let ((out (open-output-string))) + (forked (with ((port out) (output output-default)) producer) + (fn () (consumer (get-output-string out)))))) diff --git a/%3a166/base.sls b/%3a166/base.sls new file mode 100644 index 0000000..4f90526 --- /dev/null +++ b/%3a166/base.sls @@ -0,0 +1,61 @@ + +(library (srfi :166 base) + (export + ;; basic + show displayed written written-shared written-simply + escaped maybe-escaped + numeric numeric/comma numeric/si numeric/fitted + nl fl space-to tab-to nothing each each-in-list + joined joined/prefix joined/suffix joined/last joined/dot + joined/range padded padded/right padded/both + trimmed trimmed/right trimmed/both trimmed/lazy + fitted fitted/right fitted/both output-default + ;; computations + fn with with! forked call-with-output + ;; state variables + make-state-variable + port row col width output writer pad-char ellipsis + string-width substring/width substring/preserve + radix precision decimal-sep decimal-align sign-rule + comma-sep comma-rule word-separator? ambiguous-is-wide? + pretty-environment + ) + (import (except (rnrs) + error + define-record-type + string-hash string-ci-hash) + (rnrs eval) + (rnrs r5rs) + (srfi :6) + (srfi :23 error tricks) + (srfi :69) + (srfi :130) + (only (srfi :152 strings) write-string) + (rename (srfi :165) + (computation-each sequence) + (computation-with! with!) + (computation-forked forked) + (make-computation-environment-variable make-state-variable)) + (srfi private include) + (srfi :166 show-shared)) + + (define (interaction-environment) (environment '(rnrs))) + (define-syntax let-optionals* + (syntax-rules () + ((let-optionals* opt-ls () . body) + (begin . body)) + ((let-optionals* (op . args) vars . body) + (let ((tmp (op . args))) + (let-optionals* tmp vars . body))) + ((let-optionals* tmp ((var default) . rest) . body) + (let ((var (if (pair? tmp) (car tmp) default)) + (tmp2 (if (pair? tmp) (cdr tmp) '()))) + (let-optionals* tmp2 rest . body))) + ((let-optionals* tmp tail . body) + (let ((tail tmp)) . body)))) + + (SRFI-23-error->R6RS + "(library (srfi :166 base))" + (include/resolve ("srfi" "%3a166") "base.scm") + (include/resolve ("srfi" "%3a166") "write.scm") + (include/resolve ("srfi" "%3a166") "show.scm"))) diff --git a/%3a166/color.scm b/%3a166/color.scm new file mode 100644 index 0000000..4235705 --- /dev/null +++ b/%3a166/color.scm @@ -0,0 +1,112 @@ +;; color.scm -- colored output +;; Copyright (c) 2006-2020 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (color->ansi x) + (case x + ((bold) "1") + ((dark) "2") + ((italic) "3") + ((underline) "4") + + ((bold-off) "22") + ((italic-off) "23") + ((underline-off) "24") + + ((black) "30") + ((red) "31") + ((green) "32") + ((yellow) "33") + ((blue) "34") + ((magenta) "35") + ((cyan) "36") + ((white) "37") + ((default-fg) "39") + + ((on-black) "40") + ((on-red) "41") + ((on-green) "42") + ((on-yellow) "43") + ((on-blue) "44") + ((on-magenta) "45") + ((on-cyan) "46") + ((on-white) "47") + ((default-bg) "49"))) + +(define (ansi-escape color) + (if (string? color) + color + (string-append "\x1B;[" (color->ansi color) "m"))) + +(define color (make-state-variable 'color 'default-fg #f)) +(define background (make-state-variable 'background 'default-bg #f)) +(define bold (make-state-variable 'bold 'bold-off #f)) +(define italic (make-state-variable 'bold 'italic-off #f)) +(define underline (make-state-variable 'bold 'underline-off #f)) + +(define (with-attr var new-attr . args) + (fn ((orig-attr var)) + (with ((var new-attr)) + (each (ansi-escape new-attr) + (each-in-list args) + (ansi-escape orig-attr))))) + +(define (as-bold . args) (with-attr bold 'bold (each-in-list args))) +(define (as-italic . args) (with-attr italic 'italic (each-in-list args))) +(define (as-underline . args) (with-attr underline 'underline (each-in-list args))) + +(define (as-red . args) (with-attr color 'red (each-in-list args))) +(define (as-blue . args) (with-attr color 'blue (each-in-list args))) +(define (as-green . args) (with-attr color 'green (each-in-list args))) +(define (as-cyan . args) (with-attr color 'cyan (each-in-list args))) +(define (as-yellow . args) (with-attr color 'yellow (each-in-list args))) +(define (as-magenta . args) (with-attr color 'magenta (each-in-list args))) +(define (as-white . args) (with-attr color 'white (each-in-list args))) +(define (as-black . args) (with-attr color 'black (each-in-list args))) + +(define (on-red . args) (with-attr background 'on-red (each-in-list args))) +(define (on-blue . args) (with-attr background 'on-blue (each-in-list args))) +(define (on-green . args) (with-attr background 'on-green (each-in-list args))) +(define (on-cyan . args) (with-attr background 'on-cyan (each-in-list args))) +(define (on-yellow . args) (with-attr background 'on-yellow (each-in-list args))) +(define (on-magenta . args) (with-attr background 'on-magenta (each-in-list args))) +(define (on-white . args) (with-attr background 'on-white (each-in-list args))) +(define (on-black . args) (with-attr background 'on-black (each-in-list args))) + +(define (rgb-escape red-level green-level blue-level bg?) + (when (not (and (exact-integer? red-level) (<= 0 red-level 5))) + (error "invalid red-level value" red-level)) + (when (not (and (exact-integer? green-level) (<= 0 green-level 5))) + (error "invalid green-level value" green-level)) + (when (not (and (exact-integer? blue-level) (<= 0 blue-level 5))) + (error "invalid blue-level value" blue-level)) + (string-append + (if bg? "\x1B;[48;5;" "\x1B;[38;5;") + (number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16)) + "m")) + +(define (rgb24-escape red-level green-level blue-level bg?) + (when (not (and (exact-integer? red-level) (<= 0 red-level 255))) + (error "invalid red-level value" red-level)) + (when (not (and (exact-integer? green-level) (<= 0 green-level 255))) + (error "invalid green-level value" green-level)) + (when (not (and (exact-integer? blue-level) (<= 0 blue-level 255))) + (error "invalid blue-level value" blue-level)) + (string-append + (if bg? "\x1B;[48;2;" "\x1B;[38;2;") + (number->string red-level) ";" + (number->string green-level) ";" + (number->string blue-level) + "m")) + +(define (as-color red green blue . fmt) + (with-attr color (rgb-escape red green blue #f) (each-in-list fmt))) + +(define (as-true-color red green blue . fmt) + (with-attr color (rgb24-escape red green blue #f) (each-in-list fmt))) + +(define (on-color red green blue . fmt) + (with-attr background (rgb-escape red green blue #t) (each-in-list fmt))) + +(define (on-true-color red green blue . fmt) + (with-attr background (rgb24-escape red green blue #t) (each-in-list fmt))) diff --git a/%3a166/color.sls b/%3a166/color.sls new file mode 100644 index 0000000..31a0ffe --- /dev/null +++ b/%3a166/color.sls @@ -0,0 +1,22 @@ + +(library (srfi :166 color) + (export + ;; foreground + as-red as-blue as-green as-cyan as-yellow + as-magenta as-white as-black + as-bold as-italic as-underline + as-color as-true-color + ;; background + on-red on-blue on-green on-cyan on-yellow + on-magenta on-white on-black + on-color on-true-color + ) + (import (except (rnrs) error) + (srfi :23 error tricks) + (srfi :130) + (srfi :166 base) + (srfi private include)) + (define (exact-integer? n) (and (integer? n) (exact? n))) + (SRFI-23-error->R6RS + "(library (srfi :166 color))" + (include/resolve ("srfi" "%3a166") "color.scm"))) diff --git a/%3a166/column.scm b/%3a166/column.scm new file mode 100644 index 0000000..7b71ea2 --- /dev/null +++ b/%3a166/column.scm @@ -0,0 +1,483 @@ +;; column.scm -- formatting columns and tables +;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-split-words str separator?) + (let ((start (string-cursor-start str)) + (end (string-cursor-end str))) + (let lp ((sc start) (res '())) + (cond + ((string-cursor>=? sc end) + (reverse res)) + (else + (let ((sc2 (string-index str separator? sc))) + (lp (string-cursor-next str sc2) + (if (string-cursor=? sc sc2) + res + (cons (substring/cursors str sc sc2) res))))))))) + +(define (call-with-output-generator producer consumer) + (fn () + (let ((out (open-output-string)) + (queue (list-queue)) + (return #f) + (resume #f)) + (define eof (read-char (open-input-string ""))) + (define (output* str) + (fn (row col string-width) + (list-queue-add-back! queue str) + (each + (let ((nl-index + (string-index-right str (lambda (ch) (eqv? ch #\newline))))) + (if (string-cursor>? nl-index (string-cursor-start str)) + (with! + (row (+ row (string-count str (lambda (ch) (eqv? ch #\newline))))) + (col (string-width str (string-cursor->index str nl-index)))) + (with! (col (+ col (string-width str)))))) + (call-with-current-continuation + (lambda (cc) + (set! resume cc) + (return nothing)))) + nothing)) + (define (generate) + (when (and resume (list-queue-empty? queue)) + (call-with-current-continuation + (lambda (cc) + (set! return cc) + (resume nothing)))) + (if (list-queue-empty? queue) + eof + (list-queue-remove-front! queue))) + (forked (fn () (with ((port out) (output output*)) + (call-with-current-continuation + (lambda (cc) + (set! return cc) + (each producer + (fn (output) + (set! resume #f) + (fn () (return nothing) nothing))))))) + (fn () (consumer generate)))))) + +(define (call-with-output-generators producers consumer) + (let lp ((ls producers) (generators '())) + (if (null? ls) + (consumer (reverse generators)) + (call-with-output-generator + (car ls) + (lambda (generator) + (lp (cdr ls) (cons generator generators))))))) + +(define (string->line-generator source) + (let ((str '()) + (scanned? #f)) + (define (gen) + (if (pair? str) + (if scanned? + (let ((res (source))) + (cond + ((eof-object? res) + (let ((res (string-concatenate (reverse str)))) + (set! str '()) + res)) + ((equal? res "") + (gen)) + (else + (set! str (cons res str)) + (set! scanned? #f) + (gen)))) + (let ((nl (string-index (car str) #\newline)) + (end (string-cursor-end (car str)))) + (cond + ((string-cursorline-generator gens))) + (let lp () + (let* ((lines (map (lambda (gen) (gen)) gens)) + (num-present (count string? lines))) + (if (<= num-present num-infinite) + nothing + (each + (each-in-list + (map (lambda (col line) + ((column-format col) + (if (eof-object? line) "" line))) + cols + lines)) + "\n" + (fn () (lp)))))))))))) + +;; (columnar ['infinite|'right|'left|'center|width] string-or-formatter ...) +(define (columnar . ls) + (define (proportional-width? w) + (and (number? w) + (or (< 0 w 1) + (and (inexact? w) (= w 1.0))))) + (define (build-column ls) + (let-optionals* ls ((fixed-width #f) + (col-width #f) + (last? #t) + (tail '()) + (gen #f) + (prefix '()) + (align 'left) + (infinite? #f)) + (define (scale-width width) + (max 1 (exact (truncate (* col-width (- width fixed-width)))))) + (define (padder) + (if (proportional-width? col-width) + (case align + ((right) + (lambda (str) (fn (width) (padded (scale-width width) str)))) + ((center) + (lambda (str) (fn (width) (padded/both (scale-width width) str)))) + (else + (lambda (str) (fn (width) (padded/right (scale-width width) str))))) + (case align + ((right) (lambda (str) (padded col-width str))) + ((center) (lambda (str) (padded/both col-width str))) + (else (lambda (str) (padded/right col-width str)))))) + (define (affix x) + (cond + ((pair? tail) + (lambda (str) + (each (each-in-list prefix) + (x str) + (each-in-list tail)))) + ((pair? prefix) + (lambda (str) (each (each-in-list prefix) (x str)))) + (else (displayed x)))) + (list + ;; line formatter + (affix + (let ((pad (padder))) + (if (and last? (not (pair? tail)) (eq? align 'left)) + (lambda (str) + (fn (pad-char) + ((if (or (not pad-char) (char-whitespace? pad-char)) + displayed + pad) + str))) + pad))) + ;; generator + (if (proportional-width? col-width) + (fn ((orig-width width)) + (with ((width (scale-width orig-width))) + gen)) + (with ((width col-width)) gen)) + infinite?))) + (define (adjust-widths ls border-width) + (let* ((fixed-ls + (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls)) + (fixed-total (fold + border-width (map car fixed-ls))) + (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls)) + (denom (- (length ls) (+ (length fixed-ls) (length scaled-ls)))) + (rest (if (zero? denom) + 0 + (inexact + (/ (- 1 (fold + 0 (map car scaled-ls))) denom))))) + (if (negative? rest) + (error "fractional widths must sum to less than 1" + (map car scaled-ls))) + (map + (lambda (col) + (cons fixed-total + (if (not (number? (car col))) + (cons rest (cdr col)) + col))) + ls))) + (define (finish ls border-width) + (apply show-columns + (map build-column (adjust-widths (reverse ls) border-width)))) + (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f) + (width #t) (border-width 0) (res '())) + (cond + ((null? ls) + (cond + ((null? res) nl) + ((pair? strs) + (finish (cons (cons (caar res) + (cons #t (cons (append (reverse strs) + (cadr (cdar res))) + (cddr (cdar res))))) + (cdr res)) + border-width)) + (else + (finish (cons (cons (caar res) (cons #t (cddr (car res)))) (cdr res)) + border-width)))) + ((char? (car ls)) + (lp (cons (string (car ls)) (cdr ls)) strs align infinite? + width border-width res)) + ((string? (car ls)) + (if (string-contains "\n" (car ls)) + (error "column string literals can't contain newlines") + (lp (cdr ls) (cons (car ls) strs) align infinite? + width (+ border-width (string-length (car ls))) res))) + ((number? (car ls)) + (lp (cdr ls) strs align infinite? (car ls) border-width res)) + ((eq? (car ls) 'infinite) + (lp (cdr ls) strs align #t width border-width res)) + ((symbol? (car ls)) + (lp (cdr ls) strs (car ls) infinite? width border-width res)) + ((procedure? (car ls)) + (lp (cdr ls) '() 'left #f #t border-width + (cons (list width #f '() (car ls) (reverse strs) align infinite?) + res))) + (else + (error "invalid column" (car ls)))))) + +(define (max-line-width string-width str) + (let ((end (string-cursor-end str))) + (let lp ((i (string-cursor-start str)) (hi 0)) + (let ((j (string-index str #\newline i))) + (if (string-cursor=? i end) + nothing) + ((string-cursor>=? nli end) + (kons-in-line (substring/cursors str i end))) + (else + (each + (fn () (kons-in-line (substring/cursors str i nli))) + (fn () (lp (string-cursor-next str nli)))))))))))) + (each-in-list ls)))) + +;; `seq' is a list or vector of pre-tokenized words. `line' is called +;; on each wrapped line and the accumulator, starting with `knil'. +;; The optional `last-line' is used instead on the last line of the +;; paragraph. +(define (wrap-fold-words seq knil max-width get-width line . o) + (let* ((last-line (if (pair? o) (car o) line)) + (vec (if (list? seq) (list->vector seq) seq)) + (len (vector-length vec)) + (len-1 (- len 1)) + (breaks (make-vector len #f)) + (penalties (make-vector len #f)) + (widths + (list->vector + (map get-width (if (list? seq) seq (vector->list vec)))))) + (define (largest-fit i) + (let lp ((j (+ i 1)) (width (vector-ref widths i))) + (let ((width (+ width 1 (vector-ref widths j)))) + (cond + ((>= width max-width) (- j 1)) + ((>= j len-1) len-1) + (else (lp (+ j 1) width)))))) + (define (min-penalty! i) + (cond + ((>= i len-1) 0) + ((vector-ref penalties i)) + (else + (vector-set! penalties i (expt (+ max-width 1) 3)) + (vector-set! breaks i i) + (let ((k (largest-fit i))) + (let lp ((j i) (width 0)) + (if (<= j k) + (let* ((width (+ width (vector-ref widths j))) + (break-penalty + (+ (max 0 (expt (- max-width (+ width (- j i))) 3)) + (min-penalty! (+ j 1))))) + (cond + ((< break-penalty (vector-ref penalties i)) + (vector-set! breaks i j) + (vector-set! penalties i break-penalty))) + (lp (+ j 1) width))))) + (if (>= (vector-ref breaks i) len-1) + (vector-set! penalties i 0)) + (vector-ref penalties i)))) + (define (sub-list i j) + (let lp ((i i) (res '())) + (if (> i j) + (reverse res) + (lp (+ i 1) (cons (vector-ref vec i) res))))) + (cond + ((zero? len) + ;; degenerate case + (last-line '() knil)) + (else + ;; compute optimum breaks + (vector-set! breaks len-1 len-1) + (vector-set! penalties len-1 0) + (min-penalty! 0) + ;; fold + (let lp ((i 0) (acc knil)) + (let ((break (vector-ref breaks i))) + (if (>= break len-1) + (last-line (sub-list i len-1) acc) + (lp (+ break 1) (line (sub-list i break) acc))))))))) + +(define (wrapped/list ls) + (fn (width string-width pad-char) + (joined + (lambda (ls) (joined displayed ls pad-char)) + (reverse + (wrap-fold-words ls '() width (or string-width string-length) cons)) + "\n"))) + +(define (wrapped . ls) + (call-with-output + (each-in-list ls) + (lambda (str) + (fn (word-separator?) + (wrapped/list + (string-split-words str (or word-separator? char-whitespace?))))))) + +(define (justified . ls) + (fn (output width string-width) + (define (justify-line ls) + (if (null? ls) + nl + (let* ((sum (fold (lambda (s n) + (+ n ((or string-width string-length) s))) + 0 ls)) + (len (length ls)) + (diff (max 0 (- width sum))) + (sep (make-string (if (= len 1) + 0 + (quotient diff (- len 1))) + #\space)) + (rem (if (= len 1) + diff + (remainder diff (- len 1)))) + (p (open-output-string))) + (write-string (car ls) p) + (let lp ((ls (cdr ls)) (i 1)) + (when (pair? ls) + (write-string sep p) + (if (<= i rem) (write-char #\space p)) + (write-string (car ls) p) + (lp (cdr ls) (+ i 1)))) + (displayed (get-output-string p))))) + (define (justify-last ls) + (each (joined displayed ls " ") "\n")) + (call-with-output + (each-in-list ls) + (lambda (str) + (fn (word-separator?) + (joined/last + justify-line + justify-last + (reverse + (wrap-fold-words + (string-split-words str (or word-separator? char-whitespace?)) + '() width (or string-width string-length) + cons)) + "\n")))))) + +(define (from-file path . ls) + (let-optionals* ls ((sep nl)) + (fn () + (let ((in (open-input-file path))) + (let lp () + (let ((line (read-line in))) + (if (eof-object? line) + (begin (close-input-port in) nothing) + (each line sep + (fn () (lp)))))))))) + +(define (line-numbers . o) + (let ((start (if (pair? o) (car o) 1))) + (joined/range displayed start #f "\n"))) diff --git a/%3a166/columnar.sls b/%3a166/columnar.sls new file mode 100644 index 0000000..0c73b3d --- /dev/null +++ b/%3a166/columnar.sls @@ -0,0 +1,36 @@ + +(library (srfi :166 columnar) + (export + columnar tabular wrapped wrapped/list wrapped/char + justified from-file line-numbers) + (import (except (rnrs) + error + define-record-type) + (rnrs r5rs) + (only (srfi :1) count fold) + (srfi :6) + (srfi :9) + (srfi :23 error tricks) + (srfi :117) + (srfi :130) + (only (srfi :152 strings) write-string) + (srfi :166 base) + (srfi private include)) + (define-syntax let-optionals* + (syntax-rules () + ((let-optionals* opt-ls () . body) + (begin . body)) + ((let-optionals* (op . args) vars . body) + (let ((tmp (op . args))) + (let-optionals* tmp vars . body))) + ((let-optionals* tmp ((var default) . rest) . body) + (let ((var (if (pair? tmp) (car tmp) default)) + (tmp2 (if (pair? tmp) (cdr tmp) '()))) + (let-optionals* tmp2 rest . body))) + ((let-optionals* tmp tail . body) + (let ((tail tmp)) . body)))) + (define read-line get-line) + + (SRFI-23-error->R6RS + "(library (srfi :166 columnar))" + (include/resolve ("srfi" "%3a166") "column.scm"))) diff --git a/%3a166/pretty.scm b/%3a166/pretty.scm new file mode 100644 index 0000000..4d1d176 --- /dev/null +++ b/%3a166/pretty.scm @@ -0,0 +1,430 @@ +;; pretty.scm -- pretty printing format combinator +;; Copyright (c) 2006-2020 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (take* ls n) ; handles dotted lists and n > length + (cond ((zero? n) '()) + ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1)))) + (else '()))) + +(define (drop* ls n) ; may return the dot + (cond ((zero? n) ls) + ((pair? ls) (drop* (cdr ls) (- n 1))) + (else ls))) + +(define (make-space n) (make-string n #\space)) +(define (make-nl-space n) (string-append "\n" (make-string n #\space))) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +(define (joined/shares fmt ls shares . o) + (let ((sep (displayed (if (pair? o) (car o) " ")))) + (fn () + (cond + ((null? ls) + nothing) + ((pair? ls) + (fn () + (let lp ((ls ls)) + (each + (fmt (car ls)) + (let ((rest (cdr ls))) + (cond + ((null? rest) nothing) + ((pair? rest) + (call-with-shared-ref/cdr rest + shares + each + (fn () (lp rest)) + sep)) + (else (each sep ". " (fmt rest))))))))) + (else (fmt ls)))))) + +(define (string-find/index str pred i) + (string-cursor->index + str + (string-index str pred (string-index->cursor str i)))) + +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + +(define (try-fitted2 proc fail) + (fn (width string-width (orig-output output)) + (let ((out (open-output-string))) + (call-with-current-continuation + (lambda (abort) + ;; Modify output to accumulate to an output string port, + ;; and escape immediately with failure if we exceed the + ;; column width. + (define (output* str) + (fn (col) + (let lp ((i 0) (col col)) + (let ((nli (string-find/index str #\newline i)) + (len (string-width str))) + (if (< nli len) + (if (> (+ (- nli i) col) width) + (abort fail) + (lp (+ nli 1) 0)) + (let ((col (+ (- len i) col))) + (cond + ((> col width) + (abort fail)) + (else + (output-default str))))))))) + (forked + (with ((output output*) + (port out)) + proc) + ;; fitted successfully + (fn () (orig-output (get-output-string out))))))))) + +(define (try-fitted proc . fail) + (let lp ((proc proc) (ls fail)) + (if (null? ls) + proc + (try-fitted2 proc (lp (car ls) (cdr ls)))))) + +(define (fits-in-width width proc set-failed!) + (call-with-current-continuation + (lambda (abort) + (fn ((orig-output output)) + (define (output* str) + (each (orig-output str) + (fn (col) + (if (>= col width) + (begin (set-failed! #t) (abort #f)) + nothing)))) + (with ((output output*)) + proc))))) + +(define (fits-in-columns width ls writer set-result!) + (let ((max-w (quotient width 2))) + (fn (string-width) + (let lp ((ls ls) (res '()) (widest 0)) + (cond + ((pair? ls) + (let ((failed? #f)) + (call-with-output + (fits-in-width max-w + (writer (car ls)) + (lambda (x) (set! failed? x))) + (lambda (str) + (if failed? + (begin + (set-result! #f) + nothing) + (lp (cdr ls) + (cons str res) + (max (string-width str) widest))))))) + ((null? ls) (set-result! (cons widest (reverse res))) nothing) + (else (set-result! #f) nothing)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; style + +(define syntax-abbrevs + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@") + )) + +(define (pp-let ls pp shares color?) + (if (and (pair? (cdr ls)) (symbol? (cadr ls))) + (pp-with-indent 2 ls pp shares color?) + (pp-with-indent 1 ls pp shares color?))) + +(define indent-rules + `((lambda . 1) (define . 1) (define-syntax . 1) + (let . ,pp-let) (loop . ,pp-let) + (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2) + (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1) + (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2) + (match . 1) (match-let . 1) (match-let* . 1) + (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1) + (do . 2) (dotimes . 1) (dolist . 1) (test . 1) + (condition-case . 1) (guard . 1) (rec . 1) + (call-with-current-continuation . 0) + )) + +(define indent-prefix-rules + `(("with-" . -1) ("call-with-" . -1) ("define-" . 1)) + ) + +(define indent-suffix-rules + `(("-case" . 1)) + ) + +(define pp-macros + (append + (map car indent-rules) + '(quote quasiquote unquote unquote-splicing set! cond-expand cond ))) + +(define (pp-indentation form) + (let ((indent + (cond + ((assq (car form) indent-rules) => cdr) + ((and (symbol? (car form)) + (let ((str (symbol->string (car form)))) + (or (find (lambda (rx) (string-prefix? (car rx) str)) + indent-prefix-rules) + (find (lambda (rx) (string-suffix? (car rx) str)) + indent-suffix-rules)))) + => cdr) + (else #f)))) + (if (and (number? indent) (negative? indent)) + (max 0 (- (+ (or (length+ form) +inf.0) indent) 1)) + indent))) + +(define (with-reset-shares shares proc) + (let ((orig-count (cdr shares))) + (fn () + (let ((new-count (cdr shares))) + (when (> new-count orig-count) + (hash-table-walk + (car shares) + (lambda (k v) + (if (and (cdr v) (>= (car v) orig-count)) + (set-cdr! v #f)))) + (set-cdr! shares orig-count)) + proc)))) + +(define (pp-with-indent indent-rule ls pp shares color?) + (fn ((col1 col)) + (each + "(" + ((if (and color? (memq (car ls) pp-macros)) as-blue displayed) + (pp (car ls))) + (fn ((col2 col) width string-width) + (let ((fixed (take* (cdr ls) (or indent-rule 1))) + (tail (drop* (cdr ls) (or indent-rule 1))) + (default + (let ((sep (make-nl-space (+ col1 1)))) + (fn () (each sep (joined/shares pp (cdr ls) shares sep))))) + ;; reset in case we don't fit on the first line + (reset-shares (with-reset-shares shares nothing))) + (call-with-output + (trimmed/lazy (- width col2) + (each (if (or (null? fixed) (pair? fixed)) " " " . ") + (joined/shares + (lambda (x) (pp-flat x pp shares color?)) + fixed shares " "))) + (lambda (first-line) + (cond + ((< (+ col2 (string-width first-line)) width) + ;; fixed values on first line + (let ((sep (make-nl-space + (if indent-rule (+ col1 2) (+ col2 1))))) + (each first-line + (cond + ((not (or (null? tail) (pair? tail))) + (each ". " (pp tail))) + ((> (or (length+ (cdr ls)) +inf.0) (or indent-rule 1)) + (each sep (joined/shares pp tail shares sep))) + (else + nothing))))) + (indent-rule + ;; fixed values lined up, body indented two spaces + (try-fitted + (each + reset-shares + " " + (joined/shares pp fixed shares (make-nl-space (+ col2 1))) + (if (pair? tail) + (let ((sep (make-nl-space (+ col1 2)))) + (each sep (joined/shares pp tail shares sep))) + nothing)) + (each reset-shares default))) + (else + ;; all on separate lines + (each reset-shares default))))))) + ")"))) + +(define (pp-app ls pp shares color?) + (let ((indent-rule (pp-indentation ls))) + (if (procedure? indent-rule) + (indent-rule ls pp shares color?) + (pp-with-indent indent-rule ls pp shares color?)))) + +;; the elements may be shared, just checking the top level list +;; structure +(define (proper-non-shared-list? ls shares) + (let ((tab (car shares))) + (let lp ((ls ls)) + (or (null? ls) + (and (pair? ls) + (not (hash-table-ref/default tab ls #f)) + (lp (cdr ls))))))) + +(define (non-app? x) + (if (pair? x) + (or (not (or (null? (cdr x)) (pair? (cdr x)))) + (non-app? (car x))) + (not (symbol? x)))) + +(define (pp-data-list ls pp shares) + (each + "(" + (fn (col width string-width) + (let ((avail (- width col))) + (cond + ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))) + (let ((out (open-output-string)) + (result #f)) + (call-with-output + (fits-in-columns width ls (lambda (x) (pp-flat x pp shares #f)) + (lambda (res) (set! result res))) + (lambda (str) + (fn () + (if (not result) + ;; no room, print one per line + (joined/shares pp ls shares (make-nl-space col)) + ;; at least four elements which can be broken into columns + (let* ((prefix (make-nl-space col)) + (widest (+ 1 (car result))) + (columns (quotient width widest))) ; always >= 2 + (let lp ((ls (cdr result)) (i 1)) + (cond + ((null? ls) + nothing) + ((null? (cdr ls)) + (displayed (car ls))) + ((>= i columns) + (each (car ls) + prefix + (fn () (lp (cdr ls) 1)))) + (else + (let ((pad (- widest (string-width (car ls))))) + (each (car ls) + (make-space pad) + (lp (cdr ls) (+ i 1)))))))))))))) + (else + ;; no room, print one per line + (joined/shares pp ls shares (make-nl-space col)))))) + ")")) + +(define (pp-flat x pp shares color?) + (define (ppf x) + (pp-flat x pp shares color?)) + (cond + ((pair? x) + (cond + ((and (pair? (cdr x)) (null? (cddr x)) + (assq (car x) syntax-abbrevs)) + => (lambda (abbrev) + (each (cdr abbrev) + (call-with-shared-ref + (cadr x) + shares + each + (pp-flat (cadr x) pp shares color?))))) + (else + (fn () + (each "(" + ((if (and color? (memq (car x) pp-macros)) as-blue displayed) + (pp (car x))) + (if (null? (cdr x)) + nothing + (call-with-shared-ref/cdr + (cdr x) + shares + each + (cond + ((pair? (cdr x)) + (each "" (joined/shares ppf (cdr x) shares " "))) + (else + (each ". " (joined/shares ppf (cdr x) shares " ")))) + " ")) + ")"))))) + ((vector? x) + (each "#(" + (joined/shares ppf (vector->list x) shares " ") + ")")) + (else + (pp x)))) + +(define (pp-pair ls pp shares color?) + (cond + ;; one element list, no lines to break + ((null? (cdr ls)) + (each "(" (pp (car ls)) ")")) + ;; quote or other abbrev + ((and (pair? (cdr ls)) (null? (cddr ls)) + (assq (car ls) syntax-abbrevs)) + => (lambda (abbrev) + (each (cdr abbrev) (pp (cadr ls))))) + (else + (let ((reset-shares (with-reset-shares shares nothing))) + (try-fitted + (pp-flat ls pp shares color?) + (each + reset-shares + (fn () + (if (and (non-app? ls) + (proper-non-shared-list? ls shares)) + (pp-data-list ls pp shares) + (pp-app ls pp shares color?))))))))) + +(define (pp-vector vec pp shares) + (each "#" (pp-data-list (vector->list vec) pp shares))) + +;; adapted from `write-with-shares' +(define (pp obj shares color?) + (fn (radix precision) + (let ((write-number + (cond + ((and (not precision) + (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))) + => (lambda (cell) + (lambda (n) + (if (or (exact? n) (eqv? radix 10)) + (each (cdr cell) (number->string n (car cell))) + (with ((radix 10)) (numeric n)))))) + (else (lambda (n) (with ((radix 10)) (numeric n))))))) + (let pp ((obj obj)) + (call-with-shared-ref + obj shares each + (fn () + (cond + ((pair? obj) + (pp-pair obj pp shares color?)) + ((vector? obj) + (pp-vector obj pp shares)) + ((number? obj) + (write-number obj)) + ((and color? (string? obj)) + (as-green (write-to-string obj))) + (else + (displayed (write-to-string obj)))))))))) + +(define (pretty obj) + (fn () + (call-with-output + (each (pp obj (extract-shared-objects obj #t) #f) + fl) + displayed))) + +(define (pretty-shared obj) + (fn () + (call-with-output + (each (pp obj (extract-shared-objects obj #f) #f) + fl) + displayed))) + +(define (pretty-simply obj) + (fn () + (each (pp obj (extract-shared-objects #f #f) #f) + fl))) + +(define (pretty-with-color obj) + (fn () + (call-with-output + (each (pp obj (extract-shared-objects obj #t) #t) + fl) + displayed))) diff --git a/%3a166/pretty.sls b/%3a166/pretty.sls new file mode 100644 index 0000000..f7ae143 --- /dev/null +++ b/%3a166/pretty.sls @@ -0,0 +1,16 @@ + +(library (srfi :166 pretty) + (export pretty pretty-shared pretty-simply pretty-with-color) + (import (except (rnrs) + string-hash string-ci-hash) + (rnrs r5rs) + (rnrs mutable-pairs) + (only (srfi :1) length+) + (srfi :6) + (srfi :69) + (srfi :130) + (srfi :166 base) + (srfi :166 color) + (srfi :166 show-shared) + (srfi private include)) + (include/resolve ("srfi" "%3a166") "pretty.scm")) diff --git a/%3a166/show-shared.sls b/%3a166/show-shared.sls new file mode 100644 index 0000000..55307f1 --- /dev/null +++ b/%3a166/show-shared.sls @@ -0,0 +1,77 @@ + +;;; shared structure utilities + +(library (srfi :166 show-shared) + (export + extract-shared-objects call-with-shared-ref call-with-shared-ref/cdr) + (import (rnrs) + (rnrs mutable-pairs) + (only (srfi :69) + make-hash-table + hash-table-delete! + hash-table-ref + hash-table-ref/default + hash-table-set! + hash-table-update!/default + hash-table-walk)) + (begin + (define (extract-shared-objects x cyclic-only?) + (let ((seen (make-hash-table eq?))) + ;; find shared references + (let find ((x x)) + (cond ;; only interested in pairs and vectors (and records later) + ((or (pair? x) (vector? x)) + ;; increment the count + (hash-table-update!/default seen x (lambda (n) (+ n 1)) 0) + ;; walk if this is the first time + (cond + ((> (hash-table-ref seen x) 1)) + ((pair? x) + (find (car x)) + (find (cdr x))) + ((vector? x) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i))))) + ;; delete if this shouldn't count as a shared reference + (if (and cyclic-only? (<= (hash-table-ref/default seen x 0) 1)) + (hash-table-delete! seen x))))) + ;; extract shared references + (let ((res (make-hash-table eq?)) + (count 0)) + (hash-table-walk + seen + (lambda (k v) + (cond + ((> v 1) + (hash-table-set! res k (cons count #f)) + (set! count (+ count 1)))))) + (cons res 0)))) + + (define (gen-shared-ref cell shares) + (set-car! cell (cdr shares)) + (set-cdr! cell #t) + (set-cdr! shares (+ (cdr shares) 1)) + (string-append (number->string (car cell)))) + + (define (call-with-shared-ref obj shares each proc) + (let ((cell (hash-table-ref/default (car shares) obj #f))) + (cond + ((and (pair? cell) (cdr cell)) + (each "#" (number->string (car cell)) "#")) + ((pair? cell) + (each "#" (gen-shared-ref cell shares) "=" proc)) + (else + (each proc))))) + + (define (call-with-shared-ref/cdr obj shares each proc . o) + (let ((sep (if (pair? o) (car o) "")) + (cell (hash-table-ref/default (car shares) obj #f))) + (cond + ((and (pair? cell) (cdr cell)) + (each sep ". #" (number->string (car cell)) "#")) + ((pair? cell) + (each sep ". #" (gen-shared-ref cell shares) "=(" proc ")")) + (else + (each sep proc))))) + )) diff --git a/%3a166/show.scm b/%3a166/show.scm new file mode 100644 index 0000000..f06c2e6 --- /dev/null +++ b/%3a166/show.scm @@ -0,0 +1,316 @@ +;; show.scm -- additional combinator formatters +;; Copyright (c) 2013-2020 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> A library of procedures for formatting Scheme objects to text in +;;> various ways, and for easily concatenating, composing and +;;> extending these formatters. + +;;> \section{Background} +;;> +;;> There are several approaches to text formatting. Building strings +;;> to \scheme{display} is not acceptable, since it doesn't scale to +;;> very large output. The simplest realistic idea, and what people +;;> resort to in typical portable Scheme, is to interleave +;;> \scheme{display} and \scheme{write} and manual loops, but this is +;;> both extremely verbose and doesn't compose well. A simple concept +;;> such as padding space can't be achieved directly without somehow +;;> capturing intermediate output. +;;> +;;> The traditional approach is to use templates - typically strings, +;;> though in theory any object could be used and indeed Emacs' +;;> mode-line format templates allow arbitrary sexps. Templates can +;;> use either escape sequences (as in C's \cfun{printf} and +;;> \hyperlink["http://en.wikipedia.org/wiki/Format_(Common_Lisp)"]{CL's} +;;> \scheme{format}) or pattern matching (as in Visual Basic's +;;> \cfun{Format}, +;;> \hyperlink["http://search.cpan.org/~dconway/Perl6-Form-0.04/Form.pm"}{Perl6's} +;;> \cfun{form}, and SQL date formats). The primary disadvantage of +;;> templates is the relative difficulty (usually impossibility) of +;;> extending them, their opaqueness, and the unreadability that +;;> arises with complex formats. Templates are not without their +;;> advantages, but they are already addressed by other libraries such +;;> as +;;> \hyperlink["http://srfi.schemers.org/srfi-28/srfi-28.html"]{SRFI-28} +;;> and +;;> \hyperlink["http://srfi.schemers.org/srfi-48/srfi-48.html"]{SRFI-48}. +;;> +;;> This library takes a combinator approach. Formats are nested chains +;;> of closures, which are called to produce their output as needed. +;;> The primary goal of this library is to have, first and foremost, a +;;> maximally expressive and extensible formatting library. The next +;;> most important goal is scalability - to be able to handle +;;> arbitrarily large output and not build intermediate results except +;;> where necessary. The third goal is brevity and ease of use. + +;;> \section{Interface} + +;;> \procedure{(show out [args ...])} +;;> +;;> The primary interface. Analogous to CL's \scheme{format}, the first +;;> argument is either an output port or a boolean, with \scheme{#t} +;;> indicating \scheme{current-output-port} and \scheme{#f} indicating a +;;> string port. The remaining arguments are formatters, combined as with +;;> \scheme{each}, run with output to the given destination. If \var{out} +;;> is \scheme{#f} then the accumulated output is returned, otherwise +;;> the result is unspecified. + +;;> \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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 left str right)) + (displayed str))))))) + +;;> As \scheme{padded/both} but only applies padding on the right. +(define (padded/right 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)))))) + +;;> 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 (max 0 diff) pad-char) str)))))) + +;;> An alias for \scheme{padded/left}. +(define padded padded/left) + +;; 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/right width . ls) + (trimmed/buffered + width + (each-in-list ls) + (lambda (str str-width diff) + (fn (ellipsis string-width substring/width substring/preserve) + (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis ""))) + (ell-len (string-width ell)) + (diff (- (+ str-width ell-len) width)) + (end (- width ell-len))) + (each (if substring/preserve + (substring/preserve (substring/width str -1 0)) + nothing) + (if (negative? diff) + nothing + (substring/width str 0 end)) + ell + (if (and substring/preserve (< end str-width)) + (substring/preserve (substring/width str end str-width)) + nothing))))))) + +;;> As \scheme{trimmed/right} 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 substring/width substring/preserve) + (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis ""))) + (ell-len (string-width ell)) + (diff (- (+ str-width ell-len) width))) + (each (if (and substring/preserve (positive? diff)) + (substring/preserve (substring/width str 0 diff)) + nothing) + ell + (if (negative? diff) + nothing + (substring/width str diff str-width)))))))) + +;;> An alias for \scheme{trimmed/left}. +(define trimmed trimmed/left) + +;;> 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 substring/width substring/preserve) + (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 (- str-width (quotient (+ diff 1) 2)))) + (each + (if substring/preserve + (substring/preserve (substring/width str 0 left)) + nothing) + (if (negative? diff) + ell + (each ell (substring/width str left right) ell)) + (if substring/preserve + (substring/preserve (substring/width str right str-width)) + nothing))))))) + +;;> 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 output) string-width substring/width) + (call-with-current-continuation + (lambda (return) + (let ((chars-written 0) + (orig-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/width str 0 end))) + (each (orig-output s) + (with! (output orig-output)) + (fn () (return nothing)))) + (orig-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/right width . ls) + (padded/right width (trimmed/right width (each-in-list ls)))) + +;;> As \scheme{fitted} but pads/trims from the left. +(define (fitted/left width . ls) + (padded/left width (trimmed/left width (each-in-list ls)))) + +;;> An alias for \scheme{fitted/left}. +(define fitted fitted/left) + +;;> 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) ""))) + +;;> As \scheme{joined} but counts from \var{start} to \var{end} +;;> (exclusive), formatting each integer in the range. If \var{end} +;;> is \scheme{#f} or unspecified, produces an infinite stream of +;;> output. +(define (joined/range elt-f start . o) + (let ((end (and (pair? o) (car o))) + (sep (if (and (pair? o) (pair? (cdr o))) (cadr o) ""))) + (let lp ((i start)) + (if (and end (>= i end)) + nothing + (each (if (> i start) sep nothing) + (elt-f i) + (fn () (lp (+ i 1)))))))) diff --git a/%3a166/test.scm b/%3a166/test.scm new file mode 100644 index 0000000..8a17108 --- /dev/null +++ b/%3a166/test.scm @@ -0,0 +1,829 @@ +(library (srfi-166-test) + (export run-tests) + (import (rnrs) (rnrs mutable-pairs) + (only (srfi :1) circular-list) + (srfi :6) + (chibi test) + (only (srfi :152) write-string) + (srfi :166)) + (begin + (define-syntax test-pretty + (syntax-rules () + ((test-pretty str) + (let ((sexp (read (open-input-string str)))) + (test str (show #f (pretty sexp))))))) + (define (list-set! ls k x) + (cond ((null? ls) (error 'list-set! "invalid list index")) + ((zero? k) (set-car! ls x)) + (else (list-set! (cdr ls) (- k 1) x)))) + (define (run-tests) + (test-begin "show") + + ;; basic data types + + (test "hi" (show #f "hi")) + (test "\"hi\"" (show #f (written "hi"))) + (test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\""))) + (test "\"hello\\nworld\"" (show #f (written "hello\nworld"))) + (test "#(1 2 3)" (show #f (written '#(1 2 3)))) + (test "(1 2 3)" (show #f (written '(1 2 3)))) + (test "(1 2 . 3)" (show #f (written '(1 2 . 3)))) + (test "ABC" (show #f (upcased "abc"))) + (test "abc" (show #f (downcased "ABC"))) + + (test "a b" (show #f "a" (space-to 5) "b")) + (test "ab" (show #f "a" (space-to 0) "b")) + + (test "abc def" (show #f "abc" (tab-to) "def")) + (test "abc def" (show #f "abc" (tab-to 5) "def")) + (test "abcdef" (show #f "abc" (tab-to 3) "def")) + (test "abc\ndef\n" (show #f "abc" nl "def" nl)) + (test "abc\ndef\n" (show #f "abc" fl "def" nl fl)) + (test "abc\ndef\n" (show #f "abc" fl "def" fl fl)) + + (test "ab" (show #f "a" nothing "b")) + + ;; numbers + + (test "-1" (show #f -1)) + (test "0" (show #f 0)) + (test "1" (show #f 1)) + (test "10" (show #f 10)) + (test "100" (show #f 100)) + (test "-1" (show #f (numeric -1))) + (test "0" (show #f (numeric 0))) + (test "1" (show #f (numeric 1))) + (test "10" (show #f (numeric 10))) + (test "100" (show #f (numeric 100))) + (test "57005" (show #f #xDEAD)) + (test "#xdead" (show #f (with ((radix 16)) #xDEAD))) + (test "#xdead1234" (show #f (with ((radix 16)) #xDEAD) 1234)) + (test "de.ad" + (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100))))) + (test "d.ead" + (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000))))) + (test "0.dead" + (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000))))) + (test "1g" + (show #f (with ((radix 17)) (numeric 33)))) + + (test "3.14159" (show #f 3.14159)) + (test "3.14" (show #f (with ((precision 2)) 3.14159))) + (test "3.14" (show #f (with ((precision 2)) 3.14))) + (test "3.00" (show #f (with ((precision 2)) 3.))) + (test "1.10" (show #f (with ((precision 2)) 1.099))) + (test "0.00" (show #f (with ((precision 2)) 1e-17))) + (test "0.0000000010" (show #f (with ((precision 10)) 1e-9))) + (test "0.0000000000" (show #f (with ((precision 10)) 1e-17))) + (test "0.000004" (show #f (with ((precision 6)) 0.000004))) + (test "0.0000040" (show #f (with ((precision 7)) 0.000004))) + (test "0.00000400" (show #f (with ((precision 8)) 0.000004))) + (test "1.00" (show #f (with ((precision 2)) .997554209949891))) + (test "1.00" (show #f (with ((precision 2)) .99755420))) + (test "1.00" (show #f (with ((precision 2)) .99755))) + (test "1.00" (show #f (with ((precision 2)) .997))) + (test "0.99" (show #f (with ((precision 2)) .99))) + (test "-15" (show #f (with ((precision 0)) -14.99995999999362))) + + (test " 3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159)))) + (test " 31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159)))) + (test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159)))) + (test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59)))) + (test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9)))) + (test " -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159)))) + (test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159)))) + (test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159)))) + (test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59)))) + (test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9)))) + + (test "+inf.0" (show #f +inf.0)) + (test "-inf.0" (show #f -inf.0)) + (test "+nan.0" (show #f +nan.0)) + (test "+inf.0" (show #f (numeric +inf.0))) + (test "-inf.0" (show #f (numeric -inf.0))) + (test "+nan.0" (show #f (numeric +nan.0))) + + (cond + ((exact? (/ 1 3)) ;; exact rationals + (test "333.333333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 1000/3)))) + (test "33.333333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 100/3)))) + (test "3.333333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 10/3)))) + (test "0.333333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 1/3)))) + (test "0.033333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 1/30)))) + (test "0.003333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 1/300)))) + (test "0.000333333333333333333333333333" + (show #f (with ((precision 30)) (numeric 1/3000)))) + (test "0.666666666666666666666666666667" + (show #f (with ((precision 30)) (numeric 2/3)))) + (test "0.090909090909090909090909090909" + (show #f (with ((precision 30)) (numeric 1/11)))) + (test "1.428571428571428571428571428571" + (show #f (with ((precision 30)) (numeric 10/7)))) + (test "0.123456789012345678901234567890" + (show #f (with ((precision 30)) + (numeric (/ 123456789012345678901234567890 + 1000000000000000000000000000000))))) + (test " 333.333333333333333333333333333333" + (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3)))) + (test " 33.333333333333333333333333333333" + (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3)))) + (test " 3.333333333333333333333333333333" + (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3)))) + (test " 0.333333333333333333333333333333" + (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3)))) + )) + + (test "11.75" (show #f (with ((precision 2)) (/ 47 4)))) + (test "-11.75" (show #f (with ((precision 2)) (/ -47 4)))) + + (test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33)))) + + (test "299792458" (show #f (with ((comma-rule 3)) 299792458))) + (test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458)))) + (test "-29,97,92,458" + (show #f (with ((comma-rule '(3 2))) (numeric -299792458)))) + (test "299.792.458" + (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458)))) + (test "299.792.458,0" + (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0)))) + + (test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000)))) + (test "100,000.0" + (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000)))) + (test "100,000.00" + (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000)))) + + ;; radix argument: + (test "0" (show #f (numeric 0 2))) + (test "0" (show #f (numeric 0 10))) + (test "0" (show #f (numeric 0 36))) + + (test "0.0" (show #f (numeric 0.0 2))) + (test "0.0" (show #f (numeric 0.0 10))) + (test "0.0" (show #f (numeric 0.0 36))) + + (test "1" (show #f (numeric 1 2))) + (test "1" (show #f (numeric 1 10))) + (test "1" (show #f (numeric 1 36))) + + (test "1.0" (show #f (numeric 1.0 2))) + (test "1.0" (show #f (numeric 1.0 10))) + (test "1.0" (show #f (numeric 1.0 36))) + + (test "0" (show #f (numeric 0.0 10 0))) + (test "0" (show #f (numeric 0.0 9 0))) + (test "3/4" (show #f (numeric #e.75))) + + (test "0.0000000000000001" (show #f (numeric 1e-25 36))) + (test "100000000000000000000000000000000000000000000000000000000000000000000000000000000.0" + (show #f (numeric (expt 2.0 80) 2))) + + ;; numeric, radix=2 + (test "10" (show #f (numeric 2 2))) + (test "10.0" (show #f (numeric 2.0 2))) + (test "11/10" (show #f (numeric 3/2 2))) + (test "1001" (show #f (numeric 9 2))) + (test "1001.0" (show #f (numeric 9.0 2))) + (test "1001.01" (show #f (numeric 9.25 2))) + + ;; numeric, radix=3 + (test "11" (show #f (numeric 4 3))) + (test "10.0" (show #f (numeric 3.0 3))) + (test "11/10" (show #f (numeric 4/3 3))) + (test "1001" (show #f (numeric 28 3))) + (test "1001.0" (show #f (numeric 28.0 3))) + (test "1001.01" (show #f (numeric #i253/9 3 2))) + + ;; radix 36 + (test "zzz" (show #f (numeric (- (* 36 36 36) 1) 36))) + + ;; Precision: + (test "1.1250" (show #f (numeric 9/8 10 4))) + (test "1.125" (show #f (numeric 9/8 10 3))) + (test "1.12" (show #f (numeric 9/8 10 2))) + (test "1.1" (show #f (numeric 9/8 10 1))) + (test "1" (show #f (numeric 9/8 10 0))) + + (test "1.1250" (show #f (numeric #i9/8 10 4))) + (test "1.125" (show #f (numeric #i9/8 10 3))) + (test "1.12" (show #f (numeric #i9/8 10 2))) + (test "1.1" (show #f (numeric #i9/8 10 1))) + (test "1" (show #f (numeric #i9/8 10 0))) + + (test "1.0" + (show #f (with ((precision 1)) 0.999999999999876))) + (test "10.0" + (show #f (with ((precision 1)) 9.999999999999876))) + (test "10.0" + (show #f (numeric 9.999999999999876 10 1))) + (test "10.00" + (show #f (numeric 9.999999999999876 10 2))) + + ;; precision-show, base-4 + (test "1.1230" (show #f (numeric 91/64 4 4))) + (test "1.123" (show #f (numeric 91/64 4 3))) + (test "1.13" (show #f (numeric 91/64 4 2))) + (test "1.2" (show #f (numeric 91/64 4 1))) + (test "1" (show #f (numeric 91/64 4 0))) + + (test "1.1230" (show #f (numeric #i91/64 4 4))) + (test "1.123" (show #f (numeric #i91/64 4 3))) + (test "1.13" (show #f (numeric #i91/64 4 2))) + (test "1.2" (show #f (numeric #i91/64 4 1))) + (test "1" (show #f (numeric #i91/64 4 0))) + + ;; sign + (test "+1" (show #f (numeric 1 10 #f #t))) + (test "+1" (show #f (with ((sign-rule #t)) (numeric 1)))) + (test "(1)" (show #f (with ((sign-rule '("(" . ")"))) (numeric -1)))) + (test "-1" (show #f (with ((sign-rule '("-" . ""))) (numeric -1)))) + (test "−1" (show #f (with ((sign-rule '("−" . ""))) (numeric -1)))) + (test "-0.0" (show #f (with ((sign-rule #t)) (numeric -0.0)))) + (test "+0.0" (show #f (with ((sign-rule #t)) (numeric +0.0)))) + + ;; comma + (test "1,234,567" (show #f (numeric 1234567 10 #f #f 3))) + (test "567" (show #f (numeric 567 10 #f #f 3))) + (test "1,23,45,67" (show #f (numeric 1234567 10 #f #f 2))) + (test "12,34,567" (show #f (numeric 1234567 10 #f #f '(3 2)))) + + ;; comma-sep + (test "1|234|567" (show #f (numeric 1234567 10 #f #f 3 #\|))) + (test "1&234&567" (show #f (with ((comma-sep #\&)) (numeric 1234567 10 #f #f 3)))) + (test "1*234*567" (show #f (with ((comma-sep #\&)) (numeric 1234567 10 #f #f 3 #\*)))) + (test "567" (show #f (numeric 567 10 #f #f 3 #\|))) + (test "1,23,45,67" (show #f (numeric 1234567 10 #f #f 2))) + + ;; decimal + (test "1_5" (show #f (with ((decimal-sep #\_)) (numeric 1.5)))) + (test "1,5" (show #f (with ((comma-sep #\.)) (numeric 1.5)))) + (test "1,5" (show #f (numeric 1.5 10 #f #f #f #\.))) + (test "1%5" (show #f (numeric 1.5 10 #f #f #f #\. #\%))) + + ;;(cond-expand + ;;(complex + (test "1+2i" (show #f (string->number "1+2i"))) + (test "1.00+2.00i" + (show #f (with ((precision 2)) (string->number "1+2i")))) + (test "3.14+2.00i" + (show #f (with ((precision 2)) (string->number "3.14159+2i"))));)) + + (test "608" (show #f (numeric/si 608))) + (test "608 B" (show #f (numeric/si 608 1000 " ") "B")) + (test "4k" (show #f (numeric/si 3986))) + (test "3.9Ki" (show #f (numeric/si 3986 1024))) + (test "4kB" (show #f (numeric/si 3986 1000) "B")) + (test "1.2Mm" (show #f (numeric/si 1.23e6 1000) "m")) + (test "123km" (show #f (numeric/si 1.23e5 1000) "m")) + (test "12.3km" (show #f (numeric/si 1.23e4 1000) "m")) + (test "1.2km" (show #f (numeric/si 1.23e3 1000) "m")) + (test "123m" (show #f (numeric/si 1.23e2 1000) "m")) + (test "12.3m" (show #f (numeric/si 1.23e1 1000) "m")) + (test "1.2m" (show #f (numeric/si 1.23 1000) "m")) + (test "1.2 m" (show #f (numeric/si 1.23 1000 " ") "m")) + (test "123mm" (show #f (numeric/si 0.123 1000) "m")) + (test "12.3mm" (show #f (numeric/si 1.23e-2 1000) "m")) ;? + (test "1.2mm" (show #f (numeric/si 1.23e-3 1000) "m")) + (test "123µm" (show #f (numeric/si 1.23e-4 1000) "m")) ;? + (test "12.3µm" (show #f (numeric/si 1.23e-5 1000) "m")) ;? + (test "1.2µm" (show #f (numeric/si 1.23e-6 1000) "m")) + (test "1.2 µm" (show #f (numeric/si 1.23e-6 1000 " ") "m")) + (test "0" (show #f (numeric/si 0))) + (test "-608" (show #f (numeric/si -608))) + (test "-4k" (show #f (numeric/si -3986))) + + (test "1,234,567" (show #f (numeric/comma 1234567))) + (test "1,234,567" (show #f (numeric/comma 1234567 3))) + (test "123,4567" (show #f (numeric/comma 1234567 4))) + + (test "1.23" (show #f (numeric/fitted 4 1.2345 10 2))) + (test "1.00" (show #f (numeric/fitted 4 1 10 2))) + (test "#.##" (show #f (numeric/fitted 4 12.345 10 2))) + (test "#" (show #f (numeric/fitted 1 12.345 10 0))) + + ;; padding/trimming + + (test "abc " (show #f (padded/right 5 "abc"))) + (test " abc" (show #f (padded 5 "abc"))) + (test "abcdefghi" (show #f (padded 5 "abcdefghi"))) + (test " abc " (show #f (padded/both 5 "abc"))) + (test " abc " (show #f (padded/both 6 "abc"))) + (test "abcde" (show #f (padded/right 5 "abcde"))) + (test "abcdef" (show #f (padded/right 5 "abcdef"))) + + (test "abc" (show #f (trimmed/right 3 "abcde"))) + (test "abc" (show #f (trimmed/right 3 "abcd"))) + (test "abc" (show #f (trimmed/right 3 "abc"))) + (test "ab" (show #f (trimmed/right 3 "ab"))) + (test "a" (show #f (trimmed/right 3 "a"))) + (test "abcde" (show #f (trimmed/right 5 "abcdef"))) + (test "abcde" (show #f (trimmed 5 "abcde"))) + (test "cde" (show #f (trimmed 3 "abcde"))) + (test "bcdef" (show #f (trimmed 5 "abcdef"))) + (test "bcd" (show #f (trimmed/both 3 "abcde"))) + (test "abcd" (show #f (trimmed/both 4 "abcde"))) + (test "abcde" (show #f (trimmed/both 5 "abcdef"))) + (test "bcde" (show #f (trimmed/both 4 "abcdef"))) + (test "bcdef" (show #f (trimmed/both 5 "abcdefgh"))) + (test "abc" (show #f (trimmed/lazy 3 "abcde"))) + (test "abc" (show #f (trimmed/lazy 3 "abc\nde"))) + + (test "prefix: abc" (show #f "prefix: " (trimmed/right 3 "abcde"))) + (test "prefix: cde" (show #f "prefix: " (trimmed 3 "abcde"))) + (test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde"))) + (test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde"))) + (test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde"))) + + (test "abc :suffix" (show #f (trimmed/right 3 "abcde") " :suffix")) + (test "cde :suffix" (show #f (trimmed 3 "abcde") " :suffix")) + (test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix")) + (test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix")) + (test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix")) + + (test "abc" (show #f (trimmed/lazy 10 (trimmed/lazy 3 "abcdefghijklmnopqrstuvwxyz")))) + (test "abc" (show #f (trimmed/lazy 3 (trimmed/lazy 10 "abcdefghijklmnopqrstuvwxyz")))) + + (test "abcde" + (show #f (with ((ellipsis "...")) (trimmed/right 5 "abcde")))) + (test "ab..." + (show #f (with ((ellipsis "...")) (trimmed/right 5 "abcdef")))) + (test "abc..." + (show #f (with ((ellipsis "...")) (trimmed/right 6 "abcdefg")))) + (test "abcde" + (show #f (with ((ellipsis "...")) (trimmed 5 "abcde")))) + (test "...ef" + (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef")))) + (test "...efg" + (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg")))) + (test "abcdefg" + (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg")))) + (test "...d..." + (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh")))) + (test "...e..." + (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi")))) + + (test "abc " (show #f (fitted/right 5 "abc"))) + (test " abc" (show #f (fitted 5 "abc"))) + (test " abc " (show #f (fitted/both 5 "abc"))) + (test "abcde" (show #f (fitted/right 5 "abcde"))) + (test "abcde" (show #f (fitted 5 "abcde"))) + (test "abcde" (show #f (fitted/both 5 "abcde"))) + (test "abcde" (show #f (fitted/right 5 "abcdefgh"))) + (test "defgh" (show #f (fitted 5 "abcdefgh"))) + (test "bcdef" (show #f (fitted/both 5 "abcdefgh"))) + + (test "prefix: abc :suffix" + (show #f "prefix: " (fitted/right 5 "abc") " :suffix")) + (test "prefix: abc :suffix" + (show #f "prefix: " (fitted 5 "abc") " :suffix")) + (test "prefix: abc :suffix" + (show #f "prefix: " (fitted/both 5 "abc") " :suffix")) + (test "prefix: abcde :suffix" + (show #f "prefix: " (fitted/right 5 "abcde") " :suffix")) + (test "prefix: abcde :suffix" + (show #f "prefix: " (fitted 5 "abcde") " :suffix")) + (test "prefix: abcde :suffix" + (show #f "prefix: " (fitted/both 5 "abcde") " :suffix")) + (test "prefix: abcde :suffix" + (show #f "prefix: " (fitted/right 5 "abcdefgh") " :suffix")) + (test "prefix: defgh :suffix" + (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix")) + (test "prefix: bcdef :suffix" + (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix")) + + ;; joining + + (test "1 2 3" (show #f (joined each '(1 2 3) " "))) + + (test ":abc:123" + (show #f (joined/prefix + (lambda (x) (trimmed/right 3 x)) + '("abcdef" "123456") + ":"))) + + (test "abc\n123\n" + (show #f (joined/suffix + (lambda (x) (trimmed/right 3 x)) + '("abcdef" "123456") + nl))) + + (test "lions, tigers, and bears" + (show #f (joined/last + each + (lambda (x) (each "and " x)) + '(lions tigers bears) + ", "))) + + (test "lions, tigers, or bears" + (show #f (joined/dot + each + (lambda (x) (each "or " x)) + '(lions tigers . bears) + ", "))) + + ;; escaping + + (test "hi, bob!" (show #f (escaped "hi, bob!"))) + (test "hi, \\\"bob!\\\"" (show #f (escaped "hi, \"bob!\""))) + (test "hi, \\'bob\\'" (show #f (escaped "hi, 'bob'" #\'))) + (test "hi, ''bob''" (show #f (escaped "hi, 'bob'" #\' #\'))) + (test "hi, ''bob''" (show #f (escaped "hi, 'bob'" #\' #f))) + (test "line1\\nline2\\nkapow\\a\\n" + (show #f (escaped "line1\nline2\nkapow\a\n" + #\" #\\ + (lambda (c) (case c ((#\newline) #\n) ((#\alarm) #\a) (else #f)))))) + + (test "bob" (show #f (maybe-escaped "bob" char-whitespace?))) + (test "\"hi, bob!\"" + (show #f (maybe-escaped "hi, bob!" char-whitespace?))) + (test "\"foo\\\"bar\\\"baz\"" (show #f (maybe-escaped "foo\"bar\"baz" char-whitespace?))) + (test "'hi, ''bob'''" (show #f (maybe-escaped "hi, 'bob'" (lambda (c) #f) #\' #f))) + (test "\\" (show #f (maybe-escaped "\\" (lambda (c) #f) #\' #f))) + (test "''''" (show #f (maybe-escaped "'" (lambda (c) #f) #\' #f))) + + ;; shared structures + + (test "#0=(1 . #0#)" + (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones)))) + (test "(0 . #0=(1 . #0#))" + (show #f (written (let ((ones (list 1))) + (set-cdr! ones ones) + (cons 0 ones))))) + (test "(sym . #0=(sym . #0#))" + (show #f (written (let ((syms (list 'sym))) + (set-cdr! syms syms) + (cons 'sym syms))))) + (test "(#0=(1 . #0#) #1=(2 . #1#))" + (show #f (written (let ((ones (list 1)) + (twos (list 2))) + (set-cdr! ones ones) + (set-cdr! twos twos) + (list ones twos))))) + (test "(#0=(1 . #0#) #0#)" + (show #f (written (let ((ones (list 1))) + (set-cdr! ones ones) + (list ones ones))))) + (test "((1) (1))" + (show #f (written (let ((ones (list 1))) + (list ones ones))))) + + (test "(#0=(1) #0#)" + (show #f (written-shared (let ((ones (list 1))) + (list ones ones))))) + + ;; cycles without shared detection + + (test "(1 1 1 1 1" + (show #f (trimmed/lazy + 10 + (written-simply + (let ((ones (list 1))) (set-cdr! ones ones) ones))))) + + (test "(1 1 1 1 1 " + (show #f (trimmed/lazy + 11 + (written-simply + (let ((ones (list 1))) (set-cdr! ones ones) ones))))) + + ;; pretty printing + + (test-pretty "(foo bar)\n") + + (test-pretty + "((self . aquanet-paper-1991) + (type . paper) + (title . \"Aquanet: a hypertext tool to hold your\")) +") + + (test-pretty + "(abracadabra xylophone + bananarama + yellowstonepark + cryptoanalysis + zebramania + delightful + wubbleflubbery)\n") + + (test-pretty + "#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 + 26 27 28 29 30 31 32 33 34 35 36 37)\n") + + (test-pretty + "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 + 26 27 28 29 30 31 32 33 34 35 36 37)\n") + + (test-pretty + "(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) + #(16 17) #(18 19))\n") + + (test-pretty + "#(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) + #(16 17) #(18 19))\n") + + (test-pretty + "(define (fold kons knil ls) + (define (loop ls acc) + (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))) + (loop ls knil))\n") + + (test-pretty + "(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n") + + (test-pretty + "(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) + (vector-set! vec i 'supercalifrajalisticexpialidocious))\n") + + (test-pretty + "(do ((my-vector (make-vector 5)) (index 0 (+ index 1))) + ((= index 5) my-vector) + (vector-set! my-vector index index))\n") + + (test-pretty + "(define (fold kons knil ls) + (let loop ((ls ls) (acc knil)) + (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n") + + (test-pretty + "(define (file->sexp-list pathname) + (call-with-input-file pathname + (lambda (port) + (let loop ((res '())) + (let ((line (read port))) + (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n") + + (test-pretty + "(design + (module (name \"\\\\testshiftregister\") (attributes (attribute (name \"\\\\src\")))) + (wire (name \"\\\\shreg\") (attributes (attribute (name \"\\\\src\")))))\n") + + (test-pretty + "(design + (module (name \"\\\\testshiftregister\") + (attributes + (attribute (name \"\\\\src\") (value \"testshiftregister.v:10\")))) + (wire (name \"\\\\shreg\") + (attributes + (attribute (name \"\\\\src\") (value \"testshiftregister.v:15\")))))\n") + + (test "(let ((ones '#0=(1 . #0#))) ones)\n" + (show #f (pretty (let ((ones (list 1))) + (set-cdr! ones ones) + `(let ((ones ',ones)) ones))))) + + '(test + "(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + (ones '#0=(1 . #0#))) + (append zeros ones))\n" + (show #f (pretty + (let ((ones (list 1))) + (set-cdr! ones ones) + `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + (ones ',ones)) + (append zeros ones)))))) + + ;; pretty-simply + (let* ((d (let ((d (list 'a 'b #f))) + (list-set! d 2 d) + (list d))) + (ca (circular-list 'a))) + (test "((a b (a b (a b" (show #f (trimmed/lazy 15 (pretty-simply '((a b (a b (a b (a b))))))))) + (test "((a b\n (a b\n" (show #f (trimmed/lazy 15 (pretty-simply d)))) + (test "'(a a\n a\n " (show #f (trimmed/lazy 15 (pretty-simply `(quote ,ca))))) + (test "(foo\n (a a\n " (show #f (trimmed/lazy 15 (pretty-simply `(foo ,ca))))) + (test "(with-x \n (a a" (show #f (trimmed/lazy 15 (pretty-simply `(with-x ,ca))))) + ) + + ;; columns + + '(test "abc\ndef\n" + (show #f (show-columns (list displayed "abc\ndef\n")))) + '(test "abc123\ndef456\n" + (show #f (show-columns (list displayed "abc\ndef\n") + (list displayed "123\n456\n")))) + '(test "abc123\ndef456\n" + (show #f (show-columns (list displayed "abc\ndef\n") + (list displayed "123\n456")))) + '(test "abc123\ndef456\n" + (show #f (show-columns (list displayed "abc\ndef") + (list displayed "123\n456\n")))) + '(test "abc123\ndef456\nghi789\n" + (show #f (show-columns (list displayed "abc\ndef\nghi\n") + (list displayed "123\n456\n789\n")))) + '(test "abc123wuv\ndef456xyz\n" + (show #f (show-columns (list displayed "abc\ndef\n") + (list displayed "123\n456\n") + (list displayed "wuv\nxyz\n")))) + '(test "abc 123\ndef 456\n" + (show #f (show-columns (list (lambda (x) (padded/right 5 x)) + "abc\ndef\n") + (list displayed "123\n456\n")))) + '(test "ABC 123\nDEF 456\n" + (show #f (show-columns (list (lambda (x) (upcased (padded/right 5 x))) + "abc\ndef\n") + (list displayed "123\n456\n")))) + '(test "ABC 123\nDEF 456\n" + (show #f (show-columns (list (lambda (x) (padded/right 5 (upcased x))) + "abc\ndef\n") + (list displayed "123\n456\n")))) + + (test "" (show #f (wrapped " "))) + (test "hello\nworld" + (show #f (with ((width 8)) (wrapped "hello world")))) + (test "ｈｅｌｌｏ\nｗｏｒｌｄ" + (show #f (with ((width 16)) + (terminal-aware (wrapped "ｈｅｌｌｏ　ｗｏｒｌｄ"))))) + + (test + "The quick +brown fox +jumped +over the +lazy dog +" + (show #f + (with ((width 10)) + (justified "The quick brown fox jumped over the lazy dog")))) + + (test + "The fundamental list iterator. +Applies KONS to each element of +LS and the result of the previous +application, beginning with KNIL. +With KONS as CONS and KNIL as '(), +equivalent to REVERSE." + (show #f + (with ((width 36)) + (wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))) + + (test + "(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc))))) +" + (show #f + (with ((width 36)) + (pretty '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc))))))))) + + '(test + "(define (fold kons knil ls) ; The fundamental list iterator. + (let lp ((ls ls) (acc knil)) ; Applies KONS to each element of + (if (null? ls) ; LS and the result of the previous + acc ; application, beginning with KNIL. + (lp (cdr ls) ; With KONS as CONS and KNIL as '(), + (kons (car ls) acc))))) ; equivalent to REVERSE. +" + (show #f + (show-columns + (list + (lambda (x) (padded/right 36 x)) + (with ((width 36)) + (pretty '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc)))))))) + (list + (lambda (x) (each " ; " x)) + (with ((width 36)) + (wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))) + + (test "\n" (show #f (columnar))) ; degenerate case + (test "\n" (show #f (columnar "*"))) ; only infinite columns + (test "*\n" (show #f (columnar (each "*")))) + + (test "foo" (show #f (wrapped "foo"))) + + (test + "(define (fold kons knil ls) ; The fundamental list iterator. + (let lp ((ls ls) (acc knil)) ; Applies KONS to each element of + (if (null? ls) ; LS and the result of the previous + acc ; application, beginning with KNIL. + (lp (cdr ls) ; With KONS as CONS and KNIL as '(), + (kons (car ls) acc))))) ; equivalent to REVERSE. +" + (show #f (with ((width 76)) + (columnar + (pretty '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc)))))) + " ; " + (wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))) + + (test + "- Item 1: The text here is + indented according + to the space \"Item + 1\" takes, and one + does not known what + goes here. +" + (show #f (columnar 9 (each "- Item 1:") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))) + + (test + "- Item 1: The text here is + indented according + to the space \"Item + 1\" takes, and one + does not known what + goes here. +" + (show #f (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))) + + (test + "- Item 1: The-text-here-is---------------------------------------------------- +--------- indented-according-------------------------------------------------- +--------- to-the-space-\"Item-------------------------------------------------- +--------- 1\"-takes,-and-one--------------------------------------------------- +--------- does-not-known-what------------------------------------------------- +--------- goes-here.---------------------------------------------------------- +" + (show #f (with ((pad-char #\-)) (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))) + + (test + "a | 123 +bc | 45 +def | 6 +" + (show #f (with ((width 20)) + (tabular (each "a\nbc\ndef\n") " | " + (each "123\n45\n6\n"))))) + + ;; color + (test "\x1B;[31mred\x1B;[39m" (show #f (as-red "red"))) + (test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[39m" + (show #f (as-red "red" (as-blue "blue") "red"))) + (test "\x1b;[31m1234567\x1b;[39m col: 7" + (show #f (terminal-aware (as-red "1234567") (fn (col) (each " col: " col))))) + (test "\x1b;[31m\x1b;[4m\x1b;[1mabc\x1b;[22mdef\x1b;[24mghi\x1b;[39m" + (show #f (as-red (each (as-underline (as-bold "abc") "def") "ghi")))) + (test "\x1b;[44m\x1b;[33mabc\x1b;[39mdef\x1b;[49m" + (show #f (on-blue (each (as-yellow "abc") "def")))) + + ;; unicode + (test "〜日本語〜" + (show #f (with ((pad-char #\〜)) (padded/both 5 "日本語")))) + (test "日本語" + (show #f (terminal-aware (with ((pad-char #\〜)) (padded/both 5 "日本語"))))) + (test "本語" + (show #f (trimmed 2 "日本語"))) + (test "語" + (show #f (terminal-aware (trimmed 2 "日本語")))) + (test "日本" + (show #f (trimmed/right 2 "日本語"))) + (test "日" + (show #f (terminal-aware (trimmed/right 2 "日本語")))) + (test "\x1B;[31m日\x1B;[46m\x1B;[49m\x1B;[39m" + (show #f (terminal-aware + (trimmed/right 2 (as-red "日本語" (on-cyan "!!!!")))))) + (test "日本語" + (show #f (trimmed/right 3 "日本語"))) + (test "日" + (show #f (terminal-aware (trimmed/right 3 "日本語")))) + (test "日本語 col: 6" + (show #f (terminal-aware "日本語" (fn (col) (each " col: " col))))) + (test "日本語ΠΜΕ col: 9" + (show #f (terminal-aware "日本語ΠΜΕ" (fn (col) (each " col: " col))))) + (test "日本語ΠΜΕ col: 12" + (show #f (with ((ambiguous-is-wide? #t)) + (terminal-aware "日本語ΠΜΕ" + (fn (col) (each " col: " col)))))) + (test "ａｂｃ" (substring-terminal-width "ａｂｃ" 0 6)) + (test "ａｂ" (substring-terminal-width "ａｂｃ" 0 4)) + (test "ｂｃ" (substring-terminal-width "ａｂｃ" 2 6)) + (test "ａｂ" (substring-terminal-width "ａｂｃ" 1 4)) + (test "ａｂ" (substring-terminal-width "ａｂｃ" 1 5)) + (test "ｂ" (substring-terminal-width "ａｂｃ" 2 4)) + (test "" (substring-terminal-width "ａｂｃ" 2 3)) + (test "ａ" (substring-terminal-width "ａｂｃ" -1 2)) + + ;; from-file + ;; for reference, filesystem-test relies on creating files under /tmp + (let* ((tmp-file "chibi-show-test-0123456789") + (content-string "first line\nsecond line\nthird line")) + (with-output-to-file tmp-file (lambda () (write-string content-string))) + (test (string-append content-string "\n") + (show #f (from-file tmp-file))) + (test + " 1 first line\n 2 second line\n 3 third line\n" + (show #f (columnar 4 'right 'infinite (line-numbers) " " (from-file tmp-file)))) + (delete-file tmp-file)) + + (test-end)))) diff --git a/%3a166/unicode.scm b/%3a166/unicode.scm new file mode 100644 index 0000000..dcdc43b --- /dev/null +++ b/%3a166/unicode.scm @@ -0,0 +1,172 @@ +;; unicode.scm -- Unicode character width and ANSI escape support +;; Copyright (c) 2006-2020 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (unicode-char-width ch ambiguous-is-wide?) + (let ((ci (char->integer ch))) + (cond + ((char-set:zero-width? ci) + 0) + ((char-set:full-width? ci) + 2) + ((and ambiguous-is-wide? (char-set:ambiguous-width? ci)) + 2) + (else + 1)))) + +(define (string-terminal-width/aux str start end ambiguous-is-wide?) + (let lp1 ((sc start) (width 0)) + (if (string-cursor>=? sc end) + width + (let ((c (string-ref/cursor str sc)) + (sc2 (string-cursor-next str sc))) + (cond + ;; ANSI escapes + ;; TODO: consider maintaining a state machine so the escape + ;; can be spread across multiple strings (not needed if + ;; assuming all escapes come from (srfi 166 color)). + ((and (= 27 (char->integer c)) ; esc + (string-cursor=? sc end) width) + ((memv (string-ref/cursor str sc) '(#\m #\newline)) + (lp1 (string-cursor-next str sc) width)) + (else (lp2 (string-cursor-next str sc)))))) + ;; fast-path ASCII + ((char<=? c #\~) + (lp1 sc2 (+ width 1))) + ;; unicode + (else + (lp1 sc2 (+ width (unicode-char-width c ambiguous-is-wide?))) + )))))) + +(define (cursor-arg str x) + (if (string-cursor? x) x (string-index->cursor str x))) + +;; convert args to cursors internally for efficiency + +(define (string-terminal-width str . o) + (let ((start (cursor-arg str (if (pair? o) + (car o) + (string-cursor-start str)))) + (end (cursor-arg str (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-cursor-end str))))) + (string-terminal-width/aux str start end #f))) + +(define (string-terminal-width/wide str . o) + (let ((start (cursor-arg str (if (pair? o) + (car o) + (string-cursor-start str)))) + (end (cursor-arg str (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-cursor-end str))))) + (string-terminal-width/aux str start end #t))) + +(define (substring-terminal-width/aux str lo hi ambiguous-is-wide?) + (let ((start (string-cursor-start str)) + (end (string-cursor-end str))) + (let lp1 ((sc start) + (from (and (negative? lo) start)) + (width 0)) + (if (string-cursor>=? sc end) + (if from (substring/cursors str from end) str) + (let ((c (string-ref/cursor str sc))) + (cond + ((and (= 27 (char->integer c)) ; esc + (string-cursor=? sc2 end) + (lp1 sc2 from width)) + ((memv (string-ref/cursor str sc2) '(#\m #\newline)) + (lp1 (string-cursor-next str sc2) from width)) + (else (lp2 (string-cursor-next str sc2)))))) + (else + (let ((width2 (+ width + (unicode-char-width c ambiguous-is-wide?)))) + (cond + ((> width2 hi) + (if from + (substring/cursors str from sc) + "")) + ((and (not from) (> width2 lo)) + (lp1 (string-cursor-next str sc) sc width2)) + (else + (lp1 (string-cursor-next str sc) from width2) + )))))))))) + +(define (substring-terminal-width str lo hi) + (substring-terminal-width/aux str lo hi #f)) + +(define (substring-terminal-width/wide str lo hi) + (substring-terminal-width/aux str lo hi #t)) + +;; The BiDi control characters - trimming these would result in the +;; remaining text rendered in the wrong direction. +;; Other characters for consideration would be language tags or +;; interlinear annotation, but use of these is discouraged. +;; Similarly, we might want to preserve the BOM only at the start of +;; text, but this is a file-level encoding mechanism and not likely +;; appropriate to formatting in-memory strings. +(define non-local-controls + '(#\x061C #\x200E #\x200F #\x202A #\x202B #\x202C + #\x202D #\x202E #\x2066 #\x2067 #\x2068 #\x2069)) + +(define (substring-terminal-preserve str) + (let ((start (string-cursor-start str)) + (end (string-cursor-end str))) + (let lp1 ((sc start) (escapes '())) + (if (string-cursor>=? sc end) + (string-concatenate-reverse escapes) + (let ((c (string-ref/cursor str sc)) + (sc2 (string-cursor-next str sc))) + (cond + ((and (= 27 (char->integer c)) + (string-cursor=? sc2 end) + (string-concatenate-reverse escapes) + (let ((c2 (string-ref/cursor str sc2)) + (sc3 (string-cursor-next str sc2))) + (if (eqv? #\m c2) + (lp1 sc3 + (cons (substring/cursors str sc sc3) + escapes)) + (lp2 sc3)))))) + ((and (memv c non-local-controls)) + (lp1 sc2 (cons (string c) escapes))) + (else + (lp1 sc2 escapes)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (terminal-aware . args) + (fn (ambiguous-is-wide?) + (with ((string-width (if ambiguous-is-wide? + string-terminal-width/wide + string-terminal-width)) + (substring/width (if ambiguous-is-wide? + substring-terminal-width/wide + substring-terminal-width)) + (substring/preserve substring-terminal-preserve)) + (each-in-list args)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; String transformations + +(define (with-string-transformer proc . ls) + (fn ((orig-output output)) + (let ((output* (lambda (str) (orig-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)) diff --git a/%3a166/unicode.sls b/%3a166/unicode.sls new file mode 100644 index 0000000..d86baa2 --- /dev/null +++ b/%3a166/unicode.sls @@ -0,0 +1,14 @@ + +(library (srfi :166 unicode) + (export terminal-aware + string-terminal-width string-terminal-width/wide + substring-terminal-width substring-terminal-width/wide + substring-terminal-preserve + upcased downcased) + (import (rnrs) + (srfi :130) + (srfi :151) + (srfi :166 base) + (srfi private include)) + (include/resolve ("srfi" "%3a166") "width.scm") + (include/resolve ("srfi" "%3a166") "unicode.scm")) diff --git a/%3a166/width.scm b/%3a166/width.scm new file mode 100644 index 0000000..0f74571 --- /dev/null +++ b/%3a166/width.scm @@ -0,0 +1,9 @@ +;; char-set:zero-width +(define char-set:zero-width? (lambda (n) (if (< n 68900) (if (< n 12330) (if (< n 6679) (if (< n 1425) (if (< n 1155) (<= 768 n 879) (<= n 1159)) (if (> n 4253) (if (< n 5906) (<= 4957 n 4959) (if (> n 6459) #f (bit-set? (- n 5906) 51654814515775487143066232783390167417190249239197745817200662630546961064292554504203649883705840324554781044118350731330848841429221578063291283522087222079752503303))) (bit-set? (- n 1425) 205510703248794064385799288111379553899177236721844427958663885943912447037636015703722458582080212074964115397630065758419083258557178791291572045390928965000517761101693657384097462852805005223789556257652925846392379688350478539272364567836963922093122354965736916957801582655554045063883899910493538605405067002499688533586876666092658246104323699888852680426382228126850348432897066859954019357227298272892506279761774951117859456904408554199637716442671276335693418641886045354548080235810360809122448516863904652167066224711146510448624096937959409199684953654914585698643427248887519665328616615751486909865868764846766218624841700373624128912795005115413173034267739971653354314214069620902510761561645618122027617911016679702936039677009392664194441428497838216197914975998358752016720492749295864086894236325597101175925631693488402676580351))) (if (> n 7223) (if (< n 8400) (if (< n 7616) (if (< n 7376) #f (if (> n 7417) #f (bit-set? (- n 7376) 3367824654327))) (if (> n 7679) #f (bit-set? (- n 7616) 18158513697557839871))) (if (> n 8432) (if (< n 11647) (<= 11503 n 11505) (if (> n 11775) #f (bit-set? (- n 11647) 680564733683420601898220539676448522241))) (bit-set? (- n 8400) 8587976703))) (bit-set? (- n 6679) 93549288715282589785155353610353886491418033273055579755950049941276640743523826260726496451218508777751751117752658787002603454722245250226862282085717170773295123))) (if (> n 12442) (if (< n 65024) (if (< n 43204) (if (< n 43010) (if (< n 42607) #f (if (> n 42737) #f (bit-set? (- n 42607) 2041694201525630780780248066803074367457))) (if (> n 43052) #f (bit-set? (- n 43010) 4501125726737))) (if (> n 43766) (if (< n 64286) (if (< n 44005) #f (if (> n 44013) #f (bit-set? (- n 44005) 265))) (<= n 64286)) (bit-set? (- n 43204) 15140075821452045156435686692227855958090094076212194752904600649738386873024625209829508281199675047875687625406266463651325109390207641183187724769853784365253770870787))) (if (> n 65071) (if (< n 66422) (if (< n 66272) (<= 66045 n 66045) (<= n 66272)) (if (> n 66426) (if (< n 68325) (if (< n 68097) #f (if (> n 68159) #f (bit-set? (- n 68097) 4863887597560166455))) (<= n 68326)) #t)) (bit-set? (- n 65024) 281470681808895))) (bit-set? (- n 12330) 7788445287802241442795744493830159))) (if (> n 68903) (if (< n 92912) (if (< n 71090) (if (< n 69633) (if (< n 69446) (<= 69291 n 69292) (<= n 69456)) (if (> n 70206) (if (< n 70712) (if (< n 70367) #f (if (> n 70516) #f (bit-set? (- n 70367) 1388177832465565583748880650475847749063413745))) (if (> n 70851) #f (bit-set? (- n 70712) 1178046920456322681183219660472574183234815))) (bit-set? (- n 69633) 31315396710562944755562359524395422889373597990417327292477766884025457959630346593353500376569566606431910948292248640666923116843972687831060900891883862689184984344821761))) (if (> n 71467) (if (< n 72148) (if (< n 71995) (if (< n 71727) #f (if (> n 71738) #f (bit-set? (- n 71727) 3583))) (if (> n 72003) #f (bit-set? (- n 71995) 267))) (if (> n 72345) (if (< n 73459) (if (< n 72752) #f (if (> n 73111) #f (bit-set? (- n 72752) 1495361097625526625570256678500368769738841504996522270098150646281731627800177929801827597371100995086499711))) (<= n 73460)) (bit-set? (- n 72148) 351511567199490659298273789834301951705775336083122752065743))) (bit-set? (- n 71090) 605567007883067350144846792920936979368360383438593457381381338194386513335133428523310644367613386859332205833231))) (if (> n 92982) (if (< n 122880) (if (< n 119143) (if (< n 113821) (if (< n 94031) #f (if (> n 94180) #f (bit-set? (- n 94031) 713623846352979940529143261425908673834647553))) (<= n 113822)) (if (> n 119213) (if (< n 121344) (<= 119362 n 119364) (if (> n 121519) #f (bit-set? (- n 121344) 95779464130560000838435563242757336329136322539159551))) (bit-set? (- n 119143) 2213609288981778792455))) (if (> n 122922) (if (< n 125136) (if (< n 123628) (<= 123184 n 123190) (<= n 123631)) (if (> n 125258) (<= 917760 n 917999) (bit-set? (- n 125136) 10550747216542769741173968540975235199))) (bit-set? (- n 122880) 8641373536127))) (bit-set? (- n 92912) 2342736497361113055263))) #t)))) + +;; char-set:full-width +(define char-set:full-width? (lambda (n) (if (< n 65504) (if (< n 12880) (if (< n 11035) (if (< n 9193) (if (< n 8986) (<= 4352 n 4447) (if (> n 9002) #f (bit-set? (- n 8986) 98307))) (if (> n 9203) (if (< n 9725) #f (if (> n 10175) #f (bit-set? (- n 9725) 2907443622617266820054333480998780529725701130302280275370007947623808338047781548019528101403890814668593761726693391537327403448664067))) (bit-set? (- n 9193) 1167))) (if (> n 11093) (if (< n 12288) (if (< n 11904) #f (if (> n 12284) #f (bit-set? (- n 11904) 2462024160382423828429811516068427561660749306784056468848805869416245321611661291646414375862022918616033934704639))) (if (> n 12288) (if (< n 12289) #f (if (> n 12879) #f (bit-set? (- n 12289) 31658291388542983835601784359821364092920312042945607229551814400819120094685286422379319320933806533062611154529989222389109195010548367461806701052374837219444518916037017599))) #t)) (bit-set? (- n 11035) 297237575406452739))) (if (> n 19903) (if (< n 44032) (if (< n 42128) (if (< n 19968) (if (< n 19904) #f (if (> n 19967) #f (bit-set? (- n 19904) 0))) (<= n 42124)) (if (> n 42182) (<= 43360 n 43388) #t)) (if (> n 55203) (if (< n 65040) (<= 63744 n 64255) (if (> n 65131) (<= 65281 n 65376) (bit-set? (- n 65040) 4797017504656895971262727167))) #t)) #t)) (if (> n 65510) (if (< n 127183) (if (< n 101632) (if (< n 100344) (if (< n 94208) (if (< n 94176) #f (if (> n 94207) #f (bit-set? (- n 94176) 196639))) (<= n 100343)) (if (> n 100351) (<= 100352 n 101589) (bit-set? (- n 100344) 0))) (if (> n 101640) (if (< n 110960) (if (< n 110592) #f (if (> n 110959) #f (bit-set? (- n 110592) 2201759651238793353935978839989206105180151758945528329367307032632076306562609289056077994868130232108318719))) (if (> n 111355) (<= 126980 n 126980) #t)) #t)) (if (> n 127183) (if (< n 129292) (if (< n 127744) (if (< n 127374) #f (if (> n 127589) #f (bit-set? (- n 127374) 103666862632257055884375554338292758824945695871569254787261145081))) (if (> n 128764) (<= 128992 n 129003) (bit-set? (- n 127744) 22427532355441897097494388929338899236988773969297598703485634661859864729808161736681853448048691489805457651039471569590476931512946609416855878944269320917585568431313760949188816496022192318927601521301355797906472807547744415626581438889327443126299259883097149821600460467129283287639251279166002167807))) (if (> n 129750) (if (< n 196606) (<= 131072 n 196605) (if (> n 196607) (<= 196608 n 262141) (bit-set? (- n 196606) 0))) (bit-set? (- n 129292) 1476937530268593348028592145760648876257390306909878067362834750498663701692341803996798291958154966950849039520561259075909404413382361087))) #t)) #t)))) + +;; char-set:ambiguous-width +(define char-set:ambiguous-width? (lambda (n) (if (< n 65024) (if (< n 11094) (if (< n 8208) (if (< n 161) #f (if (> n 1105) #f (bit-set? (- n 161) 223052536271667459415678930318905079873549773617932793730641638019059504712673796525524909775020557665956016104500455950219001349342694128220978917003401578883591589344111031259581620889226429090957790179652065257339299797525743429872558723447631104797406273409853160160039741152015049))) (if (> n 8978) (if (< n 9312) #f (if (> n 10111) #f (bit-set? (- n 9312) 6661502700035245041435504908796213048795246635156488431799991666791867984381040418533146610100595617817495711540720281547788461940893726414925833870538641183879792268453003453351317627145210838405747057167482906429027337302253989020846522367))) (bit-set? (- n 8208) 6210072369202835740595918595956453086120179989637780933534686381158779319390650106752194038767228255040840848246999248665204356172037404661019798426289847167202141507582321755409018753079304131847016847989633301370435793517521875833))) (if (> n 11097) (if (< n 57344) (<= 12872 n 12879) (<= n 63743)) #t)) (if (> n 65039) (if (< n 983040) (if (< n 127232) (<= 65533 n 65533) (if (> n 127404) (<= 917760 n 917999) (bit-set? (- n 127232) 11972575780114894207525815562028054143265854222960639))) (if (> n 1048573) (if (< n 1048576) (if (< n 1048574) #f (if (> n 1048575) #f (bit-set? (- n 1048574) 0))) (<= n 1114109)) #t)) #t)))) + diff --git a/%3a166/write.scm b/%3a166/write.scm new file mode 100644 index 0000000..a185ec9 --- /dev/null +++ b/%3a166/write.scm @@ -0,0 +1,509 @@ +;; write.scm - written formatting, the default displayed for non-string/chars +;; Copyright (c) 2006-2019 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> \section{String utilities} + +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + +(define (string-replace-all str ch1 ch2) + (let ((out (open-output-string))) + (string-for-each + (lambda (ch) (display (if (eqv? ch ch1) ch2 ch) out)) + str) + (get-output-string out))) + +(define (string-intersperse-right str sep rule) + (let ((start (string-cursor-start str))) + (let lp ((i (string-cursor-end str)) + (rule rule) + (res '())) + (let* ((offset (if (pair? rule) (car rule) rule)) + (i2 (if offset (string-cursor-back str i offset) start))) + (if (string-cursor<=? i2 start) + (apply string-append (cons (substring/cursors str start i) res)) + (lp i2 + (if (and (pair? rule) (not (null? (cdr rule)))) (cdr rule) rule) + (cons sep (cons (substring/cursors str i2 i) res)))))))) + +;;> Outputs the string str, escaping any quote or escape characters. +;;> If esc-ch, which defaults to #\\, is #f, escapes only the +;;> quote-ch, which defaults to #\", by doubling it, as in SQL strings +;;> and CSV values. If renamer is provided, it should be a procedure +;;> of one character which maps that character to its escape value, +;;> e.g. #\newline => #\n, or #f if there is no escape value. + +(define (escaped fmt . o) + (let-optionals* o ((quot #\") + (esc #\\) + (rename (lambda (x) #f))) + (let ((esc-str (cond ((char? esc) (string esc)) + ((not esc) (string quot)) + (else esc)))) + (fn ((orig-output output)) + (define (output* str) + (let ((start (string-cursor-start str)) + (end (string-cursor-end str))) + (let lp ((i start) (j start)) + (define (collect) + (if (eq? i j) "" (substring/cursors str i j))) + (if (string-cursor>=? j end) + (orig-output (collect)) + (let ((c (string-ref/cursor str j)) + (j2 (string-cursor-next str j))) + (cond + ((or (eqv? c quot) (eqv? c esc)) + (each (orig-output (collect)) + (orig-output esc-str) + (fn () (lp j j2)))) + ((rename c) + => (lambda (c2) + (each (orig-output (collect)) + (orig-output esc-str) + (orig-output (if (char? c2) (string c2) c2)) + (fn () (lp j2 j2))))) + (else + (lp i j2)))))))) + (with ((output output*)) + fmt))))) + +;;> Only escape if there are special characters, in which case also +;;> wrap in quotes. For writing symbols in |...| escapes, or CSV +;;> fields, etc. The predicate indicates which characters cause +;;> slashification - this is in addition to automatic slashifying when +;;> either the quote or escape char is present. + +(define (maybe-escaped fmt pred . o) + (let-optionals* o ((quot #\") + (esc #\\) + (rename (lambda (x) #f))) + (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c))) + (call-with-output + fmt + (lambda (str) + (if (string-cursor) (else c))) + +(define (integer-log a base) + (if (zero? a) + 0 + ;; (exact (ceiling (/ (log (+ a 1)) (log base)))) + (do ((ndigits 1 (+ ndigits 1)) + (p base (* p base))) + ((> p a) ndigits)))) + +;; The original fmt algorithm was based on "Printing Floating-Point +;; Numbers Quickly and Accurately" by Burger and Dybvig +;; (FP-Printing-PLDI96.pdf). It had grown unwieldy with formatting +;; special cases, so the below is a simplification which tries to rely +;; on number->string for common cases. + +(define unspec (list 'unspecified)) + +(define-syntax default + (syntax-rules () + ((default var dflt) (if (eq? var unspec) dflt var)))) + +(define (numeric n . o) + (let-optionals* o ((rad unspec) (prec unspec) (sgn unspec) + (comma unspec) (commasep unspec) (decsep unspec)) + (fn (radix precision sign-rule + comma-rule comma-sep decimal-sep decimal-align) + (let* ((radix (default rad radix)) + (precision (default prec precision)) + (sign-rule (default sgn sign-rule)) + (comma-rule (default comma comma-rule)) + (comma-sep (default commasep comma-sep)) + (dec-sep (default decsep + (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))) + (dec-ls (if (char? dec-sep) + (list dec-sep) + (reverse (string->list dec-sep))))) + ;; General formatting utilities. + (define (get-scale q) + (expt radix (- (integer-log q radix) 1))) + (define (char-digit d) + (cond ((char? d) d) + ((< d 10) (integer->char (+ d (char->integer #\0)))) + (else (integer->char (+ (- d 10) (char->integer #\a)))))) + (define (digit-value ch) + (let ((res (- (char->integer ch) (char->integer #\0)))) + (if (<= 0 res 9) + res + ch))) + (define (round-up ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (append (reverse res) '(1))) + ((not (number? (car ls))) + (lp (cdr ls) (cons (car ls) res))) + ((= (car ls) (- radix 1)) + (lp (cdr ls) (cons 0 res))) + (else + (append (reverse res) (cons (+ 1 (car ls)) (cdr ls))))))) + (define (maybe-round n d ls) + (let* ((q (quotient n d)) + (digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q)))) + (if (or (> digit radix) + (and (= digit radix) + (let ((prev (find integer? ls))) + (and prev (odd? prev))))) + (round-up ls) + ls))) + (define (maybe-trim-zeros i res inexact?) + (if (and (not precision) (positive? i)) + (let lp ((res res)) + (cond + ((and (pair? res) (eqv? 0 (car res))) (lp (cdr res))) + ((and (pair? res) + (eqv? (car dec-ls) (car res)) + (null? (cdr dec-ls))) + (if inexact? + (cons 0 res) ; "1.0" + (cdr res))) ; "1" + (else res))) + res)) + ;; General slow loop to generate digits one at a time, for + ;; non-standard radixes or writing rationals with a fixed + ;; precision. + (define (gen-general n-orig) + (let* ((p (exact n-orig)) + (n (numerator p)) + (d (denominator p))) + (let lp ((n n) + (i (if (zero? p) -1 (- (integer-log p radix)))) + (res '())) + (cond + ;; Use a fixed precision if specified, otherwise generate + ;; 15 decimals. + ((if precision (< i precision) (< i 16)) + (let ((res (if (zero? i) + (append dec-ls (if (null? res) (cons 0 res) res)) + res)) + (q (quotient n d))) + (cond + ((< i -1) + (let* ((scale (expt radix (- -1 i))) + (digit (quotient q scale)) + (n2 (- n (* d digit scale)))) + (lp n2 (+ i 1) (cons digit res)))) + (else + (lp (* (remainder n d) radix) + (+ i 1) + (cons q res)))))) + (else + (reverse-list->string + (map char-digit + (maybe-trim-zeros i (maybe-round n d res) (inexact? n-orig))))))))) + ;; Generate a fixed precision decimal result by post-editing the + ;; result of string->number. + (define (gen-fixed n) + (cond + ((and (eqv? radix 10) (zero? precision) (inexact? n)) + (number->string (exact (round n)))) + ((and (eqv? radix 10) (or (integer? n) (inexact? n))) + (let* ((s (number->string n)) + (end (string-cursor-end s)) + (dec (string-index s #\.)) + (digits (- (string-cursor->index s end) + (string-cursor->index s dec)))) + (cond + ((string-cursor next 5) + (and (= next 5) + (string-cursor>? last (string-cursor-start s)) + (memv (digit-value + (string-ref/cursor + s (string-cursor-prev s last))) + '(1 3 5 7 9)))))) + (reverse-list->string + (map char-digit + (round-up + (reverse + (map digit-value (string->list res)))))) + res)))))) + (else + (gen-general n)))) + ;; Generate any unsigned real number. + (define (gen-positive-real n) + (cond + (precision + (gen-fixed n)) + ((memv radix (if (exact? n) '(2 8 10 16) '(10))) + (number->string n radix)) + (else + (gen-general n)))) + ;; Insert commas according to the current comma-rule. + (define (insert-commas str) + (let* ((dec-pos (if (string? dec-sep) + (or (string-contains str dec-sep) + (string-cursor-end str)) + (string-index str dec-sep))) + (left (substring/cursors str (string-cursor-start str) dec-pos)) + (right (string-copy/cursors str dec-pos)) + (sep (cond ((char? comma-sep) (string comma-sep)) + ((string? comma-sep) comma-sep) + ((eqv? #\, dec-sep) ".") + (else ",")))) + (string-append + (string-intersperse-right left sep comma-rule) + right))) + ;; Post-process a positive real number with decimal char fixup + ;; and commas as needed. + (define (wrap-comma n) + (if (and (not precision) (exact? n) (not (integer? n))) + (string-append (wrap-comma (numerator n)) + "/" + (wrap-comma (denominator n))) + (let* ((s0 (gen-positive-real n)) + (s1 (if (or (eqv? #\. dec-sep) + (equal? "." dec-sep)) + s0 + (string-replace-all s0 #\. dec-sep)))) + (if comma-rule (insert-commas s1) s1)))) + ;; Wrap the sign of a real number, forcing a + prefix or using + ;; parentheses (n) for negatives according to sign-rule. + + (define-syntax is-neg-zero? + (syntax-rules () + ((_ n) + (is-neg-zero? (-0.0) n)) + ((_ (0.0) n) ; -0.0 is not distinguished? + #f) + ((_ (-0.0) n) + (eqv? -0.0 n)))) + (define (negative?* n) + (or (negative? n) + (is-neg-zero? n))) + (define (wrap-sign n sign-rule) + (cond + ((negative?* n) + (cond + ((char? sign-rule) + (string-append (string sign-rule) + (wrap-comma (- n)) + (string (char-mirror sign-rule)))) + ((pair? sign-rule) + (string-append (car sign-rule) + (wrap-comma (- n)) + (cdr sign-rule))) + (else + (string-append "-" (wrap-comma (- n)))))) + ((eq? #t sign-rule) + (string-append "+" (wrap-comma n))) + (else + (wrap-comma n)))) + ;; Format a single real number with padding as necessary. + (define (format n sign-rule) + (cond + ((finite? n) + (let* ((s (wrap-sign n sign-rule)) + (dec-pos (if decimal-align + (string-cursor->index + s + (if (char? dec-sep) + (string-index s dec-sep) + (or (string-contains s dec-sep) + (string-cursor-end s)))) + 0)) + (diff (- (or decimal-align 0) dec-pos 1))) + (if (positive? diff) + (string-append (make-string diff #\space) s) + s))) + (else + (number->string n)))) + ;; Write any number. + (define (write-complex n) + (cond + ((and radix (not (and (integer? radix) (<= 2 radix 36)))) + (error "invalid radix for numeric formatting" radix)) + ((zero? (imag-part n)) + (displayed (format (real-part n) sign-rule))) + (else + (each (format (real-part n) sign-rule) + (format (imag-part n) #t) + "i")))) + (write-complex n))))) + +(define numeric/si + (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y")) + (names-10 '#("" "m" "µ" "n" "p" "f" "a" "z" "y")) + (names2 (list->vector + (cons "" + (cons "Ki" (map (lambda (s) (string-append s "i")) + (cddr (vector->list names10))))))) + (names-2 (list->vector + (cons "" + (map (lambda (s) (string-append s "i")) + (cdr (vector->list names-10))))))) + (define (round-to n k) + (/ (round (* n k)) k)) + (lambda (n . o) + (let-optionals* o ((base 1000) + (separator "")) + (if (zero? n) + "0" + (let* ((log-n (log (abs n))) + (names (if (negative? log-n) + (if (= base 1024) names-2 names-10) + (if (= base 1024) names2 names10))) + (k (min (exact ((if (negative? log-n) ceiling floor) + (/ (abs log-n) (log base)))) + (- (vector-length names) 1))) + (n2 (round-to (/ (abs n) + (expt base (if (negative? log-n) (- k) k))) + 10))) + (each (if (negative? n) "-" "") + (if (integer? n2) + (number->string (exact n2)) + (inexact n2)) + ;; (if (zero? k) "" separator) + separator + (vector-ref names k)))))))) + +;; Force a number into a fixed width, print as #'s if doesn't fit. +;; Needs to be wrapped in PADDED if you want to expand to the width. + +(define (numeric/fitted width n . args) + (call-with-output + (apply numeric n args) + (lambda (str) + (if (> (string-length str) width) + (fn (precision decimal-sep comma-sep) + (let ((prec (if (and (pair? args) (pair? (cdr args))) + (cadr args) + precision))) + (if (and prec (not (zero? prec))) + (let* ((dec-sep + (or decimal-sep + (if (eqv? #\. comma-sep) #\, #\.))) + (diff (- width (+ prec + (if (char? dec-sep) + 1 + (string-length dec-sep)))))) + (each (if (positive? diff) (make-string diff #\#) "") + dec-sep (make-string prec #\#))) + (displayed (make-string width #\#))))) + (displayed str))))) + +(define (numeric/comma n . o) + (fn ((orig-comma-rule comma-rule)) + (with ((comma-rule (if (pair? o) (car o) (or orig-comma-rule 3)))) + (apply numeric n (if (pair? o) (cdr o) '()))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; written + +(define (write-with-shares obj shares) + (fn ((orig-radix radix) precision) + (let ((write-number + ;; Shortcut for numeric values. Try to rely on + ;; number->string for standard radixes and no precision, + ;; otherwise fall back on numeric but resetting to a usable + ;; radix. + (cond + ((and (not precision) + (assv orig-radix + '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))) + => (lambda (cell) + (lambda (n) + (cond + ((eqv? orig-radix 10) + (displayed (number->string n (car cell)))) + ((exact? n) + (each (cdr cell) (number->string n (car cell)))) + (else + (with ((radix 10)) (numeric n))))))) + (else (lambda (n) (with ((radix 10)) (numeric n))))))) + ;; `wr' is the recursive writer closing over the shares. + (let wr ((obj obj)) + (call-with-shared-ref + obj shares each + (fn () + (cond + ((pair? obj) + (each "(" + (fn () + (let lp ((ls obj)) + (let ((rest (cdr ls))) + (each (wr (car ls)) + (cond + ((null? rest) + nothing) + ((pair? rest) + (each + " " + (call-with-shared-ref/cdr + rest shares each + (fn () (lp rest))))) + (else + (each " . " (wr rest)))))))) + ")")) + ((vector? obj) + (let ((len (vector-length obj))) + (if (zero? len) + (displayed "#()") + (each "#(" + (wr (vector-ref obj 0)) + (fn () + (let lp ((i 1)) + (if (>= i len) + nothing + (each " " (wr (vector-ref obj i)) + (fn () (lp (+ i 1))))))) + ")")))) + ((number? obj) + (write-number obj)) + (else + (displayed (write-to-string obj)))))))))) + +;; The default formatter for `written', overriden with the `writer' +;; variable. Intended to be equivalent to `write', using datum labels +;; for shared notation iff there are cycles in the object. + +(define (written-default obj) + (fn () + (write-with-shares obj (extract-shared-objects obj #t)))) + +;; Writes the object showing the full shared structure. + +(define (written-shared obj) + (fn () + (write-with-shares obj (extract-shared-objects obj #f)))) + +;; The only expensive part, in both time and memory, of handling +;; shared structures when writing is building the initial table, so +;; for the efficient version we just skip that and re-use the writing +;; code. + +(define (written-simply obj) + (fn () + (write-with-shares obj (extract-shared-objects #f #f)))) + +;; Local variables: +;; eval: (put 'fn 'scheme-indent-function 1) +;; End: