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

better keybindings, halfway to store tree navigation

Browse Source
This commit is contained in:
cqc
2021-09-03 08:42:49 -05:00
parent d6b16f2a4e
commit 335d864a8b
1 changed files with 195 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files

273
main.ml
View File

@ -19,7 +19,6 @@ some options:
open Lwt.Infix open Lwt.Infix
module F = Fmt module F = Fmt
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
module Input = struct module Input = struct
open CamomileLibrary open CamomileLibrary
@ -66,39 +65,48 @@ module Input = struct
module Keymod = Set.Make (KeymodSet) module Keymod = Set.Make (KeymodSet)
let modset = Keymod.of_list
type key = {mods: Keymod.t; code: code} type key = {mods: Keymod.t; code: code}
module Key = struct module Key = struct
type t = key type t = key
let compare (x : t) (y : t) = compare x y let compare = compare
end end
module Bind = struct module Bind = struct
(* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
module S = Zed_input.Make (Key) module S = Zed_input.Make (Key)
include S include S
type action = Custom of (unit -> unit) | Zed of Zed_edit.action type action = Custom of (unit -> unit) | Zed of Zed_edit.action
type binding = key * action list
type bindings = binding list
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
type t = action list S.t type t = action list S.t
type resolver = action list S.resolver type resolver = action list S.resolver
type result = action list S.result type result = action list S.result
type state =
{ mutable bindings: t
; mutable state: result
; mutable last_keyseq: key list
; mutable last_actions: action list }
let add events action bindings =
let events =
List.map
(fun (m, k) ->
{mods= Keymod.of_list m; code= Char (UChar.of_char k)} )
events in
S.add events action bindings
let default_resolver b = let default_resolver b =
resolver [pack (fun (x : action list) -> x) b] resolver [pack (fun (x : action list) -> x) b]
let get_resolver result default = let get_resolver result default =
match result with Continue r -> r | _ -> default match result with Continue r -> r | _ -> default
let handle_actions actions zectx = let init bindings =
List.iter {bindings; state= S.Rejected; last_keyseq= []; last_actions= []}
(function
| Custom f -> f () | Zed za -> Zed_edit.get_action za zectx
)
actions
end end
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
@ -340,6 +348,30 @@ module Event = struct
let key_left : Sdl.keycode = 0x40000050 let key_left : Sdl.keycode = 0x40000050
let key_right : Sdl.keycode = 0x4000004f let key_right : Sdl.keycode = 0x4000004f
let handle_keyevents (el : events) f = List.iter f el let handle_keyevents (el : events) f = List.iter f el
let actions_of_events (state : Input.Bind.state) (events : events) =
let open Input.Bind in
List.iter
(function
| `Key_down (k : Input.key) ->
( 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
| _ -> () )
events ;
match state.state with
| Accepted a ->
state.last_actions <- a ;
a
| Rejected ->
state.last_actions <- [] ;
[]
| _ -> []
end end
module Display = struct module Display = struct
@ -610,9 +642,9 @@ module Panel = struct
open Gg open Gg
type t = type t =
{ act: t -> Event.events -> t * Display.pane { mutable act: t -> Event.events -> t * Display.pane
; subpanels: t list ; mutable subpanels: t list
; tag: string } ; mutable tag: string }
type actor = Event.events -> Display.pane type actor = Event.events -> Display.pane
@ -671,6 +703,7 @@ module Panel = struct
type Format.stag += Color_bg of Wall.color type Format.stag += Color_bg of Wall.color
type Format.stag += Color_fg of Wall.color type Format.stag += Color_fg of Wall.color
type Format.stag += Cursor of Wall.color type Format.stag += Cursor of Wall.color
type Format.stag += None_tag
let draw_pp height fpp (s : state) = let draw_pp height fpp (s : state) =
let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in
@ -760,7 +793,7 @@ module Panel = struct
let open Zed_edit in let open Zed_edit in
let m = Input.Keymod.of_list in let m = Input.Keymod.of_list in
let b = ref empty in let b = ref empty in
let add e a = b := Input.Bind.add e a !b in let add e a = b := Input.Bind.S.add e a !b in
add [{mods= m []; code= Left}] [Zed Prev_char] ; add [{mods= m []; code= Left}] [Zed Prev_char] ;
add [{mods= m []; code= Right}] [Zed Next_char] ; add [{mods= m []; code= Right}] [Zed Next_char] ;
add [{mods= m []; code= Up}] [Zed Prev_line] ; add [{mods= m []; code= Up}] [Zed Prev_line] ;
@ -834,47 +867,18 @@ module Panel = struct
!b !b
type textedit = type textedit =
{ ze: unit Zed_edit.t {ze: unit Zed_edit.t; zc: Zed_cursor.t; keybind: Input.Bind.state}
; zc: Zed_cursor.t
; mutable bindings: Input.Bind.t
; mutable binding_state: Input.Bind.result
; mutable last_keyseq: Input.key list
; mutable last_actions: Input.Bind.action list }
let make_textedit () = let make_textedit ?(keybinds = default_bindings) () =
let z = Zed_edit.create () in let z = Zed_edit.create () in
{ ze= z { ze= z
; zc= Zed_edit.new_cursor z ; zc= Zed_edit.new_cursor z
; bindings= default_bindings ; keybind= Input.Bind.init keybinds }
; binding_state= Input.Bind.S.Rejected
; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}]
; last_actions= [] }
(* pane that displays last key binding match state *)
let draw_textedit_input height (te : textedit) =
draw_pp height (fun pp ->
Format.pp_open_hbox pp () ;
F.text pp
(List.fold_right
(fun x s -> Input.to_string_compact x ^ " " ^ s)
te.last_keyseq "" ) ;
F.text pp
(List.fold_right
(fun x s ->
s ^ "-> "
^ Input.Bind.(
match x with
| Zed a -> Zed_edit.name_of_action a
| Custom _ -> "Custom") )
te.last_actions "" ) ;
Format.pp_close_box pp () ;
F.flush pp () )
let str_of_textedit (te : textedit) = let str_of_textedit (te : textedit) =
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
let textedit ?(_keybinds : Input.Bind.bindings = []) let textedit ?(_initialstring = "") ?(height = !g_text_height) te =
?(_initialstring = "") ?(height = !g_text_height) te =
{ act= { act=
(fun panel events -> (fun panel events ->
let ctx = Zed_edit.context te.ze te.zc in let ctx = Zed_edit.context te.ze te.zc in
@ -883,19 +887,20 @@ module Panel = struct
(function (function
| `Key_down (k : Input.key) -> ( | `Key_down (k : Input.key) -> (
let open Input.Bind in let open Input.Bind in
( match te.binding_state with ( match te.keybind.state with
| Accepted _ | Rejected -> | Accepted _ | Rejected ->
te.last_keyseq <- [] ; te.keybind.last_keyseq <- [] ;
te.last_actions <- [] te.keybind.last_actions <- []
| Continue _ -> () ) ; | Continue _ -> () ) ;
te.binding_state <- te.keybind.state <-
resolve k resolve k
(get_resolver te.binding_state (get_resolver te.keybind.state
(default_resolver te.bindings) ) ; (default_resolver te.keybind.bindings) ) ;
te.last_keyseq <- k :: te.last_keyseq ; te.keybind.last_keyseq <-
match te.binding_state with k :: te.keybind.last_keyseq ;
match te.keybind.state with
| Accepted a -> | Accepted a ->
te.last_actions <- a ; te.keybind.last_actions <- a ;
List.iter List.iter
(function (function
| Input.Bind.Custom f -> f () | Input.Bind.Custom f -> f ()
@ -931,15 +936,45 @@ module Panel = struct
; subpanels= [] ; subpanels= []
; tag= "textedit" } ; tag= "textedit" }
(* pane that displays last key binding match state *)
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state) =
{ act=
(fun panel _events ->
( panel
, draw_pp height (fun pp ->
Format.pp_open_hbox pp () ;
F.text pp
(List.fold_left
(fun s x -> Input.to_string_compact x ^ " " ^ s)
"" b.last_keyseq ) ;
F.text pp "-> " ;
F.text pp
( match b.state with
| Accepted a ->
"Accepted "
^ List.fold_right
(fun x s ->
s
^ Input.Bind.(
match x with
| Zed a -> Zed_edit.name_of_action a
| Custom _ -> "Custom")
^ "; " )
a ""
| Rejected -> "Rejected"
| Continue _ -> "Continue" ) ;
Format.pp_close_box pp () ;
F.flush pp () ) ) )
; subpanels= []
; tag= "binding-state" }
let prettyprint ?(height = !g_text_height) fpp = let prettyprint ?(height = !g_text_height) fpp =
{ act= (fun panel _events -> (panel, draw_pp height fpp)) { act= (fun panel _events -> (panel, draw_pp height fpp))
; subpanels= [] ; subpanels= []
; tag= "pretty-print" } ; tag= "pretty-print" }
let enclosure = ref blank
let actor (panel : t) : Event.events -> Display.pane = let actor (panel : t) : Event.events -> Display.pane =
enclosure := panel ; let enclosure = ref panel in
fun events -> fun events ->
let panel, pane = panel.act !enclosure events in let panel, pane = panel.act !enclosure events in
enclosure := panel ; enclosure := panel ;
@ -952,39 +987,93 @@ module I = Image
module P = Path module P = Path
module Text = Wall_text module Text = Wall_text
type storeview = {s: Store.t; path: string list} module Store = struct
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
let make_storeview storepath branch ?(path = []) () = type storeview =
{ s= { store: Istore.t
; mutable view: string list
; mutable selected: int list
(* values of offset to Istore.Tree.list because ugh *)
; mutable edit: bool }
let make_storeview ?(path = []) storepath branch =
{ store=
Lwt_main.run Lwt_main.run
(Store.of_branch (Istore.of_branch
(Lwt_main.run (Store.Repo.v (Irmin_git.config storepath))) (Lwt_main.run
(Istore.Repo.v (Irmin_git.config storepath)) )
branch ) branch )
; path } ; view= path
; selected= [2]
; edit= false }
let draw_storeview (r : storeview) height (s : Display.state) = let draw_storeview tree selected pp =
let indent = ref 0 in let indent = ref 0 in
let rec draw_levels (tree : (string * Store.tree) list) pp = let rec draw_levels ttree sel =
indent := !indent + 1 ; indent := !indent + 1 ;
List.iter List.iteri
(fun (step, node) -> (fun i (step, node) ->
Format.pp_open_vbox pp 0 ; Format.pp_open_vbox pp 0 ;
Format.pp_open_hbox pp () ; Format.pp_open_hbox pp () ;
for _ = 0 to !indent do for _ = 0 to !indent do
Format.pp_print_space pp () Format.pp_print_space pp ()
done ; done ;
if sel = [i] then
Format.pp_open_stag pp
Display.(
Panel.Color_bg (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
Format.fprintf pp "%d-%s@." !indent step ; Format.fprintf pp "%d-%s@." !indent step ;
if sel = [i] then Format.pp_close_stag pp () ;
Format.pp_close_box pp () ; Format.pp_close_box pp () ;
let subtree = Lwt_main.run (Store.Tree.list node []) in let subtree = Lwt_main.run (Istore.Tree.list node []) in
draw_levels subtree pp ; let subsel =
if List.length sel > 0 && List.hd sel = i then List.tl sel
else [] in
draw_levels subtree subsel ;
Format.pp_close_box pp () ) Format.pp_close_box pp () )
tree ; ttree ;
indent := !indent - 1 in indent := !indent - 1 in
draw_levels tree selected
let navigate sv action =
let _root =
Lwt_main.run
( Istore.get_tree sv.store sv.view
>>= fun n -> Istore.Tree.list n [] ) in
let rec listlast f = function
| [] -> []
| [x] -> F.epr "%d@." x ; [f x]
| _ :: x -> listlast f x in
fun () ->
match action with
| `Next -> sv.selected <- listlast succ sv.selected
| `Prev -> sv.selected <- listlast pred sv.selected
let editor ?(branch = "current") storepath : Panel.t =
let sv = make_storeview storepath branch in
let keybinds =
let open CamomileLibrary in
let open Input.Bind in
add [([], 'n')] [Custom (navigate sv `Next)]
@@ add [([], 'p')] [Custom (navigate sv `Prev)] empty in
let bindstate = Input.Bind.init keybinds in
{ act=
(fun panel events ->
List.iter
Input.Bind.(function Custom f -> f () | _ -> ())
(Event.actions_of_events bindstate events) ;
(Panel.vbox panel.subpanels).act panel events )
; subpanels=
[ Panel.prettyprint (fun pp ->
let root = let root =
Lwt_main.run Lwt_main.run
(Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n []) ( Istore.get_tree sv.store sv.view
in >>= fun n -> Istore.Tree.list n [] ) in
Panel.draw_pp height (draw_levels root) s draw_storeview root sv.selected pp )
; Panel.bindingstate bindstate ]
; tag= "store-editor" }
end
let format_symbolic_output_buffer (ppf : Format.formatter) buf = let format_symbolic_output_buffer (ppf : Format.formatter) buf =
List.iter List.iter
@ -1017,7 +1106,7 @@ type top =
; mutable eval: Topinf.evalenv option ; mutable eval: Topinf.evalenv option
; mutable path: string list ; mutable path: string list
; mutable histpath: string list ; mutable histpath: string list
; storeview: storeview } ; storeview: Store.storeview }
let make_top storepath ?(branch = "current") () = let make_top storepath ?(branch = "current") () =
let t = let t =
@ -1026,15 +1115,15 @@ let make_top storepath ?(branch = "current") () =
; eval= None ; eval= None
; path= ["init"] ; path= ["init"]
; histpath= ["history"] ; histpath= ["history"]
; storeview= make_storeview storepath branch () } in ; storeview= Store.make_storeview storepath branch } in
Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res ; Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res ;
Format.pp_set_formatter_out_functions Format.std_formatter (* Format.pp_set_formatter_out_functions Format.std_formatter
(out_funs_of_sob t.res) ; (out_funs_of_sob t.res) ;*)
let zctx = Zed_edit.context t.te.ze t.te.zc in let zctx = Zed_edit.context t.te.ze t.te.zc in
Zed_edit.insert zctx Zed_edit.insert zctx
(Zed_rope.of_string (Zed_rope.of_string
(Zed_string.of_utf8 (Zed_string.of_utf8
(Lwt_main.run (Store.get t.storeview.s t.path)) ) ) ; (Lwt_main.run (Store.Istore.get t.storeview.store t.path)) ) ) ;
t t
let top_panel (t : top) = let top_panel (t : top) =
@ -1055,9 +1144,9 @@ let top_panel (t : top) =
try try
ignore ignore
(Lwt_main.run (Lwt_main.run
( Store.tree t.storeview.s ( Store.Istore.tree t.storeview.store
>>= fun tree -> >>= fun tree ->
Store.Tree.add tree Store.Istore.Tree.add tree
(t.histpath @ ["input"]) (t.histpath @ ["input"])
(Panel.str_of_textedit t.te) ) ) ; (Panel.str_of_textedit t.te) ) ) ;
ignore (Format.flush_symbolic_output_buffer t.res) ; ignore (Format.flush_symbolic_output_buffer t.res) ;
@ -1069,14 +1158,14 @@ let top_panel (t : top) =
(Format.get_symbolic_output_buffer t.res) ; (Format.get_symbolic_output_buffer t.res) ;
ignore ignore
(Lwt_main.run (Lwt_main.run
( Store.tree t.storeview.s ( Store.Istore.tree t.storeview.store
>>= fun tree -> >>= fun tree ->
Store.Tree.add tree Store.Istore.Tree.add tree
(t.histpath @ ["output"]) (t.histpath @ ["output"])
(Buffer.contents b) ) ) ; (Buffer.contents b) ) ) ;
ignore ignore
(Lwt_main.run (Lwt_main.run
(Store.set_exn t.storeview.s (Store.Istore.set_exn t.storeview.store
~info:(Irmin_unix.info "history") ~info:(Irmin_unix.info "history")
t.path t.path
(Panel.str_of_textedit t.te) ) ) ; (Panel.str_of_textedit t.te) ) ) ;
@ -1085,12 +1174,12 @@ let top_panel (t : top) =
F.pf ppf "Exception in pane_top//eval@." ; F.pf ppf "Exception in pane_top//eval@." ;
Location.report_exception ppf e ; Location.report_exception ppf e ;
F.epr "Exception in pane_top//eval@." in F.epr "Exception in pane_top//eval@." in
t.te.bindings <- t.te.keybind.bindings <-
Input.( Input.(
Bind.add Bind.S.add
[{mods= Keymod.of_list [Ctrl]; code= Enter}] [{mods= Keymod.of_list [Ctrl]; code= Enter}]
Bind.[Custom eval] Bind.[Custom eval]
t.te.bindings) ; t.te.keybind.bindings) ;
Panel.( Panel.(
vbox vbox
[ textedit t.te [ textedit t.te
@ -1101,7 +1190,7 @@ let top_panel (t : top) =
Format.pp_close_box pp () ; Format.pp_close_box pp () ;
F.flush pp () ) (*; draw_textedit_input height t.te *) ]) F.flush pp () ) (*; draw_textedit_input height t.te *) ])
let top_1 = make_top "../rootstore" () (*let top_1 = make_top "../rootstore" () *)
let () = let () =
let actor = let actor =
@ -1109,7 +1198,7 @@ let () =
(Panel.obox (Panel.obox
[ Panel.draw (fun (s : Display.state) -> [ Panel.draw (fun (s : Display.state) ->
(s, Display.fill_box (Display.gray 0.125) s.box) ) (s, Display.fill_box (Display.gray 0.125) s.box) )
; top_panel top_1 ] ) in ; Store.editor "../rootstore" (*top_panel top_1*) ] ) in
Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) actor) () Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) actor) ()
(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)