diff --git a/human.ml b/human.ml index e382df4..0f04899 100644 --- a/human.ml +++ b/human.ml @@ -42,9 +42,6 @@ module Key = struct type keystate = {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} - type mods = Ctrl | Meta | Super | Shift - type key = Char of char | Code of code - module KeyS = struct type t = keystate @@ -55,20 +52,18 @@ module Key = struct (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) module S = Zed_input.Make (KeyS) - type action = - | Custom of (unit -> unit) - | CustomLwt of (unit -> unit Lwt.t) - | Zed of Zed_edit.action + type 'a t = 'a list S.t + type 'a resolver = 'a list S.resolver + type 'a result = 'a list S.result - type t = action list S.t - type resolver = action list S.resolver - type result = action list S.result - - type state = - { mutable bindings: t - ; mutable state: result + type 'a state = + { mutable bindings: 'a t + ; mutable state: 'a result ; mutable last_keyseq: keystate list - ; mutable last_actions: action list } + ; mutable last_actions: 'a list } + + type mods = Ctrl | Meta | Super | Shift + type key = C of char | U of code let keystate_of_mods ks m = List.fold_left @@ -91,8 +86,8 @@ module Key = struct ; shift= false ; code= ( match k with - | Char c -> `Uchar (Uchar.of_char c) - | Code c -> c ) } + | C c -> `Uchar (Uchar.of_char c) + | U c -> c ) } m ) events in S.add events action bindings @@ -108,7 +103,37 @@ module Key = struct let resolve = S.resolve let empty = S.empty - let actions_of_events (state : state) events = + type action = + | Custom of (unit -> unit) + | CustomLwt of (unit -> unit Lwt.t) + | Zed of Zed_edit.action + + let resolve_events (state : 'a state) events = + List.flatten + (List.filter_map + (fun e -> + match e with + | `Key (`Press, (k : keystate)) -> ( + ( match state.state with + | Continue _ -> () + | _ -> state.last_keyseq <- [] ) ; + state.state <- + resolve k + (get_resolver state.state + (default_resolver state.bindings) ) ; + state.last_keyseq <- k :: state.last_keyseq ; + match state.state with + | Accepted a -> + state.last_actions <- a ; + Some a + | Rejected -> + state.last_actions <- [] ; + None + | _ -> None ) + | _ -> None ) + events ) + + let actions_of_events (state : action state) events = List.flatten (List.filter_map (fun e -> @@ -224,7 +249,7 @@ module Event = struct | `Release -> "`Release " | `Repeat -> "`Repeat " ) ^ Key.to_string k - | `Mouse -> "`Mouse" + | `Mouse m -> F.str "`Mouse %a" V2.pp m | `Quit -> "`Quit" | `Fullscreen b -> F.str "`Fullscreen %b" b | `Unknown s -> F.str "`Unknown %s" s @@ -338,8 +363,7 @@ module Event = struct | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ") | `Multi_gesture -> Some (`Unknown "`Multi_gesture") | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ") - | `Unknown e -> - Some (`Unknown (Format.sprintf "Some (`Unknown %d " e)) + | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e)) | `User_event -> Some (`Unknown "`User_event ") | `Display_event -> Some (`Unknown "`Display_event ") | `Sensor_update -> Some (`Unknown "`Sensor_update ") @@ -855,49 +879,49 @@ module Panel = struct type t = { mutable zed: unit Zed_edit.context ; mutable view: Zed_cursor.t - ; mutable keybind: Key.Bind.state } + ; mutable keybind: Key.Bind.action Key.Bind.state } let bindings te = let open Key.Bind in - add [([], Code (`Arrow `Left))] [Zed Prev_char] - @@ add [([], Code (`Arrow `Right))] [Zed Next_char] - @@ add [([], Code (`Arrow `Up))] [Zed Prev_line] - @@ add [([], Code (`Arrow `Down))] [Zed Next_line] - @@ add [([], Code `Home)] [Zed Goto_bol] - @@ add [([], Code `End)] [Zed Goto_eol] - @@ add [([], Code `Insert)] [Zed Switch_erase_mode] - @@ add [([], Code `Delete)] [Zed Delete_next_char] - @@ add [([], Code `Enter)] [Zed Newline] - @@ add [([Ctrl], Char ' ')] [Zed Set_mark] - @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] - @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] - @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] - @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] - @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] - @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] - @@ add [([Ctrl], Char 'n')] [Zed Next_line] - @@ add [([Ctrl], Char 'p')] [Zed Prev_line] - @@ add [([Ctrl], Char 'w')] [Zed Kill] - @@ add [([Ctrl], Char 'y')] [Zed Yank] - @@ add [([], Code `Backspace)] [Zed Delete_prev_char] - @@ add [([Meta], Char 'w')] [Zed Copy] - @@ add [([Meta], Char 'c')] [Zed Capitalize_word] - @@ add [([Meta], Char 'l')] [Zed Lowercase_word] - @@ add [([Meta], Char 'u')] [Zed Uppercase_word] - @@ add [([Meta], Char 'b')] [Zed Prev_word] - @@ add [([Meta], Char 'f')] [Zed Next_word] - @@ add [([Meta], Code (`Arrow `Right))] [Zed Next_word] - @@ add [([Meta], Code (`Arrow `Left))] [Zed Prev_word] - @@ add [([Ctrl], Code (`Arrow `Right))] [Zed Next_word] - @@ add [([Ctrl], Code (`Arrow `Left))] [Zed Prev_word] - @@ add [([Meta], Code `Backspace)] [Zed Kill_prev_word] - @@ add [([Meta], Code `Delete)] [Zed Kill_prev_word] - @@ add [([Ctrl], Code `Delete)] [Zed Kill_next_word] - @@ add [([Meta], Char 'd')] [Zed Kill_next_word] - @@ add [([Ctrl], Char '/')] [Zed Undo] - @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] + add [([], U (`Arrow `Left))] [Zed Prev_char] + @@ add [([], U (`Arrow `Right))] [Zed Next_char] + @@ add [([], U (`Arrow `Up))] [Zed Prev_line] + @@ add [([], U (`Arrow `Down))] [Zed Next_line] + @@ add [([], U `Home)] [Zed Goto_bol] + @@ add [([], U `End)] [Zed Goto_eol] + @@ add [([], U `Insert)] [Zed Switch_erase_mode] + @@ add [([], U `Delete)] [Zed Delete_next_char] + @@ add [([], U `Enter)] [Zed Newline] + @@ add [([Ctrl], C ' ')] [Zed Set_mark] + @@ add [([Ctrl], C 'a')] [Zed Goto_bol] + @@ add [([Ctrl], C 'e')] [Zed Goto_eol] + @@ add [([Ctrl], C 'd')] [Zed Delete_next_char] + @@ add [([Ctrl], C 'h')] [Zed Delete_prev_char] + @@ add [([Ctrl], C 'k')] [Zed Kill_next_line] + @@ add [([Ctrl], C 'u')] [Zed Kill_prev_line] + @@ add [([Ctrl], C 'n')] [Zed Next_line] + @@ add [([Ctrl], C 'p')] [Zed Prev_line] + @@ add [([Ctrl], C 'w')] [Zed Kill] + @@ add [([Ctrl], C 'y')] [Zed Yank] + @@ add [([], U `Backspace)] [Zed Delete_prev_char] + @@ add [([Meta], C 'w')] [Zed Copy] + @@ add [([Meta], C 'c')] [Zed Capitalize_word] + @@ add [([Meta], C 'l')] [Zed Lowercase_word] + @@ add [([Meta], C 'u')] [Zed Uppercase_word] + @@ add [([Meta], C 'b')] [Zed Prev_word] + @@ add [([Meta], C 'f')] [Zed Next_word] + @@ add [([Meta], U (`Arrow `Right))] [Zed Next_word] + @@ add [([Meta], U (`Arrow `Left))] [Zed Prev_word] + @@ add [([Ctrl], U (`Arrow `Right))] [Zed Next_word] + @@ add [([Ctrl], U (`Arrow `Left))] [Zed Prev_word] + @@ add [([Meta], U `Backspace)] [Zed Kill_prev_word] + @@ add [([Meta], U `Delete)] [Zed Kill_prev_word] + @@ add [([Ctrl], U `Delete)] [Zed Kill_next_word] + @@ add [([Meta], C 'd')] [Zed Kill_next_word] + @@ add [([Ctrl], C '/')] [Zed Undo] + @@ add [([Ctrl], C 'x'); ([], C 'u')] [Zed Undo] @@ add - [([Ctrl], Char 'v')] + [([Ctrl], C 'v')] [ Custom (fun () -> let r = Zed_edit.text (Zed_edit.edit te.zed) in @@ -906,7 +930,7 @@ module Panel = struct Zed_cursor.goto te.view (Zed_lines.line_start l i + 10) ) ] @@ add - [([Meta], Char 'v')] + [([Meta], C 'v')] [ Custom (fun () -> let r = Zed_edit.text (Zed_edit.edit te.zed) in @@ -1012,7 +1036,8 @@ module Panel = struct ; tag= "textedit" } (* pane that displays last key binding match state *) - let bindingstate ?(height = !g_text_height) (b : Key.Bind.state) = + let bindingstate ?(height = !g_text_height) + (b : Key.Bind.action Key.Bind.state) = Lwt.return { act= (fun _panel _events -> @@ -1065,7 +1090,7 @@ module Panel = struct let keybinds = let open Key.Bind in add - [([], Code `Enter)] + [([], U `Enter)] [ Custom (fun () -> (* set input first so a modal can trigger another modal *) @@ -1325,13 +1350,19 @@ module Panel = struct | Some x -> fold_lwt_opt ~t ~start:c ~f x | None -> Lwt.return acc ) | None -> Lwt.return acc + + end module Ui = struct open Gg open Wall - type t = [`Atom of atom | `Attr of attr | `Region of region] + type t = [`Atom of atom | `Attr of (attr * node) | `Region of (dir * region)] + + and node = {mutable parent: parent; mutable child: t} + + and parent = [ `Atom of atom | `Attr of (attr * node) | `Region of (dir * region * Region.cursor)] and atom = [ `Image of image @@ -1342,38 +1373,31 @@ module Panel = struct [ `Style of style | `Pad of Pad.t | `Shift of dim - | `Focus of focus * Focus.handle + | `Focus of handle * Focus.handle | `Handle of handle ] - * node - and region = [`X | `Y | `Z] * node Region.t + and region = node Region.t - and node = {mutable parent: node; mutable child: t} + + and dir = [`X | `Y | `Z] and image = Wall.image * Size2.t and dim = Gg.size2 - and text = string - and style = Style.t - and status = [`Handled | `Event of Event.t] - - and event_status = - [ `Handled - | (*`Focus of [`Next | `Prev | `Up | `Down] | *) - `Event of - Event.t ] - - and focus = node -> Event.t -> status Lwt.t - - and handle = node -> Event.t -> status Lwt.t + and handle = node -> Event.t -> Event.t option Lwt.t let empty_image = (Image.empty, V2.zero) let empty_node = - let rec parent = {parent; child= `Atom (`Image empty_image)} in + let rec parent = `Atom (`Image empty_image) in + parent + + let empty_region dir = + let rec parent = + `Region (dir, Region.create ()) in parent let set_parent_on_children parent = @@ -1397,7 +1421,7 @@ module Panel = struct let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) - let focus ((f, h) : focus * Focus.handle) (n : node) = + let focus ((f, h) : handle * Focus.handle) (n : node) = node (`Attr (`Focus (f, h), n)) let node_func ?(fnode = fun (x : node) -> x) @@ -1439,6 +1463,36 @@ module Panel = struct () ) parent + let rec search_backward (node : node) (t : [`Atom of atom | `Attr of attr | `Region of dir] ) = + match node.parent.child with + | `Atom a when t <> `Atom a -> search_backward node.parent t + | `Attr (a, n) when t <> `Attr a -> search_backward node.parent t + | `Region (d, r) when t <> `Region d -> + + | `Region -> x where x = t -> x + + + + + let join_ d (a : node) (b : node) = + let rec parent = + { parent + ; child= + `Region + (d, Region.append (Region.append (Region.create ()) a) b) + } in + set_parent_on_children parent ; + parent + + let join_x = join_ `X + let join_y = join_ `Y + let join_z = join_ `Z + let pack_x : node Lwd_utils.monoid = (empty_region `X, join_x) + let pack_y : node Lwd_utils.monoid = (empty_region `Y, join_y) + let pack_z : node Lwd_utils.monoid = (empty_region `Z, join_z) + let ( ^^ ) = join_x + let ( ^/^ ) = join_y + module Text = struct (* let to_buffer t = let b = Buffer.create 0 in @@ -1543,26 +1597,6 @@ module Panel = struct let text = Text.text - let join_ d (a : node) (b : node) = - let rec parent = - { parent - ; child= - `Region - (d, Region.append (Region.append (Region.create ()) a) b) - } in - a.parent <- parent ; - b.parent <- parent ; - parent - - let join_x = join_ `X - let join_y = join_ `Y - let join_z = join_ `Z - let pack_x : node Lwd_utils.monoid = (empty_node, join_x) - let pack_y : node Lwd_utils.monoid = (empty_node, join_y) - let pack_z : node Lwd_utils.monoid = (empty_node, join_z) - let ( ^^ ) = join_x - let ( ^/^ ) = join_y - module Draw = struct type d = [`X | `Y | `Z] @@ -1647,76 +1681,143 @@ module Panel = struct | `Region a -> region ~style a end + module Action = struct + type segment_type = + [`Char | `Word | `Phrase | `Line | `Page | `Region] + + type segment = + [ `Beginning of segment_type + | `Back of segment_type + | `Forward of segment_type + | `End of segment_type ] + + type t = + [ `Move of segment + | `Yank of segment + | `Kill of segment + | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ] + + type dir = + [ `Next + | `Prev + | `Up + | `Down + | `Left + | `Right + | `Fwd + | `Enter + | `In + | `Out ] + + let handle (action : t) (node : node) : node option = + match action with + | `Move (`Beginning `Char) -> Some node + | `Move (`Beginning `Word) -> + Some (search_backward node (`Boundary `Word)) + | `Move _ -> None + | `Yank _s -> None + | `Kill _s -> None + | `Custom _s -> None + end + + type event_status = + [ `Handled + | (*`Focus of [`Next | `Prev | `Up | `Down] | *) + `Event of + Event.t ] + let rec handle_event (node : node) (ev : Event.t) : event_status Lwt.t = - Lwt.return `Handled + match node.child with + | `Atom _ -> Lwt.return (`Event ev) + | `Attr (`Focus (f, _), n) -> ( + f n ev + >>= function + | None -> Lwt.return `Handled | Some e -> handle_event n e ) + | `Attr (`Handle f, n) -> ( + f n ev + >>= function + | None -> Lwt.return `Handled | Some e -> handle_event n e ) + | `Attr (_, n) -> handle_event n ev + | `Region (_, r) -> + Region.fold_lwt_opt ~t:r + ~f:(fun _ n (es : event_status) -> + match es with + | `Event e -> ( + handle_event n e + >>= function + | `Handled -> Lwt.return None + | x -> Lwt.return (Some x) ) + | `Handled -> Lwt.return None ) + (`Event ev) - (* - match node.child with - | `Atom _ -> Lwt.return (`Event ev) - | `Attr (`Focus (f, _), n) -> ( - f n ev - >>= function - | `Unhandled -> handle_event n ev - | `Handled -> Lwt.return `Handled ) - | `Attr (`Handle f, n) -> ( - f n ev - >>= function - | `Handled -> Lwt.return `Handled - | `Event e -> handle_event n e ) - | `Attr (_, n) -> handle_event n ev - | `Region (_, r) -> - Region.fold_lwt_opt ~t:r - ~f:(fun _ n (es : event_status) -> - match es with - | `Event e -> ( - handle_event n e - >>= function - | `Handled -> Lwt.return None - | x -> Lwt.return (Some x) ) - | `Handled -> Lwt.return None ) - (`Event ev) *) + let textedit_bindings = + let open Key.Bind in + empty + |> add [([Ctrl], C 'f')] [`Move (`Forward `Char)] + |> add [([Ctrl], C 'b')] [`Move (`Back `Char)] + |> add [([Ctrl], C 'f')] [`Move (`Forward `Word)] + |> add [([Meta], C 'b')] [`Move (`Back `Word)] + |> add + [([Ctrl], C 'c'); ([Ctrl], C 'n')] + [`Move (`Forward `Phrase)] + |> add [([Ctrl], C 'c'); ([Ctrl], C 'p')] [`Move (`Back `Phrase)] + |> add [([Ctrl], C 'n')] [`Move (`Forward `Line)] + |> add [([Ctrl], C 'p')] [`Move (`Back `Line)] + |> add [([Meta], C 'v')] [`Move (`Forward `Page)] + |> add [([Ctrl], C 'v')] [`Move (`Back `Page)] + |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)] + |> add [([Ctrl], C 'e')] [`Move (`End `Line)] + |> add [([Ctrl], C 'k')] [`Kill (`End `Line)] + |> add [([Ctrl], U `Backspace)] [`Kill (`Back `Word)] + |> add [([Meta], U `Backspace)] [`Kill (`Back `Word)] + |> add + [([Ctrl], C 'x'); ([], U `Backspace)] + [`Kill (`Back `Phrase)] - (* - let _nav (code, (ctrl, meta, shift, super)) = - let nomod = (false, false, false, false) in - (match code, (ctrl, meta, shift, super) with - `Enter, x when x = nomod -> (* `Focus `Next *) () - | `Uchar b when b = (Uchar.of_char 'b') -> ) - - let navigator n = + let textedit_handler ?(bindings = textedit_bindings) n = + let bind = Key.Bind.init bindings in + let fq = Stack.create () in + Stack.push (`Down, node) fq ; focus - ( (fun (n : node) : (Event.t -> status Lwt.t) -> function - | `Key (`Press, {ctrl; meta; shift; super; code}) -> - Lwt.return( _nav (code, (ctrl, meta, shift, super))) - | x -> Lwt.return (`Event x) ) + ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t -> + match Key.Bind.resolve_events bind [e] with + | x :: _ -> Action.handle x + | [] -> Lwt.return_some e ) , Focus.make () ) n -*) + let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t = let rq = Lwd.make_release_queue () in let root = Lwd.observe t in Lwt.return (fun ev -> let r = Lwd.sample rq root in - (*handle_events r ev - >>= fun h -> - ( match h with - | [] -> () - | _ -> F.epr "handle_event: Unhandled event@." ) ;*) - Lwt.return (Draw.pane r) ) + Lwt_list.iter_s + (fun e -> + handle_event r e + >>= fun h -> + ( match h with + | `Handled -> () + | `Event e -> + F.epr "handle_event: Unhandled event: %s@." + (Event.to_string e) ) ; + Lwt.return_unit ) + ev + >|= fun () -> Draw.pane r ) let test = panel (Lwd.pure - (style Style.dark - (join_y + (textedit_handler + (style Style.dark (join_y - (Text.of_string - "-- welcome to the land of idiots ---" ) - (join_x - (Text.of_string "hello bitch") - (Text.of_string "! sup dude") ) ) - (Text.of_string "test 1 2 3 4 5 6") ) ) ) + (join_y + (Text.of_string + "-- welcome to the land of idiots ---" ) + (join_x + (Text.of_string "hello bitch") + (Text.of_string "!\n sup dude") ) ) + (Text.of_string "test 1 2 3 4 5 6") ) ) ) ) end end @@ -1856,7 +1957,7 @@ module Store = struct let editbinds = let open Key.Bind in add - [([Ctrl], Char 'c')] + [([Ctrl], C 'c')] [ Custom (fun () -> sv.editmode <- not sv.editmode ; @@ -1864,14 +1965,14 @@ module Store = struct (sv.view @ sv.selection) (Panel.Textedit.contents te) ) ] @@ add - [([Ctrl], Char 's')] + [([Ctrl], C 's')] [ Custom (fun () -> save sv.store (sv.view @ sv.selection) (Panel.Textedit.contents te) ) ] @@ add - [([Ctrl], Char 'x'); ([], Char 'x')] + [([Ctrl], C 'x'); ([], C 'x')] [ Custom (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ] @@ -1948,14 +2049,14 @@ module Store = struct Istore.set_tree_exn ~info:(Irmin_unix.info "new Contents") sv.store sv.view newtree ) in - add [([], Char 'n')] [CustomLwt (navigate sv `Next)] - @@ add [([], Char 'p')] [CustomLwt (navigate sv `Prev)] - @@ add [([], Char 'w')] [CustomLwt (navigate sv `Prev)] - @@ add [([], Char 's')] [CustomLwt (navigate sv `Next)] - @@ add [([], Char 'd')] [CustomLwt (navigate sv `Sub)] - @@ add [([], Char 'a')] [CustomLwt (navigate sv `Sup)] + add [([], C 'n')] [CustomLwt (navigate sv `Next)] + @@ add [([], C 'p')] [CustomLwt (navigate sv `Prev)] + @@ add [([], C 'w')] [CustomLwt (navigate sv `Prev)] + @@ add [([], C 's')] [CustomLwt (navigate sv `Next)] + @@ add [([], C 'd')] [CustomLwt (navigate sv `Sub)] + @@ add [([], C 'a')] [CustomLwt (navigate sv `Sup)] @@ add - [([], Char 'e')] (* enter edit mode *) + [([], C 'e')] (* enter edit mode *) [ Custom (fun () -> Lwt.async (fun () -> @@ -1964,17 +2065,17 @@ module Store = struct if not nb then sv.editmode <- not sv.editmode ; Lwt.return_unit ) ) ] @@ add - [([], Char 'f')] (* find: enter path in modal *) + [([], C 'f')] (* find: enter path in modal *) [Custom (fun () -> ())] @@ add - [([], Char 'c')] (* contents: create new contents node *) + [([], C 'c')] (* contents: create new contents node *) [ Custom (fun () -> Panel.Modal.start ~prompt:"Contents name > " modalstate "" (fun name -> new_contents (Istore.Key.v [name]) "" ) ) ] @@ add - [([], Char 't')] (* tree: create new subtree *) + [([], C 't')] (* tree: create new subtree *) [ Custom (fun () -> Panel.Modal.start ~prompt:"Node name > " modalstate @@ -1986,7 +2087,7 @@ module Store = struct (Istore.Key.v [nodename; contentsname]) "" ) ) ) ] @@ add - [([], Char 'r')] (* remove contents/node *) + [([], C 'r')] (* remove contents/node *) [ CustomLwt (fun () -> let selection = sv.selection in @@ -2000,7 +2101,7 @@ module Store = struct ~info:(Irmin_unix.info "remove Contents/Node") sv.store sv.view newtree ) ] @@ add - [([], Char 'x')] (* execute contents/node *) + [([], C 'x')] (* execute contents/node *) [ Custom (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ]