blob: 96103f5262c9d800eff42e59d64c1a628fc8494c (
plain) (
blame)
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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
open Base
open Unix
open Util
type terminal_size = int * int
type state = { tio : terminal_io; size : terminal_size }
let escape ?(prefix = "") ?(args = []) op =
let open Bytes in
let args = List.map ~f:Int.to_string args |> String.concat ~sep:";" in
let lenp = String.length prefix in
let lena = String.length args in
let lenb = 3 + lena + lenp in
let dst = Bytes.create lenb in
set dst 0 '\x1b';
set dst 1 '[';
From_string.blit ~src:prefix ~src_pos:0 ~dst ~dst_pos:2 ~len:lenp;
From_string.blit ~src:args ~src_pos:0 ~dst ~dst_pos:(2 + lenp) ~len:lena;
set dst (length dst - 1) op;
sequence_of_bytes dst
let clear_screen = escape 'J' ~args:[ 2 ]
let clear_to_eol = escape 'K'
let move_cursor x y = escape 'H' ~args:[ x; y ]
let move_down n = escape 'B' ~args:[ n ]
let move_right n = escape 'C' ~args:[ n ]
let query_cursor_pos = escape 'n' ~args:[ 6 ]
let reset_cursor = move_cursor 1 1
let show_cursor show =
let cmd = if show then 'h' else 'l' in
escape cmd ~prefix:"?" ~args:[ 25 ]
(* Incomplete. See https://stackoverflow.com/a/33206814 for a full list
of escape codes related to terminal formatting capabilities *)
let fmt_reset = escape 'm'
let fmt_bold_on = escape ~args:[ 1 ] 'm'
let fmt_bold_off = escape ~args:[ 22 ] 'm'
let fmt_underline = escape ~args:[ 4 ] 'm'
let fmt_blink = escape ~args:[ 5 ] 'm'
let fmt_inverted_on = escape ~args:[ 7 ] 'm'
let fmt_inverted_off = escape ~args:[ 27 ] 'm'
let input_bytes = Bytes.create 1
let get_char () =
let syscall () = read stdin input_bytes 0 1 in
match handle_unix_error syscall () with
| 0 -> None
| _ -> Some (Bytes.get input_bytes 0)
let char_stream : char option Sequence.t =
Sequence.unfold ~init:() ~f:(fun s -> Some (get_char (), s))
let write_seq =
let syscall s =
let buf = Sequence.to_list s |> Bytes.of_char_list in
single_write stdout buf 0 (Bytes.length buf) |> ignore
in
handle_unix_error syscall
(* FIXME there is currently a bug that clears the last character of a
long line (when a "clear_to_eol" escape sequence wouldn't be needed).
This is because the escape sequence deletes everything *from the
cursor* onwards, which includes. This will most likely get solved
when we move away from this to implement something like a "right
column" *)
let write_lines (lines : char Sequence.t Sequence.t) =
let crnl = Sequence.of_list [ '\r'; '\n' ] in
let clear s = Sequence.append s clear_to_eol in
let syscall seq =
let buf =
Sequence.(map ~f:clear seq |> intersperse ~sep:crnl |> concat |> to_list)
|> Bytes.of_char_list
in
single_write stdout buf 0 (Bytes.length buf) |> ignore
in
handle_unix_error syscall lines
let cmds_to_sequence l = Sequence.(of_list l |> concat)
let restore_screen () =
cmds_to_sequence [ clear_screen; reset_cursor; show_cursor true ] |> write_seq
let redraw screen (x, y) =
let pre = cmds_to_sequence [ show_cursor false; reset_cursor ]
and post = cmds_to_sequence [ move_cursor x y; show_cursor true ] in
write_seq pre;
write_lines screen;
write_seq post
let get_state () = { tio = handle_unix_error tcgetattr stdin; size = (-1, -1) }
let size =
let query () =
cmds_to_sequence [ move_right 999; move_down 999; query_cursor_pos ]
|> write_seq
and get_reply () =
Sequence.(
char_stream
|> take_while ~f:Option.is_some
|> Fn.flip drop_eagerly 2 (* Drop escape sequence '<esc>[' *)
|> map ~f:(Option.value ~default:'R')
|> take_while ~f:(fun c -> Char.(c <> 'R'))
|> to_list |> String.of_char_list |> Stdlib.Scanf.sscanf
|> fun scanner -> scanner "%d;%d" (fun a b -> (a, b)))
in
query &> get_reply
let enable_raw_mode tio =
let syscall () =
tcsetattr stdin TCSAFLUSH
{
tio with
c_brkint = false;
c_csize = 8;
c_echo = false;
c_echonl = false;
c_icanon = false;
c_icrnl = false;
c_ignbrk = false;
c_igncr = false;
c_inlcr = false;
c_inpck = false;
c_isig = false;
c_istrip = false;
c_ixon = false;
c_opost = false;
c_parenb = false;
c_parmrk = false;
c_vmin = 0;
c_vtime = 1;
}
in
handle_unix_error syscall
let restore_status tio =
let syscall () = tcsetattr stdin TCSAFLUSH tio in
handle_unix_error syscall
let init () =
let state = get_state () in
enable_raw_mode state.tio ();
restore_status state.tio |> Stdlib.at_exit;
restore_screen |> Stdlib.at_exit;
{ state with size = size () }
|