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

Further integration of lwt, irc basically works

Browse Source
This commit is contained in:
cqc
2021-10-11 11:52:36 -05:00
parent 630ccb0a6f
commit f3d52bc506
2 changed files with 320 additions and 274 deletions
Download Patch File Download Diff File Expand all files Collapse all files

188
human.ml
View File

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

12
irc.ml
View File

@ -53,7 +53,11 @@ module Communicator = struct
C.reconnect_loop ~after:30 C.reconnect_loop ~after:30
~connect:(fun () -> ~connect:(fun () ->
Lwt_io.printl "Connecting..." Lwt_io.printl "Connecting..."
>>= fun () -> C.connect_by_name ~server ~port ~nick () ) >>= fun () ->
C.connect_by_name ~server ~port ~nick ()
>>= fun c ->
Lwt_io.printl "connect_by_name returned"
>>= fun () -> Lwt.return c )
~f:(fun connection -> ~f:(fun connection ->
Lwt_io.printl "Connected" Lwt_io.printl "Connected"
>>= fun () -> >>= fun () ->
@ -89,7 +93,7 @@ module Communicator = struct
F.pf pp " <><><> COMMUNICATOR <><><> @.@." ; F.pf pp " <><><> COMMUNICATOR <><><> @.@." ;
List.iter List.iter
(fun msg -> F.pf pp "[%s] %s@." msg.time msg.content) (fun msg -> F.pf pp "[%s] %s@." msg.time msg.content)
c.channel.content ) (List.rev c.channel.content) )
end end
end end
@ -98,8 +102,8 @@ let _ =
let hackint = let hackint =
Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml" Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
["#CQC"] in ["#CQC"] in
root_actor := std_actor (Communicator.Panel.panel comm) ; Lwt.async (fun () -> hackint) ;
Lwt.async (fun () -> hackint) root_actor := std_actor (Communicator.Panel.panel comm)
(** (**
program starts... program starts...