aboutsummaryrefslogtreecommitdiff
path: root/src/screen.ml
blob: c61efea49aae56263a12ff97ed9ef3423a7b955f (plain)
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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
(** Curses submodules *)
module Attrs = Curses.A
module Color = Curses.Color

module T2 = Tools.Tuple2

module Option = Tools.Option

let cell_size = 10

let u = UTF8.from_utf8string

type t = {
  window: Curses.window;    (* the main window *)
  sheet: Curses.window;     (* the spreadsheet *)
  input: Curses.window;     (* the input window *)
  status: Curses.window;    (* status bar *)
  start: (int * int);       (* Left corner *)
  left_margin: int;         (* Reserved margin for rows name *)

  mutable size: int * int;  (* Terminal size *)
}

let get_cell screen (x, y) = begin

  let x' = (fst screen.start) + (x - screen.left_margin) / cell_size
  and y' = (snd screen.start) + y - 3 in

  if (x' < 1 || y' < 1) then
    None
  else
    Some (x', y')
end

let center data screen height width = begin
  let height' = height - 3
  and width'  = (width - screen.left_margin) / cell_size in
  let end_x = (fst screen.start) + width' -1 in
  let end_y = (snd screen.start) + height' -2 in

  let selected = Selection.extract data.Sheet.selected in

  let center_axis f replace max_limit shift screen = begin
    let selected_axis = f selected in
    match (selected_axis >= f screen.start), (selected_axis > max_limit) with
    | true, false  -> screen
    | _ -> { screen with  start = replace (max 1 (selected_axis - shift)) screen.start }
  end in
    center_axis T2.fst T2.replace1 end_x (width' / 2) screen
 |> center_axis T2.snd T2.replace2 end_y (height' / 2)
end

let status screen msg = begin
  let height, width = screen.size in
  UTF8.encode msg |> Option.iter (fun encoded ->
    let status = Bytes.make (width -1) ' ' in
    String.blit encoded 0 status 0 (String.length encoded);
    Curses.werase screen.status;
    if not (
      Curses.mvwaddstr screen.status 0 0 encoded
      && Curses.wrefresh screen.status
    ) then
    raise (Failure "Status update")
  )
end

(** Draw the spreadsheet *)
let draw data screen = begin

  let selected = Selection.extract data.Sheet.selected in

  let referenced =
       Sheet.Raw.get_expr selected data.Sheet.data
    |> Expression.collect_sources

  and sink = Sheet.Raw.get_sink selected data.Sheet.data in

  let height, width = screen.size in
  let screen = center data screen height width in

  for y = 1 to (height-2) do
    let pos_y = (y + (snd screen.start) - 1) in
    if (Curses.has_colors ()) then begin
      if Selection.is_selected (Selection.Vertical pos_y) data.Sheet.selected then
        Curses.wattrset screen.sheet (Attrs.color_pair 2 )
      else
        Curses.wattrset screen.sheet (Attrs.color_pair 1 )
      end;
    ignore
    @@ Curses.mvwaddstr screen.sheet y 0
    @@ Printf.sprintf "%-*d" screen.left_margin pos_y
  done;
  Curses.wattrset screen.sheet Attrs.normal;

  for x = 0 to ((width - cell_size - screen.left_margin) / cell_size) do
    let pos_x = x + (fst screen.start) in
    if (Curses.has_colors ()) then begin
      if Selection.is_selected (Selection.Horizontal pos_x) data.Sheet.selected then
        Curses.wattrset screen.sheet (Attrs.color_pair 2 )
      else
        Curses.wattrset screen.sheet (Attrs.color_pair 1 )
      end;

    ignore
    @@ Curses.mvwaddstr screen.sheet 0 (x * cell_size + screen.left_margin)
    @@ Printf.sprintf "%-*s" cell_size (UTF8.raw_encode @@ Cell.to_hname pos_x);

    Curses.wattrset screen.sheet Attrs.normal;

    for y = 1 to (height-2) do

      let pos_y = y + (snd screen.start) - 1 in

      if (Curses.has_colors ()) then begin
        if Selection.is_selected (Selection.Cell (pos_x, pos_y)) data.Sheet.selected then
          Curses.wattrset screen.sheet (Attrs.color_pair 3 )
        else if Cell.Set.mem (pos_x, pos_y) referenced then
          Curses.wattrset screen.sheet (Attrs.color_pair 4 )
        else if Cell.Set.mem (pos_x, pos_y) sink then
          Curses.wattrset screen.sheet (Attrs.color_pair 5 )
        else
          Curses.wattrset screen.sheet Attrs.normal;
      end;


      (* Get the content from the cell *)
      let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data
        |> Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x))
        |> Option.default UTF8.empty in

      (* If the content is defined, try to encode it and print it*)
      UTF8.encode content |> Tools.Option.iter (fun value ->
        let length = UTF8.length content in
        let strlength = String.length value in
        let blank = cell_size - length in
        let padding = if blank > 0
          then String.make blank ' '
          else "" in
        ignore
        @@ Curses.mvwaddnstr screen.sheet y (x * cell_size + screen.left_margin)
           (Printf.sprintf "%s%s" value padding)
           0 (blank + strlength)
      )
    done
  done;
  ignore @@ Curses.wrefresh screen.sheet;
  screen

end

let init () = begin
  (* Do not set delay after ESC keycode *)
  begin try ignore @@ Unix.getenv "ESCDELAY" with
  | Not_found -> Unix.putenv "ESCDELAY" "25" end;

  let window = Curses.initscr () in
  let height, width = Curses.getmaxyx window in

  Tools.NCurses.set_mouse_event (Tools.NCurses.BUTTON1_CLICKED::[]);

  let init = Curses.keypad window true
  && Curses.noecho ()
  && Curses.start_color ()
  && Curses.use_default_colors ()

  (* Build the color map *)
  && Curses.init_pair 1 Color.white Color.blue  (* Titles *)
  && Curses.init_pair 2 Color.blue Color.white  (* Selected titles *)
  && Curses.init_pair 3 Color.black Color.white (* Selected cell *)
  && Curses.init_pair 4 Color.black Color.red   (* referenced cell *)
  && Curses.init_pair 5 Color.black Color.green (* sink cell *)
  && Curses.curs_set 0 in

  if not init then
    raise (Failure "Initialisation")
  else
    {
      window = window;
      input = Curses.subwin window 2 width 0 0;
      sheet = Curses.subwin window (height - 3) width 2 0;
      status = Curses.subwin window 1 width (height - 1) 0;
      start = 1, 1;
      left_margin = 4;
      size = height, width;
    }
end

let close {window} = begin
  ignore @@ (Curses.keypad window false && Curses.echo ());
  Curses.endwin()
end

let draw_input t screen = begin

  let height, width = screen.size in

  let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data
          |> Expression.show in

  let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data
            |> Option.map ScTypes.Result.show
            |> Option.default UTF8.empty in

  UTF8.encode result |> Option.iter (fun encoded_result ->
    (* Compute the difference between number of bytes in the string, and the
       number of character printed : Printf.sprintf format use the bytes number
       in the string, while Curses print the characters in the user encoding *)
    let result_length_delta = (UTF8.length result) - (String.length encoded_result) in

    ignore (
       encoded_result
    |> Printf.sprintf "%-*s" (width - 11 - result_length_delta)
    |> Curses.mvwaddstr screen.input 0 10

    && Curses.wrefresh screen.input)
  );
  status screen expr;
  screen
end

(** Wait for an event and return the key pressed
    If the key code contains more than one char, they are both returned
 *)
let read_key {window} = begin
  let buff = Buffer.create 2 in
  let int_val = Curses.wgetch window in
  if int_val > 255 then
    Buffer.add_string buff @@ Tools.String.string_of_ints int_val
  else
    Buffer.add_char buff @@ char_of_int int_val;
  (** Check for a second key code *)
  ignore @@ Curses.nodelay window true;
  begin match Curses.wgetch window with
  | -1 -> ()
  | x ->  Buffer.add_char buff @@ char_of_int x;
  end;
  ignore @@ Curses.nodelay window false;
  Buffer.contents buff
end

let resize data t = begin
  let size = Curses.getmaxyx t.window in
  if (size <> t.size) then (
    let height, width = size in
    t.size <- size;
    ignore (
       Curses.wresize t.input 2 width

    && Curses.wresize t.sheet (height - 3) width

    (* The status window *)
    && Curses.wresize t.status 1 width
    && Curses.mvwin t.status (height - 1) 0);
    Curses.wclear t.status;
    ignore @@ Curses.wrefresh t.status;
    draw data t
  ) else t
end

let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin
  let encodedPrefix = UTF8.raw_encode prefix
  and encodedInit = UTF8.raw_encode init in
  let with_refs, position = match position with
  | None -> false, (1, 1)
  | Some x -> true, x in
  Curses.werase t.status;
  ignore @@ Curses.mvwaddstr t.status 0 0 (encodedPrefix^encodedInit);
  ignore @@ Curses.wrefresh t.status;

  (** Rewrite all the text after the cursor *)
  let rewrite_after = begin function
  | [] -> ()
  | elems -> ( (* Rewrite each char after the cursor *)
    let y, x = Curses.getyx t.status in
    List.iter (fun x -> ignore @@ Curses.waddstr t.status (UTF8.raw_encode x)) elems;
    ignore @@ Curses.wmove t.status y x )
  end

  (** Delete the previous text (or block of text) *)
  and delete_previous hd = begin
    let y, x = Curses.getyx t.status in
    let length = UTF8.length hd in
    ignore @@ Curses.wmove t.status y (x - length);
    for position = 1 to length do
      ignore @@ Curses.wdelch t.status
    done;
  end in

  (* Text edition, handle the keycode.

    [before] contains all the caracters inserted before the cursor (reverse
     ordered), and [after] contains all the caracters after the cursor.
   *)
  let rec _edit before after = begin function
  | "\027" -> (* Escape, cancel the modifications *)
    None
  | "\010" -> (* Enter, validate the input *)

    (* We concatenate all the characters. This can create an invalid string in
     * the current locale (if there are copy/paste, or other events).
     *)
    Some (UTF8.implode @@ (UTF8.rev_implode before)::after)

  | "\001\004" -> (* Left *)
    begin match before with
    | [] -> _edit before after @@ read_key t
    | hd::tl ->
      let y, x = Curses.getyx t.status
      and length = UTF8.length hd in
      ignore @@ Curses.wmove t.status y (x - length);
      ignore @@ Curses.wrefresh t.status;
      _edit tl (hd::after) @@ read_key t
    end

  | "\001\005" -> (* Right *)
    begin match after with
    | [] -> _edit before after @@ read_key t
    | hd::tl ->
      let y, x = Curses.getyx t.status
      and length = UTF8.length hd in
      ignore @@ Curses.wmove t.status y (x + length);
      ignore @@ Curses.wrefresh t.status;
      _edit (hd::before) tl @@ read_key t
    end

  | "\001\007" ->   (* Backspace *)
    begin match before with
    | [] -> _edit before after @@ read_key t
    | hd::tl ->
      delete_previous hd;
      ignore @@ Curses.wrefresh t.status;
      _edit tl after @@ read_key t
    end

  | "\001\006" ->   (* Home *)
    begin match before with
    | [] -> _edit before after @@ read_key t
    | elems ->
        let to_left (size, after) elem = begin
          let size' = size + UTF8.length elem in
          size', elem::after
        end in
        let chars, after' = List.fold_left to_left (0, after) elems in
        let y, x = Curses.getyx t.status in
        ignore @@ Curses.wmove t.status y (x - chars);
        ignore @@ Curses.wrefresh t.status;
        _edit [] after' @@ read_key t
    end

  | "\001\104" ->   (* End *)
    begin match after with
    | [] -> _edit before after @@ read_key t
    | elems ->
        let to_rigth (size, before) elem = begin
          let size' = size + UTF8.length elem in
          size', elem::before
        end in
        let chars, before' = List.fold_left to_rigth (0, before) elems in
        let y, x = Curses.getyx t.status in
        ignore @@ Curses.wmove t.status y (x + chars);
        ignore @@ Curses.wrefresh t.status;
        _edit before' [] @@ read_key t
    end
  | "\001\074"
  | "\127" ->       (* Del *)
    begin match after with
    | [] ->  _edit before after @@ read_key t
    | hd::tl ->
      let y, x = Curses.getyx t.status in
      ignore @@ Curses.wmove t.status y (x + 1);
      delete_previous hd;
      ignore @@ Curses.wrefresh t.status;
      _edit before tl @@ read_key t
    end

  | ("\001\002" as key)     (* Down *)
  | ("\001\003" as key)     (* Up *)
  | ("\001\153" as key) ->  (* click *)
    if with_refs then
      select_content position (UTF8.empty) before after key
    else
      _edit before after @@ read_key t

  | any ->
    ignore @@ Curses.waddstr t.status any;
    rewrite_after after;
    ignore @@ Curses.wrefresh t.status;
    _edit (UTF8.decode any::before) after @@ read_key t
  end

  (* Selection mode, Left and Right keys allow to select a cell, and not to
     move inside the edition *)
  and select_content (x, y) name before after = begin
  function
  | "\001\002" -> (* Down *) insert_cell_name (x, y + 1) name before after
  | "\001\005" -> (* Right *) insert_cell_name (x + 1, y) name before after

  | "\001\003" -> (* Up *)
    if y > 1 then
      insert_cell_name (x, y - 1) name before after
    else select_content (x, y) name before after @@ read_key t

  | "\001\004" -> (* Left *)
    if x > 1 then
      insert_cell_name (x - 1, y) name before after
    else select_content (x, y) name before after @@ read_key t

  | "\001\153" -> (* click *)
    let position =
    begin match Tools.NCurses.get_mouse_event () with
    | None -> None
    | Some (id, ev, (x, y, z)) ->
        if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev
        || Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then
          get_cell t (x,y)
        else
          None
    end in
    begin match position with
    | None -> select_content (x, y) name before after @@ read_key t
    | Some (x, y) -> insert_cell_name (x, y) name before after
    end

  | key ->
    _edit (UTF8.fold List.cons name before) after key
  end

  and insert_cell_name position name before after = begin
    let cell_name = Cell.to_string @@ (position, (false, false)) in
    ignore @@ delete_previous name;
    ignore @@ Curses.waddstr t.status (UTF8.raw_encode cell_name);
    rewrite_after after;
    ignore @@ Curses.wrefresh t.status;
    select_content position cell_name before after @@ read_key t
  end
  in

  Tools.try_finally
    (fun () ->
      ignore @@ Curses.curs_set 1;
      try _edit (UTF8.rev_explode init) [] @@ read_key t
      with _ -> None)
    (fun () -> ignore @@ Curses.curs_set 0)

end

let search screen = begin
  let result = editor ~prefix:(u"/") screen in
  begin match result with
  | Some content -> content
  | None -> UTF8.empty
  end
end

let run f =
  let window = init () in
  Tools.try_finally
    (fun () -> f window)
    (fun () -> ignore @@ close window )