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

i left it like this for a long time whoops

Browse Source
This commit is contained in:
cqc
2022-01-04 04:17:26 -06:00
parent 8ee3789cb9
commit 481870e067
1 changed files with 272 additions and 171 deletions
Download Patch File Download Diff File Expand all files Collapse all files

389
human.ml
View File

@ -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,23 +1681,63 @@ 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
| `Unhandled -> handle_event n ev
| `Handled -> Lwt.return `Handled )
| None -> Lwt.return `Handled | Some e -> handle_event n e )
| `Attr (`Handle f, n) -> (
f n ev
>>= function
| `Handled -> Lwt.return `Handled
| `Event e -> handle_event n e )
| None -> Lwt.return `Handled | Some e -> handle_event n e )
| `Attr (_, n) -> handle_event n ev
| `Region (_, r) ->
Region.fold_lwt_opt ~t:r
@ -1675,39 +1749,66 @@ module Panel = struct
| `Handled -> Lwt.return None
| x -> Lwt.return (Some x) )
| `Handled -> Lwt.return None )
(`Event ev) *)
(`Event ev)
(*
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 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 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
Lwt_list.iter_s
(fun e ->
handle_event r e
>>= fun h ->
( match h with
| [] -> ()
| _ -> F.epr "handle_event: Unhandled event@." ) ;*)
Lwt.return (Draw.pane r) )
| `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
(textedit_handler
(style Style.dark
(join_y
(join_y
@ -1715,8 +1816,8 @@ module Panel = struct
"-- 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") ) ) )
(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) ) ]