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