Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding initial srfi 166 implementation

Browse source
This commit is contained in:
Alex Shinn 2020-05-25 18:54:22 +09:00
parent 6b449150fc
commit b1af52195a
16 changed files with 1174 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
lib/chibi/show/base.sld
View file

@ -8,7 +8,8 @@
output-default extract-shared-objects write-to-string write-with-shares output-default extract-shared-objects write-to-string write-with-shares
call-with-shared-ref call-with-shared-ref/cdr) call-with-shared-ref call-with-shared-ref/cdr)
(import (scheme base) (scheme write) (scheme complex) (scheme inexact) (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
(srfi 1) (srfi 69) (chibi string) (chibi monad environment)) (srfi 1) (srfi 69) (chibi string) (chibi monad environment)
(chibi show shared))
(cond-expand (cond-expand
(chibi (chibi
(import (only (chibi) let-optionals*))) (import (only (chibi) let-optionals*)))

45
lib/chibi/show/color.scm
View file

@ -1,5 +1,5 @@
;; color.scm -- colored output ;; color.scm -- colored output
;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved. ;; Copyright (c) 2006-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
(define (color->ansi x) (define (color->ansi x)
@ -15,21 +15,24 @@
((magenta) "35") ((magenta) "35")
((cyan) "36") ((cyan) "36")
((white) "37") ((white) "37")
((reset) "39")
(else "0"))) (else "0")))
(define (ansi-escape color) (define (ansi-escape color)
(string-append (string (integer->char 27)) "[" (color->ansi color) "m")) (if (string? color)
color
(string-append "\x1B;[" (color->ansi color) "m")))
(define (colored new-color . args) (define (colored new-color . args)
(fn (color) (fn ((orig-color color))
(with ((color new-color)) (with ((color new-color))
(each (ansi-escape new-color) (each (ansi-escape new-color)
(each-in-list args) (each-in-list args)
(if (or (memq new-color '(bold underline)) (if (or (memq new-color '(bold underline))
(memq color '(bold underline))) (memq orig-color '(bold underline)))
(ansi-escape 'reset) (ansi-escape 'reset)
nothing) nothing)
(ansi-escape color))))) (ansi-escape orig-color)))))
(define (as-red . args) (colored 'red (each-in-list args))) (define (as-red . args) (colored 'red (each-in-list args)))
(define (as-blue . args) (colored 'blue (each-in-list args))) (define (as-blue . args) (colored 'blue (each-in-list args)))
@ -41,3 +44,35 @@
(define (as-black . args) (colored 'black (each-in-list args))) (define (as-black . args) (colored 'black (each-in-list args)))
(define (as-bold . args) (colored 'bold (each-in-list args))) (define (as-bold . args) (colored 'bold (each-in-list args)))
(define (as-underline . args) (colored 'underline (each-in-list args))) (define (as-underline . args) (colored 'underline (each-in-list args)))
(define (rgb-escape red-level green-level blue-level)
(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
"\x1B;[38;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
(define (rgb24-escape red-level green-level blue-level)
(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
"\x1B;[38;2;"
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
(define (as-color red green blue . fmt)
(colored (rgb-escape red green blue) (each-in-list fmt)))
(define (as-true-color red green blue . fmt)
(colored (rgb24-escape red green blue) (each-in-list fmt)))

3
lib/chibi/show/color.sld
View file

@ -3,5 +3,6 @@
(import (scheme base) (chibi show base)) (import (scheme base) (chibi show base))
(export as-red as-blue as-green as-cyan as-yellow (export as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black as-magenta as-white as-black
as-bold as-underline) as-bold as-underline
as-color as-true-color)
(include "color.scm")) (include "color.scm"))

24
lib/chibi/show/column.scm
View file

@ -56,7 +56,7 @@
(fn (output) (fn (output)
(set! resume #f) (set! resume #f)
(fn () (return nothing) nothing))))))) (fn () (return nothing) nothing)))))))
(consumer generate))))) (fn () (consumer generate))))))
(define (call-with-output-generators producers consumer) (define (call-with-output-generators producers consumer)
(let lp ((ls producers) (generators '())) (let lp ((ls producers) (generators '()))
@ -172,13 +172,13 @@
(if (proportional-width? col-width) (if (proportional-width? col-width)
(case align (case align
((right) ((right)
(lambda (str) (fn (width) (padded/left (scale-width width) str)))) (lambda (str) (fn (width) (padded (scale-width width) str))))
((center) ((center)
(lambda (str) (fn (width) (padded/both (scale-width width) str)))) (lambda (str) (fn (width) (padded/both (scale-width width) str))))
(else (else
(lambda (str) (fn (width) (padded/right (scale-width width) str))))) (lambda (str) (fn (width) (padded/right (scale-width width) str)))))
(case align (case align
((right) (lambda (str) (padded/left col-width str))) ((right) (lambda (str) (padded col-width str)))
((center) (lambda (str) (padded/both col-width str))) ((center) (lambda (str) (padded/both col-width str)))
(else (lambda (str) (padded/right col-width str)))))) (else (lambda (str) (padded/right col-width str))))))
(define (affix x) (define (affix x)
@ -205,8 +205,8 @@
pad))) pad)))
;; generator ;; generator
(if (proportional-width? col-width) (if (proportional-width? col-width)
(fn (width) (fn ((orig-width width))
(with ((width (scale-width width))) (with ((width (scale-width orig-width)))
gen)) gen))
(with ((width col-width)) gen)) (with ((width col-width)) gen))
infinite?))) infinite?)))
@ -309,7 +309,7 @@
;; break lines only, don't join short lines or justify ;; break lines only, don't join short lines or justify
(define (wrapped/char . ls) (define (wrapped/char . ls)
(fn (output width string-width) (fn ((orig-output output) width string-width)
(define (kons-in-line str) (define (kons-in-line str)
(fn (col) (fn (col)
(let ((len ((or string-width string-length) str)) (let ((len ((or string-width string-length) str))
@ -318,13 +318,13 @@
((equal? "" str) ((equal? "" str)
nothing) nothing)
((or (<= len space) (not (positive? space))) ((or (<= len space) (not (positive? space)))
(each (output str) (output "\n"))) (each (orig-output str) (orig-output "\n")))
(else (else
(each (each
;; TODO: when splitting by string-width, substring needs ;; TODO: when splitting by string-width, substring needs
;; to be provided ;; to be provided
(output (substring str 0 space)) (orig-output (substring str 0 space))
(output "\n") (orig-output "\n")
(fn () (kons-in-line (substring str space len))))))))) (fn () (kons-in-line (substring str space len)))))))))
(with ((output (with ((output
(lambda (str) (lambda (str)
@ -440,12 +440,12 @@
diff diff
(remainder diff (- len 1)))) (remainder diff (- len 1))))
(p (open-output-string))) (p (open-output-string)))
(display (car ls) p) (write-string (car ls) p)
(let lp ((ls (cdr ls)) (i 1)) (let lp ((ls (cdr ls)) (i 1))
(when (pair? ls) (when (pair? ls)
(display sep p) (write-string sep p)
(if (<= i rem) (write-char #\space p)) (if (<= i rem) (write-char #\space p))
(display (car ls) p) (write-string (car ls) p)
(lp (cdr ls) (+ i 1)))) (lp (cdr ls) (+ i 1))))
(displayed (get-output-string p))))) (displayed (get-output-string p)))))
(define (justify-last ls) (define (justify-last ls)

26
lib/chibi/show/pretty.scm
View file

@ -1,5 +1,5 @@
;; pretty.scm -- pretty printing format combinator ;; pretty.scm -- pretty printing format combinator
;; Copyright (c) 2006-2018 Alex Shinn. All rights reserved. ;; Copyright (c) 2006-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -32,6 +32,7 @@
((pair? rest) ((pair? rest)
(call-with-shared-ref/cdr rest (call-with-shared-ref/cdr rest
shares shares
each
(fn () (lp rest)) (fn () (lp rest))
sep)) sep))
(else (each sep ". " (fmt rest))))))))))) (else (each sep ". " (fmt rest)))))))))))
@ -41,8 +42,11 @@
str str
(string-find str pred (string-index->cursor str i)))) (string-find 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) (define (try-fitted2 proc fail)
(fn (width output) (fn (width (orig-output output))
(let ((out (open-output-string))) (let ((out (open-output-string)))
(call-with-current-continuation (call-with-current-continuation
(lambda (abort) (lambda (abort)
@ -69,21 +73,22 @@
(port out)) (port out))
proc) proc)
;; fitted successfully ;; fitted successfully
(output (get-output-string out)))))))) (fn () (orig-output (get-output-string out)))))))))
(define (try-fitted proc . fail) (define (try-fitted proc . fail)
(if (null? fail) (let lp ((proc proc) (ls fail))
(if (null? ls)
proc proc
(try-fitted2 proc (apply try-fitted fail)))) (try-fitted2 proc (lp (car ls) (cdr ls))))))
(define (fits-in-width width proc) (define (fits-in-width width proc)
(call-with-current-continuation (call-with-current-continuation
(lambda (abort) (lambda (abort)
(show (show
#f #f
(fn (output) (fn ((orig-output output))
(define (output* str) (define (output* str)
(each (output str) (each (orig-output str)
(fn (col) (fn (col)
(if (>= col width) (if (>= col width)
(abort #f) (abort #f)
@ -284,6 +289,7 @@
(call-with-shared-ref (call-with-shared-ref
(cadr x) (cadr x)
shares shares
each
(pp-flat (cadr x) pp shares))))) (pp-flat (cadr x) pp shares)))))
(else (else
(each "(" (each "("
@ -336,7 +342,7 @@
(else (lambda (n) (with ((radix 10)) (numeric n))))))) (else (lambda (n) (with ((radix 10)) (numeric n)))))))
(let pp ((obj obj)) (let pp ((obj obj))
(call-with-shared-ref (call-with-shared-ref
obj shares obj shares each
(fn () (fn ()
(cond (cond
((pair? obj) ((pair? obj)
@ -346,7 +352,7 @@
((number? obj) ((number? obj)
(write-number obj)) (write-number obj))
(else (else
(write-with-shares obj shares))))))))) (displayed (write-to-string obj))))))))))
(define (pretty obj) (define (pretty obj)
(fn () (fn ()
@ -366,3 +372,5 @@
(fn () (fn ()
(each (pp obj (extract-shared-objects #f #f)) (each (pp obj (extract-shared-objects #f #f))
fl))) fl)))
(define pretty-color pretty)

67
lib/chibi/show/shared.sld Normal file
View file

@ -0,0 +1,67 @@
;;; shared structure utilities
(define-library (chibi show shared)
(import (scheme base) (scheme write) (srfi 69))
(export
extract-shared-objects call-with-shared-ref call-with-shared-ref/cdr)
(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 (maybe-gen-shared-ref cell shares)
(cond
((pair? cell)
(set-car! cell (cdr shares))
(set-cdr! cell #t)
(set-cdr! shares (+ (cdr shares) 1))
(string-append "#" (number->string (car cell)) "="))
(else "")))
(define (call-with-shared-ref obj shares each proc)
(let ((cell (hash-table-ref/default (car shares) obj #f)))
(if (and (pair? cell) (cdr cell))
(each "#" (number->string (car cell)) "#")
(each (maybe-gen-shared-ref cell shares) 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 ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
(else
(each sep proc)))))
))

15
lib/chibi/show/show.scm
View file

@ -1,5 +1,5 @@
;; show.scm -- additional combinator formatters ;; show.scm -- additional combinator formatters
;; Copyright (c) 2013-2017 Alex Shinn. All rights reserved. ;; Copyright (c) 2013-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> A library of procedures for formatting Scheme objects to text in ;;> A library of procedures for formatting Scheme objects to text in
@ -86,9 +86,10 @@
;;; String transformations ;;; String transformations
(define (with-string-transformer proc . ls) (define (with-string-transformer proc . ls)
(fn (output) (fn ((orig-output output))
(let ((output* (lambda (str) (fn () (output (proc str)))))) (let ((output* (lambda (str) (orig-output (proc str)))))
(with ((output output*)) (each-in-list ls))))) (with ((output output*))
(each-in-list ls)))))
;;> Show each of \var{ls}, uppercasing all generated text. ;;> Show each of \var{ls}, uppercasing all generated text.
(define (upcased . ls) (apply with-string-transformer string-upcase ls)) (define (upcased . ls) (apply with-string-transformer string-upcase ls))
@ -215,17 +216,17 @@
(call-with-current-continuation (call-with-current-continuation
(lambda (return) (lambda (return)
(let ((chars-written 0) (let ((chars-written 0)
(output (or orig-output output-default))) (orig-output (or orig-output output-default)))
(define (output* str) (define (output* str)
(let ((len (string-width str))) (let ((len (string-width str)))
(set! chars-written (+ chars-written len)) (set! chars-written (+ chars-written len))
(if (> chars-written width) (if (> chars-written width)
(let* ((end (max 0 (- len (- chars-written width)))) (let* ((end (max 0 (- len (- chars-written width))))
(s (substring str 0 end))) (s (substring str 0 end)))
(each (output s) (each (orig-output s)
(with! (output orig-output)) (with! (output orig-output))
(fn () (return nothing)))) (fn () (return nothing))))
(output str)))) (orig-output str))))
(with ((output output*)) (with ((output output*))
(each-in-list ls))))))) (each-in-list ls)))))))

95
lib/chibi/show/write.scm
View file

@ -7,9 +7,7 @@
;;> \section{String utilities} ;;> \section{String utilities}
(define (write-to-string x) (define (write-to-string x)
(let ((out (open-output-string))) (call-with-output-string (lambda (out) (write x out))))
(write x out)
(get-output-string out)))
(define (string-replace-all str ch1 ch2) (define (string-replace-all str ch1 ch2)
(let ((out (open-output-string))) (let ((out (open-output-string)))
@ -45,7 +43,7 @@
(let ((esc-str (cond ((char? esc) (string esc)) (let ((esc-str (cond ((char? esc) (string esc))
((not esc) (string quot)) ((not esc) (string quot))
(else esc)))) (else esc))))
(fn (output) (fn ((orig-output output))
(define (output* str) (define (output* str)
(let ((start (string-cursor-start str)) (let ((start (string-cursor-start str))
(end (string-cursor-end str))) (end (string-cursor-end str)))
@ -53,19 +51,19 @@
(define (collect) (define (collect)
(if (eq? i j) "" (substring-cursor str i j))) (if (eq? i j) "" (substring-cursor str i j)))
(if (string-cursor>=? j end) (if (string-cursor>=? j end)
(output (collect)) (orig-output (collect))
(let ((c (string-cursor-ref str j)) (let ((c (string-cursor-ref str j))
(j2 (string-cursor-next str j))) (j2 (string-cursor-next str j)))
(cond (cond
((or (eqv? c quot) (eqv? c esc)) ((or (eqv? c quot) (eqv? c esc))
(each (output (collect)) (each (orig-output (collect))
(output esc-str) (orig-output esc-str)
(fn () (lp j j2)))) (fn () (lp j j2))))
((rename c) ((rename c)
=> (lambda (c2) => (lambda (c2)
(each (output (collect)) (each (orig-output (collect))
(output esc-str) (orig-output esc-str)
(output (if (char? c2) (string c2) c2)) (orig-output (if (char? c2) (string c2) c2))
(fn () (lp j2 j2))))) (fn () (lp j2 j2)))))
(else (else
(lp i j2)))))))) (lp i j2))))))))
@ -409,77 +407,15 @@
(displayed str))))) (displayed str)))))
(define (numeric/comma n . o) (define (numeric/comma n . o)
(fn (comma-rule) (fn ((orig-comma-rule comma-rule))
(with ((comma-rule (or comma-rule 3))) (with ((comma-rule (or orig-comma-rule 3)))
(apply numeric n o)))) (apply numeric n o))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities
(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 (maybe-gen-shared-ref cell shares)
(cond
((pair? cell)
(set-car! cell (cdr shares))
(set-cdr! cell #t)
(set-cdr! shares (+ (cdr shares) 1))
(each "#" (number->string (car cell)) "="))
(else nothing)))
(define (call-with-shared-ref obj shares proc)
(let ((cell (hash-table-ref/default (car shares) obj #f)))
(if (and (pair? cell) (cdr cell))
(each "#" (number->string (car cell)) "#")
(each (maybe-gen-shared-ref cell shares) proc))))
(define (call-with-shared-ref/cdr obj shares proc . o)
(let ((sep (displayed (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 ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
(else
(each sep proc)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; written ;; written
(define (write-with-shares obj shares) (define (write-with-shares obj shares)
(fn (radix precision) (fn ((orig-radix radix) precision)
(let ((write-number (let ((write-number
;; Shortcut for numeric values. Try to rely on ;; Shortcut for numeric values. Try to rely on
;; number->string for standard radixes and no precision, ;; number->string for standard radixes and no precision,
@ -487,11 +423,12 @@
;; radix. ;; radix.
(cond (cond
((and (not precision) ((and (not precision)
(assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))) (assv orig-radix
'((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
=> (lambda (cell) => (lambda (cell)
(lambda (n) (lambda (n)
(cond (cond
((eqv? radix 10) ((eqv? orig-radix 10)
(displayed (number->string n (car cell)))) (displayed (number->string n (car cell))))
((exact? n) ((exact? n)
(each (cdr cell) (number->string n (car cell)))) (each (cdr cell) (number->string n (car cell))))
@ -501,7 +438,7 @@
;; `wr' is the recursive writer closing over the shares. ;; `wr' is the recursive writer closing over the shares.
(let wr ((obj obj)) (let wr ((obj obj))
(call-with-shared-ref (call-with-shared-ref
obj shares obj shares each
(fn () (fn ()
(cond (cond
((pair? obj) ((pair? obj)
@ -517,7 +454,7 @@
(each (each
" " " "
(call-with-shared-ref/cdr (call-with-shared-ref/cdr
rest shares rest shares each
(fn () (lp rest))))) (fn () (lp rest)))))
(else (else
(each " . " (wr rest)))))))) (each " . " (wr rest))))))))

36
lib/srfi/166.sld Normal file
View file

@ -0,0 +1,36 @@
(define-library (srfi 166)
(import (srfi 166 base)
(srfi 166 pretty)
(srfi 166 columnar)
(srfi 166 unicode)
(srfi 166 color))
(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
port row col width output writer string-width pad-char ellipsis
radix precision decimal-sep decimal-align sign-rule
comma-sep comma-rule word-separator?
;; pretty
pretty pretty-shared pretty-simply pretty-color
;; columnar
columnar tabular wrapped wrapped/list wrapped/char
justified from-file line-numbers show-columns
;; unicode
as-unicode unicode-terminal-width
upcased downcased
;; color
as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black
as-bold as-underline
as-color as-true-color
))

120
lib/srfi/166/base.scm Normal file
View file

@ -0,0 +1,120 @@
;;> 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)))
;;> 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-find-right str #\newline)))
(write-string str port)
(if (string-cursor>? nl-index (string-cursor-start str))
(with! (row (+ r (string-count str #\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)
(word-separator? char-whitespace?)
(ellipsis "")
(decimal-align #f)
(decimal-sep #f)
(comma-sep #f)
(comma-rule #f)
(sign-rule #f)
(precision #f)
(writer #f)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \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))))))

55
lib/srfi/166/base.sld Normal file
View file

@ -0,0 +1,55 @@
(define-library (srfi 166 base)
(import (scheme base)
(scheme char)
(scheme write)
(scheme complex)
(scheme inexact)
(srfi 1)
(srfi 69)
(chibi show shared)
(chibi string)
(rename (srfi 165)
(computation-each sequence)
(computation-with! with!)
(computation-forked forked)
))
(cond-expand
(chibi
(import (only (chibi) let-optionals*)))
(else
(begin
(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)))))))
(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
upcased downcased
;; computations
fn with with! forked call-with-output
;; state variables
port row col width output writer string-width pad-char ellipsis
radix precision decimal-sep decimal-align sign-rule
comma-sep comma-rule word-separator?
)
(include "base.scm")
(include "../../chibi/show/write.scm")
(include "../../chibi/show/show.scm"))

11
lib/srfi/166/color.sld Normal file
View file

@ -0,0 +1,11 @@
(define-library (srfi 166 color)
(import (scheme base) (srfi 130) (srfi 165) (srfi 166 base))
(export as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black
as-bold as-underline
as-color as-true-color)
(begin
(define color
(make-computation-environment-variable 'color #f #f)))
(include "../../chibi/show/color.scm"))

13
lib/srfi/166/columnar.sld Normal file
View file

@ -0,0 +1,13 @@
(define-library (srfi 166 columnar)
(import (scheme base)
(scheme char)
(scheme file)
(srfi 1)
(srfi 117)
(srfi 130)
(srfi 166 base)
(chibi optional)
)
(export-all)
(include "../../chibi/show/column.scm"))

12
lib/srfi/166/pretty.sld Normal file
View file

@ -0,0 +1,12 @@
(define-library (srfi 166 pretty)
(import (scheme base)
(scheme char)
(scheme write)
(chibi show shared)
(chibi string)
(srfi 1)
(srfi 69)
(srfi 166 base))
(export-all)
(include "../../chibi/show/pretty.scm"))

757
lib/srfi/166/test.sld Normal file
View file

@ -0,0 +1,757 @@
(define-library (srfi 166 test)
(export run-tests)
(import (scheme base) (scheme char) (scheme read) (scheme file)
(only (srfi 1) circular-list)
(chibi test)
(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 (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)))
;; 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 "3.9Ki" (show #f (numeric/si 3986)))
(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 "1,234,567" (show #f (numeric/comma 1234567)))
(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 "cde" (show #f (trimmed 3 "abcde")))
(test "bcd" (show #f (trimmed/both 3 "abcde")))
(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
"(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 "hello\nworld\n"
(show #f (with ((width 8)) (wrapped "hello world"))))
(test "\n" (show #f (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
"(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;[0m" (show #f (as-red "red")))
(test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[0m"
(show #f (as-red "red" (as-blue "blue") "red")))
(test "\x1b;[31m1234567\x1b;[0m col: 7"
(show #f (as-unicode (as-red "1234567") (fn (col) (each " col: " col)))))
;; unicode
(test "〜日本語〜"
(show #f (with ((pad-char #\〜)) (padded/both 5 "日本語"))))
(test "日本語"
(show #f (as-unicode (with ((pad-char #\〜)) (padded/both 5 "日本語")))))
(test "日本語 col: 6"
(show #f (as-unicode "日本語" (fn (col) (each " col: " col)))))
;; 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))))

5
lib/srfi/166/unicode.sld Normal file
View file

@ -0,0 +1,5 @@
(define-library (srfi 166 unicode)
(import (scheme base) (srfi 151) (srfi 166 base))
(export-all)
(include "../../chibi/show/unicode.scm"))