Further integration of lwt, irc basically works
This commit is contained in:
cqc
582
human.ml
582
human.ml
@ -71,7 +71,11 @@ module Input = struct
|
||||
(* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||||
module S = Zed_input.Make (Key)
|
||||
|
||||
type action = Custom of (unit -> unit) | Zed of Zed_edit.action
|
||||
type action =
|
||||
| Custom of (unit -> unit)
|
||||
| CustomLwt of (unit -> unit Lwt.t)
|
||||
| Zed of Zed_edit.action
|
||||
|
||||
type t = action list S.t
|
||||
type resolver = action list S.resolver
|
||||
type result = action list S.result
|
||||
@ -147,8 +151,11 @@ module Input = struct
|
||||
events )
|
||||
|
||||
let process bindstate events =
|
||||
List.iter
|
||||
(function Custom f -> f () | _ -> ())
|
||||
Lwt_list.iter_s
|
||||
(function
|
||||
| Custom f -> Lwt.return (f ())
|
||||
| CustomLwt f -> f ()
|
||||
| _ -> Lwt.return_unit )
|
||||
(actions_of_events bindstate events)
|
||||
end
|
||||
|
||||
@ -501,36 +508,41 @@ module Display = struct
|
||||
Sdl.gl_swap_window frame.sdl_win ;
|
||||
Ok ()
|
||||
|
||||
let display_frame frame (actor : actor) =
|
||||
let get_events () =
|
||||
(* create and fill event list *)
|
||||
let convert_event ev =
|
||||
match Event.event_of_sdlevent ev with
|
||||
(* Handle relevant events *)
|
||||
| a -> a in
|
||||
let convert_event = Event.event_of_sdlevent in
|
||||
let ev = Sdl.Event.create () in
|
||||
let events : Event.t list ref = ref [] in
|
||||
if Sdl.wait_event_timeout (Some ev) 100 then (
|
||||
if Sdl.wait_event_timeout (Some ev) 20 then (
|
||||
events := !events @ [convert_event ev] ;
|
||||
while Sdl.wait_event_timeout (Some ev) 1 do
|
||||
events := !events @ [convert_event ev]
|
||||
done ) ;
|
||||
events
|
||||
|
||||
let display_frame frame (actor : actor) =
|
||||
let events = get_events () in
|
||||
handle_frame_events frame !events ;
|
||||
if List.length !events > 0 then (
|
||||
(* recompute the actor definition with the new events to return a new pane *)
|
||||
!actor !events
|
||||
>>= fun p ->
|
||||
F.epr "pane generated@." ;
|
||||
frame.last_pane <- p ;
|
||||
(* call draw_pane because we should redraw now that we have updated *)
|
||||
ignore (draw_pane frame frame.last_pane) ;
|
||||
Lwt.return_unit )
|
||||
else Lwt.return_unit
|
||||
else (
|
||||
ignore (draw_pane frame frame.last_pane) ;
|
||||
Lwt.return_unit )
|
||||
|
||||
let run frame actor () =
|
||||
let frame = get_result frame in
|
||||
Sdl.show_window frame.sdl_win ;
|
||||
let rec loop () =
|
||||
ignore (display_frame frame actor) ;
|
||||
Lwt_main.yield ()
|
||||
display_frame frame actor
|
||||
>>= fun () ->
|
||||
Lwt.pause () (* seems required for the irc connection to work *)
|
||||
>>= fun () ->
|
||||
if not frame.quit then loop () else Lwt.return_unit in
|
||||
Lwt_main.run (loop ()) ;
|
||||
@ -667,7 +679,7 @@ module Panel = struct
|
||||
|
||||
type t =
|
||||
{ mutable act: t -> Event.events -> (t * Display.pane) Lwt.t
|
||||
; mutable subpanels: t list
|
||||
; mutable subpanels: t Lwt.t list
|
||||
; mutable tag: string }
|
||||
|
||||
let blank =
|
||||
@ -677,51 +689,65 @@ module Panel = struct
|
||||
; tag= "blank pane" }
|
||||
|
||||
let draw (pane : Display.pane) =
|
||||
{ act= (fun panel _events -> Lwt.return (panel, pane))
|
||||
; subpanels= []
|
||||
; tag= "draw-pane" }
|
||||
Lwt.return
|
||||
{ act= (fun panel _events -> Lwt.return (panel, pane))
|
||||
; subpanels= []
|
||||
; tag= "draw-pane" }
|
||||
|
||||
let actor (panel : t) : Event.events -> Display.pane Lwt.t =
|
||||
fun events ->
|
||||
panel.act panel events >>= fun (_panel, pane) -> Lwt.return pane
|
||||
|
||||
let filter_events ef p =
|
||||
{p with act= (fun panel events -> p.act panel (ef events))}
|
||||
p
|
||||
>>= fun p' ->
|
||||
Lwt.return
|
||||
{p' with act= (fun panel events -> p'.act panel (ef events))}
|
||||
|
||||
(* draws subsequent items below *)
|
||||
let vbox subpanels =
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
Lwt_list.map_p
|
||||
(fun subpanel ->
|
||||
subpanel.act subpanel events
|
||||
>>= fun (_panel, pane) -> Lwt.return pane )
|
||||
panel.subpanels
|
||||
>>= fun pl -> Lwt.return (panel, pane_box Box2.tl_pt pl) )
|
||||
(* tl_pt is actually bl_pt in the Wall coordinate system *)
|
||||
; subpanels
|
||||
; tag= "vertical-box" }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
Lwt_list.map_p
|
||||
(fun s ->
|
||||
s
|
||||
>>= fun subpanel ->
|
||||
subpanel.act subpanel events
|
||||
>>= fun (_panel, pane) -> Lwt.return pane )
|
||||
panel.subpanels
|
||||
>>= fun pl -> Lwt.return (panel, pane_box Box2.tl_pt pl)
|
||||
)
|
||||
(* tl_pt is actually bl_pt in the Wall coordinate system *)
|
||||
; subpanels
|
||||
; tag= "vertical-box" }
|
||||
|
||||
(* draws subsequent item to the right *)
|
||||
let hbox subpanels =
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
Lwt_list.map_p
|
||||
(fun subpanel ->
|
||||
subpanel.act subpanel events
|
||||
>>= fun (_panel, pane) -> Lwt.return pane )
|
||||
panel.subpanels
|
||||
>>= fun pl -> Lwt.return (panel, pane_box Box2.br_pt pl) )
|
||||
(* br_pt is actually tr_pt in the Wall coordinate system *)
|
||||
; subpanels
|
||||
; tag= "horizontal-box" }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
Lwt_list.map_p
|
||||
(fun s ->
|
||||
s
|
||||
>>= fun subpanel ->
|
||||
subpanel.act subpanel events
|
||||
>>= fun (_panel, pane) -> Lwt.return pane )
|
||||
panel.subpanels
|
||||
>>= fun pl -> Lwt.return (panel, pane_box Box2.br_pt pl)
|
||||
)
|
||||
(* br_pt is actually tr_pt in the Wall coordinate system *)
|
||||
; subpanels
|
||||
; tag= "horizontal-box" }
|
||||
|
||||
(* draws subsequent panels overtop each other *)
|
||||
let obox subpanels =
|
||||
let obox (subpanels : t Lwt.t list) =
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
Lwt_list.map_p
|
||||
(fun subpanel ->
|
||||
subpanel
|
||||
>>= fun subpanel ->
|
||||
subpanel.act subpanel events
|
||||
>>= fun (_panel, pane) -> Lwt.return pane )
|
||||
panel.subpanels
|
||||
@ -846,10 +872,11 @@ module Panel = struct
|
||||
|
||||
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
|
||||
fpp =
|
||||
{ act=
|
||||
(fun panel _events -> Lwt.return (panel, draw_pp height fpp))
|
||||
; subpanels= []
|
||||
; tag }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel _events -> Lwt.return (panel, draw_pp height fpp))
|
||||
; subpanels= []
|
||||
; tag }
|
||||
|
||||
module Textedit = struct
|
||||
let bindings =
|
||||
@ -917,100 +944,109 @@ module Panel = struct
|
||||
insert te initialtext ; te
|
||||
|
||||
let panel ?(height = !g_text_height) te =
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
(* collect events and update Zed context *)
|
||||
List.iter
|
||||
(function
|
||||
| `Key_down (k : Input.keystate) -> (
|
||||
let open Input.Bind in
|
||||
( match te.keybind.state with
|
||||
| Accepted _ | Rejected ->
|
||||
te.keybind.last_keyseq <- [] ;
|
||||
te.keybind.last_actions <- []
|
||||
| Continue _ -> () ) ;
|
||||
te.keybind.state <-
|
||||
resolve k
|
||||
(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.keybind.last_actions <- a ;
|
||||
List.iter
|
||||
(function
|
||||
| Input.Bind.Custom f -> f ()
|
||||
| Zed za -> Zed_edit.get_action za te.zed
|
||||
)
|
||||
a
|
||||
| Continue _ -> ()
|
||||
| Rejected -> () )
|
||||
| `Key_up _ -> ()
|
||||
| `Text_input s ->
|
||||
Zed_edit.insert te.zed
|
||||
(Zed_rope.of_string (Zed_string.of_utf8 s))
|
||||
| _ -> () )
|
||||
events ;
|
||||
let draw_textedit =
|
||||
draw_pp height (fun pp ->
|
||||
let zrb, zra =
|
||||
Zed_rope.break
|
||||
(Zed_edit.text (Zed_edit.edit te.zed))
|
||||
(Zed_cursor.get_position
|
||||
(Zed_edit.cursor te.zed) ) in
|
||||
let before_cursor =
|
||||
Zed_string.to_utf8 (Zed_rope.to_string zrb) in
|
||||
let after_cursor =
|
||||
Zed_string.to_utf8 (Zed_rope.to_string zra) in
|
||||
Format.pp_open_hvbox pp 0 ;
|
||||
F.text pp before_cursor ;
|
||||
Format.pp_open_stag pp
|
||||
(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
|
||||
F.pf pp "" ;
|
||||
Format.pp_close_stag pp () ;
|
||||
F.text pp after_cursor ;
|
||||
F.pf pp "@." ;
|
||||
Format.pp_close_box pp () ) in
|
||||
Lwt.return (panel, draw_textedit) )
|
||||
; subpanels= []
|
||||
; tag= "textedit" }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
(* collect events and update Zed context *)
|
||||
Lwt_list.iter_s
|
||||
(function
|
||||
| `Key_down (k : Input.keystate) -> (
|
||||
let open Input.Bind in
|
||||
( match te.keybind.state with
|
||||
| Accepted _ | Rejected ->
|
||||
te.keybind.last_keyseq <- [] ;
|
||||
te.keybind.last_actions <- []
|
||||
| Continue _ -> () ) ;
|
||||
te.keybind.state <-
|
||||
resolve k
|
||||
(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.keybind.last_actions <- a ;
|
||||
Lwt_list.iter_s
|
||||
(function
|
||||
| Input.Bind.Custom f ->
|
||||
Lwt.return (f ())
|
||||
| Input.Bind.CustomLwt f -> f ()
|
||||
| Zed za ->
|
||||
Lwt.return
|
||||
(Zed_edit.get_action za te.zed) )
|
||||
a
|
||||
| Continue _ | Rejected -> Lwt.return_unit )
|
||||
| `Key_up _ -> Lwt.return_unit
|
||||
| `Text_input s ->
|
||||
Lwt.return
|
||||
(Zed_edit.insert te.zed
|
||||
(Zed_rope.of_string (Zed_string.of_utf8 s)) )
|
||||
| _ -> Lwt.return_unit )
|
||||
events
|
||||
>>= fun () ->
|
||||
let draw_textedit =
|
||||
draw_pp height (fun pp ->
|
||||
let zrb, zra =
|
||||
Zed_rope.break
|
||||
(Zed_edit.text (Zed_edit.edit te.zed))
|
||||
(Zed_cursor.get_position
|
||||
(Zed_edit.cursor te.zed) ) in
|
||||
let before_cursor =
|
||||
Zed_string.to_utf8 (Zed_rope.to_string zrb)
|
||||
in
|
||||
let after_cursor =
|
||||
Zed_string.to_utf8 (Zed_rope.to_string zra)
|
||||
in
|
||||
Format.pp_open_hvbox pp 0 ;
|
||||
F.text pp before_cursor ;
|
||||
Format.pp_open_stag pp
|
||||
(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
|
||||
F.pf pp "" ;
|
||||
Format.pp_close_stag pp () ;
|
||||
F.text pp after_cursor ;
|
||||
F.pf pp "@." ;
|
||||
Format.pp_close_box pp () ) in
|
||||
Lwt.return (panel, draw_textedit) )
|
||||
; 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 ->
|
||||
Lwt.return
|
||||
( 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" }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel _events ->
|
||||
Lwt.return
|
||||
( 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
|
||||
| CustomLwt _ -> "CustomLwt"
|
||||
| Custom _ -> "Custom")
|
||||
^ "; " )
|
||||
a ""
|
||||
| Rejected -> "Rejected"
|
||||
| Continue _ -> "Continue" ) ;
|
||||
Format.pp_close_box pp () ;
|
||||
F.flush pp () ) ) )
|
||||
; subpanels= []
|
||||
; tag= "binding-state" }
|
||||
end
|
||||
|
||||
module Modal = struct
|
||||
@ -1037,18 +1073,19 @@ module Panel = struct
|
||||
me.handle (Textedit.contents me.te) ) ]
|
||||
Textedit.bindings in
|
||||
me.te.keybind.bindings <- keybinds ;
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
match me.input with
|
||||
| Some text ->
|
||||
Textedit.insert me.te text ;
|
||||
(hbox panel.subpanels).act panel events
|
||||
| None -> Lwt.return (panel, Display.pane_empty)
|
||||
(* don't draw anything if modal isn't active *) )
|
||||
; subpanels=
|
||||
[ prettyprint (fun pp -> F.text pp me.prompt)
|
||||
; Textedit.panel ~height me.te ]
|
||||
; tag= "modal-edit" }
|
||||
Lwt.return
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
match me.input with
|
||||
| Some text ->
|
||||
Textedit.insert me.te text ;
|
||||
hbox panel.subpanels >>= fun p -> p.act panel events
|
||||
| None -> Lwt.return (panel, Display.pane_empty)
|
||||
(* don't draw anything if modal isn't active *) )
|
||||
; subpanels=
|
||||
[ prettyprint (fun pp -> F.text pp me.prompt)
|
||||
; Textedit.panel ~height me.te ]
|
||||
; tag= "modal-edit" }
|
||||
|
||||
let start me ?(prompt = "> ") text handler =
|
||||
me.input <- Some text ;
|
||||
@ -1103,20 +1140,19 @@ module Store = struct
|
||||
; sob: Format.symbolic_output_buffer }
|
||||
|
||||
let make_storeview ?(path = []) storepath branch =
|
||||
Lwt_main.run
|
||||
( Istore.Repo.v (Irmin_git.config storepath)
|
||||
>>= fun repo ->
|
||||
Istore.of_branch repo branch
|
||||
>>= fun store ->
|
||||
let view = Istore.Key.v path in
|
||||
Istore.list store view
|
||||
>>= fun viewlist ->
|
||||
Lwt.return
|
||||
{ store
|
||||
; view
|
||||
; selection= Istore.Key.v [fst (List.hd viewlist)]
|
||||
; editmode= false
|
||||
; sob= Format.make_symbolic_output_buffer () } )
|
||||
Istore.Repo.v (Irmin_git.config storepath)
|
||||
>>= fun repo ->
|
||||
Istore.of_branch repo branch
|
||||
>>= fun store ->
|
||||
let view = Istore.Key.v path in
|
||||
Istore.list store view
|
||||
>>= fun viewlist ->
|
||||
Lwt.return
|
||||
{ store
|
||||
; view
|
||||
; selection= Istore.Key.v [fst (List.hd viewlist)]
|
||||
; editmode= false
|
||||
; sob= Format.make_symbolic_output_buffer () }
|
||||
|
||||
let directives (top : Toplevel.t) sv =
|
||||
let dir_use_key key_lid =
|
||||
@ -1155,49 +1191,48 @@ module Store = struct
|
||||
| [] -> 0
|
||||
| a :: b -> (if a = value then -1 else findi value b) + 1 in
|
||||
fun () ->
|
||||
Lwt_main.run
|
||||
( Istore.get_tree sv.store sv.view
|
||||
>>= fun top ->
|
||||
match Istore.Key.rdecons sv.selection with
|
||||
| Some (ppath, step) ->
|
||||
Istore.Tree.list top ppath
|
||||
>>= fun neighbors ->
|
||||
let steplist = fst (List.split neighbors) in
|
||||
let stepi = findi step steplist in
|
||||
Istore.Tree.list (snd (List.nth neighbors stepi)) []
|
||||
>>= fun subtreelist ->
|
||||
Lwt.return
|
||||
( match action with
|
||||
| `Next ->
|
||||
let stepi = findi step steplist in
|
||||
if List.length steplist - 1 > stepi then
|
||||
sv.selection <-
|
||||
Istore.Key.rcons ppath
|
||||
(List.nth steplist (stepi + 1))
|
||||
| `Prev ->
|
||||
if stepi > 0 then
|
||||
sv.selection <-
|
||||
Istore.Key.rcons ppath
|
||||
(List.nth steplist (stepi - 1))
|
||||
| `Sub ->
|
||||
if List.length subtreelist > 0 then
|
||||
sv.selection <-
|
||||
sv.selection @ [fst (List.hd subtreelist)]
|
||||
| `Sup ->
|
||||
if List.length ppath > 0 then sv.selection <- ppath
|
||||
)
|
||||
| None -> Lwt.return_unit )
|
||||
Istore.get_tree sv.store sv.view
|
||||
>>= fun top ->
|
||||
match Istore.Key.rdecons sv.selection with
|
||||
| Some (ppath, step) ->
|
||||
Istore.Tree.list top ppath
|
||||
>>= fun neighbors ->
|
||||
let steplist = fst (List.split neighbors) in
|
||||
let stepi = findi step steplist in
|
||||
Istore.Tree.list (snd (List.nth neighbors stepi)) []
|
||||
>>= fun subtreelist ->
|
||||
Lwt.return
|
||||
( match action with
|
||||
| `Next ->
|
||||
let stepi = findi step steplist in
|
||||
if List.length steplist - 1 > stepi then
|
||||
sv.selection <-
|
||||
Istore.Key.rcons ppath
|
||||
(List.nth steplist (stepi + 1))
|
||||
| `Prev ->
|
||||
if stepi > 0 then
|
||||
sv.selection <-
|
||||
Istore.Key.rcons ppath
|
||||
(List.nth steplist (stepi - 1))
|
||||
| `Sub ->
|
||||
if List.length subtreelist > 0 then
|
||||
sv.selection <-
|
||||
sv.selection @ [fst (List.hd subtreelist)]
|
||||
| `Sup ->
|
||||
if List.length ppath > 0 then sv.selection <- ppath )
|
||||
| None -> Lwt.return_unit
|
||||
|
||||
let editor ?(branch = "current") storepath : Panel.t =
|
||||
let sv = make_storeview storepath branch in
|
||||
let editor ?(branch = "current") storepath : Panel.t Lwt.t =
|
||||
make_storeview storepath branch
|
||||
>>= fun sv ->
|
||||
let top = Toplevel.init () in
|
||||
let modalstate = Panel.Modal.make () in
|
||||
let te = Panel.Textedit.make "" () in
|
||||
let save store path content =
|
||||
Lwt_main.run
|
||||
(Istore.set_exn store
|
||||
~info:(Irmin_unix.info "editor-save")
|
||||
path content ) in
|
||||
Lwt.async (fun () ->
|
||||
Istore.set_exn store
|
||||
~info:(Irmin_unix.info "editor-save")
|
||||
path content ) in
|
||||
let editbinds =
|
||||
let open Input.Bind in
|
||||
add
|
||||
@ -1223,13 +1258,11 @@ module Store = struct
|
||||
Panel.Textedit.bindings in
|
||||
te.keybind.bindings <- editbinds ;
|
||||
let is_node path =
|
||||
Lwt_main.run
|
||||
( Istore.get_tree sv.store sv.view
|
||||
>>= fun t ->
|
||||
Istore.Tree.kind t path
|
||||
>>= function
|
||||
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false )
|
||||
in
|
||||
Istore.get_tree sv.store sv.view
|
||||
>>= fun t ->
|
||||
Istore.Tree.kind t path
|
||||
>>= function
|
||||
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false in
|
||||
let update_storeview () =
|
||||
ignore (Format.flush_symbolic_output_buffer sv.sob) ;
|
||||
let pp = Format.formatter_of_symbolic_output_buffer sv.sob in
|
||||
@ -1283,30 +1316,33 @@ module Store = struct
|
||||
let navbinds =
|
||||
let open Input.Bind in
|
||||
let new_contents name content =
|
||||
Lwt_main.run
|
||||
(let s =
|
||||
match Istore.Key.rdecons sv.selection with
|
||||
| Some (t, _) -> t
|
||||
| None -> Istore.Key.empty in
|
||||
Istore.get_tree sv.store (sv.view @ s)
|
||||
>>= fun tree ->
|
||||
Istore.Tree.add tree name content
|
||||
>>= fun newtree ->
|
||||
Istore.set_tree_exn
|
||||
~info:(Irmin_unix.info "new Contents")
|
||||
sv.store sv.view newtree ) in
|
||||
add [([], Char 'n')] [Custom (navigate sv `Next)]
|
||||
@@ add [([], Char 'p')] [Custom (navigate sv `Prev)]
|
||||
@@ add [([], Char 'w')] [Custom (navigate sv `Prev)]
|
||||
@@ add [([], Char 's')] [Custom (navigate sv `Next)]
|
||||
@@ add [([], Char 'd')] [Custom (navigate sv `Sub)]
|
||||
@@ add [([], Char 'a')] [Custom (navigate sv `Sup)]
|
||||
Lwt.async (fun () ->
|
||||
let s =
|
||||
match Istore.Key.rdecons sv.selection with
|
||||
| Some (t, _) -> t
|
||||
| None -> Istore.Key.empty in
|
||||
Istore.get_tree sv.store (sv.view @ s)
|
||||
>>= fun tree ->
|
||||
Istore.Tree.add tree name content
|
||||
>>= fun newtree ->
|
||||
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
|
||||
[([], Char 'e')] (* enter edit mode *)
|
||||
[ Custom
|
||||
(fun () ->
|
||||
if not (is_node sv.selection) then
|
||||
sv.editmode <- not sv.editmode ) ]
|
||||
Lwt.async (fun () ->
|
||||
is_node sv.selection
|
||||
>>= fun nb ->
|
||||
if not nb then sv.editmode <- not sv.editmode ;
|
||||
Lwt.return_unit ) ) ]
|
||||
@@ add
|
||||
[([], Char 'f')] (* find: enter path in modal *)
|
||||
[Custom (fun () -> ())]
|
||||
@ -1331,18 +1367,18 @@ module Store = struct
|
||||
"" ) ) ) ]
|
||||
@@ add
|
||||
[([], Char 'r')] (* remove contents/node *)
|
||||
[ Custom
|
||||
[ CustomLwt
|
||||
(fun () ->
|
||||
let selection = sv.selection in
|
||||
navigate sv `Next () ;
|
||||
Lwt_main.run
|
||||
( Istore.get_tree sv.store sv.view
|
||||
>>= fun tree ->
|
||||
Istore.Tree.remove tree selection
|
||||
>>= fun newtree ->
|
||||
Istore.set_tree_exn
|
||||
~info:(Irmin_unix.info "remove Contents/Node")
|
||||
sv.store sv.view newtree ) ) ]
|
||||
navigate sv `Next ()
|
||||
>>= fun () ->
|
||||
Istore.get_tree sv.store sv.view
|
||||
>>= fun tree ->
|
||||
Istore.Tree.remove tree selection
|
||||
>>= fun newtree ->
|
||||
Istore.set_tree_exn
|
||||
~info:(Irmin_unix.info "remove Contents/Node")
|
||||
sv.store sv.view newtree ) ]
|
||||
@@ add
|
||||
[([], Char 'x')] (* execute contents/node *)
|
||||
[ Custom
|
||||
@ -1350,44 +1386,50 @@ module Store = struct
|
||||
Toplevel.eval top (Panel.Textedit.contents te) ) ]
|
||||
empty in
|
||||
let bindstate = Input.Bind.init navbinds in
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
( if
|
||||
(not sv.editmode)
|
||||
&& not (Panel.Modal.is_active modalstate)
|
||||
then (
|
||||
Input.Bind.process bindstate events ;
|
||||
Lwt.join [update_storeview (); update_textedit ()] )
|
||||
else Lwt.return_unit )
|
||||
>>= fun () -> (Panel.vbox panel.subpanels).act panel events
|
||||
)
|
||||
; subpanels=
|
||||
[ Panel.filter_events
|
||||
(fun ev ->
|
||||
if Panel.Modal.is_active modalstate then ev else [] )
|
||||
(Panel.Modal.panel modalstate)
|
||||
; Panel.hbox
|
||||
[ Panel.prettyprint (fun pp ->
|
||||
Panel.format_symbolic_output_buffer pp
|
||||
(Format.get_symbolic_output_buffer sv.sob) )
|
||||
; Panel.vbox
|
||||
[ Panel.filter_events
|
||||
(fun ev -> if sv.editmode then ev else [])
|
||||
(Panel.Textedit.panel te)
|
||||
; Panel.prettyprint (fun pp ->
|
||||
Format.pp_open_hovbox pp 0 ;
|
||||
Lwt.return
|
||||
Panel.
|
||||
{ act=
|
||||
(fun panel events ->
|
||||
( if
|
||||
(not sv.editmode)
|
||||
&& not (Panel.Modal.is_active modalstate)
|
||||
then
|
||||
Input.Bind.process bindstate events
|
||||
>>= fun () ->
|
||||
Lwt.join [update_storeview (); update_textedit ()]
|
||||
else Lwt.return_unit )
|
||||
>>= fun () ->
|
||||
Panel.vbox panel.subpanels
|
||||
>>= fun p -> p.act panel events )
|
||||
; subpanels=
|
||||
[ Panel.filter_events
|
||||
(fun ev ->
|
||||
if Panel.Modal.is_active modalstate then ev else []
|
||||
)
|
||||
(Panel.Modal.panel modalstate)
|
||||
; Panel.hbox
|
||||
[ Panel.prettyprint (fun pp ->
|
||||
Panel.format_symbolic_output_buffer pp
|
||||
(Format.get_symbolic_output_buffer
|
||||
(Toplevel.result_sob top) ) ;
|
||||
Format.pp_close_box pp () ;
|
||||
F.flush pp () ) ] ]
|
||||
; Panel.Textedit.bindingstate bindstate
|
||||
; Panel.prettyprint (fun pp ->
|
||||
Format.fprintf pp "sv.editmode = %b @." sv.editmode ) ]
|
||||
; tag= "store-editor" }
|
||||
(Format.get_symbolic_output_buffer sv.sob) )
|
||||
; Panel.vbox
|
||||
[ Panel.filter_events
|
||||
(fun ev -> if sv.editmode then ev else [])
|
||||
(Panel.Textedit.panel te)
|
||||
; Panel.prettyprint (fun pp ->
|
||||
Format.pp_open_hovbox pp 0 ;
|
||||
Panel.format_symbolic_output_buffer pp
|
||||
(Format.get_symbolic_output_buffer
|
||||
(Toplevel.result_sob top) ) ;
|
||||
Format.pp_close_box pp () ;
|
||||
F.flush pp () ) ] ]
|
||||
; Panel.Textedit.bindingstate bindstate
|
||||
; Panel.prettyprint (fun pp ->
|
||||
Format.fprintf pp "sv.editmode = %b @." sv.editmode )
|
||||
]
|
||||
; tag= "store-editor" }
|
||||
end
|
||||
|
||||
let std_actor root_panel =
|
||||
let std_actor (root_panel : Panel.t Lwt.t) =
|
||||
Panel.actor
|
||||
(Panel.obox
|
||||
[ Panel.draw (fun (s : Display.state) ->
|
||||
|
||||
Reference in New Issue
Block a user