diff --git a/dune b/dune index 1a1ba1d..38fbc85 100644 --- a/dune +++ b/dune @@ -58,6 +58,7 @@ zed lambda-term irmin-unix + inuit irc-client irc-client-lwt irc-client-unix diff --git a/human.ml b/human.ml index 233523c..0a3d251 100644 --- a/human.ml +++ b/human.ml @@ -155,7 +155,7 @@ module Input = struct (function | Custom f -> Lwt.return (f ()) | CustomLwt f -> f () - | _ -> Lwt.return_unit ) + | Zed _ -> Lwt.return_unit ) (actions_of_events bindstate events) end @@ -508,42 +508,36 @@ module Display = struct Sdl.gl_swap_window frame.sdl_win ; Ok () - let get_events () = + let rec get_events () : Event.t list = (* create and fill event list *) - 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) 20 then ( - events := !events @ [convert_event ev] ; - while Sdl.wait_event_timeout (Some ev) 1 do - events := !events @ [convert_event ev] - done ) ; - events + if Sdl.poll_event (Some ev) then + get_events () @ [Event.event_of_sdlevent ev] + else [] let display_frame frame (actor : actor) = let events = get_events () in - handle_frame_events frame !events ; - if List.length !events > 0 then ( + 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 + !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 ( - ignore (draw_pane frame frame.last_pane) ; - Lwt.return_unit ) + else Lwt.return_unit let run frame actor () = let frame = get_result frame in Sdl.show_window frame.sdl_win ; let rec loop () = - display_frame frame actor - >>= fun () -> Lwt.pause () (* seems required for the irc connection to work *) >>= fun () -> + Lwt_unix.sleep 0.030 + >>= fun () -> + display_frame frame actor + >>= fun () -> if not frame.quit then loop () else Lwt.return_unit in Lwt_main.run (loop ()) ; print_endline "quit" ; @@ -678,25 +672,24 @@ module Panel = struct open Gg type t = - { mutable act: t -> Event.events -> (t * Display.pane) Lwt.t + { mutable act: t -> Event.events -> Display.pane Lwt.t ; mutable subpanels: t Lwt.t list ; mutable tag: string } let blank = - { act= - (fun panel _events -> Lwt.return (panel, Display.pane_empty)) + { act= (fun _panel _events -> Lwt.return Display.pane_empty) ; subpanels= [] ; tag= "blank pane" } let draw (pane : Display.pane) = Lwt.return - { act= (fun panel _events -> Lwt.return (panel, pane)) + { act= (fun _panel _events -> Lwt.return 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 + panel.act panel events >>= fun pane -> Lwt.return pane let filter_events ef p = p @@ -704,20 +697,19 @@ module Panel = struct Lwt.return {p' with act= (fun panel events -> p'.act panel (ef events))} + let resolve_panels events = + Lwt_list.map_s (fun s -> + s + >>= fun subpanel -> + subpanel.act subpanel events >>= fun pane -> Lwt.return pane ) + (* draws subsequent items below *) let vbox subpanels = 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) - ) + resolve_panels events panel.subpanels + >|= fun pl -> pane_box Box2.tl_pt pl ) (* tl_pt is actually bl_pt in the Wall coordinate system *) ; subpanels ; tag= "vertical-box" } @@ -727,15 +719,8 @@ module Panel = struct 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) - ) + resolve_panels events panel.subpanels + >|= fun pl -> pane_box Box2.br_pt pl ) (* br_pt is actually tr_pt in the Wall coordinate system *) ; subpanels ; tag= "horizontal-box" } @@ -744,14 +729,8 @@ module Panel = struct 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 - >>= fun pl -> Lwt.return (panel, pane_box Box2.o pl) ) + resolve_panels events panel.subpanels + >|= fun pl -> pane_box Box2.o pl ) ; subpanels ; tag= "origin-box" } @@ -853,33 +832,22 @@ module Panel = struct | Output_string s -> Format.pp_print_string ppf s | Output_spaces n | Output_indent n -> Format.pp_print_string ppf (String.make n ' ')) - buf - - let out_funs_of_sob sob = - Format. - { out_string= - (fun s p n -> - add_symbolic_output_item sob - (Output_string (String.sub s p n)) ) - ; out_flush= - (fun () -> add_symbolic_output_item sob Output_flush) - ; out_indent= - (fun n -> add_symbolic_output_item sob (Output_indent n)) - ; out_newline= - (fun () -> add_symbolic_output_item sob Output_newline) - ; out_spaces= - (fun n -> add_symbolic_output_item sob (Output_spaces n)) } + (Format.get_symbolic_output_buffer buf) let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print") fpp = Lwt.return - { act= - (fun panel _events -> Lwt.return (panel, draw_pp height fpp)) + { act= (fun _panel _events -> Lwt.return (draw_pp height fpp)) ; subpanels= [] ; tag } module Textedit = struct - let bindings = + type t = + { mutable zed: unit Zed_edit.context + ; mutable view: Zed_cursor.t + ; mutable keybind: Input.Bind.state } + + let bindings te = let open Input.Bind in add [([], Code Left)] [Zed Prev_char] @@ add [([], Code Right)] [Zed Next_char] @@ -918,12 +886,26 @@ module Panel = struct @@ add [([Meta], Char 'd')] [Zed Kill_next_word] @@ add [([Ctrl], Char '/')] [Zed Undo] @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] + @@ add + [([Ctrl], Char 'v')] + [ Custom + (fun () -> + let r = Zed_edit.text (Zed_edit.edit te.zed) in + let l = Zed_lines.of_rope r in + let i = Zed_cursor.get_line te.view in + Zed_cursor.goto te.view + (Zed_lines.line_start l i + 10) ) ] + @@ add + [([Meta], Char 'v')] + [ Custom + (fun () -> + let r = Zed_edit.text (Zed_edit.edit te.zed) in + let l = Zed_lines.of_rope r in + let i = Zed_cursor.get_line te.view in + Zed_cursor.goto te.view + (Zed_lines.line_start l i - 10) ) ] @@ empty - type t = - { mutable zed: unit Zed_edit.context - ; mutable keybind: Input.Bind.state } - let clear te = let ze = Zed_edit.create () in te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze) @@ -940,13 +922,16 @@ module Panel = struct let ze = Zed_edit.create () in let te = { zed= Zed_edit.context ze (Zed_edit.new_cursor ze) - ; keybind= Input.Bind.init keybinds } in - insert te initialtext ; te + ; view= Zed_edit.new_cursor ze + ; keybind= Input.Bind.init Input.Bind.empty } in + te.keybind.bindings <- keybinds te ; + insert te initialtext ; + te let panel ?(height = !g_text_height) te = Lwt.return { act= - (fun panel events -> + (fun _panel events -> (* collect events and update Zed context *) Lwt_list.iter_s (function @@ -986,27 +971,39 @@ module Panel = struct >>= fun () -> let draw_textedit = draw_pp height (fun pp -> - let zrb, zra = + let _, view = 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 + (Zed_cursor.get_position te.view) 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 ; + if + Zed_cursor.get_position te.view + > Zed_cursor.get_position + (Zed_edit.cursor te.zed) + then ( + 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 + 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 ) + else + F.text pp + (Zed_string.to_utf8 (Zed_rope.to_string view)) ; F.pf pp "@." ; Format.pp_close_box pp () ) in - Lwt.return (panel, draw_textedit) ) + Lwt.return draw_textedit ) ; subpanels= [] ; tag= "textedit" } @@ -1015,40 +1012,865 @@ module Panel = struct = Lwt.return { act= - (fun panel _events -> + (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 () ) ) ) + (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 InuitTextedit = struct + open Format + + type 'a clickable = [> `Clickable | `Clicked] as 'a + type 'a editable = [> `Editable | `Prompt] as 'a + + module Patch = struct + type symbols = symbolic_output_item list + + type operation = + | Remove of int + | Insert of symbols + | Replace of int * symbols + | Propertize of int + + type 'flags t = + { offset: int (** Starting at [offset]'th unicode sequence *) + ; operation: operation + ; text_len: int + ; flags: 'flags list + (** A list of backend defined [flags]. *) } + + let make ~offset flags operation = + { flags + ; offset + ; operation + ; text_len= + ( match operation with + | Insert text | Replace (_, text) -> List.length text + | _ -> 0 ) } + + let with_flags flags t = + if t.flags == flags then t else {t with flags} + + let removed t = + match t.operation with + | Insert _ | Propertize _ -> 0 + | Remove n | Replace (n, _) -> n + + let inserted t = + match t.operation with + | Insert _ | Replace _ -> t.text_len + | Propertize _ | Remove _ -> 0 + + let inserted_text t = + match t.operation with + | Insert txt | Replace (_, txt) -> txt + | Propertize _ | Remove _ -> [] + end + + type 'flags patch = 'flags Patch.t + type side = [`Local | `Remote] + + let cons_some x xs = match x with None -> xs | Some x -> x :: xs + + module Socket = Inuit.Socket + + module Region = struct + type status = Ready | Locked + + type 'flags t = + { buffer: 'flags buffer + ; left: Trope.cursor + ; right: Trope.cursor + ; parent: 'flags t + ; observers: + ( side + -> 'flags patch + -> 'flags list * (unit -> unit) option ) + lazy_t + list + ; mutable closed: bool } + + and 'flags buffer = + { mutable trope: 'flags t Trope.t + ; mutable status: status + ; mutable socket: 'flags Patch.t Socket.controller } + + let unsafe_left_offset t = Trope.position t.buffer.trope t.left + + let unsafe_right_offset t = + Trope.position t.buffer.trope t.right + + let is_open t = + (not t.closed) + && ( Trope.member t.buffer.trope t.right + || + ( t.closed <- true ; + false ) ) + + let is_closed t = not (is_open t) + + let notify_observers buffer side region ~stop_at patch = + assert (buffer.status = Ready) ; + let rec aux patch acc = function + | [] -> acc + | fs when fs == stop_at -> acc + | (lazy f) :: fs -> + let flags, f' = f side patch in + let patch = Patch.with_flags flags patch in + let acc = cons_some f' acc in + aux patch acc fs in + buffer.status <- Locked ; + let fs = + try aux patch [] region.observers + with exn -> + buffer.status <- Ready ; + raise exn in + buffer.status <- Ready ; + fs + + let exec_observed fs = List.iter (fun f -> f ()) fs + + let check_local_change name buffer = + match buffer.status with + | Locked -> + invalid_arg + ( "Inuit_base.Region." ^ name + ^ ": attempt to change locked buffer (buffer under \ + observation)" ) + | Ready -> () + + let region_parent region = + let parent = region.parent in + if parent == region then None else Some parent + + let region_before trope cursor = + match Trope.find trope cursor with + | region when region.right == cursor -> Some region + | region -> region_parent region + | exception Not_found -> None + + let region_after trope cursor = + match Trope.find trope cursor with + | region when region.left == cursor -> Some region + | region -> region_parent region + | exception Not_found -> None + + let rec look_for_empty trope position cursor0 = + match Trope.seek_before trope cursor0 with + | Some (cursor, region) + when Trope.position trope cursor = position -> + if region.right == cursor0 then Some cursor + else look_for_empty trope position cursor + | _ -> None + + let insertion_cursor ~left_leaning trope position = + match Trope.find_before trope position with + | None -> (position, None) + | Some (cursor0, region) -> ( + match position - Trope.position trope cursor0 with + | n when n < 0 -> assert false + | 0 when left_leaning -> ( + match look_for_empty trope position cursor0 with + | Some cursor -> (0, Some cursor) + | None -> ( + if region.left == cursor0 then (0, Some cursor0) + else + match Trope.seek_before trope cursor0 with + | None -> (position, None) + | Some (cursor, _) -> + ( position - Trope.position trope cursor + , Some cursor ) ) ) + | n -> (n, Some cursor0) ) + + let replacement_bound trope position = + match Trope.find_after trope position with + | None -> None + | Some (cursor, _region) -> + Some (Trope.position trope cursor - position, cursor) + + let ancestor_region l r = + let rec aux l r = + let c = Trope.compare l.left r.left in + if c < 0 then + match region_parent r with + | None -> None + | Some r' -> aux l r' + else if c > 0 then + match region_parent l with + | None -> None + | Some l' -> aux l' r + else Some l in + aux l r + + let remote_replace b ({Patch.offset; _} as patch) old_len + new_len = + let trope = b.trope in + (* Find bounds *) + let left_offset, left_cursor = + insertion_cursor ~left_leaning:true trope offset in + let right_bound = replacement_bound trope (offset + old_len) in + (* Find affected regions and ancestor *) + let left_region = + match left_cursor with + | None -> None + | Some c -> region_after trope c in + let right_region = + match right_bound with + | None -> None + | Some (_, c) -> region_before trope c in + let ancestor = + match (left_region, right_region) with + | None, _ | _, None -> None + | Some l, Some r -> ancestor_region l r in + (* Notify observers *) + let left_o = + match left_region with + | None -> [] + | Some region -> + notify_observers b `Remote region ~stop_at:[] patch + and right_o = + match right_region with + | None -> [] + | Some right -> + let stop_at = + match ancestor with + | None -> [] + | Some region -> region.observers in + notify_observers b `Remote right ~stop_at patch in + (* Update trope *) + let trope = + let trope = + match (left_cursor, right_bound) with + | Some l, Some (_, r) -> Trope.remove_between trope l r + | Some l, None -> + Trope.remove_after trope l (left_offset + old_len) + | None, Some (right_offset, r) -> + Trope.remove_before trope r + (left_offset + old_len + right_offset) + | None, None -> + Trope.remove trope ~at:0 ~len:(left_offset + old_len) + in + (* Reinsert cursors *) + let check = + match ancestor with + | None -> fun _ -> true + | Some region -> ( != ) region in + let rec reinsert_from_left trope = function + | Some region when check region -> + reinsert_from_left + (Trope.put_left trope region.right region) + (region_parent region) + | _ -> trope in + let rec reinsert_from_right trope = function + | Some region when check region -> + reinsert_from_right + (Trope.put_left trope region.left region) + (region_parent region) + | _ -> trope in + let trope = reinsert_from_left trope left_region in + let trope = reinsert_from_right trope right_region in + (* Fix padding *) + let trope = + match right_bound with + | None -> trope + | Some (offset, r) -> Trope.insert_before trope r offset + in + let trope = + match left_cursor with + | None -> + Trope.insert trope ~at:0 ~len:(left_offset + new_len) + | Some c -> + Trope.insert_after trope c (left_offset + new_len) + in + trope in + b.trope <- trope ; + exec_observed right_o ; + exec_observed left_o + + let remote_propertize b ({Patch.offset; _} as patch) len = + let trope = b.trope in + (* Find bounds *) + let _left_offset, left_cursor = + insertion_cursor ~left_leaning:false trope offset in + let right_bound = replacement_bound trope (offset + len) in + (* Find affected regions and ancestor *) + let left_region = + match left_cursor with + | None -> None + | Some c -> region_after trope c in + let right_region = + match right_bound with + | None -> None + | Some (_, c) -> region_before trope c in + let ancestor = + match (left_region, right_region) with + | None, _ | _, None -> None + | Some l, Some r -> ancestor_region l r in + (* Notify observers *) + let left_o = + match left_region with + | None -> [] + | Some region -> + notify_observers b `Remote region ~stop_at:[] patch + and right_o = + match right_region with + | None -> [] + | Some right -> + let stop_at = + match ancestor with + | None -> [] + | Some region -> region.observers in + notify_observers b `Remote right ~stop_at patch in + exec_observed right_o ; exec_observed left_o + + let remote_insert b ({Patch.offset; _} as patch) new_len = + let trope = b.trope in + let left_offset, left_cursor = + insertion_cursor ~left_leaning:true trope offset in + let left_region = + match left_cursor with + | None -> None + | Some cursor -> region_after trope cursor in + let trope = + match left_cursor with + | None -> Trope.insert trope ~at:left_offset ~len:new_len + | Some cursor -> Trope.insert_after trope cursor new_len + in + let observed = + match left_region with + | None -> [] + | Some region -> + notify_observers b `Remote region ~stop_at:[] patch + in + b.trope <- trope ; + exec_observed observed + + let remote_change b patch = + match b.status with + | Locked -> + invalid_arg + "Inuit_base.Region.remote_change: attempt to change \ + locked buffer (buffer under observation)" + | Ready -> ( + let {Patch.operation; offset= _; text_len; flags= _} = + patch in + match operation with + | Patch.Remove n -> remote_replace b patch n 0 + | Patch.Replace (n, _) -> + remote_replace b patch n text_len + | Patch.Insert _ -> remote_insert b patch text_len + | Patch.Propertize n -> remote_propertize b patch n ) + + let append t flags text = + if is_open t then ( + let buffer = t.buffer in + check_local_change "append" buffer ; + let trope = buffer.trope in + let offset = Trope.position trope t.right in + let patch = Patch.make ~offset flags (Patch.Insert text) in + let observed = + notify_observers buffer `Local t ~stop_at:[] patch in + buffer.trope <- + Trope.insert_before trope t.right patch.Patch.text_len ; + Socket.send buffer.socket patch ; + exec_observed observed ) + + let generic_clear f t = + if is_open t then ( + let buffer = t.buffer in + check_local_change "clear" buffer ; + let trope = buffer.trope in + let offset = Trope.position trope t.left in + let length = Trope.position trope t.right - offset in + let patch = Patch.make ~offset [] (Patch.Remove length) in + let observed = + notify_observers buffer `Local t ~stop_at:[] patch in + buffer.trope <- f t buffer.trope ; + Socket.send buffer.socket patch ; + exec_observed observed ) + + let clear t = + generic_clear + (fun t trope -> Trope.remove_between trope t.left t.right) + t + + let kill t = + generic_clear + (fun t trope -> + let trope = Trope.remove_between trope t.left t.right in + let trope = Trope.rem_cursor trope t.left in + let trope = Trope.rem_cursor trope t.right in + trope ) + t + + let propertize flags t = + if is_open t then ( + let buffer = t.buffer in + let trope = buffer.trope in + let offset = Trope.position trope t.left in + let length = Trope.position trope t.right - offset in + let patch = + Patch.make ~offset flags (Patch.Propertize length) in + let observed = + notify_observers buffer `Local t ~stop_at:[] patch in + Socket.send buffer.socket patch ; + exec_observed observed ) + + let sub ?(at = `Right) ?observer parent = + if is_open parent then ( + let left = + match at with + | `Before -> Trope.cursor_before parent.left + | `Left -> Trope.cursor_after parent.left + | `Right -> Trope.cursor_before parent.right + | `After -> Trope.cursor_after parent.right in + let right = Trope.cursor_after left in + let parent = + match at with + | `Before | `After -> parent.parent + | `Left | `Right -> parent in + let buffer = parent.buffer in + let t' = + match observer with + | None -> + { left + ; right + ; parent + ; buffer + ; closed= false + ; observers= parent.observers } + | Some observer -> + let rec t' = + { left + ; right + ; parent + ; buffer + ; closed= false + ; observers= lazy (observer t') :: parent.observers + } in + t' in + let trope = buffer.trope in + let trope = + match at with + | `Right | `Before -> Trope.put_right trope left t' + | `Left | `After -> Trope.put_left trope left t' in + buffer.trope <- Trope.put_left trope right t' ; + (match t'.observers with [] -> () | (lazy _x) :: _ -> ()) ; + t' ) + else parent + + let make () = + let socket = Socket.make ~receive:ignore in + let trope = Trope.create () in + let left = Trope.cursor_at_origin trope in + let right = Trope.cursor_after left in + let rec t' = + { left + ; right + ; buffer= {trope; status= Ready; socket} + ; closed= false + ; parent= t' + ; observers= [] } in + let buffer = t'.buffer in + buffer.trope <- + Trope.put_left (Trope.put_left trope left t') right t' ; + Socket.set_receive socket (remote_change buffer) ; + Socket.set_on_closed socket (fun () -> + buffer.trope <- Trope.clear buffer.trope ) ; + (t', Socket.endpoint socket) + + type 'flags observer = + 'flags t + -> side + -> 'flags patch + -> 'flags list * (unit -> unit) option + end + + module Inuit_region = Region + + module Cursor = struct + type 'flags cursor = + { region: 'flags Inuit_region.t + ; flags: 'flags list + ; indent: int } + + type 'flags clickable = [> `Clickable | `Clicked] as 'flags + + let count_char str chr = + let count = ref 0 in + for i = 0 to String.length str - 1 do + if str.[i] = chr then incr count + done ; + !count + + let indent_text col text = + if col <= 0 then text + else + List.flatten + (List.map + (function + | Format.Output_newline as r -> + [r; Format.Output_indent col] + | x -> [x] ) + text ) + + let text t ?(flags = t.flags) text = + Inuit_region.append t.region flags (indent_text t.indent text) + + let clear t = Inuit_region.clear t.region + let kill t = Inuit_region.kill t.region + let sub t = {t with region= Inuit_region.sub t.region} + + let observe {region; flags; indent} f = + let observer region = + let t' = {region; flags; indent} in + fun side patch -> f t' side patch in + {region= Inuit_region.sub ~observer region; flags; indent} + + let is_closed t = Inuit_region.is_closed t.region + let mem_flag flag cursor = List.mem flag cursor.flags + + let add_flag flag cursor = + if mem_flag flag cursor then cursor + else {cursor with flags= flag :: cursor.flags} + + let rem_flag flag cursor = + if mem_flag flag cursor then + {cursor with flags= List.filter (( <> ) flag) cursor.flags} + else cursor + + let get_flags t = t.flags + let with_flags flags t = {t with flags} + let region t = t.region + + let clickable t f = + let t = add_flag `Clickable t in + observe t (fun t' _side patch -> + let {Patch.flags; offset; _} = patch in + if + Inuit_region.unsafe_right_offset t'.region > offset + && List.mem `Clicked flags + then + ( List.filter (( <> ) `Clicked) flags + , Some (fun () -> f t') ) + else (flags, None) ) + + let printf t ?flags fmt = + let sob = Format.make_symbolic_output_buffer () in + let pp = Format.formatter_of_symbolic_output_buffer sob in + Format.fprintf pp fmt ; + Format.pp_print_flush pp () ; + List.iter + (function + | Output_string s -> F.epr "printf: %s @." s | _ -> () ) + (Format.flush_symbolic_output_buffer sob) ; + text t ?flags (Format.flush_symbolic_output_buffer sob) + + let link t ?flags fmt f = + let sob = Format.make_symbolic_output_buffer () in + let pp = Format.formatter_of_symbolic_output_buffer sob in + Format.fprintf pp fmt ; + Format.pp_print_flush pp () ; + text (clickable t f) ?flags + (Format.flush_symbolic_output_buffer sob) + + let cursor_of_region ?(flags = []) ?(indent = 0) region = + {region; flags; indent} + + let make () = + let region, pipe = Inuit_region.make () in + (cursor_of_region region, pipe) + + let get_indent t = t.indent + let with_indent t indent = {t with indent} + + let shift_indent t indent = + {t with indent= max 0 (t.indent + indent)} + end + + module Edit = struct + open Cursor + + type 'flags t = + { mutable cursor: 'flags cursor + ; mutable state: Format.symbolic_output_buffer } + + let rec list_split i ?(left = []) = function + | [] -> (left, []) + | x :: xs -> + if i <= 0 then (left, x :: xs) + else list_split (i - 1) ~left:(left @ [x]) xs + + let make ?(state = []) ?on_change cursor = + let t = + {cursor; state= Format.make_symbolic_output_buffer ()} in + let on_change = + match on_change with + | None -> None + | Some f -> Some (fun _ -> f t) in + printf (add_flag `Prompt cursor) "# " ; + t.cursor <- + observe cursor (fun cursor' side p -> + let s = Format.flush_symbolic_output_buffer t.state in + let offset = + p.Patch.offset + - Inuit_region.unsafe_left_offset (region cursor') + in + let sl, sr = list_split offset s in + List.iter + (Format.add_symbolic_output_item t.state) + (sl @ Patch.inserted_text p @ sr) ; + let callback = + if side = `Remote then on_change else None in + (p.Patch.flags, callback) ) ; + text t.cursor state ; + t + + let change t ~state = clear t.cursor ; text t.cursor state + let state t = t.state + end + + module Nav = struct + open Cursor + + type 'flags t = + { mutable prev: 'flags page list + ; mutable page: 'flags page + ; mutable next: 'flags page list + ; frame: 'flags frame option } + + and 'flags page = + Format.symbolic_output_buffer * ('flags frame -> unit) + + and 'flags frame = + {title: 'flags cursor; body: 'flags cursor; nav: 'flags t} + + let make title body = + let page = (title, body) in + {prev= []; page; next= []; frame= None} + + let update_frame t = + match t.frame with + | None -> () + | Some frame -> + let {title; body; nav= _} = frame in + clear title ; + text title + (Format.get_symbolic_output_buffer (fst t.page)) ; + clear body ; + (snd t.page) frame + + let goto t title body = + t.page <- (title, body) ; + t.next <- [] ; + update_frame t + + let push t title body = + t.prev <- t.page :: t.prev ; + goto t title body + + let next t = + match t.next with + | [] -> () + | page :: pages -> + t.prev <- t.page :: t.prev ; + t.page <- page ; + t.next <- pages ; + update_frame t + + let prev t = + match t.prev with + | [] -> () + | page :: pages -> + t.next <- t.page :: t.next ; + t.page <- page ; + t.prev <- pages ; + update_frame t + + let render_header t cursor = + (*⏪*) + (*↻*) + (*⏩*) + link cursor "[<<]" (fun _ -> prev t) ; + text cursor [Output_string " "] ; + link cursor "[reload]" (fun _ -> update_frame t) ; + text cursor [Output_string " "] ; + link cursor "[>>]" (fun _ -> next t) + + let render t cursor = + let open Cursor in + if not (is_closed cursor) then ( + let header = sub cursor in + printf cursor " " ; + let title = sub cursor in + printf cursor "\n\n" ; + let body = sub cursor in + let rec nav = {t with frame= Some frame} + and frame = {title; body; nav} in + render_header nav header ; + update_frame nav ) + end + + type flag = + [ `Clickable + | `Clicked + | `Editable + | `Prompt + | `Focus + | `Custom of string ] + + type t = + { edit: flag Cursor.cursor + ; sock: flag Patch.t Socket.t + ; view: flag Nav.t + ; bind: Input.Bind.state } + + let clear t = Cursor.clear t.edit + let insert t = Cursor.text t.edit + + let contents t : Format.symbolic_output_buffer = + (t.view.page.) + + let pr s = + let sob = make_symbolic_output_buffer () in + let pp = formatter_of_symbolic_output_buffer sob in + F.pf pp s ; sob + + let bindings _t = + let open Input.Bind in + add [([], Code Left)] [Zed Prev_char] + @@ add [([], Code Right)] [Zed Next_char] + @@ add [([], Code Up)] [Zed Prev_line] + @@ add [([], Code Down)] [Zed Next_line] + @@ add [([], Code Home)] [Zed Goto_bol] + @@ add [([], Code End)] [Zed Goto_eol] + @@ add [([], Code Insert)] [Zed Switch_erase_mode] + @@ add [([], Code Delete)] [Zed Delete_next_char] + @@ add [([], Code Enter)] [Zed Newline] + @@ add [([Ctrl], Char ' ')] [Zed Set_mark] + @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] + @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] + @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] + @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] + @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] + @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] + @@ add [([Ctrl], Char 'n')] [Zed Next_line] + @@ add [([Ctrl], Char 'p')] [Zed Prev_line] + @@ add [([Ctrl], Char 'w')] [Zed Kill] + @@ add [([Ctrl], Char 'y')] [Zed Yank] + @@ add [([], Code Backspace)] [Zed Delete_prev_char] + @@ add [([Meta], Char 'w')] [Zed Copy] + @@ add [([Meta], Char 'c')] [Zed Capitalize_word] + @@ add [([Meta], Char 'l')] [Zed Lowercase_word] + @@ add [([Meta], Char 'u')] [Zed Uppercase_word] + @@ add [([Meta], Char 'b')] [Zed Prev_word] + @@ add [([Meta], Char 'f')] [Zed Next_word] + @@ add [([Meta], Code Right)] [Zed Next_word] + @@ add [([Meta], Code Left)] [Zed Prev_word] + @@ add [([Ctrl], Code Right)] [Zed Next_word] + @@ add [([Ctrl], Code Left)] [Zed Prev_word] + @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word] + @@ add [([Meta], Code Delete)] [Zed Kill_prev_word] + @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word] + @@ add [([Meta], Char 'd')] [Zed Kill_next_word] + @@ add [([Ctrl], Char '/')] [Zed Undo] + @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] + @@ add [([Ctrl], Char 'v')] [Custom (fun () -> ())] + @@ add [([Meta], Char 'v')] [Custom (fun () -> ())] + @@ empty + + let make ?(bindings = bindings) title main = + let sob = Format.make_symbolic_output_buffer () in + let edit, sock = Cursor.make () in + let sock' = Socket.make ~receive:ignore in + Socket.connect + ~a:(Socket.endpoint sock) + ~b:(Socket.endpoint sock') ; + + let t = + { edit + ; sock + ; buff = sob + ; view= + ( Nav.make title + @@ fun {Nav.title= _; body; nav} -> + let open Cursor in + printf body "Je mens.\n\n" ; + link body "- C'est vrai." (fun _ -> + Nav.push nav (pr "C'est vrai !") + @@ fun {Nav.body; _} -> printf body "C'est faux." ) ; + printf body "\n" ; + link body "- C'est faux." (fun _ -> + Nav.push nav (pr "C'est faux !") + @@ fun {Nav.body; _} -> printf body "C'est vrai." ) ; + printf body "\n" ; + printf body main ) + ; bind= Input.Bind.init Input.Bind.empty } in + t.bind.bindings <- bindings t ; + t + + let panel ?(height = !g_text_height) t = + Lwt.return + { act= + (fun _panel events -> + (* collect events and update Zed context *) + let open Input.Bind in + Lwt_list.iter_s + (function + | Custom f -> f () ; Lwt.return_unit + | CustomLwt f -> f () + | _ -> Lwt.return_unit ) + (actions_of_events t.bind events) + >>= fun () -> + Lwt_list.iter_s + (function + | `Text_input _s -> Lwt.return_unit + | _ -> Lwt.return_unit ) + events + >>= fun () -> + Nav.render t.view t.edit ; + Lwt.return + (draw_pp height (fun pp -> + Format.pp_open_hvbox pp 0 ; + F.epr "format_symbolic_output_buffer: @." ; + format_symbolic_output_buffer F.stderr + (contents t) ; + format_symbolic_output_buffer pp (contents t) ; + F.pf pp "@." ; + F.epr "@." ; + Format.pp_close_box pp () ) ) ) + ; subpanels= [] + ; tag= "textedit" } + end + module Modal = struct type t = { te: Textedit.t @@ -1071,7 +1893,7 @@ module Panel = struct (* set input first so a modal can trigger another modal *) me.input <- None ; me.handle (Textedit.contents me.te) ) ] - Textedit.bindings in + (Textedit.bindings me.te) in me.te.keybind.bindings <- keybinds ; Lwt.return { act= @@ -1080,7 +1902,7 @@ module Panel = struct | Some text -> Textedit.insert me.te text ; hbox panel.subpanels >>= fun p -> p.act panel events - | None -> Lwt.return (panel, Display.pane_empty) + | None -> Lwt.return Display.pane_empty (* don't draw anything if modal isn't active *) ) ; subpanels= [ prettyprint (fun pp -> F.text pp me.prompt) @@ -1118,7 +1940,7 @@ module Toplevel = struct let b = Buffer.create 69 in Panel.format_symbolic_output_buffer (Format.formatter_of_buffer b) - (Format.get_symbolic_output_buffer t.res) + t.res with e -> F.pf ppf "Exception in pane_top//eval@." ; Location.report_exception ppf e ; @@ -1255,7 +2077,7 @@ module Store = struct [ Custom (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ] - Panel.Textedit.bindings in + (Panel.Textedit.bindings te) in te.keybind.bindings <- editbinds ; let is_node path = Istore.get_tree sv.store sv.view @@ -1409,8 +2231,7 @@ module Store = struct (Panel.Modal.panel modalstate) ; Panel.hbox [ Panel.prettyprint (fun pp -> - Panel.format_symbolic_output_buffer pp - (Format.get_symbolic_output_buffer sv.sob) ) + Panel.format_symbolic_output_buffer pp sv.sob ) ; Panel.vbox [ Panel.filter_events (fun ev -> if sv.editmode then ev else []) @@ -1418,8 +2239,7 @@ module Store = struct ; 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) ) ; + (Toplevel.result_sob top) ; Format.pp_close_box pp () ; F.flush pp () ) ] ] ; Panel.Textedit.bindingstate bindstate @@ -1438,7 +2258,14 @@ let std_actor (root_panel : Panel.t Lwt.t) = let root_actor = ref (std_actor (Store.editor "../rootstore")) +open Panel + +let inuit_test = + let t = InuitTextedit.make (Format.make_symbolic_output_buffer ()) in + InuitTextedit.panel (t " TEST @. What @. Help @.") + let start () = + root_actor := std_actor inuit_test ; Display.( run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ()) diff --git a/irc.ml b/irc.ml index 5a42fe6..4df3b52 100644 --- a/irc.ml +++ b/irc.ml @@ -22,25 +22,22 @@ module Communicator = struct type channel = { mutable name: string ; mutable content: msg list - ; mutable sender: string -> unit } + ; mutable recv: msg -> unit } let add_msg (c : channel) msg = c.content <- msg :: c.content - type c = {mutable channel: channel; mutable subs: c list} + type t = {mutable channel: channel; mutable subs: t list} type protocol = Irc | Email | Rss | Mublog - let make_channel (c : c) ?(sender = fun _ -> ()) name = - c.subs <- - {channel= {name; content= []; sender}; subs= []} :: c.subs + let make_channel ?(recv = add_msg) name = + let c = {name; content= []; recv= (fun _ -> ())} in + {c with recv= recv c} - let make () : c = - let c = - { name= "top" - ; content= [create_msg "Wecome to the Communicator"] - ; sender= (fun _ -> ()) } in - c.sender <- (fun s -> c.content <- create_msg s :: c.content) ; - c.sender "Currently only IRC is implemented" ; - {channel= c; subs= []} + let make () : t = + let channel = make_channel "top" in + channel.recv (create_msg "Wecome to the Communicator") ; + channel.recv (create_msg "Currently only IRC is implemented") ; + {channel; subs= []} type connection = unit Lwt.t @@ -48,7 +45,7 @@ module Communicator = struct module C = Irc_client_tls module M = Irc_message - let connection (c : c) server port nick channels : unit Lwt.t = + let connection (c : t) server port nick channels : unit Lwt.t = let add_msg cn str = add_msg cn.channel (create_msg str) in C.reconnect_loop ~after:30 ~connect:(fun () -> @@ -88,12 +85,22 @@ module Communicator = struct end module Panel = struct - let panel c = - Panel.prettyprint ~height:20. ~tag:"Communicator" (fun pp -> - F.pf pp " <><><> COMMUNICATOR <><><> @.@." ; - List.iter - (fun msg -> F.pf pp "[%s] %s@." msg.time msg.content) - (List.rev c.channel.content) ) + let panel (c : t) = + let open Panel in + let te = Textedit.make "" () in + Textedit.panel ~height:20. te + >>= fun p -> + Lwt.return + { p with + act= + (fun panel events -> + Textedit.clear te ; + List.iter + (fun m -> + Textedit.insert te + (F.str "[%s] %s\n" m.time m.content) ) + c.channel.content ; + p.act panel events ) } end end