Import new table renderer.
This commit is contained in:
parent
3a59a9293a
commit
3f7f1356a4
12 changed files with 3859 additions and 1 deletions
485
src/sgr-list.scm
Normal file
485
src/sgr-list.scm
Normal file
|
|
@ -0,0 +1,485 @@
|
|||
;;
|
||||
;; sgr-list.scm
|
||||
;;
|
||||
;; Intermediate representation of strings with SGR state changes.
|
||||
;;
|
||||
;; ISC License
|
||||
;;
|
||||
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||
;;
|
||||
;; Permission to use, copy, modify, and/or distribute this software
|
||||
;; for any purpose with or without fee is hereby granted, provided
|
||||
;; that the above copyright notice and this permission notice appear
|
||||
;; in all copies.
|
||||
;;
|
||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||
;;
|
||||
|
||||
(declare (unit sgr-list))
|
||||
|
||||
(module
|
||||
sgr-list
|
||||
(
|
||||
string->sgr-list
|
||||
string->sgr-list/words
|
||||
|
||||
sgr-list->string
|
||||
|
||||
sgr-list-length
|
||||
sgr-list-length/stretch
|
||||
sgr-list-length-w/o-glues
|
||||
|
||||
sgr-token-spaces?
|
||||
sgr-token-glue?
|
||||
sgr-token-newline?
|
||||
sgr-token-unglue?
|
||||
|
||||
sgr-token-neutralize
|
||||
sgr-list-neutralize
|
||||
|
||||
sgr-list-num-glues
|
||||
|
||||
sgr-list-min-width
|
||||
|
||||
sgr-list-last-state
|
||||
|
||||
sgr-list-tests!
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken string)
|
||||
racket-kwargs
|
||||
sgr-state
|
||||
testing
|
||||
util-utf8)
|
||||
|
||||
;; Converts given string into a list of string parts and sgr-states
|
||||
(define* (string->sgr-list str
|
||||
(initial-state empty-sgr-state))
|
||||
(let ((src-len (string-length str)))
|
||||
(let loop ((src-idx 0)
|
||||
(token-start 0)
|
||||
(token-end 0)
|
||||
(token-pos 0)
|
||||
(state initial-state)
|
||||
(res '()))
|
||||
(if (>= src-idx src-len)
|
||||
(reverse
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)))
|
||||
(let ((ch (string-ref str src-idx)))
|
||||
(cond
|
||||
((eq? ch #\x1b)
|
||||
(let-values (((sgr-parsed next-idx)
|
||||
(parse-csi-sgr-sequence+pos str src-idx state)))
|
||||
(let ((token (update-sgr-state-from-list state sgr-parsed)))
|
||||
(loop next-idx
|
||||
next-idx
|
||||
next-idx
|
||||
0
|
||||
token
|
||||
(cons token
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)))))))
|
||||
(else
|
||||
(let ((next-idx (utf8-string-next-char str src-idx)))
|
||||
(loop next-idx
|
||||
token-start
|
||||
next-idx
|
||||
(add1 token-pos)
|
||||
state
|
||||
res)))))))))
|
||||
|
||||
;; Converts given string into a list of string parts and sgr-states,
|
||||
;; handling continuous whitespace as separate tokens.
|
||||
(define* (string->sgr-list/words str
|
||||
(initial-state empty-sgr-state))
|
||||
(let ((src-len (string-length str)))
|
||||
(let loop ((src-idx 0)
|
||||
(token-start 0)
|
||||
(token-end 0)
|
||||
(token-pos 0)
|
||||
(state initial-state)
|
||||
(space? #f)
|
||||
(res '()))
|
||||
(if (>= src-idx src-len)
|
||||
(reverse
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)))
|
||||
(let ((ch (string-ref str src-idx)))
|
||||
(cond
|
||||
((eq? ch #\x1b)
|
||||
(let-values (((sgr-parsed next-idx)
|
||||
(parse-csi-sgr-sequence+pos str src-idx state)))
|
||||
(let ((token (update-sgr-state-from-list state sgr-parsed)))
|
||||
(loop next-idx
|
||||
next-idx
|
||||
next-idx
|
||||
0
|
||||
token
|
||||
#f
|
||||
(cons token
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)))))))
|
||||
((eq? ch #\backspace)
|
||||
(let ((next-idx (add1 src-idx)))
|
||||
(loop next-idx
|
||||
next-idx
|
||||
next-idx
|
||||
0
|
||||
state
|
||||
#f
|
||||
(cons (cons "\b" 1)
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res))))))
|
||||
((eq? ch #\newline)
|
||||
(let ((next-idx (add1 src-idx)))
|
||||
(loop next-idx
|
||||
next-idx
|
||||
next-idx
|
||||
0
|
||||
state
|
||||
#f
|
||||
(cons (cons "\n" 1)
|
||||
(if (= token-start token-end)
|
||||
res
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res))))))
|
||||
((memq ch '(#\space #\tab))
|
||||
(let ((next-idx (add1 src-idx)))
|
||||
(loop next-idx
|
||||
(if space?
|
||||
token-start
|
||||
src-idx)
|
||||
next-idx
|
||||
(if space?
|
||||
(add1 token-pos)
|
||||
1)
|
||||
state
|
||||
#t
|
||||
(if (and (not space?)
|
||||
(> token-end token-start))
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)
|
||||
res))))
|
||||
(else
|
||||
(let ((next-idx (utf8-string-next-char str src-idx)))
|
||||
(loop next-idx
|
||||
(if space?
|
||||
src-idx
|
||||
token-start)
|
||||
next-idx
|
||||
(if space?
|
||||
1
|
||||
(add1 token-pos))
|
||||
state
|
||||
#f
|
||||
(if space?
|
||||
(cons (cons (substring str token-start token-end)
|
||||
token-pos)
|
||||
res)
|
||||
res))))))))))
|
||||
|
||||
;; Converts a SGR list into a single string
|
||||
(define* (sgr-list->string lst
|
||||
(initial-state empty-sgr-state)
|
||||
#:reset-state (reset-state #f))
|
||||
(let loop ((lst lst)
|
||||
(res '())
|
||||
(state initial-state))
|
||||
(if (null? lst)
|
||||
(string-intersperse
|
||||
(reverse (if reset-state
|
||||
(cons reset-state res)
|
||||
res))
|
||||
"")
|
||||
(let ((token (car lst)))
|
||||
(if (sgr-state? token)
|
||||
(loop (cdr lst)
|
||||
(cons (sgr-state-change->string state token) res)
|
||||
token)
|
||||
(loop (cdr lst)
|
||||
(cons (car token) res)
|
||||
state))))))
|
||||
|
||||
;; Predicate for SGR list tokens
|
||||
(define (sgr-list-token? v)
|
||||
(and (pair? v)
|
||||
(string? (car v))
|
||||
(fixnum? (cdr v))))
|
||||
|
||||
;; Returns the length of all utf8 strings in the sgr-list
|
||||
(define (sgr-list-length sl)
|
||||
(foldl
|
||||
(lambda (acc tk)
|
||||
(if (sgr-list-token? tk)
|
||||
(+ acc (cdr tk))
|
||||
acc))
|
||||
0 sl))
|
||||
|
||||
;; Returns the length of all utf8 strings without glues. Glues must
|
||||
;; have at least width 1 if they are not the first or last
|
||||
;; token. Those can have zero length. All spaces have width of
|
||||
;; 1. Used for wrapping blocks.
|
||||
(define (sgr-list-length/stretch sl)
|
||||
(let loop ((sl sl)
|
||||
(len 0)
|
||||
(seen-string? #f)
|
||||
(last-space? #f))
|
||||
(if (null? sl)
|
||||
(if last-space?
|
||||
(sub1 len)
|
||||
len)
|
||||
(let* ((tk (car sl))
|
||||
(is-spaces? (sgr-token-spaces? tk))
|
||||
(is-string? (and (not (sgr-state? tk))
|
||||
(not is-spaces?))))
|
||||
(loop (cdr sl)
|
||||
(cond ((sgr-token-spaces? tk)
|
||||
(if seen-string?
|
||||
(add1 len)
|
||||
len))
|
||||
((sgr-state? tk)
|
||||
len)
|
||||
(else
|
||||
(+ len (cdr tk))))
|
||||
(or seen-string?
|
||||
is-string?)
|
||||
(if is-string?
|
||||
#f
|
||||
(if is-spaces?
|
||||
#t
|
||||
last-space?)))))))
|
||||
|
||||
;; Returns length without glues
|
||||
(define (sgr-list-length-w/o-glues sl)
|
||||
(foldl (lambda (acc tk)
|
||||
(if (or (sgr-state? tk)
|
||||
(sgr-token-glue? tk)
|
||||
(sgr-token-unglue? tk))
|
||||
acc
|
||||
(+ acc (cdr tk))))
|
||||
0 sl))
|
||||
|
||||
|
||||
;; Predicate for string token containing only spaces and tabs
|
||||
(define (sgr-token-spaces? t)
|
||||
(and (pair? t)
|
||||
(string? (car t))
|
||||
(let loop ((i 0))
|
||||
(if (= i (cdr t))
|
||||
#t
|
||||
(if (memq (string-ref (car t) i) '(#\space #\tab))
|
||||
(loop (add1 i))
|
||||
#f)))))
|
||||
|
||||
;; Predicate for string token with only spaces and at least one tab
|
||||
(define (sgr-token-glue? t)
|
||||
(and (pair? t)
|
||||
(string? (car t))
|
||||
(let loop ((i 0)
|
||||
(glue #f))
|
||||
(if (= i (cdr t))
|
||||
glue
|
||||
(let ((ch (string-ref (car t) i)))
|
||||
(if (eq? ch #\tab)
|
||||
(loop (add1 i) #t)
|
||||
(if (eq? ch #\space)
|
||||
(loop (add1 i) glue)
|
||||
#f)))))))
|
||||
|
||||
;; Predicate for string containing only a newline
|
||||
(define (sgr-token-newline? t)
|
||||
(and (pair? t)
|
||||
(string? (car t))
|
||||
(eq? (cdr t) 1)
|
||||
(eq? (string-ref (car t) 0) #\newline)))
|
||||
|
||||
;; Predicate for unglue (used for justify)
|
||||
(define (sgr-token-unglue? t)
|
||||
(and (pair? t)
|
||||
(string? (car t))
|
||||
(eq? (cdr t) 1)
|
||||
(eq? (string-ref (car t) 0) #\backspace)))
|
||||
|
||||
;; Replaces all occurences of #\tab with #\space and removes trailing
|
||||
;; #\backspace
|
||||
(define (sgr-token-neutralize t)
|
||||
(if (and (pair? t)
|
||||
(string? (car t)))
|
||||
(let* ((str (string-copy (car t)))
|
||||
(len (string-length str)))
|
||||
(if (> len 0)
|
||||
(let loop ((idx 0))
|
||||
(if (= idx len)
|
||||
(if (eq? (string-ref str (sub1 len)) #\backspace)
|
||||
(cons (substring str 0 (sub1 len))
|
||||
(sub1 len))
|
||||
(cons str len))
|
||||
(let ((ch (string-ref str idx)))
|
||||
(when (eq? ch #\tab)
|
||||
(string-set! str idx #\space))
|
||||
(loop (add1 idx)))))
|
||||
t))))
|
||||
|
||||
;; Neutralizes whole SGR list
|
||||
(define (sgr-list-neutralize sl)
|
||||
(map sgr-token-neutralize sl))
|
||||
|
||||
;; Returns the number of glues in given SGR list
|
||||
(define (sgr-list-num-glues sl)
|
||||
(foldl (lambda (acc t)
|
||||
(if (sgr-token-glue? t)
|
||||
(add1 acc)
|
||||
acc))
|
||||
0 sl))
|
||||
|
||||
;; Returns the longest word
|
||||
(define (sgr-list-min-width sl)
|
||||
(let loop ((sl sl)
|
||||
(res 0))
|
||||
(if (null? sl)
|
||||
res
|
||||
(let ((tk (car sl)))
|
||||
(loop (cdr sl)
|
||||
(if (sgr-state? tk)
|
||||
res
|
||||
(max res (cdr tk))))))))
|
||||
|
||||
;; Returns the last SGR state in given sgr-list
|
||||
(define* (sgr-list-last-state sl (initial-state empty-sgr-state))
|
||||
(let loop ((sl sl)
|
||||
(state initial-state))
|
||||
(if (null? sl)
|
||||
state
|
||||
(loop (cdr sl)
|
||||
(if (sgr-state? (car sl))
|
||||
(car sl)
|
||||
state)))))
|
||||
|
||||
;; Module self-tests
|
||||
(define (sgr-list-tests!)
|
||||
(run-tests
|
||||
sgr-list
|
||||
(test-equal? sgr-list->string
|
||||
(sgr-list->string '(("Hello" . 5)))
|
||||
"Hello")
|
||||
(test-true sgr-list-token?
|
||||
(sgr-list-token? '("Hello" . 5)))
|
||||
(test-false sgr-list-token?
|
||||
(sgr-list-token? empty-sgr-state))
|
||||
(test-false sgr-list-token?
|
||||
(sgr-list-token? (set-sgr-state-foreground
|
||||
empty-sgr-state
|
||||
(make-sgr-truecolor 1 2 3))))
|
||||
(test-equal? sgr-list-length
|
||||
(sgr-list-length '(("Hello" . 5)))
|
||||
5)
|
||||
(test-true sgr-token-spaces?
|
||||
(sgr-token-spaces? '(" " . 5)))
|
||||
(test-true sgr-token-spaces?
|
||||
(sgr-token-spaces? '(" \x09 " . 5)))
|
||||
(test-false sgr-token-spaces?
|
||||
(sgr-token-spaces? '(" x " . 5)))
|
||||
(test-true sgr-token-newline?
|
||||
(sgr-token-newline? '("\n" . 1)))
|
||||
(test-false sgr-token-newline?
|
||||
(sgr-token-newline? '("\na" . 2)))
|
||||
(test-false sgr-token-newline?
|
||||
(sgr-token-newline? '("x" . 1)))
|
||||
(test-true sgr-token-glue?
|
||||
(sgr-token-glue? '(" \t " . 5)))
|
||||
(test-true sgr-token-glue?
|
||||
(sgr-token-glue? '("\t" . 1)))
|
||||
(test-false sgr-token-glue?
|
||||
(sgr-token-glue? '(" " . 5)))
|
||||
(test-false sgr-token-glue?
|
||||
(sgr-token-glue? '(" x " . 5)))
|
||||
(test-equal? string->sgr-list
|
||||
(string->sgr-list "Hello")
|
||||
'(("Hello" . 5)))
|
||||
(test-equal? string->sgr-list
|
||||
(string->sgr-list "\x1b[1mHello \x1b[0mWorld!")
|
||||
'(1 ("Hello " . 6) 0 ("World!" . 6)))
|
||||
(test-equal? string->sgr-list/words
|
||||
(string->sgr-list/words "Hello World!")
|
||||
'(("Hello" . 5)
|
||||
(" " . 1)
|
||||
("World!" . 6)))
|
||||
(test-equal? string->sgr-list/words
|
||||
(string->sgr-list/words "\x1b[1mHello \x1b[0mWorld!")
|
||||
'(1
|
||||
("Hello" . 5)
|
||||
(" " . 1)
|
||||
0
|
||||
("World!" . 6)))
|
||||
(test-equal? string->sgr-list/words
|
||||
(string->sgr-list/words "Hello World!\b")
|
||||
'(("Hello" . 5)
|
||||
(" " . 1)
|
||||
("World!" . 6)
|
||||
("\b" . 1)))
|
||||
(test-equal? string->sgr-list/words
|
||||
(string->sgr-list/words "Hello\nWorld!")
|
||||
'(("Hello" . 5)
|
||||
("\n" . 1)
|
||||
("World!" . 6)))
|
||||
(test-equal? sgr-list-length/stretch
|
||||
(sgr-list-length/stretch
|
||||
'(("Hello" . 5)))
|
||||
5)
|
||||
(test-equal? sgr-list-length/stretch
|
||||
(sgr-list-length/stretch
|
||||
'(("Hello" . 5) (" " . 4)))
|
||||
5)
|
||||
(test-equal? sgr-list-length/stretch
|
||||
(sgr-list-length/stretch
|
||||
'(("Hello" . 5) (" " . 4) 1))
|
||||
5)
|
||||
(test-equal? sgr-list-length/stretch
|
||||
(sgr-list-length/stretch
|
||||
'(1 (" " . 4) ("Hello" . 5) (" " . 4) 1))
|
||||
5)
|
||||
(test-equal? sgr-list-length/stretch
|
||||
(sgr-list-length/stretch
|
||||
'(("Hello" . 5) (" " . 4) ("World" . 5)))
|
||||
11)
|
||||
(test-equal? sgr-list-length-w/o-glues
|
||||
(sgr-list-length-w/o-glues
|
||||
'(("Hello" . 5) (" \t " . 5) ("World" . 5)))
|
||||
10)
|
||||
(test-true sgr-token-unglue?
|
||||
(sgr-token-unglue? '("\b" . 1)))
|
||||
(test-false sgr-token-unglue?
|
||||
(sgr-token-unglue? '(" \b" . 2)))
|
||||
(test-equal? sgr-token-neutralize
|
||||
(sgr-token-neutralize '("Hello\b" . 6))
|
||||
'("Hello" . 5))
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue