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

582
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,51 +689,65 @@ module Panel = struct
; tag= "blank pane" } ; tag= "blank pane" }
let draw (pane : Display.pane) = let draw (pane : Display.pane) =
{ act= (fun panel _events -> Lwt.return (panel, pane)) Lwt.return
; subpanels= [] { act= (fun panel _events -> Lwt.return (panel, pane))
; tag= "draw-pane" } ; subpanels= []
; tag= "draw-pane" }
let actor (panel : t) : Event.events -> Display.pane Lwt.t = let actor (panel : t) : Event.events -> Display.pane Lwt.t =
fun events -> fun events ->
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 =
{ act= Lwt.return
(fun panel events -> { act=
Lwt_list.map_p (fun panel events ->
(fun subpanel -> Lwt_list.map_p
subpanel.act subpanel events (fun s ->
>>= fun (_panel, pane) -> Lwt.return pane ) s
panel.subpanels >>= fun subpanel ->
>>= fun pl -> Lwt.return (panel, pane_box Box2.tl_pt pl) ) subpanel.act subpanel events
(* tl_pt is actually bl_pt in the Wall coordinate system *) >>= fun (_panel, pane) -> Lwt.return pane )
; subpanels panel.subpanels
; tag= "vertical-box" } >>= 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 *) (* draws subsequent item to the right *)
let hbox subpanels = let hbox subpanels =
{ act= Lwt.return
(fun panel events -> { act=
Lwt_list.map_p (fun panel events ->
(fun subpanel -> Lwt_list.map_p
subpanel.act subpanel events (fun s ->
>>= fun (_panel, pane) -> Lwt.return pane ) s
panel.subpanels >>= fun subpanel ->
>>= fun pl -> Lwt.return (panel, pane_box Box2.br_pt pl) ) subpanel.act subpanel events
(* br_pt is actually tr_pt in the Wall coordinate system *) >>= fun (_panel, pane) -> Lwt.return pane )
; subpanels panel.subpanels
; tag= "horizontal-box" } >>= 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 *) (* 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,10 +872,11 @@ module Panel = struct
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print") let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
fpp = fpp =
{ act= Lwt.return
(fun panel _events -> Lwt.return (panel, draw_pp height fpp)) { act=
; subpanels= [] (fun panel _events -> Lwt.return (panel, draw_pp height fpp))
; tag } ; subpanels= []
; tag }
module Textedit = struct module Textedit = struct
let bindings = let bindings =
@ -917,100 +944,109 @@ 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 =
{ act= Lwt.return
(fun panel events -> { act=
(* collect events and update Zed context *) (fun panel events ->
List.iter (* collect events and update Zed context *)
(function Lwt_list.iter_s
| `Key_down (k : Input.keystate) -> ( (function
let open Input.Bind in | `Key_down (k : Input.keystate) -> (
( match te.keybind.state with let open Input.Bind in
| Accepted _ | Rejected -> ( match te.keybind.state with
te.keybind.last_keyseq <- [] ; | Accepted _ | Rejected ->
te.keybind.last_actions <- [] te.keybind.last_keyseq <- [] ;
| Continue _ -> () ) ; te.keybind.last_actions <- []
te.keybind.state <- | Continue _ -> () ) ;
resolve k te.keybind.state <-
(get_resolver te.keybind.state resolve k
(default_resolver te.keybind.bindings) ) ; (get_resolver te.keybind.state
te.keybind.last_keyseq <- (default_resolver te.keybind.bindings) ) ;
k :: te.keybind.last_keyseq ; te.keybind.last_keyseq <-
match te.keybind.state with k :: te.keybind.last_keyseq ;
| Accepted a -> match te.keybind.state with
te.keybind.last_actions <- a ; | Accepted a ->
List.iter te.keybind.last_actions <- a ;
(function Lwt_list.iter_s
| Input.Bind.Custom f -> f () (function
| Zed za -> Zed_edit.get_action za te.zed | Input.Bind.Custom f ->
) Lwt.return (f ())
a | Input.Bind.CustomLwt f -> f ()
| Continue _ -> () | Zed za ->
| Rejected -> () ) Lwt.return
| `Key_up _ -> () (Zed_edit.get_action za te.zed) )
| `Text_input s -> a
Zed_edit.insert te.zed | Continue _ | Rejected -> Lwt.return_unit )
(Zed_rope.of_string (Zed_string.of_utf8 s)) | `Key_up _ -> Lwt.return_unit
| _ -> () ) | `Text_input s ->
events ; Lwt.return
let draw_textedit = (Zed_edit.insert te.zed
draw_pp height (fun pp -> (Zed_rope.of_string (Zed_string.of_utf8 s)) )
let zrb, zra = | _ -> Lwt.return_unit )
Zed_rope.break events
(Zed_edit.text (Zed_edit.edit te.zed)) >>= fun () ->
(Zed_cursor.get_position let draw_textedit =
(Zed_edit.cursor te.zed) ) in draw_pp height (fun pp ->
let before_cursor = let zrb, zra =
Zed_string.to_utf8 (Zed_rope.to_string zrb) in Zed_rope.break
let after_cursor = (Zed_edit.text (Zed_edit.edit te.zed))
Zed_string.to_utf8 (Zed_rope.to_string zra) in (Zed_cursor.get_position
Format.pp_open_hvbox pp 0 ; (Zed_edit.cursor te.zed) ) in
F.text pp before_cursor ; let before_cursor =
Format.pp_open_stag pp Zed_string.to_utf8 (Zed_rope.to_string zrb)
(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; in
F.pf pp "" ; let after_cursor =
Format.pp_close_stag pp () ; Zed_string.to_utf8 (Zed_rope.to_string zra)
F.text pp after_cursor ; in
F.pf pp "@." ; Format.pp_open_hvbox pp 0 ;
Format.pp_close_box pp () ) in F.text pp before_cursor ;
Lwt.return (panel, draw_textedit) ) Format.pp_open_stag pp
; subpanels= [] (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
; tag= "textedit" } 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 *) (* 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)
= =
{ act= Lwt.return
(fun panel _events -> { act=
Lwt.return (fun panel _events ->
( panel Lwt.return
, draw_pp height (fun pp -> ( panel
Format.pp_open_hbox pp () ; , draw_pp height (fun pp ->
F.text pp Format.pp_open_hbox pp () ;
(List.fold_left F.text pp
(fun s x -> (List.fold_left
Input.to_string_compact x ^ " " ^ s ) (fun s x ->
"" b.last_keyseq ) ; Input.to_string_compact x ^ " " ^ s )
F.text pp "-> " ; "" b.last_keyseq ) ;
F.text pp F.text pp "-> " ;
( match b.state with F.text pp
| Accepted a -> ( match b.state with
"Accepted " | Accepted a ->
^ List.fold_right "Accepted "
(fun x s -> ^ List.fold_right
s (fun x s ->
^ Input.Bind.( s
match x with ^ Input.Bind.(
| Zed a -> match x with
Zed_edit.name_of_action a | Zed a ->
| Custom _ -> "Custom") Zed_edit.name_of_action a
^ "; " ) | CustomLwt _ -> "CustomLwt"
a "" | Custom _ -> "Custom")
| Rejected -> "Rejected" ^ "; " )
| Continue _ -> "Continue" ) ; a ""
Format.pp_close_box pp () ; | Rejected -> "Rejected"
F.flush pp () ) ) ) | Continue _ -> "Continue" ) ;
; subpanels= [] Format.pp_close_box pp () ;
; tag= "binding-state" } F.flush pp () ) ) )
; subpanels= []
; tag= "binding-state" }
end end
module Modal = struct module Modal = struct
@ -1037,18 +1073,19 @@ 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 ;
{ act= Lwt.return
(fun panel events -> { act=
match me.input with (fun panel events ->
| Some text -> match me.input with
Textedit.insert me.te text ; | Some text ->
(hbox panel.subpanels).act panel events Textedit.insert me.te text ;
| None -> Lwt.return (panel, Display.pane_empty) hbox panel.subpanels >>= fun p -> p.act panel events
(* don't draw anything if modal isn't active *) ) | None -> Lwt.return (panel, Display.pane_empty)
; subpanels= (* don't draw anything if modal isn't active *) )
[ prettyprint (fun pp -> F.text pp me.prompt) ; subpanels=
; Textedit.panel ~height me.te ] [ prettyprint (fun pp -> F.text pp me.prompt)
; tag= "modal-edit" } ; Textedit.panel ~height me.te ]
; tag= "modal-edit" }
let start me ?(prompt = "> ") text handler = let start me ?(prompt = "> ") text handler =
me.input <- Some text ; me.input <- Some text ;
@ -1103,20 +1140,19 @@ 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 -> let view = Istore.Key.v path in
let view = Istore.Key.v path in Istore.list store view
Istore.list store view >>= fun viewlist ->
>>= fun viewlist -> Lwt.return
Lwt.return { store
{ store ; 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,49 +1191,48 @@ 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) -> Istore.Tree.list top ppath
Istore.Tree.list top ppath >>= fun neighbors ->
>>= fun neighbors -> let steplist = fst (List.split neighbors) in
let steplist = fst (List.split neighbors) in let stepi = findi step steplist in
let stepi = findi step steplist in Istore.Tree.list (snd (List.nth neighbors stepi)) []
Istore.Tree.list (snd (List.nth neighbors stepi)) [] >>= fun subtreelist ->
>>= fun subtreelist -> Lwt.return
Lwt.return ( match action with
( match action with | `Next ->
| `Next -> let stepi = findi step steplist in
let stepi = findi step steplist in if List.length steplist - 1 > stepi then
if List.length steplist - 1 > stepi then sv.selection <-
sv.selection <- Istore.Key.rcons ppath
Istore.Key.rcons ppath (List.nth steplist (stepi + 1))
(List.nth steplist (stepi + 1)) | `Prev ->
| `Prev -> if stepi > 0 then
if stepi > 0 then sv.selection <-
sv.selection <- Istore.Key.rcons ppath
Istore.Key.rcons ppath (List.nth steplist (stepi - 1))
(List.nth steplist (stepi - 1)) | `Sub ->
| `Sub -> if List.length subtreelist > 0 then
if List.length subtreelist > 0 then 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 =
let open Input.Bind in let open Input.Bind in
add add
@ -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 in
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false )
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,30 +1316,33 @@ 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
Istore.get_tree sv.store (sv.view @ s) Istore.get_tree sv.store (sv.view @ s)
>>= fun tree -> >>= fun tree ->
Istore.Tree.add tree name content Istore.Tree.add tree name content
>>= fun newtree -> >>= fun newtree ->
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,44 +1386,50 @@ 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
{ act= Lwt.return
(fun panel events -> Panel.
( if { act=
(not sv.editmode) (fun panel events ->
&& not (Panel.Modal.is_active modalstate) ( if
then ( (not sv.editmode)
Input.Bind.process bindstate events ; && not (Panel.Modal.is_active modalstate)
Lwt.join [update_storeview (); update_textedit ()] ) then
else Lwt.return_unit ) Input.Bind.process bindstate events
>>= fun () -> (Panel.vbox panel.subpanels).act panel events >>= fun () ->
) Lwt.join [update_storeview (); update_textedit ()]
; subpanels= else Lwt.return_unit )
[ Panel.filter_events >>= fun () ->
(fun ev -> Panel.vbox panel.subpanels
if Panel.Modal.is_active modalstate then ev else [] ) >>= fun p -> p.act panel events )
(Panel.Modal.panel modalstate) ; subpanels=
; Panel.hbox [ Panel.filter_events
[ Panel.prettyprint (fun pp -> (fun ev ->
Panel.format_symbolic_output_buffer pp if Panel.Modal.is_active modalstate then ev else []
(Format.get_symbolic_output_buffer sv.sob) ) )
; Panel.vbox (Panel.Modal.panel modalstate)
[ Panel.filter_events ; Panel.hbox
(fun ev -> if sv.editmode then ev else []) [ Panel.prettyprint (fun pp ->
(Panel.Textedit.panel te)
; Panel.prettyprint (fun pp ->
Format.pp_open_hovbox pp 0 ;
Panel.format_symbolic_output_buffer pp Panel.format_symbolic_output_buffer pp
(Format.get_symbolic_output_buffer (Format.get_symbolic_output_buffer sv.sob) )
(Toplevel.result_sob top) ) ; ; Panel.vbox
Format.pp_close_box pp () ; [ Panel.filter_events
F.flush pp () ) ] ] (fun ev -> if sv.editmode then ev else [])
; Panel.Textedit.bindingstate bindstate (Panel.Textedit.panel te)
; Panel.prettyprint (fun pp -> ; Panel.prettyprint (fun pp ->
Format.fprintf pp "sv.editmode = %b @." sv.editmode ) ] Format.pp_open_hovbox pp 0 ;
; tag= "store-editor" } 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 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...