-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathecho.rkt
110 lines (91 loc) · 6.11 KB
/
echo.rkt
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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#lang typed/racket/base
(provide Term-Color term-colorize)
(provide term-format echof fechof eechof)
(require racket/string)
(require racket/symbol)
(require "digitama/minimal/string.rkt")
(require (for-syntax racket/base))
(require (for-syntax racket/syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-type Term-Color (Option (U String Symbol Byte)))
(define-syntax (define-esc stx)
(syntax-case stx [:]
[(_ esc [[arg : Type defval ...] ...] fmt)
(with-syntax ([esc* (format-id #'esc "~a*" (syntax-e #'esc))])
(syntax/loc stx
(begin (provide esc* esc)
(define (esc* [arg : Type defval ...] ... #:/dev/stdout [/dev/stdout : Output-Port (current-output-port)]) : Void
(fprintf /dev/stdout fmt arg ...))
(define (esc [arg : Type defval ...] ... #:/dev/stdout [/dev/stdout : Output-Port (current-output-port)]) : Void
(when (terminal-port? /dev/stdout)
(esc* #:/dev/stdout /dev/stdout arg ...))))))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define named-colors : (Immutable-HashTable Symbol Byte)
#hasheq((black . 0) (darkgray . 8) (darkgrey . 8) (lightgray . 7) (lightgrey . 7) (gray . 7) (grey . 7) (white . 15)
(darkred . 1) (darkgreen . 2) (darkyellow . 3) (darkblue . 4) (brown . 5) (darkmagenta . 5)
(darkcyan . 6) (red . 9) (lightred . 9) (green . 10) (lightgreen . 10) (yellow . 11) (lightyellow . 11)
(blue . 12) (lightblue . 12) (magenta . 13) (lightmagenta . 13) (cyan . 14) (lightcyan . 14)))
(define term-colorize : (-> Term-Color Term-Color (Listof Symbol) String String)
(lambda [fg bg attrs content]
(define (color-code [color : (U Byte String Symbol)] [bg? : Boolean]) : String
(format "~a8;5;~a"
(if bg? 4 3)
(cond [(symbol? color)
(hash-ref named-colors color
(λ [] (hash-ref named-colors (string->symbol (string-downcase (symbol->immutable-string color)))
(λ [] 0))))]
[(string? color) (hash-ref named-colors (string->symbol (string-downcase color)) (λ [] 0))]
[else color])))
(regexp-replace #px"^(\\s*)(.+?)(\\s*)$" content
(format "\\1\033[~a;~a;~am\\2\033[0m\\3"
(string-replace (for/fold : String ([effects ""]) ([attr : Symbol (in-list attrs)])
(case (string-downcase (symbol->immutable-string attr))
[{"bold" "bright"} (string-append effects ";1")]
[{"dim"} (string-append effects ";2")]
[{"underline" "undercurl"} (string-append effects ";4")]
[{"blink"} (string-append effects ";5")]
[{"reverse" "inverse"} (string-append effects ";7")]
[{"hidden" "password"} (string-append effects ";8")]
[else (error 'tarminal-colorize "Unsupported Terminal Attribute: ~a" attr)]))
"^;" "" #:all? #false)
(if (not fg) 39 (color-code fg #false))
(if (not bg) 49 (color-code bg #true))))))
(define term-echo : (-> Output-Port String Term-Color Term-Color (Listof Symbol) Void)
(lambda [/dev/stdout rawmsg fg bg attrs]
; TODO: ~ is an operator in some language, that's the root of problem
(define safe-msg (string-replace rawmsg "~n" "\n"))
(display (cond [(not (terminal-port? /dev/stdout)) safe-msg]
[else (term-colorize fg bg attrs safe-msg)])
/dev/stdout)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define term-format : (-> String [#:fgcolor Term-Color] [#:bgcolor Term-Color] [#:attributes (Listof Symbol)] Any * String)
(lambda [msgfmt #:fgcolor [fg #false] #:bgcolor [bg #false] #:attributes [attrs null] . vals]
(term-colorize fg bg attrs (~string msgfmt vals))))
(define echof : (-> String [#:fgcolor Term-Color] [#:bgcolor Term-Color] [#:attributes (Listof Symbol)] Any * Void)
(lambda [msgfmt #:fgcolor [fg #false] #:bgcolor [bg #false] #:attributes [attrs null] . vals]
(term-echo (current-output-port) (~string msgfmt vals) fg bg attrs)))
(define eechof : (-> String [#:fgcolor Term-Color] [#:bgcolor Term-Color] [#:attributes (Listof Symbol)] Any * Void)
(lambda [msgfmt #:fgcolor [fg #false] #:bgcolor [bg #false] #:attributes [attrs null] . vals]
(term-echo (current-error-port) (~string msgfmt vals) fg bg attrs)))
(define fechof : (-> Output-Port String [#:fgcolor Term-Color] [#:bgcolor Term-Color] [#:attributes (Listof Symbol)] Any * Void)
(lambda [/dev/stdout msgfmt #:fgcolor [fg #false] #:bgcolor [bg #false] #:attributes [attrs null] . vals]
(term-echo /dev/stdout (~string msgfmt vals) fg bg attrs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-esc esc-save [] "\033[s")
(define-esc esc-restore [] "\033[u")
(define-esc esc-screen-home [] "\033[H") ; cell(0, 0)
(define-esc esc-cell [[row : Integer 0] [col : Integer 0]] "\033[~a;~af")
(define-esc esc-move-up [[line : Integer 1]] "\033[~aA")
(define-esc esc-move-down [[line : Integer 1]] "\033[~aB")
(define-esc esc-move-right [[col : Integer 1]] "\033[~aC")
(define-esc esc-move-left [[col : Integer 1]] "\033[~aD")
(define-esc esc-return-down [[line : Integer 1]] "\033[~aE")
(define-esc esc-return-up [[line : Integer 1]] "\033[~aF")
(define-esc esc-move-to [[col : Integer 0]] "\033[~aG")
(define-esc esc-home [] "\033[0G") ; move-to(0)
(define-esc esc-clear-screen-to-end [] "\033[J")
(define-esc esc-clear-screen-from-beginning [] "\033[1J")
(define-esc esc-clear-screen [] "\033[2J")
(define-esc esc-clear-line-to-end [] "\033[K")
(define-esc esc-clear-line-from-beginning [] "\033[1K")
(define-esc esc-clear-line [] "\033[2K")