2024-02-28 21:07:04 +00:00
( define-module ( reflow ansi )
# :use-module ( rnrs io ports )
2024-03-06 03:53:17 +00:00
# :export ( %ansi-marker
%reset
%reset-seq
ansi-terminator?
make-ansi-port-tuple ) )
2024-02-28 21:07:04 +00:00
2024-03-06 03:53:17 +00:00
( define %ansi-marker #\x1b )
( define %reset "[0m" )
( define %reset-seq
( string-append ( string %ansi-marker ) %reset ) )
2024-02-28 21:07:04 +00:00
( define ( ansi-terminator? char )
( let ( ( c ( char->integer char ) ) )
( or ( and ( >= c # x40 ) ( <= c # x5a ) ) ( and ( >= c # x61 ) ( <= c # x7a ) ) ) ) )
;; TODO: create helpers that allow the reflow to operate properly.
( define ( make-ansi-port-tuple o-port )
2024-02-29 16:55:55 +00:00
"Return the wrapping port and 3 functions acting on it: `current-sequence', `reset-sequence', `restore-sequence'. `current-sequence': Returns the current, complete sequence applied to the port. `reset-sequence': Sends a reset sequence to the port if necessary (if there is currently a sequence). `restore-sequence': If there is a sequence, send it to the port."
2024-02-29 14:33:11 +00:00
;; The sequence we are currently building up, a list of characters (reversed).
( define wip-sequence-list ' ( ) )
2024-02-28 21:07:04 +00:00
2024-02-29 14:33:11 +00:00
;; The current sequence, a list of strings (reversed).
;; These will be compressed into a single string upon reading.
( define current-sequence-list ' ( ) )
2024-02-28 21:07:04 +00:00
2024-02-29 16:55:55 +00:00
;; #t if we are currently defining an escape sequence
2024-02-28 21:07:04 +00:00
( define in-escape-sequence? #f )
2024-02-29 16:55:55 +00:00
;; #t if there is a sequence stored.
2024-02-29 14:33:11 +00:00
( define ( sequence? ) ( not ( null? current-sequence-list ) ) )
( define-syntax-rule ( cons! item lst )
( set! lst ( cons item lst ) ) )
2024-02-28 21:07:04 +00:00
;; rune by rune
( define ( put-char c )
( cond
2024-02-29 16:55:55 +00:00
;; If we see a marker, flag it and begin building the sequence list
2024-03-06 03:53:17 +00:00
( ( equal? %ansi-marker c )
2024-02-28 21:07:04 +00:00
( set! in-escape-sequence? #t )
2024-02-29 14:33:11 +00:00
( cons! c wip-sequence-list ) )
2024-02-28 21:07:04 +00:00
( in-escape-sequence?
2024-02-29 16:55:55 +00:00
;; If we are still in an escape sequence continue building
2024-02-29 14:33:11 +00:00
( cons! c wip-sequence-list )
2024-02-28 21:07:04 +00:00
( when ( ansi-terminator? c )
2024-02-29 16:55:55 +00:00
;; If we reach a terminator char, we have completed building the sequence
2024-02-28 21:07:04 +00:00
( set! in-escape-sequence? #f )
2024-02-29 16:55:55 +00:00
;; Convert it to a string (reverse, because we used cons)
2024-02-29 14:33:11 +00:00
( let ( ( sequence ( reverse-list->string wip-sequence-list ) ) )
2024-02-28 21:07:04 +00:00
( cond
2024-02-29 16:55:55 +00:00
;; Is it a reset sequence? Clear it
2024-03-06 03:53:17 +00:00
( ( string-suffix? %reset sequence )
2024-02-29 14:33:11 +00:00
( set! current-sequence-list ' ( ) ) )
2024-02-29 16:55:55 +00:00
;; Is it a color code? Add it to the sequence!
2024-02-28 21:07:04 +00:00
( ( equal? c #\m )
2024-02-29 14:33:11 +00:00
( cons! sequence current-sequence-list ) ) )
2024-02-28 21:07:04 +00:00
2024-02-29 16:55:55 +00:00
;; Now we can output the full sequence in one go
;; and clear the work-in-progress list
2024-02-28 21:07:04 +00:00
( display sequence o-port )
2024-02-29 14:33:11 +00:00
( set! wip-sequence-list ' ( ) ) ) ) )
2024-02-28 21:07:04 +00:00
( else
2024-02-29 16:55:55 +00:00
;; Just display the text right away
2024-02-28 21:07:04 +00:00
( display c o-port ) ) ) )
( define port
( make-soft-port
( vector
;; Char out
2024-03-06 03:53:17 +00:00
put-char
2024-02-29 16:55:55 +00:00
;; String out, go char by char
2024-02-28 21:07:04 +00:00
( λ ( s ) ( string-for-each put-char s ) )
2024-03-06 03:55:10 +00:00
#f #f #f )
2024-02-28 21:07:04 +00:00
"w" ) )
2024-02-29 14:54:46 +00:00
( define ( current-sequence )
2024-02-29 16:55:55 +00:00
"Returns the currently defined ansi sequence."
2024-02-29 14:33:11 +00:00
( and
( sequence? )
( if ( = 1 ( length current-sequence-list ) )
( car current-sequence-list )
;; On read, compress the list of strings to a single string for safekeeping
( let ( ( str ( string-concatenate-reverse/shared current-sequence-list ) ) )
( set! current-sequence-list ( list str ) )
str ) ) ) )
2024-02-28 21:07:04 +00:00
( define ( reset-ansi )
2024-02-29 16:55:55 +00:00
"Reset the current ansi sequence if needed by outputting to the wrapped port."
2024-02-29 14:33:11 +00:00
( when ( sequence? )
2024-03-06 03:53:17 +00:00
( display %reset-seq o-port ) ) )
2024-02-28 21:07:04 +00:00
( define ( restore-ansi )
2024-02-29 16:55:55 +00:00
"Restore the current ansi sequence by outputting to the wrapped port."
2024-02-29 14:54:46 +00:00
( let ( ( seq ( current-sequence ) ) )
2024-02-28 21:07:04 +00:00
( when seq
( display seq o-port ) ) ) )
2024-02-29 14:54:46 +00:00
( values port current-sequence reset-ansi restore-ansi ) )