console/oplevel
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

inprogress

Browse Source
This commit is contained in:
cqc
2024-07-27 12:38:41 -05:00
parent 686d868a94
commit 7ed07061aa
1 changed files with 241 additions and 251 deletions
Download Patch File Download Diff File Expand all files Collapse all files

492
ogui.ml
View File

@ -440,7 +440,6 @@ module Event = struct
let pp_event : event F.t = let pp_event : event F.t =
fun ppf e -> fun ppf e ->
let open Glfw_types in
match e with match e with
| Key (a, k, m) -> | Key (a, k, m) ->
F.pf ppf "%a %a %a" pp_key_action a pp_key k pp_mods m F.pf ppf "%a %a %a" pp_key_action a pp_key k pp_mods m
@ -723,7 +722,7 @@ module Ui = struct
enabled : bool; enabled : bool;
gv : Gv.t; gv : Gv.t;
glfw_window : GLFW.window option; glfw_window : GLFW.window option;
bindings : (int * action list Event.t) Lwd.var; bindings : (int * action list Event.resolver) Lwd.var;
} }
and action = Custom of string * (unit -> unit Lwt.t) and action = Custom of string * (unit -> unit Lwt.t)
@ -741,7 +740,9 @@ module Ui = struct
gv; gv;
glfw_window = window; glfw_window = window;
bindings = bindings =
Lwd.var ~eq:(fun (a, _) (b, _) -> a = b) (0, Event.empty); Lwd.var
~eq:(fun (a, _) (b, _) -> a = b)
(0, Event.[ pack Fun.id empty ]);
} }
let pp_action : action F.t = let pp_action : action F.t =
@ -766,11 +767,8 @@ module Ui = struct
let res = let res =
match resolver with match resolver with
| Event.Rejected | Event.Accepted _ -> | Event.Rejected | Event.Accepted _ ->
[ t.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample
t.bindings |> Lwd.peek |> snd
(*Lwd.get |> Lwd.observe |> Lwd.quick_sample *) |> snd
|> Event.pack Fun.id;
]
| Event.Continue r -> r | Event.Continue r -> r
in in
let res = Event.resolve (Key (state, key, mods)) res in let res = Event.resolve (Key (state, key, mods)) res in
@ -785,11 +783,13 @@ module Ui = struct
| Event.Continue _ | Event.Rejected -> Lwt.return_unit) | Event.Continue _ | Event.Rejected -> Lwt.return_unit)
>>= fun () -> Lwt.return res >>= fun () -> Lwt.return res
let update_bindings ui let append_bindings ui (f : action list Event.resolver) =
(f : action list Event.t -> action list Event.t) =
Lwd.set ui.bindings Lwd.set ui.bindings
( Lwd.peek ui.bindings |> fst |> Int.add 1, ( Lwd.peek ui.bindings |> fst |> Int.add 1,
f (Lwd.peek ui.bindings |> snd) ) List.append f (Lwd.peek ui.bindings |> snd) )
let reset_bindings ui =
Lwd.set ui.bindings (Lwd.peek ui.bindings |> fst |> Int.add 1, [])
let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
ref (fun _c -> ref (fun _c ->
@ -814,11 +814,11 @@ module Ui = struct
| Accepted _ -> "Accepted" | Accepted _ -> "Accepted"
| Continue _ -> "Continue" | Continue _ -> "Continue"
| Rejected -> "Rejected")); | Rejected -> "Rejected"));
(* junk the `Char that is sent with a `Key that has no mods *)
(match res with (match res with
| Accepted _ when mods = [] || mods == [ Shift ] -> ( | Accepted _ when mods = [] || mods == [ Shift ] -> (
(* junk the `Char that is sent with a `Key that has no mods *) Lwt_stream.peek events >>= function
Lwt_stream.peek events
>>= function
| Some (`Char _) -> | Some (`Char _) ->
F.epr "process_events: junking next event@."; F.epr "process_events: junking next event@.";
Lwt_stream.junk events Lwt_stream.junk events
@ -830,7 +830,6 @@ module Ui = struct
(Uchar.of_int char); (Uchar.of_int char);
process_char char >>= fun () -> proc (Event.Accepted []) process_char char >>= fun () -> proc (Event.Accepted [])
in in
proc Event.Rejected >>= fun _ -> Lwt.return_unit) proc Event.Rejected >>= fun _ -> Lwt.return_unit)
module Style = struct module Style = struct
@ -962,235 +961,210 @@ module TextEdit = struct
let cursor_set (t : t) (index : int) : unit Lwt.t = let cursor_set (t : t) (index : int) : unit Lwt.t =
cursor_update t (Fun.const index) cursor_update t (Fun.const index)
let default_bindings (t : t) (ui : Ui.t) : unit = let default_bindings (t : t) : Ui.action list Event.pack =
let open GLFW in let open GLFW in
let open Event in let open Event in
let open Ui in let open Ui in
Ui.update_bindings ui (fun a -> (Ui.chrcallback_ref :=
a fun c ->
|> adds TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
[ >>= fun _ -> cursor_move t 1);
[ Key (Press, F, [ Control ]) ]; empty
[ Key (Repeat, F, [ Control ]) ]; |> adds
[ Key (Press, Right, []) ]; [
[ Key (Repeat, Right, []) ]; [ Key (Press, F, [ Control ]) ];
] [ Key (Repeat, F, [ Control ]) ];
[ Custom ("char_forward", fun () -> cursor_move t 1) ] [ Key (Press, Right, []) ];
|> adds [ Key (Repeat, Right, []) ];
[ ]
[ Key (Press, B, [ Control ]) ]; [ Custom ("char_forward", fun () -> cursor_move t 1) ]
[ Key (Repeat, B, [ Control ]) ]; |> adds
[ Key (Press, Left, []) ]; [
[ Key (Repeat, Left, []) ]; [ Key (Press, B, [ Control ]) ];
] [ Key (Repeat, B, [ Control ]) ];
[ [ Key (Press, Left, []) ];
Custom ("char_backward", fun () -> cursor_move t (-1)); [ Key (Repeat, Left, []) ];
] ]
|> adds [ Custom ("char_backward", fun () -> cursor_move t (-1)) ]
[ |> adds
[ Key (Press, N, [ Control ]) ]; [
[ Key (Repeat, N, [ Control ]) ]; [ Key (Press, N, [ Control ]) ];
[ Key (Press, Down, []) ]; [ Key (Repeat, N, [ Control ]) ];
[ Key (Repeat, Down, []) ]; [ Key (Press, Down, []) ];
] [ Key (Repeat, Down, []) ];
[ ]
Custom [
( "forward_line", Custom
fun () -> ( "forward_line",
TextBuffer.fold_string t.text (fun s -> fun () ->
let sn = String.length s in TextBuffer.fold_string t.text (fun s ->
let seol = let sn = String.length s in
Str.search_forward (Str.regexp "$") let seol = Str.search_forward (Str.regexp "$") in
in let next_bol =
let next_bol = min sn (seol s (Lwd.peek t.cursor).index + 1)
min sn in
(seol s (Lwd.peek t.cursor).index + 1) let next_line_len = seol s next_bol - next_bol in
in next_bol
let next_line_len = +
seol s next_bol - next_bol if (Lwd.peek t.cursor).last_col > next_line_len
in then next_line_len
next_bol else
+ min next_line_len (Lwd.peek t.cursor).last_col)
if >>= cursor_set t );
(Lwd.peek t.cursor).last_col ]
> next_line_len |> adds
then next_line_len [
else [ Key (Press, P, [ Control ]) ];
min next_line_len [ Key (Repeat, P, [ Control ]) ];
(Lwd.peek t.cursor).last_col) [ Key (Press, Up, []) ];
>>= cursor_set t ); [ Key (Repeat, Up, []) ];
] ]
|> adds [
[ Custom
[ Key (Press, P, [ Control ]) ]; ( "line_backward",
[ Key (Repeat, P, [ Control ]) ]; fun () ->
[ Key (Press, Up, []) ]; TextBuffer.fold_string t.text (fun s ->
[ Key (Repeat, Up, []) ]; let sbol =
] Str.search_backward (Str.regexp "^") s
[ in
Custom let bol = sbol (Lwd.peek t.cursor).index in
( "line_backward", if bol > 0 then
fun () -> let prev_bol = sbol (max 0 (bol - 1)) in
TextBuffer.fold_string t.text (fun s -> let prev_line_len = bol - 1 - prev_bol in
let sbol =
Str.search_backward (Str.regexp "^") s
in
let bol = sbol (Lwd.peek t.cursor).index in
if bol > 0 then
let prev_bol = sbol (max 0 (bol - 1)) in
let prev_line_len = bol - 1 - prev_bol in
(*F.epr (*F.epr
"up: index=%d bol=%d prev_bol=%d \ "up: index=%d bol=%d prev_bol=%d \
prev_line_len=%d @." prev_line_len=%d @."
t.cursor.index bol prev_bol prev_line_len; *) t.cursor.index bol prev_bol prev_line_len; *)
prev_bol prev_bol
+ +
if if (Lwd.peek t.cursor).last_col > prev_line_len
(Lwd.peek t.cursor).last_col then prev_line_len
> prev_line_len else
then prev_line_len min prev_line_len
else (Lwd.peek t.cursor).last_col
min prev_line_len else (Lwd.peek t.cursor).index)
(Lwd.peek t.cursor).last_col >>= cursor_set t );
else (Lwd.peek t.cursor).index) ]
>>= cursor_set t ); |> adds (* EOL *)
] [ [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ] ]
|> adds (* EOL *) [
[ Custom
[ Key (Press, E, [ Control ]) ]; ( "end_of_line",
[ Key (Press, End, []) ]; fun () ->
] TextBuffer.fold_string t.text (fun s ->
[ let bol =
Custom Str.search_backward (Str.regexp "^") s
( "end_of_line", (Lwd.peek t.cursor).index
fun () -> in
TextBuffer.fold_string t.text (fun s -> let eol =
let bol = Str.search_forward (Str.regexp "$") s
Str.search_backward (Str.regexp "^") s (Lwd.peek t.cursor).index
(Lwd.peek t.cursor).index in
in Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:(eol - bol) eol)
);
]
|> adds (* BOL *)
[
[ Key (Press, A, [ Control ]) ]; [ Key (Press, Home, []) ];
]
[
Custom
( "beginning_of_line",
fun () ->
TextBuffer.fold_string t.text (fun s ->
Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:0
(Str.search_backward (Str.regexp "^") s
(Lwd.peek t.cursor).index)) );
]
|> adds
[
[ Key (Press, Backspace, []) ];
[ Key (Repeat, Backspace, []) ];
]
[
Custom
( "delete_char_backward",
fun () ->
match Lwd.peek t.mark with
| Some mark ->
TextBuffer.remove t.text
(mark, (Lwd.peek t.cursor).index)
>>= fun _ ->
Lwd.set t.mark None;
cursor_set t (min mark (Lwd.peek t.cursor).index)
| None ->
if (Lwd.peek t.cursor).index > 0 then
TextBuffer.remove_uchar t.text
((Lwd.peek t.cursor).index - 1)
>>= fun _ -> cursor_move t (-1)
else Lwt.return_unit );
]
|> adds
[ [ Key (Press, K, [ Control ]) ] ]
[
Custom
( "line_kill",
fun () ->
TextBuffer.fold_string t.text (fun s ->
TextBuffer.remove t.text
( (Lwd.peek t.cursor).index,
let eol = let eol =
Str.search_forward (Str.regexp "$") s Str.search_forward (Str.regexp "$") s
(Lwd.peek t.cursor).index (Lwd.peek t.cursor).index
in in
Lwd.set t.cursor if
@@ TextLayout.cursor ~last_col:(eol - bol) eol == (Lwd.peek t.cursor).index
eol) ); && String.length s > eol
] then eol + 1
|> adds (* BOL *) else eol )
[ >>= fun _ ->
[ Key (Press, A, [ Control ]) ];
[ Key (Press, Home, []) ];
]
[
Custom
( "beginning_of_line",
fun () ->
TextBuffer.fold_string t.text (fun s ->
Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:0
(Str.search_backward (Str.regexp "^") s
(Lwd.peek t.cursor).index)) );
]
|> adds
[
[ Key (Press, Backspace, []) ];
[ Key (Repeat, Backspace, []) ];
]
[
Custom
( "delete_char_backward",
fun () ->
match Lwd.peek t.mark with
| Some mark ->
TextBuffer.remove t.text
(mark, (Lwd.peek t.cursor).index)
>>= fun _ ->
Lwd.set t.mark None;
cursor_set t
(min mark (Lwd.peek t.cursor).index)
| None ->
if (Lwd.peek t.cursor).index > 0 then
TextBuffer.remove_uchar t.text
((Lwd.peek t.cursor).index - 1)
>>= fun _ -> cursor_move t (-1)
else Lwt.return_unit );
]
|> adds
[ [ Key (Press, K, [ Control ]) ] ]
[
Custom
( "line_kill",
fun () ->
TextBuffer.fold_string t.text (fun s ->
TextBuffer.remove t.text
( (Lwd.peek t.cursor).index,
let eol =
Str.search_forward (Str.regexp "$") s
(Lwd.peek t.cursor).index
in
if
eol == (Lwd.peek t.cursor).index
&& String.length s > eol
then eol + 1
else eol )
>>= fun _ ->
Lwd.set t.mark None;
cursor_set t (Lwd.peek t.cursor).index)
>>= fun u -> u );
]
|> adds
[
[ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ];
]
[
Custom
( "new_line",
fun () ->
TextBuffer.insert_uchar t.text
(Lwd.peek t.cursor).index (Uchar.of_char '\n')
>>= fun _ -> cursor_move t 1 );
]
|> adds
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
[
Custom
( "mark_toggle",
fun () ->
Lwd.set t.mark
(match Lwd.peek t.mark with
| Some _ -> None
| None -> Some (Lwd.peek t.cursor).index);
Lwt.return_unit );
]
|> adds
[ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
[
Custom
( "command_clear",
fun () ->
Lwd.set t.mark None; Lwd.set t.mark None;
Lwt.return_unit ); cursor_set t (Lwd.peek t.cursor).index)
] >>= fun u -> u );
|> adds ]
[ |> adds
[ [ [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ] ]
Key (Press, X, [ Control ]); [
Key (Press, S, [ Control ]); Custom
]; ( "new_line",
] fun () ->
(* Save *) TextBuffer.insert_uchar t.text
[ (Lwd.peek t.cursor).index (Uchar.of_char '\n')
Custom ("save_buffer", fun () -> TextBuffer.save t.text); >>= fun _ -> cursor_move t 1 );
]); ]
|> adds
Ui.chrcallback_ref := [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
fun c -> [
TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c Custom
>>= fun _ -> cursor_move t 1 ( "mark_toggle",
(* This creates a giant stack of calls lol fun () ->
>>= fun () -> !Ui.chrcallback_ref c *) Lwd.set t.mark
(match Lwd.peek t.mark with
| Some _ -> None
| None -> Some (Lwd.peek t.cursor).index);
Lwt.return_unit );
]
|> adds
[ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
[
Custom
( "command_clear",
fun () ->
Lwd.set t.mark None;
Lwt.return_unit );
]
|> adds
[
[
Key (Press, X, [ Control ]); Key (Press, S, [ Control ]);
];
]
(* Save *)
[ Custom ("save_buffer", fun () -> TextBuffer.save t.text) ]
|> Event.pack Fun.id
let multiline ui ?(text_format = TextLayout.format_default) let multiline ui ?(text_format = TextLayout.format_default)
(text : TextBuffer.t) : t = (text : TextBuffer.t) : t =
@ -1218,7 +1192,7 @@ module TextEdit = struct
(* return_key = keyboard_shortcut; *) (* return_key = keyboard_shortcut; *)
} }
in in
default_bindings t ui; Ui.append_bindings ui [ default_bindings t ];
t t
end end
@ -1355,16 +1329,31 @@ end
module WindowManager = struct module WindowManager = struct
open Layout open Layout
type t = type content = [ `TextEdit of TextEdit.t | `Frame of frame ]
[ `T of dir * (t * dim) list type bindings = Event.event Event.resolver
| `TextEdit of TextEdit.t
| `Frame of frame ] type t = [ `T of dir * tt list | content ]
and tt = { t : t; dim : dim; bindings : bindings }
let rec length : t -> int = function let rec length : t -> int = function
| `T (_, tl) -> | `T (_, tl) ->
List.fold_left (fun a (t', _) -> a + length t') 0 tl List.fold_left (fun a { t; _ } -> a + length t) 0 tl
| _ -> 1 | _ -> 1
let rec nth (n : int) : t -> content option = function
| `T (_, tl) ->
let rec nl n' : tt list -> content option = function
| { t; _ } :: tl' -> (
match nth n' t with
| Some t -> Some t
| None -> nl (n - 1) tl')
| [] -> None
in
nl n tl
| (`TextEdit _ | `Frame _) as t ->
F.epr "nth: %d@." n;
if n == 0 then Some t else None
let rec fold_left ?(dir = `X) let rec fold_left ?(dir = `X)
~(f : ~(f :
dir -> dir ->
@ -1416,6 +1405,12 @@ module WindowManager = struct
~size:(`Ratio 1.0, `Pixels 30.) ~size:(`Ratio 1.0, `Pixels 30.)
(F.str "window/%d" n, status_format (n == cursor)))) (F.str "window/%d" n, status_format (n == cursor))))
let frame_default_bindings ui f = Event.empty |> Event.pack Fun.id
let default_bindings ui = function
| `TextEdit t -> [ TextEdit.default_bindings t ]
| `Frame f -> [ frame_default_bindings ui f ]
let make ui ?(style = textedit_style) let make ui ?(style = textedit_style)
?(_mode : [ `Tiling | `FullScreen | `Floating ] = `Tiling) ?(_mode : [ `Tiling | `FullScreen | `Floating ] = `Tiling)
(telist : t Lwd.var) = (telist : t Lwd.var) =
@ -1434,9 +1429,9 @@ module WindowManager = struct
< (Lwd.peek telist |> length) - 1 < (Lwd.peek telist |> length) - 1
then Lwd.peek cursor + 1 then Lwd.peek cursor + 1
else 0); else 0);
(*TextEdit.default_bindings default_bindings
(List.nth (Lwd.peek telist) (Lwd.peek cursor)) (nth (Lwd.peek cursor) (Lwd.peek telist))
ui; *) ui;
Lwt.return_unit ); Lwt.return_unit );
] ]
|> Event.adds |> Event.adds
@ -1634,7 +1629,7 @@ module Painter = struct
Gg.Box2.union ra rb |> Lwt.return Gg.Box2.union ra rb |> Lwt.return
| `TextEdit tt -> | `TextEdit tt ->
F.epr "`TextEdit"; F.epr "`TextEdit";
text_layout ui.gv box' tt text_layout ui.gv box' tt >>= fun _ -> Lwt.return box'
| `None -> | `None ->
F.epr "`None"; F.epr "`None";
Lwt.return Gg.Box2.(v (o box') Gg.V2.zero) Lwt.return Gg.Box2.(v (o box') Gg.V2.zero)
@ -1645,12 +1640,7 @@ module Painter = struct
>>= fun r -> >>= fun r ->
F.epr "@]"; F.epr "@]";
let r' = let r' = Margin.outer style.margin r in
(*Box2.add_pt r
V2.(Box2.max r + v style.margin.right style.margin.bottom)
|> *)
Margin.outer style.margin r
in
(*F.epr "layout: box=%a box'=%a r=%a r'=%a@." Gg.Box2.pp box (*F.epr "layout: box=%a box'=%a r=%a r'=%a@." Gg.Box2.pp box
Gg.Box2.pp box' Gg.Box2.pp r Gg.Box2.pp r'; *) Gg.Box2.pp box' Gg.Box2.pp r Gg.Box2.pp r'; *)