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} *)
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,6 +689,7 @@ module Panel = struct
; tag= "blank pane" }
let draw (pane : Display.pane) =
Lwt.return
{ act= (fun panel _events -> Lwt.return (panel, pane))
; subpanels= []
; tag= "draw-pane" }
@ -686,42 +699,55 @@ module Panel = struct
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 =
Lwt.return
{ act=
(fun panel events ->
Lwt_list.map_p
(fun subpanel ->
(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) )
>>= 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 =
Lwt.return
{ act=
(fun panel events ->
Lwt_list.map_p
(fun subpanel ->
(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) )
>>= 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,6 +872,7 @@ module Panel = struct
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
fpp =
Lwt.return
{ act=
(fun panel _events -> Lwt.return (panel, draw_pp height fpp))
; subpanels= []
@ -917,10 +944,11 @@ module Panel = struct
insert te initialtext ; te
let panel ?(height = !g_text_height) te =
Lwt.return
{ act=
(fun panel events ->
(* collect events and update Zed context *)
List.iter
Lwt_list.iter_s
(function
| `Key_down (k : Input.keystate) -> (
let open Input.Bind in
@ -938,20 +966,24 @@ module Panel = struct
match te.keybind.state with
| Accepted a ->
te.keybind.last_actions <- a ;
List.iter
Lwt_list.iter_s
(function
| Input.Bind.Custom f -> f ()
| Zed za -> Zed_edit.get_action za te.zed
)
| 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 -> () )
| `Key_up _ -> ()
| Continue _ | Rejected -> Lwt.return_unit )
| `Key_up _ -> Lwt.return_unit
| `Text_input s ->
Zed_edit.insert te.zed
(Zed_rope.of_string (Zed_string.of_utf8 s))
| _ -> () )
events ;
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 =
@ -960,9 +992,11 @@ module Panel = struct
(Zed_cursor.get_position
(Zed_edit.cursor te.zed) ) in
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 =
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 ;
F.text pp before_cursor ;
Format.pp_open_stag pp
@ -979,6 +1013,7 @@ module Panel = struct
(* pane that displays last key binding match state *)
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state)
=
Lwt.return
{ act=
(fun panel _events ->
Lwt.return
@ -1002,6 +1037,7 @@ module Panel = struct
match x with
| Zed a ->
Zed_edit.name_of_action a
| CustomLwt _ -> "CustomLwt"
| Custom _ -> "Custom")
^ "; " )
a ""
@ -1037,12 +1073,13 @@ module Panel = struct
me.handle (Textedit.contents me.te) ) ]
Textedit.bindings in
me.te.keybind.bindings <- keybinds ;
Lwt.return
{ act=
(fun panel events ->
match me.input with
| Some 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)
(* don't draw anything if modal isn't active *) )
; subpanels=
@ -1103,8 +1140,7 @@ module Store = struct
; sob: Format.symbolic_output_buffer }
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 ->
Istore.of_branch repo branch
>>= fun store ->
@ -1116,7 +1152,7 @@ module Store = struct
; view
; selection= Istore.Key.v [fst (List.hd viewlist)]
; editmode= false
; sob= Format.make_symbolic_output_buffer () } )
; sob= Format.make_symbolic_output_buffer () }
let directives (top : Toplevel.t) sv =
let dir_use_key key_lid =
@ -1155,8 +1191,7 @@ 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
Istore.get_tree sv.store sv.view
>>= fun top ->
match Istore.Key.rdecons sv.selection with
| Some (ppath, step) ->
@ -1184,18 +1219,18 @@ module Store = struct
sv.selection <-
sv.selection @ [fst (List.hd subtreelist)]
| `Sup ->
if List.length ppath > 0 then sv.selection <- ppath
)
| None -> Lwt.return_unit )
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
Lwt.async (fun () ->
Istore.set_exn store
~info:(Irmin_unix.info "editor-save")
path content ) in
let editbinds =
@ -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
Istore.get_tree sv.store sv.view
>>= fun t ->
Istore.Tree.kind t path
>>= function
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false )
in
| 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,8 +1316,8 @@ module Store = struct
let navbinds =
let open Input.Bind in
let new_contents name content =
Lwt_main.run
(let s =
Lwt.async (fun () ->
let s =
match Istore.Key.rdecons sv.selection with
| Some (t, _) -> t
| None -> Istore.Key.empty in
@ -1295,18 +1328,21 @@ module Store = struct
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)]
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
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 ) ) ]
sv.store sv.view newtree ) ]
@@ add
[([], Char 'x')] (* execute contents/node *)
[ Custom
@ -1350,21 +1386,26 @@ module Store = struct
Toplevel.eval top (Panel.Textedit.contents te) ) ]
empty in
let bindstate = Input.Bind.init navbinds in
Lwt.return
Panel.
{ 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 ()] )
then
Input.Bind.process bindstate events
>>= fun () ->
Lwt.join [update_storeview (); update_textedit ()]
else Lwt.return_unit )
>>= fun () -> (Panel.vbox panel.subpanels).act panel events
)
>>= 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 [] )
if Panel.Modal.is_active modalstate then ev else []
)
(Panel.Modal.panel modalstate)
; Panel.hbox
[ Panel.prettyprint (fun pp ->
@ -1383,11 +1424,12 @@ module Store = struct
F.flush pp () ) ] ]
; Panel.Textedit.bindingstate bindstate
; Panel.prettyprint (fun pp ->
Format.fprintf pp "sv.editmode = %b @." sv.editmode ) ]
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) ->

12
irc.ml
View File

@ -53,7 +53,11 @@ module Communicator = struct
C.reconnect_loop ~after:30
~connect:(fun () ->
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 ->
Lwt_io.printl "Connected"
>>= fun () ->
@ -89,7 +93,7 @@ module Communicator = struct
F.pf pp " <><><> COMMUNICATOR <><><> @.@." ;
List.iter
(fun msg -> F.pf pp "[%s] %s@." msg.time msg.content)
c.channel.content )
(List.rev c.channel.content) )
end
end
@ -98,8 +102,8 @@ let _ =
let hackint =
Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
["#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...