From 8ee3789cb9125900cbc588d5409cb6590dabdc58 Mon Sep 17 00:00:00 2001 From: cqc Date: Mon, 8 Nov 2021 22:27:47 -0600 Subject: [PATCH] mr. derpsalot derps more; refactored the ui widget thing again... --- dune | 5 + human.ml | 1718 ++++++++++++++++++++++++++---------------------------- irc.ml | 76 +-- 3 files changed, 874 insertions(+), 925 deletions(-) diff --git a/dune b/dune index 2f86cfe..c41da22 100644 --- a/dune +++ b/dune @@ -15,7 +15,12 @@ zed lambda-term irmin-unix + nottui nottui-pretty + uuseg.string + grenier.trope + uutf + uucp ocaml-compiler-libs.common ocaml-compiler-libs.bytecomp ocaml-compiler-libs.toplevel)) diff --git a/human.ml b/human.ml index 018d98d..e382df4 100644 --- a/human.ml +++ b/human.ml @@ -19,41 +19,25 @@ some options: open Lwt.Infix module F = Fmt +module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String) -module Input = struct - open CamomileLibrary +module Key = struct + type special = + [ `Enter + | `Escape + | `Tab + | `Arrow of [`Up | `Down | `Left | `Right] + | `Function of int + | `Page of [`Up | `Down] + | `Home + | `End + | `Insert + | `Delete + | `Backspace ] (** Type of key code. *) type code = - | UChar of UChar.t (** A unicode character. *) - | Enter - | Escape - | Tab - | Up - | Down - | Left - | Right - | F1 - | F2 - | F3 - | F4 - | F5 - | F6 - | F7 - | F8 - | F9 - | F10 - | F11 - | F12 - | Next_page - | Prev_page - | Home - | End - | Insert - | Delete - | Backspace - | Unknown - | None + [`Uchar of Uchar.t (** A unicode character. *) | special] type keystate = {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} @@ -61,7 +45,7 @@ module Input = struct type mods = Ctrl | Meta | Super | Shift type key = Char of char | Code of code - module Key = struct + module KeyS = struct type t = keystate let compare = compare @@ -69,7 +53,7 @@ module Input = struct module Bind = struct (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) - module S = Zed_input.Make (Key) + module S = Zed_input.Make (KeyS) type action = | Custom of (unit -> unit) @@ -107,7 +91,7 @@ module Input = struct ; shift= false ; code= ( match k with - | Char c -> UChar (UChar.of_char c) + | Char c -> `Uchar (Uchar.of_char c) | Code c -> c ) } m ) events in @@ -128,9 +112,8 @@ module Input = struct List.flatten (List.filter_map (fun e -> - (*F.epr "action_of_events: %s@." (to_string e) ;*) match e with - | `Key_down (k : keystate) -> ( + | `Key (`Press, (k : keystate)) -> ( ( match state.state with | Continue _ -> () | _ -> state.last_keyseq <- [] ) ; @@ -161,35 +144,24 @@ module Input = struct (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function - | UChar ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch) - | Enter -> "Enter" - | Escape -> "Escape" - | Tab -> "Tab" - | Up -> "Up" - | Down -> "Down" - | Left -> "Left" - | Right -> "Right" - | F1 -> "F1" - | F2 -> "F2" - | F3 -> "F3" - | F4 -> "F4" - | F5 -> "F5" - | F6 -> "F6" - | F7 -> "F7" - | F8 -> "F8" - | F9 -> "F9" - | F10 -> "F10" - | F11 -> "F11" - | F12 -> "F12" - | Next_page -> "Next_page" - | Prev_page -> "Prev_page" - | Home -> "Home" - | End -> "End" - | Insert -> "Insert" - | Delete -> "Delete" - | Backspace -> "Backspace" - | Unknown -> "Unknown" - | None -> "None" + | `Uchar ch -> + if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch) + else F.str "Char 0x%02x" (Uchar.to_int ch) + | `Enter -> "Enter" + | `Escape -> "Escape" + | `Tab -> "Tab" + | `Arrow `Up -> "Up" + | `Arrow `Down -> "Down" + | `Arrow `Left -> "Left" + | `Arrow `Right -> "Right" + | `Function i -> F.str "F%d" i + | `Page `Up -> "Page Up" + | `Page `Down -> "Page Down" + | `Home -> "Home" + | `End -> "End" + | `Insert -> "Insert" + | `Delete -> "Delete" + | `Backspace -> "Backspace" let to_string key = Printf.sprintf @@ -204,10 +176,10 @@ module Input = struct if key.shift then Buffer.add_string buffer "Shift-" ; if key.super then Buffer.add_string buffer "Super-" ; ( match key.code with - | UChar ch -> - let code = UChar.code ch in - if code <= 255 then - match Char.chr code with + | `Uchar ch -> + let code = Uchar.to_int ch in + if Uchar.is_char ch then + match Uchar.to_char ch with | ( 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' @@ -220,8 +192,8 @@ module Input = struct else if code <= 0xffff then Printf.bprintf buffer "U+%04x" code else Printf.bprintf buffer "U+%06x" code - | Next_page -> Buffer.add_string buffer "next" - | Prev_page -> Buffer.add_string buffer "prev" + | `Page `Down -> Buffer.add_string buffer "pgup" + | `Page `Up -> Buffer.add_string buffer "pgdn" | code -> Buffer.add_string buffer (String.lowercase_ascii (string_of_code code)) ) ; @@ -230,161 +202,148 @@ end module Event = struct open Tsdl - open CamomileLibrary - open Input + open Key + open Gg - type mouse = int * int + type mouse = V2.t type t = - [ `Key_down of Input.keystate - | `Key_up of Input.keystate - | `Text_editing of string - | `Text_input of string + [ `Key of [`Press | `Release | `Repeat] * keystate | `Mouse of mouse | `Quit | `Fullscreen of bool - | `Unknown of string - | `None ] + | `Unknown of string ] type events = t list - let string_of_event = function - | `Key_down _ -> "`Key_down" - | `Key_up _ -> "`Key_up" - | `Text_editing _ -> "`Text_editing" - | `Text_input _ -> "`Text_input" - | `Mouse _ -> "`Mouse" + let to_string = function + | `Key (x, k) -> + "`Key " + ^ ( match x with + | `Press -> "`Press " + | `Release -> "`Release " + | `Repeat -> "`Repeat " ) + ^ Key.to_string k + | `Mouse -> "`Mouse" | `Quit -> "`Quit" - | `Fullscreen _ -> "`Fullscreen" - | `Unknown _ -> "`Unknown" - | `None -> "`None" + | `Fullscreen b -> F.str "`Fullscreen %b" b + | `Unknown s -> F.str "`Unknown %s" s - let to_string ev = - let p = - match ev with - | `Key_down k | `Key_up k -> Input.to_string k - | `Text_editing s | `Text_input s -> s - | `Mouse _ -> "" - | `Fullscreen b -> Format.sprintf "%b" b - | `Unknown s -> s - | `Quit | `None -> "" in - string_of_event ev ^ " " ^ p + let sdlkey_map = Hashtbl.create 1024 - let event_of_sdlevent ev = - let key_of_sdlkey ev = - let (kc : Sdl.keycode) = - Sdl.Event.get ev Sdl.Event.keyboard_keycode - land lnot Sdl.K.scancode_mask in - let open Sdl.K in - let (c : Input.code) = - match (kc : Sdl.keycode) with - (* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *) - | x when x = return -> Enter - | x when x = escape -> Escape - | x when x = backspace -> Backspace - | x when x = tab -> Tab - | x when x = f1 -> F1 - | x when x = f2 -> F2 - | x when x = f3 -> F3 - | x when x = f4 -> F4 - | x when x = f5 -> F5 - | x when x = f6 -> F6 - | x when x = f7 -> F7 - | x when x = f8 -> F8 - | x when x = f9 -> F9 - | x when x = f10 -> F10 - | x when x = f11 -> F11 - | x when x = f12 -> F12 - | x when x = insert -> Insert - | x when x = delete -> Delete - | x when x = home -> Home - | x when x = kend -> End - | x when x = pageup -> Prev_page - | x when x = pagedown -> Next_page - | x when x = right -> Right - | x when x = left -> Left - | x when x = down -> Down - | x when x = up -> Up - | k -> ( - match UChar.char_of (UChar.of_int k) with - | 'a' .. 'z' - |'A' .. 'Z' - |'0' .. '9' - |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' - |'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' - |'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"' - |'\'' | '>' | '<' | '^' | '`' | '|' -> - UChar (UChar.of_int k) - | _ -> None ) in - let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in - { code= c - ; ctrl= km land Sdl.Kmod.ctrl > 0 - ; meta= km land Sdl.Kmod.alt > 0 - ; super= km land Sdl.Kmod.gui > 0 - ; shift= km land Sdl.Kmod.shift > 0 } in - let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in - let r = - match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with - | `Text_editing -> - `Unknown - (Format.sprintf "`Text_editing %s" - (Sdl.Event.get ev Sdl.Event.text_editing_text) ) - | `Text_input -> - `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text) - | `Key_down -> - if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None - | `Key_up -> - if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None - | `Mouse_motion -> - let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in - `Mouse mouse_xy - | `Quit -> `Quit - (* Unhandled events *) - | `App_did_enter_background -> - `Unknown "`App_did_enter_background" - | `App_did_enter_foreground -> - `Unknown "`App_did_enter_foreground " - | `App_low_memory -> `Unknown "`App_low_memory " - | `App_terminating -> `Unknown "`App_terminating " - | `App_will_enter_background -> - `Unknown "`App_will_enter_background " - | `App_will_enter_foreground -> - `Unknown "`App_will_enter_foreground " - | `Clipboard_update -> `Unknown "`Clipboard_update " - | `Controller_axis_motion -> `Unknown "`Controller_axis_motion " - | `Controller_button_down -> `Unknown "`Controller_button_down " - | `Controller_button_up -> `Unknown "`Controller_button_up " - | `Controller_device_added -> - `Unknown "`Controller_device_added " - | `Controller_device_remapped -> - `Unknown "`Controller_device_remapped " - | `Controller_device_removed -> - `Unknown "`Controller_device_removed " - | `Dollar_gesture -> `Unknown "`Dollar_gesture " - | `Dollar_record -> `Unknown "`Dollar_record " - | `Drop_file -> `Unknown "`Drop_file " - | `Finger_down -> `Unknown "`Finger_down" - | `Finger_motion -> `Unknown "`Finger_motion " - | `Finger_up -> `Unknown "`Finger_up " - | `Joy_axis_motion -> `Unknown "`Joy_axis_motion " - | `Joy_ball_motion -> `Unknown "`Joy_ball_motion " - | `Joy_button_down -> `Unknown "`Joy_button_down " - | `Joy_button_up -> `Unknown "`Joy_button_up " - | `Joy_device_added -> `Unknown "`Joy_device_added " - | `Joy_device_removed -> `Unknown "`Joy_device_removed " - | `Joy_hat_motion -> `Unknown "`Joy_hat_motion " - | `Mouse_button_down -> `Unknown "`Mouse_button_down " - | `Mouse_button_up -> `Unknown "`Mouse_button_up" - | `Mouse_wheel -> `Unknown "`Mouse_wheel " - | `Multi_gesture -> `Unknown "`Multi_gesture" - | `Sys_wm_event -> `Unknown "`Sys_wm_event " - | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e) - | `User_event -> `Unknown "`User_event " - | `Display_event -> `Unknown "`Display_event " - | `Sensor_update -> `Unknown "`Sensor_update " - | `Window_event -> `Unknown "`Window_event " in - (* F.epr "event_of_sdlevent: %s@." (to_string r) ;*) - r + let () = + let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in + let open Sdl.K in + aa return `Enter ; + aa escape `Escape ; + aa backspace `Backspace ; + aa tab `Tab ; + aa f1 (`Function 1) ; + aa f2 (`Function 2) ; + aa f3 (`Function 3) ; + aa f4 (`Function 4) ; + aa f5 (`Function 5) ; + aa f6 (`Function 6) ; + aa f7 (`Function 7) ; + aa f8 (`Function 8) ; + aa f9 (`Function 9) ; + aa f10 (`Function 10) ; + aa f11 (`Function 11) ; + aa f12 (`Function 12) ; + aa insert `Insert ; + aa delete `Delete ; + aa home `Home ; + aa kend `End ; + aa pageup (`Page `Up) ; + aa pagedown (`Page `Down) ; + aa right (`Arrow `Right) ; + aa left (`Arrow `Left) ; + aa down (`Arrow `Down) ; + aa up (`Arrow `Up) + + let key_of_sdlkey ev = + let (kc : Sdl.keycode) = + Sdl.Event.get ev Sdl.Event.keyboard_keycode + land lnot Sdl.K.scancode_mask in + match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with + | Some s, _ -> Some s + | None, true -> Some (`Uchar (Uchar.of_int kc)) + | None, false -> None + + let event_of_sdlevent ev : t option = + match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with + | (`Key_down | `Key_up) as d -> ( + match key_of_sdlkey ev with + | None -> None + | Some code -> + let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in + Some + (`Key + ( ( match d with + | _ + when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1 + -> + `Repeat + | `Key_up -> `Release + | _ -> `Press ) + , { code + ; ctrl= km land Sdl.Kmod.ctrl > 0 + ; meta= km land Sdl.Kmod.alt > 0 + ; super= km land Sdl.Kmod.gui > 0 + ; shift= km land Sdl.Kmod.shift > 0 } ) ) ) + | `Mouse_motion -> + let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in + Some (`Mouse (V2.v (float x) (float y))) + | `Quit -> Some `Quit + (* Unhandled events *) + | `Text_editing -> Some (`Unknown "`Text_editing") + | `Text_input -> Some (`Unknown "`Text_input") + | `App_did_enter_background -> + Some (`Unknown "`App_did_enter_background") + | `App_did_enter_foreground -> + Some (`Unknown "`App_did_enter_foreground ") + | `App_low_memory -> Some (`Unknown "`App_low_memory ") + | `App_terminating -> Some (`Unknown "`App_terminating ") + | `App_will_enter_background -> + Some (`Unknown "`App_will_enter_background ") + | `App_will_enter_foreground -> + Some (`Unknown "`App_will_enter_foreground ") + | `Clipboard_update -> Some (`Unknown "`Clipboard_update ") + | `Controller_axis_motion -> + Some (`Unknown "`Controller_axis_motion ") + | `Controller_button_down -> + Some (`Unknown "`Controller_button_down ") + | `Controller_button_up -> Some (`Unknown "`Controller_button_up ") + | `Controller_device_added -> + Some (`Unknown "`Controller_device_added ") + | `Controller_device_remapped -> + Some (`Unknown "`Controller_device_remapped ") + | `Controller_device_removed -> + Some (`Unknown "`Controller_device_removed ") + | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ") + | `Dollar_record -> Some (`Unknown "`Dollar_record ") + | `Drop_file -> Some (`Unknown "`Drop_file ") + | `Finger_down -> Some (`Unknown "`Finger_down") + | `Finger_motion -> Some (`Unknown "`Finger_motion ") + | `Finger_up -> Some (`Unknown "`Finger_up ") + | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ") + | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ") + | `Joy_button_down -> Some (`Unknown "`Joy_button_down ") + | `Joy_button_up -> Some (`Unknown "`Joy_button_up ") + | `Joy_device_added -> Some (`Unknown "`Joy_device_added ") + | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ") + | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ") + | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ") + | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up") + | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ") + | `Multi_gesture -> Some (`Unknown "`Multi_gesture") + | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ") + | `Unknown e -> + Some (`Unknown (Format.sprintf "Some (`Unknown %d " e)) + | `User_event -> Some (`Unknown "`User_event ") + | `Display_event -> Some (`Unknown "`Display_event ") + | `Sensor_update -> Some (`Unknown "`Sensor_update ") + | `Window_event -> Some (`Unknown "`Window_event ") let key_up : Sdl.keycode = 0x40000052 let key_down : Sdl.keycode = 0x40000051 @@ -400,7 +359,6 @@ module Display = struct open Wall module I = Image module P = Path - module Text = Wall_text let ( >>>= ) x f = match x with Ok a -> f a | Error _ as result -> result @@ -511,7 +469,9 @@ module Display = struct (* create and fill event list *) let ev = Sdl.Event.create () in if Sdl.poll_event (Some ev) then - get_events () @ [Event.event_of_sdlevent ev] + match Event.event_of_sdlevent ev with + | Some e -> get_events () @ [e] + | None -> get_events () else [] let successful_actor = ref (fun _ -> Lwt.return pane_empty) @@ -561,18 +521,27 @@ module Display = struct let gray ?(a = 1.0) v = Color.v v v v a + module FontCache = Map.Make (String) + + let font_cache = ref FontCache.empty + let load_font name = - let ic = open_in_bin name in - let dim = in_channel_length ic in - let fd = Unix.descr_of_in_channel ic in - let buffer = - Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false - [|dim|] - |> Bigarray.array1_of_genarray in - let offset = List.hd (Stb_truetype.enum buffer) in - match Stb_truetype.init buffer offset with - | None -> assert false + match FontCache.find_opt name !font_cache with | Some font -> font + | None -> ( + let ic = open_in_bin name in + let dim = in_channel_length ic in + let fd = Unix.descr_of_in_channel ic in + let buffer = + Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout + false [|dim|] + |> Bigarray.array1_of_genarray in + let offset = List.hd (Stb_truetype.enum buffer) in + match Stb_truetype.init buffer offset with + | None -> assert false + | Some font -> + font_cache := FontCache.add name font !font_cache ; + font ) let font_icons = lazy (load_font "fonts/entypo.ttf") let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") @@ -604,11 +573,14 @@ module Display = struct (Box2.oy b) (Box2.maxx b) (Box2.maxy b) let draw_label text b = - let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in - ( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b)) + let f = + Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) + in + ( Box2.v (Box2.o b) + (P2.v (Wall_text.Font.text_width f text) (Box2.h b)) , I.paint (Paint.color (gray ~a:0.5 1.0)) - Text.( + Wall_text.( simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) ~y:(Box2.oy b +. (Box2.h b *. 0.75)) text) ) @@ -654,9 +626,9 @@ module Display = struct *) let simple_text f text (s : state) = - let fm = Text.Font.font_metrics f in + let fm = Wall_text.Font.font_metrics f in let font_height = fm.ascent -. fm.descent +. fm.line_gap in - let tm = Text.Font.text_measure f text in + let tm = Wall_text.Font.text_measure f text in let br_pt = P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height) in @@ -667,7 +639,7 @@ module Display = struct , (* I.stack redbox *) I.paint (Paint.color (gray ~a:0.5 1.0)) - Text.( + Wall_text.( simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box) ~y:(Box2.oy s.box +. fm.ascent) @@ -707,6 +679,8 @@ module Panel = struct ; mutable subpanels: t Lwt.t list ; mutable tag: string } + type panel = t + let blank = { act= (fun _panel _events -> Lwt.return Display.pane_empty) ; subpanels= [] @@ -778,8 +752,9 @@ module Panel = struct node := I.stack !node i ; sc := s ; box := b in - let font = Text.Font.make ~size:height (Lazy.force font_sans) in - let fm = Text.Font.font_metrics font in + let font = + Wall_text.Font.make ~size:height (Lazy.force font_sans) in + let fm = Wall_text.Font.font_metrics font in let font_height = fm.ascent -. fm.descent +. fm.line_gap in let max_x = ref 0. in let out_string text o l = @@ -801,7 +776,7 @@ module Panel = struct (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height)) (Box2.max s.box) } in let out_spaces n = - let wpx = Text.Font.text_width font " " in + let wpx = Wall_text.Font.text_width font " " in if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then (* WRAP *) out_newline () ; @@ -844,7 +819,7 @@ module Panel = struct print_close_stag= (fun _ -> (*""*) ()) } ; Format.pp_set_tags pp true ; let margin = - int_of_float (Box2.w s.box /. Text.Font.text_width font " ") + int_of_float (Box2.w s.box /. Wall_text.Font.text_width font " ") in let max_indent = margin - 1 in Format.pp_safe_set_geometry pp ~max_indent ~margin ; @@ -880,19 +855,19 @@ module Panel = struct type t = { mutable zed: unit Zed_edit.context ; mutable view: Zed_cursor.t - ; mutable keybind: Input.Bind.state } + ; mutable keybind: Key.Bind.state } let bindings te = - 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] + let open Key.Bind in + add [([], Code (`Arrow `Left))] [Zed Prev_char] + @@ add [([], Code (`Arrow `Right))] [Zed Next_char] + @@ add [([], Code (`Arrow `Up))] [Zed Prev_line] + @@ add [([], Code (`Arrow `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] @@ -904,20 +879,20 @@ module Panel = struct @@ 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 [([], 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], Code (`Arrow `Right))] [Zed Next_word] + @@ add [([Meta], Code (`Arrow `Left))] [Zed Prev_word] + @@ add [([Ctrl], Code (`Arrow `Right))] [Zed Next_word] + @@ add [([Ctrl], Code (`Arrow `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] @@ -958,7 +933,7 @@ module Panel = struct let te = { zed= Zed_edit.context ze (Zed_edit.new_cursor ze) ; view= Zed_edit.new_cursor ze - ; keybind= Input.Bind.init Input.Bind.empty } in + ; keybind= Key.Bind.(init empty) } in te.keybind.bindings <- keybinds te ; insert te initialtext ; te @@ -970,8 +945,8 @@ module Panel = struct (* collect events and update Zed context *) Lwt_list.iter_s (function - | `Key_down (k : Input.keystate) -> ( - let open Input.Bind in + | `Key (`Press, (k : Key.keystate)) -> ( + let open Key.Bind in ( match te.keybind.state with | Accepted _ | Rejected -> te.keybind.last_keyseq <- [] ; @@ -988,19 +963,13 @@ module Panel = struct te.keybind.last_actions <- a ; Lwt_list.iter_s (function - | Input.Bind.Custom f -> - Lwt.return (f ()) - | Input.Bind.CustomLwt f -> f () + | Custom f -> Lwt.return (f ()) + | CustomLwt f -> f () | Zed za -> Lwt.return (Zed_edit.get_action za te.zed) ) a | Continue _ | Rejected -> Lwt.return_unit ) - | `Key_up _ -> Lwt.return_unit - | `Text_input s -> - Lwt.return - (Zed_edit.insert te.zed - (Zed_rope.of_string (Zed_string.of_utf8 s)) ) | _ -> Lwt.return_unit ) events >>= fun () -> @@ -1043,8 +1012,7 @@ module Panel = struct ; tag= "textedit" } (* 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 : Key.Bind.state) = Lwt.return { act= (fun _panel _events -> @@ -1054,7 +1022,7 @@ module Panel = struct F.text pp (List.fold_left (fun s x -> - Input.to_string_compact x ^ " " ^ s ) + Key.to_string_compact x ^ " " ^ s ) "" b.last_keyseq ) ; F.text pp "-> " ; F.text pp @@ -1064,7 +1032,7 @@ module Panel = struct ^ List.fold_right (fun x s -> s - ^ Input.Bind.( + ^ Key.Bind.( match x with | Zed a -> Zed_edit.name_of_action a @@ -1095,8 +1063,9 @@ module Panel = struct let panel ?(height = !g_text_height) me = let keybinds = - let open Input.Bind in - add [([], Code Enter)] + let open Key.Bind in + add + [([], Code `Enter)] [ Custom (fun () -> (* set input first so a modal can trigger another modal *) @@ -1129,671 +1098,625 @@ module Panel = struct match me.input with Some _ -> true | None -> false end - module Nottui = struct - open Nottui - module P = Nottui_pretty - - let convert_events events : Nottui_lwt.event option list = - let key_of_keystate - (Input.{ctrl; meta; shift; super= _; code} as k) : - Notty.Unescape.key option = - F.epr "Nottui.convert_events: %s@." - (Input.to_string_compact k) ; - match code with - | None | Unknown -> None - | code -> - Some - ( ( match code with - | UChar c -> - let d = - Uchar.of_int (CamomileLibrary.UChar.code c) - in - if Uchar.is_char d then `ASCII (Uchar.to_char d) - else `Uchar d - | Enter -> `Enter - | Escape -> `Escape - | Tab -> `Tab - | Up -> `Arrow `Up - | Down -> `Arrow `Down - | Left -> `Arrow `Left - | Right -> `Arrow `Right - | F1 -> `Function 1 - | F2 -> `Function 2 - | F3 -> `Function 3 - | F4 -> `Function 4 - | F5 -> `Function 5 - | F6 -> `Function 6 - | F7 -> `Function 7 - | F8 -> `Function 8 - | F9 -> `Function 9 - | F10 -> `Function 10 - | F11 -> `Function 11 - | F12 -> `Function 12 - | Next_page -> `Page `Down - | Prev_page -> `Page `Up - | Home -> `Home - | End -> `End - | Insert -> `Insert - | Delete -> `Delete - | Backspace -> `Backspace - | _ -> `Uchar (Uchar.of_int 0) ) - , (if ctrl then [`Ctrl] else []) - @ (if meta then [`Meta] else []) - @ if shift then [`Shift] else [] ) in - List.filter_map - (function - | `Key_down k -> ( - match key_of_keystate k with - | None -> None - | Some k -> Some (Some (`Key k)) ) - | _ -> None ) - events - - module Attr = struct - type attr = - { fg: Wall.color - ; bg: Wall.color - ; size: float - ; font: [`Sans | `Serif | `Mono] - ; weight: [`Bold | `Regular | `Light] + module Style = struct + module Font = struct + type t = + { size: float option + ; font: [`Sans | `Serif | `Mono | `None] + ; weight: [`Bold | `Regular | `Light | `None] ; italic: [`Italic | `None] ; underline: [`Underline | `None] } let empty = - { fg= Color.void - ; bg= Color.void - ; size= 0. - ; font= `Sans - ; weight= `Regular + { size= None + ; font= `None + ; weight= `None ; italic= `None ; underline= `None } - let equal = ( == ) + let default = + ref + { size= Some 20. + ; font= `Sans + ; weight= `Regular + ; italic= `None + ; underline= `None } - let ( ++ ) a1 a2 = - if a1 == empty then a2 - else if a2 == empty then a1 - else - { a1 with - fg= Color.blend a1.fg a2.fg - ; bg= Color.blend a1.bg a2.bg } + let size {size; _} = + match (size, !default.size) with + | None, None -> 20. + | None, Some s | Some s, _ -> s - let fg fg = {empty with fg} - let bg bg = {empty with bg} - - let get_font a = - Text.Font.make ~size:a.size + let get a = + Wall_text.Font.make ~size:(size a) (load_font ( match (a.font, a.weight, a.italic) with | `Sans, `Regular, `None -> "fonts/Roboto-Regular.ttf" | `Sans, `Bold, `None -> "fonts/Roboto-Bold.ttf" | `Sans, `Light, `None -> "fonts/Roboto-Light.ttf" - | `Sans, `Regular, `Italic -> "fonts/Roboto-Italic.ttf" - | `Sans, `Bold, `Italic -> "fonts/Roboto-BoldItalic.ttf" - | `Sans, `Light, `Italic -> - "fonts/Roboto-LightItalic.ttf" - | `Serif, `Bold, _ -> "fonts/ScheherazadeNew-Bold.ttf" - | `Serif, _, _ -> "fonts/ScheherazadeNew-Regular.ttf" - | `Mono, `Regular, `None -> - "fonts/static/RobotoMono-Regular.ttf" + (* | `Sans, `Regular, `Italic -> "fonts/Roboto-Italic.ttf" + | `Sans, `Bold, `Italic -> "fonts/Roboto-BoldItalic.ttf" + | `Sans, `Light, `Italic -> + "fonts/Roboto-LightItalic.ttf" + | `Serif, `Bold, _ -> "fonts/ScheherazadeNew-Bold.ttf" + | `Serif, _, _ -> "fonts/ScheherazadeNew-Regular.ttf" + | `Mono, `Regular, `None -> + "fonts/static/RobotoMono-Regular.ttf"*) | _, _, _ -> "fonts/Roboto-Regular.ttf" ) ) + + let merge a b = + { size= + ( match (a.size, b.size) with + | None, None -> None + | Some s, None | None, Some s -> Some s + | Some s1, Some s2 -> Some (Float.fmax s1 s2) ) + ; font= + ( match (a.font, b.font) with + | `Sans, _ | _, `Sans -> `Sans + | `Serif, (`Serif | `Mono | `None) + |(`Mono | `None), `Serif -> + `Serif + | `Mono, (`Mono | `None) | `None, `Mono -> `Mono + | `None, `None -> `None ) + ; weight= + ( match (a.weight, b.weight) with + | `Bold, _ | _, `Bold -> `Bold + | `Regular, (`Regular | `Light | `None) + |(`Light | `None), `Regular -> + `Regular + | `Light, (`Light | `None) | `None, `Light -> `Light + | `None, `None -> `None ) + ; italic= + ( match (a.italic, b.italic) with + | `Italic, _ | _, `Italic -> `Italic + | _ -> `None ) + ; underline= + ( match (a.underline, b.underline) with + | `Underline, _ | _, `Underline -> `Underline + | _ -> `None ) } end - let invalid_arg fmt = Format.kasprintf invalid_arg fmt - let ( &. ) f g x = f (g x) - let btw (x : int) a b = a <= x && x <= b - let bit n b = b land (1 lsl n) > 0 - let max (a : int) b = if a > b then a else b - let min (a : int) b = if a < b then a else b + type t = {fg: Wall.color; bg: Wall.color; font: Font.t} + type attr = t - let is_C0 x = x < 0x20 || x = 0x7f - and is_C1 x = 0x80 <= x && x < 0xa0 + let empty = {fg= Color.void; bg= Color.void; font= Font.empty} + let light = {empty with fg= Color.gray 0.2} + let dark = {empty with fg= Color.gray 0.8} + let equal = ( == ) - let is_ctrl x = is_C0 x || is_C1 x and is_ascii x = x < 0x80 + let ( ++ ) a1 a2 = + if a1 == empty then a2 + else if a2 == empty then a1 + else + { a1 with + fg= Color.blend a1.fg a2.fg + ; bg= Color.blend a1.bg a2.bg } - let rec concatm z ( @ ) xs = - let rec accum ( @ ) = function - | ([] | [_]) as xs -> xs - | a :: b :: xs -> (a @ b) :: accum ( @ ) xs in - match xs with - | [] -> z - | [x] -> x - | xs -> concatm z ( @ ) (accum ( @ ) xs) + let fg fg = {empty with fg} + let bg bg = {empty with bg} - let rec linspcm z ( @ ) x n f = - match n with - | 0 -> z - | 1 -> f x - | _ -> - let m = n / 2 in - linspcm z ( @ ) x m f @ linspcm z ( @ ) (x + m) (n - m) f + let merge a b = + { fg= Wall.Color.blend a.fg b.fg + ; bg= Wall.Color.blend a.bg b.bg + ; font= Font.merge a.font b.font } + end - let memo (type a) ?(hash = Hashtbl.hash) ?(eq = ( = )) ~size f = - let module H = Ephemeron.K1.Make (struct - type t = a + module Focus = struct + (* Stolen from lwd/lib/nottui/nottui.ml *) + type var = int Lwd.var + type status = [`Empty | `Handle of int * var | `Conflict of int] + type handle = var * status Lwd.t - let hash, equal = (hash, eq) - end) in - let t = H.create size in - fun x -> - try H.find t x - with Not_found -> - let y = f x in - H.add t x y ; y + let make () = + let v = Lwd.var 0 in + (v, Lwd.map ~f:(fun n -> `Handle (n, v)) (Lwd.get v)) - module List = struct - include List + let empty : status = `Empty + let status (h : handle) : status Lwd.t = snd h - let init n f = - let rec go a n = if n < 0 then a else go (f n :: a) (n - 1) in - go [] (n - 1) - end + let has_focus = function + | `Empty -> false + | `Handle (i, _) | `Conflict i -> i > 0 - module Buffer = struct - include Buffer + let clock = ref 0 + let request_var (v : var) = incr clock ; Lwd.set v !clock + let request ((v, _) : handle) = request_var v + let release ((v, _) : handle) = incr clock ; Lwd.set v 0 - let buf = Buffer.create 1024 + let merge s1 s2 : status = + match (s1, s2) with + | s, (`Empty | `Handle (0, _)) | (`Empty | `Handle (0, _)), s -> + s + | (`Handle (i, _) as s), `Handle (j, _) when i = j -> s + | (`Handle (i, _) | `Conflict i), (`Conflict j as s) when i < j + -> + s + | (`Handle (i, _) | `Conflict i), `Handle (j, _) when i < j -> + `Conflict j + | (`Conflict _ as s), (`Handle (_, _) | `Conflict _) -> s + | `Handle (i, _), (`Handle (_, _) | `Conflict _) -> `Conflict i + end - let mkstring f = - f buf ; - let res = contents buf in - reset buf ; res + module Pad = struct + type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1} - let add_decimal b = function - | x when btw x 0 999 -> - let d1 = x / 100 - and d2 = x mod 100 / 10 - and d3 = x mod 10 in - if d1 > 0 then 0x30 + d1 |> Char.unsafe_chr |> add_char b ; - if d1 + d2 > 0 then - 0x30 + d2 |> Char.unsafe_chr |> add_char b ; - 0x30 + d3 |> Char.unsafe_chr |> add_char b - | x -> string_of_int x |> add_string b + let empty = + { t= Gg.Size1.zero + ; b= Gg.Size1.zero + ; l= Gg.Size1.zero + ; r= Gg.Size1.zero } + end - let add_chars b c n = - for _ = 1 to n do - add_char b c - done - end + module Region = struct + type 'a t = + {t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor} + + type cursor = Trope.cursor + type 'a region = 'a t + + let create () = + let t = Trope.create () in + let left = Trope.cursor_at_origin t in + {t; left; right= left} + + let append (t : 'a region) (e : 'a) : 'a region = + let right = Trope.cursor_after t.right in + {t with t= Trope.put_right t.t right e; right} + + let rec iter ~t ?(start = t.left) ~(f : 'a -> unit) () = + match Trope.seek_after t.t start with + | Some (c, e) -> f e ; iter ~start:c ~t ~f () + | None -> () + + let rec trope_replace ~(t : 'a region) ?(start = t.left) + ~(f : + 'a Trope.t * Trope.cursor + -> 'a + -> 'a Trope.t * Trope.cursor ) () : 'a region = + match Trope.seek_after t.t start with + | Some (c, e) -> + let t', c' = f (t.t, c) e in + trope_replace + ~t: + { t with + t= t' + ; right= + ( if Trope.compare t.right c' < 0 then c' + else t.right ) } + ~start:c' ~f () + | None -> t + + let rec replace ~(r : 'a region) ?(start = r.left) + ~(f : 'a t * cursor -> 'a -> 'a t * cursor) () : 'a region = + match Trope.seek_after r.t start with + | Some (c, e) -> + let r', c' = f (r, c) e in + replace + ~r: + { r' with + right= + ( if Trope.compare r.right c' < 0 then c' + else r.right ) } + ~start:c' ~f () + | None -> r + + let rec fold ~(t : 'a region) ?(start = t.left) + ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b) + : 'b = + match Trope.seek_after t.t start with + | Some (c, e) -> fold ~t ~start:c ~f (f (t.t, c) e acc) + | None -> acc + + let rec fold_lwt ~(t : 'a region) ?(start = t.left) + ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b Lwt.t) + (acc : 'b) : 'b Lwt.t = + match Trope.seek_after t.t start with + | Some (c, e) -> + f (t.t, c) e acc >>= fun x -> fold_lwt ~t ~start:c ~f x + | None -> Lwt.return acc + + let rec fold_lwt_opt ~(t : 'a region) ?(start = t.left) + ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b option Lwt.t) + (acc : 'b) : 'b Lwt.t = + match Trope.seek_after t.t start with + | Some (c, e) -> ( + f (t.t, c) e acc + >>= function + | Some x -> fold_lwt_opt ~t ~start:c ~f x + | None -> Lwt.return acc ) + | None -> Lwt.return acc + end + + module Ui = struct + open Gg + open Wall + + type t = [`Atom of atom | `Attr of attr | `Region of region] + + and atom = + [ `Image of image + | `Uchar of Uchar.t + | `Boundary of [`Word | `Line | `Sentance | `Hint] ] + + and attr = + [ `Style of style + | `Pad of Pad.t + | `Shift of dim + | `Focus of focus * Focus.handle + | `Handle of handle ] + * node + + and region = [`X | `Y | `Z] * node Region.t + + and node = {mutable parent: node; mutable child: t} + + and image = Wall.image * Size2.t + + and dim = Gg.size2 + + and text = string + + and style = Style.t + + and status = [`Handled | `Event of Event.t] + + and event_status = + [ `Handled + | (*`Focus of [`Next | `Prev | `Up | `Down] | *) + `Event of + Event.t ] + + and focus = node -> Event.t -> status Lwt.t + + and handle = node -> Event.t -> status Lwt.t + + let empty_image = (Image.empty, V2.zero) + + let empty_node = + let rec parent = {parent; child= `Atom (`Image empty_image)} in + parent + + let set_parent_on_children parent = + match parent.child with + | `Atom _ -> () + | `Attr (_, n) -> n.parent <- parent + | `Region (_, r) -> + Region.iter ~t:r ~f:(fun n -> n.parent <- parent) () + + let set_children_on_parent (t : t) = + match t with + | `Atom _ -> () + | `Attr (_, n) -> n.parent.child <- t + | `Region (_, r) -> + Region.iter ~t:r ~f:(fun n -> n.parent.child <- t) () + + let node (child : t) = + let rec parent = {parent; child} in + set_parent_on_children parent ; + parent + + let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) + + let focus ((f, h) : focus * Focus.handle) (n : node) = + node (`Attr (`Focus (f, h), n)) + + let node_func ?(fnode = fun (x : node) -> x) + ?(fregion = fun (x : node Region.t) -> x) + ?(fatom = fun (x : atom) -> x) parent : node = + parent.child <- + ( match parent.child with + | `Attr (a, n) -> `Attr (a, {(fnode n) with parent}) + | `Region (a, r) -> `Region (a, fregion r) + | `Atom a -> `Atom (fatom a) ) ; + parent + + let rec traverse_nodes ~(f : node -> node) (n : node) : node = + node_func + ~fnode:(fun n -> traverse_nodes ~f (f n)) + ~fregion:(fun r -> + Region.replace ~r + ~f:(fun (r, c) e -> + ( { r with + t= + Trope.put_right r.t c + {(traverse_nodes ~f e) with parent= n} } + , c ) ) + () ) + n + + let rec traverse_regions + ~(region : + parent:node + -> node Region.t * Region.cursor + -> child:node + -> node Region.t * Region.cursor ) ~(node : node -> node) + (parent : node) : node = + node_func + ~fnode:(fun n -> traverse_regions ~region ~node (node n)) + ~fregion:(fun r -> + Region.replace ~r + ~f:(fun (r, c) child -> region ~parent (r, c) ~child) + () ) + parent module Text = struct - let err_ctrl u = - invalid_arg "Notty: control char: U+%02X, %S" (Char.code u) + (* let to_buffer t = + let b = Buffer.create 0 in + let enc' = Uutf.encoder `UTF_8 (`Buffer b) in + let rec enc c = + match Uutf.encode enc' c with + | `Partial -> enc `Await + | `Ok -> () in + let rec aux c = + match Trope.seek_after t.t c with + | Some (c, Uchar char) -> + enc (`Uchar char) ; + aux c + | Some (c, _) -> aux c + | None -> () in + aux line.left ; b - let err_malformed = invalid_arg "Notty: malformed UTF-8: %s, %S" + let to_string t = + Bytes.to_string (Buffer.to_bytes (to_buffer t)) *) - type t = - | Ascii of string * int * int - | Utf8 of string * int array * int * int + let rec _of_string ~rl (str : string) : node = + let rec parent = {parent; child= `Region (`Y, rl)} in + let uudec = Uutf.decoder (`String str) in + let rec dec (rl : node Region.t) : 'a * node Region.t = + match Uutf.decode uudec with + | `Malformed b -> + dec + (Region.append rl + (_of_string ~rl:(Region.create ()) + (String.escaped b) ) ) + | (`Await | `Uchar _ | `End) as x -> (x, rl) in + let uuline = Uuseg.create `Line_break in + let rec line (rl : node Region.t) = + let rec char (x, t) (line : node Region.t) = + match Uuseg.add uuline x with + | `End as x -> (line, x) + | `Boundary as x when Uuseg.mandatory uuline -> (line, x) + | `Await -> char (dec t) line + | `Boundary -> + char + (`Await, t) + (Region.append line + {parent; child= `Atom (`Boundary `Hint)} ) + | `Uchar c -> + char + (`Await, t) + (Region.append line + {parent; child= `Atom (`Uchar c)} ) in + match + char + (`Await, rl) + (Region.append (Region.create ()) + {parent; child= `Atom (`Boundary `Line)} ) + with + | l, `Boundary -> + line (Region.append rl {parent; child= `Region (`X, l)}) + | l, `End -> + Region.append rl {parent; child= `Region (`X, l)} in + parent.child <- `Region (`Y, line rl) ; + parent - let equal t1 t2 = - match (t1, t2) with - | Utf8 (s1, _, i1, n1), Utf8 (s2, _, i2, n2) - |Ascii (s1, i1, n1), Ascii (s2, i2, n2) -> - i1 = i2 && n1 = n2 && s1 = s2 - | _ -> false + let of_string ?(rl = Region.create ()) (str : string) = + _of_string ~rl str - let width = function - | Utf8 (_, _, _, w) -> w - | Ascii (_, _, w) -> w + let segment ?(boundary = `Word) ?(label = `Word) (node : node) : + node = + let uuseg = Uuseg.create boundary in + traverse_regions + ~node:(fun node -> node) + ~region:(fun ~parent (r, c) ~child -> + match child.child with + | `Atom (`Uchar uc) -> + let rec seg ((t : node Trope.t), (c : Region.cursor)) + e' = + match Uuseg.add uuseg e' with + | `Boundary -> + seg + ( Trope.put_right t c + {parent; child= `Atom (`Boundary label)} + , Trope.cursor_after c ) + `Await + | `End | `Await -> (t, c) + | `Uchar ch -> + seg + ( Trope.put_right t c + {parent; child= `Atom (`Uchar ch)} + , c ) + `Await in + let r', c' = seg (r.t, c) (`Uchar uc) in + ({r with t= r'}, c') + | _ -> (r, c) ) + node - let empty = Ascii ("", 0, 0) + let words node : node = + segment ~boundary:`Word ~label:`Word node - let graphemes str = - let seg = Uuseg.create `Grapheme_cluster in - let rec f ((is, w) as acc) i evt = - match Uuseg.add seg evt with - | `Await | `End -> acc - | `Uchar u -> - f (is, w + Uucp.Break.tty_width_hint u) i `Await - | `Boundary -> - let is = - match w with - | 0 -> is - | 1 -> i :: is - | _ -> i :: -1 :: is in - f (is, 0) i `Await in - let acc = - Uutf.String.fold_utf_8 - (fun acc i -> function - | `Malformed err -> err_malformed err str - | `Uchar _ as u -> f acc i u ) - ([0], 0) - str in - f acc (String.length str) `End - |> fst |> List.rev |> Array.of_list + let sentances node : node = + segment ~boundary:`Sentence ~label:`Sentance node - let dead = ' ' - - let to_buffer buf = function - | Ascii (s, off, w) -> Buffer.add_substring buf s off w - | Utf8 (s, ix, off, w) -> - let x1 = - match ix.(off) with - | -1 -> - Buffer.add_char buf dead ; - ix.(off + 1) - | x -> x - and x2 = ix.(off + w) in - Buffer.add_substring buf s x1 - @@ ((if x2 = -1 then ix.(off + w - 1) else x2) - x1) ; - if x2 = -1 then Buffer.add_char buf dead - - let sub t x w = - let w1 = width t in - if w = 0 || x >= w1 then empty - else - let w = min w (w1 - x) in - if w = w1 then t - else - match t with - | Ascii (s, off, _) -> Ascii (s, off + x, w) - | Utf8 (s, ix, off, _) -> Utf8 (s, ix, off + x, w) - - let is_ascii_or_raise_ctrl s = - let ( @! ) s i = String.unsafe_get s i |> Char.code in - let rec go s acc i n = - if n = 0 then acc - else - let x = s @! i in - if is_C0 x then err_ctrl s.[i] s - else if x = 0xc2 && n > 1 && is_C1 (s @! (i + 1)) then - err_ctrl s.[i + 1] s - else go s (acc && is_ascii x) (i + 1) (n - 1) in - go s true 0 (String.length s) - - let of_ascii s = Ascii (s, 0, String.length s) - - and of_unicode s = - let x = graphemes s in - Utf8 (s, x, 0, Array.length x - 1) - - let of_unicode = memo ~eq:String.equal ~size:128 of_unicode - - let of_string = function - | "" -> empty - | s -> - if is_ascii_or_raise_ctrl s then of_ascii s - else of_unicode s - - let of_uchars ucs = - of_string @@ Buffer.mkstring - @@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs - - let replicateu w u = - if is_ctrl (Uchar.to_int u) then - err_ctrl (Uchar.unsafe_to_char u) "" - else if w < 1 then empty - else if is_ascii (Uchar.to_int u) then - of_ascii (String.make w (Uchar.unsafe_to_char u)) - else - of_unicode @@ Buffer.mkstring - @@ fun buf -> - for _ = 1 to w do - Buffer.add_utf_8_uchar buf u - done - - let replicatec w c = replicateu w (Uchar.of_char c) + let text str : node = of_string str |> sentances |> words end - module I = struct - type dim = int * int + let text = Text.text - type t = - | Empty - | Segment of Text.t - | Attr of (t * Attr.attr) * dim - | Hcompose of (t * t) * dim - | Vcompose of (t * t) * dim - | Zcompose of (t * t) * dim - | Hcrop of (t * int * int) * dim - | Vcrop of (t * int * int) * dim - | Void of dim + let join_ d (a : node) (b : node) = + let rec parent = + { parent + ; child= + `Region + (d, Region.append (Region.append (Region.create ()) a) b) + } in + a.parent <- parent ; + b.parent <- parent ; + parent - let width = function - | Empty -> 0 - | Segment text -> Text.width text - | Attr (_, (w, _)) -> w - | Hcompose (_, (w, _)) -> w - | Vcompose (_, (w, _)) -> w - | Zcompose (_, (w, _)) -> w - | Hcrop (_, (w, _)) -> w - | Vcrop (_, (w, _)) -> w - | Void (w, _) -> w - [@@inline] + let join_x = join_ `X + let join_y = join_ `Y + let join_z = join_ `Z + let pack_x : node Lwd_utils.monoid = (empty_node, join_x) + let pack_y : node Lwd_utils.monoid = (empty_node, join_y) + let pack_z : node Lwd_utils.monoid = (empty_node, join_z) + let ( ^^ ) = join_x + let ( ^/^ ) = join_y - let height = function - | Empty -> 0 - | Segment _ -> 1 - | Attr (_, (_, h)) -> h - | Hcompose (_, (_, h)) -> h - | Vcompose (_, (_, h)) -> h - | Zcompose (_, (_, h)) -> h - | Hcrop (_, (_, h)) -> h - | Vcrop (_, (_, h)) -> h - | Void (_, h) -> h - [@@inline] + module Draw = struct + type d = [`X | `Y | `Z] - let equal t1 t2 = - let rec eq t1 t2 = - match (t1, t2) with - | Empty, Empty -> true - | Segment t1, Segment t2 -> Text.equal t1 t2 - | Attr ((a, a1), _), Attr ((b, a2), _) -> - Attr.equal a1 a2 && eq a b - | Hcompose ((a, b), _), Hcompose ((c, d), _) - |Vcompose ((a, b), _), Vcompose ((c, d), _) - |Zcompose ((a, b), _), Zcompose ((c, d), _) -> - eq a c && eq b d - | Hcrop ((a, i1, n1), _), Hcrop ((b, i2, n2), _) - |Vcrop ((a, i1, n1), _), Vcrop ((b, i2, n2), _) -> - i1 = i2 && n1 = n2 && eq a b - | Void (a, b), Void (c, d) -> a = c && b = d - | _ -> false in - width t1 = width t2 && height t1 = height t2 && eq t1 t2 + let vcat d a b = + match d with + | `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b)) + | `Y -> V2.v (Float.fmax (V2.x a) (V2.x b)) (V2.y a +. V2.y b) + | `Z -> + V2.v + (Float.fmax (V2.x a) (V2.x b)) + (Float.fmax (V2.y a) (V2.y b)) - let empty = Empty + let pad (p : Pad.t) (img, sv) = + ( I.transform Transform.(translate ~x:p.l ~y:p.t identity) img + , V2.v (p.l +. V2.x sv +. p.r) (p.t +. V2.y sv +. p.b) ) - let void w h = - if w < 1 && h < 1 then Empty else Void (max 0 w, max 0 h) + let shift v (img, sv) = + ( I.transform + Transform.( + translate ~x:(Size2.w v) ~y:(Size2.h v) identity) + img + , sv ) - let attr a = function - | Attr ((t, a0), dim) -> Attr ((t, Attr.(a ++ a0)), dim) - | t -> Attr ((t, a), (width t, height t)) + let uchar (style : Style.t) (uc : Uchar.t) : image = + let open Wall_text in + let f = Style.Font.get style.font in + let b = Buffer.create 1 in + let enc = Uutf.encoder `UTF_8 (`Buffer b) in + let rec encode c = + match Uutf.encode enc c with + | `Ok -> () + | `Partial -> encode `Await in + encode (`Uchar uc) ; + encode `End ; + let str = Bytes.to_string (Buffer.to_bytes b) in + let m = Wall_text.Font.text_measure f str in + let v = Gg.Size2.v m.width (f.size +. f.line_height) in + ( I.stack + (I.paint + (Wall.Paint.color style.fg) + (simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0. + str ) ) + (I.paint + (Wall.Paint.color style.bg) + ( I.fill_path + @@ fun t -> + P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) ) + , v ) - let ( <|> ) t1 t2 = - match (t1, t2) with - | _, Empty -> t1 - | Empty, _ -> t2 - | _ -> - let w = width t1 + width t2 - and h = max (height t1) (height t2) in - Hcompose ((t1, t2), (w, h)) + let cat d (ai, av) (bi, bv) = + ( I.stack ai + (I.transform + Transform.( + match d with + | `X -> translate ~x:(Size2.w av) ~y:0. identity + | `Y -> translate ~x:0. ~y:(Size2.h av) identity + | `Z -> translate ~x:0. ~y:0. identity) + bi ) + , vcat d av bv ) - let ( <-> ) t1 t2 = - match (t1, t2) with - | _, Empty -> t1 - | Empty, _ -> t2 - | _ -> - let w = max (width t1) (width t2) - and h = height t1 + height t2 in - Vcompose ((t1, t2), (w, h)) + let rec atom ?(style = Style.empty) : atom -> image = function + | `Image i -> i + | `Uchar uc -> uchar style uc + | `Boundary _ -> empty_image - let ( ) t1 t2 = - match (t1, t2) with - | _, Empty -> t1 - | Empty, _ -> t2 - | _ -> - let w = max (width t1) (width t2) - and h = max (height t1) (height t2) in - Zcompose ((t1, t2), (w, h)) + and attr ?(style = Style.empty) (attr, node) : image = + match attr with + | `Style s -> pane ~style:(Style.merge s style) node + | `Pad p -> pad p (pane ~style node) + | `Shift s -> shift s (pane ~style node) + | _ -> pane ~style node - let lincropinv crop void ( ++ ) init fini img = - match (init >= 0, fini >= 0) with - | true, true -> crop init fini img - | true, _ -> crop init 0 img ++ void (-fini) - | _, true -> void (-init) ++ crop 0 fini img - | _ -> void (-init) ++ img ++ void (-fini) + and region ?(style = Style.empty) (dir, region) : image = + Region.fold ~t:region + ~f:(fun _ n i -> cat dir i (pane ~style n)) + empty_image - let hcrop = - let ctor left right img = - let h = height img and w = width img - left - right in - if w > 0 then Hcrop ((img, left, right), (w, h)) - else void w h in - lincropinv ctor (fun w -> void w 0) ( <|> ) - - let vcrop = - let ctor top bottom img = - let w = width img and h = height img - top - bottom in - if h > 0 then Vcrop ((img, top, bottom), (w, h)) - else void w h in - lincropinv ctor (void 0) ( <-> ) - - let crop ?(l = 0) ?(r = 0) ?(t = 0) ?(b = 0) img = - let img = if l <> 0 || r <> 0 then hcrop l r img else img in - if t <> 0 || b <> 0 then vcrop t b img else img - - let hpad left right img = hcrop (-left) (-right) img - let vpad top bottom img = vcrop (-top) (-bottom) img - - let pad ?(l = 0) ?(r = 0) ?(t = 0) ?(b = 0) img = - crop ~l:(-l) ~r:(-r) ~t:(-t) ~b:(-b) img - - let hcat = concatm empty ( <|> ) - let vcat = concatm empty ( <-> ) - let zcat xs = List.fold_right ( ) xs empty - - let text attr tx = - match (Text.width tx, attr) with - | 0, _ -> void 0 1 - | w, Some a -> Attr ((Segment tx, a), (w, 1)) - | _, _ -> Segment tx - - let string ?attr s = text attr (Text.of_string s) - let uchars ?attr a = text attr (Text.of_uchars a) - - let tabulate m n f = - let m = max m 0 and n = max n 0 in - linspcm empty ( <-> ) 0 n (fun y -> - linspcm empty ( <|> ) 0 m (fun x -> f x y) ) - - let chars ctor ?attr c w h = - let w = max 0 w and h = max 0 h in - if w < 1 || h < 1 then void w h - else - let line = text attr (ctor w c) in - tabulate 1 h (fun _ _ -> line) + and pane ?(style = Style.empty) (node : node) : image = + match node.child with + | `Atom a -> atom ~style a + | `Attr a -> attr ~style a + | `Region a -> region ~style a end - (* let string ?(attr = Attr.empty) str = - let control_character_index str i = - let len = String.length str in - let i = ref i in - while - let i = !i in - i < len && str.[i] >= ' ' - do - incr i - done ; - if !i = len then raise Not_found ; - !i in - let rec split str i = - match control_character_index str i with - | j -> - let img = I.string ~attr (String.sub str i (j - i)) in - img :: split str (j + 1) - | exception Not_found -> - [ I.string ~attr - ( if i = 0 then str - else String.sub str i (String.length str - i) ) ] - in - Ui.atom (I.vcat (split str 0))*) + let rec handle_event (node : node) (ev : Event.t) : + event_status Lwt.t = + Lwt.return `Handled - let attr_menu_main = Attr.(bg (Color.gray 0.7) ++ fg Color.black) - let attr_menu_sub = Attr.(bg (Color.gray 0.5) ++ fg Color.black) - let attr_clickable = Attr.(bg Color.blue) + (* + match node.child with + | `Atom _ -> Lwt.return (`Event ev) + | `Attr (`Focus (f, _), n) -> ( + f n ev + >>= function + | `Unhandled -> handle_event n ev + | `Handled -> Lwt.return `Handled ) + | `Attr (`Handle f, n) -> ( + f n ev + >>= function + | `Handled -> Lwt.return `Handled + | `Event e -> handle_event n e ) + | `Attr (_, n) -> handle_event n ev + | `Region (_, r) -> + Region.fold_lwt_opt ~t:r + ~f:(fun _ n (es : event_status) -> + match es with + | `Event e -> ( + handle_event n e + >>= function + | `Handled -> Lwt.return None + | x -> Lwt.return (Some x) ) + | `Handled -> Lwt.return None ) + (`Event ev) *) - let sub' str p l = - if p = 0 && l = String.length str then str - else String.sub str p l + (* + let _nav (code, (ctrl, meta, shift, super)) = + let nomod = (false, false, false, false) in + (match code, (ctrl, meta, shift, super) with + `Enter, x when x = nomod -> (* `Focus `Next *) () + | `Uchar b when b = (Uchar.of_char 'b') -> ) - (* let edit_field ?(focus = Focus.make ()) state ~on_change = - let update focus_h focus (text, pos) = - let pos = min (max 0 pos) (String.length text) in - let content = - Ui.atom @@ I.hcat - @@ - if Focus.has_focus focus then - let attr = attr_clickable in - let len = String.length text in - ( if pos >= len then [I.string attr text] - else [I.string attr (sub' text 0 pos)] ) - @ - if pos < String.length text then - [ I.string Attr.(bg lightred) (sub' text pos 1) - ; I.string attr (sub' text (pos + 1) (len - pos - 1)) ] - else [I.string Attr.(bg lightred) " "] - else - [ I.string - Attr.(st underline) - (if text = "" then " " else text) ] in - let handler = function - | `ASCII 'U', [`Ctrl] -> - on_change ("", 0) ; - `Handled (* clear *) - | `ASCII 'k', [`Ctrl] -> - on_change (String.sub text 0 pos, pos) ; - `Handled (* clear *) - | `Escape, [] | `ASCII 'n', [`Ctrl] -> - Focus.release focus_h ; `Handled - | `ASCII k, [] -> - let text = - if pos < String.length text then - String.sub text 0 pos ^ String.make 1 k - ^ String.sub text pos (String.length text - pos) - else text ^ String.make 1 k in - on_change (text, pos + 1) ; - `Handled - | `Backspace, _ -> - let text = - if pos > 0 then - if pos < String.length text then - String.sub text 0 (pos - 1) - ^ String.sub text pos (String.length text - pos) - else if String.length text > 0 then - String.sub text 0 (String.length text - 1) - else text - else text in - let pos = max 0 (pos - 1) in - on_change (text, pos) ; - `Handled - | `Arrow `Left, [] | `ASCII 'b', [`Ctrl] -> - if pos > 0 && pos < String.length text then ( - on_change (text, pos - 1) ; - `Handled ) - else `Unhandled - | `Arrow `Right, [] | `ASCII 'f', [`Ctrl] -> - let pos = pos + 1 in - if pos <= String.length text then ( - on_change (text, pos) ; - `Handled ) - else `Unhandled - | `ASCII 'e', [`Ctrl] -> - on_change (text, String.length text) ; - `Handled - | `ASCII 'a', [`Ctrl] -> - on_change (text, 0) ; - `Handled - | _ -> `Unhandled in - Ui.keyboard_area ~focus handler content in - let node = - Lwd.map2 ~f:(update focus) (Focus.status focus) state in - let mouse_grab (text, pos) ~x ~y:_ = function - | `Left -> - if x <> pos then on_change (text, x) ; - Nottui.Focus.request focus ; - `Handled - | _ -> `Unhandled in - Lwd.map2 state node ~f:(fun state content -> - Ui.mouse_area (mouse_grab state) content ) + let navigator n = + focus + ( (fun (n : node) : (Event.t -> status Lwt.t) -> function + | `Key (`Press, {ctrl; meta; shift; super; code}) -> + Lwt.return( _nav (code, (ctrl, meta, shift, super))) + | x -> Lwt.return (`Event x) ) + , Focus.make () ) + n +*) + let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t = + let rq = Lwd.make_release_queue () in + let root = Lwd.observe t in + Lwt.return (fun ev -> + let r = Lwd.sample rq root in + (*handle_events r ev + >>= fun h -> + ( match h with + | [] -> () + | _ -> F.epr "handle_event: Unhandled event@." ) ;*) + Lwt.return (Draw.pane r) ) - let simple_edit s = - let var = Lwd.var (s, 0) in - edit_field (Lwd.get var) ~on_change:(Lwd.set var) - *) - (* let render (img : Notty.I.t) w h : Wall.Image.t = - let module WI = Wall.Image in - let open Operation in - let simple_text ~x ~y s a : Wall.image = - let font = get_font a in - let fm = Text.Font.font_metrics font in - let font_height = fm.ascent -. fm.descent +. fm.line_gap in - (* let _, (_, redbox) = path_box Color.red bextent s in*) - WI.paint (Wall.Paint.color a.fg) - Text.(simple_text font ~valign:`TOP ~halign:`LEFT ~x ~y s) - in - let a' = ref attr_default in - let rec line (x, y) (op : Operation.t) : Wall.Image.t = - match op with - | End -> Image.empty - | Skip (n, End) -> Image.empty - | Text (a, x, End) -> erase cap buf ; text_op cap buf a x - | Skip (n, ops) -> - WI.stack - (simple_text !a' (String.make n ' ')) - (line (x, y) 0) - | Text (a, x, ops) -> - a' := a ; - WI.stack (simple_text a x) (line (x, y) ops) in - let rec lines = function - | [] -> () - | [ln] -> line cap buf ln ; cap.sgr Attr.empty buf - | ln :: lns -> - line cap buf ln ; cap.newline buf ; lines cap buf lns - in - simple_text - Operation.of_image (0 0) (w h) img |> lines*) - - let scroll_area ?(offset = (0, 0)) ?(scroll_step = 1) t = - let offset = Lwd.var offset in - let scroll d_x d_y = - let s_x, s_y = Lwd.peek offset in - let s_x = max 0 (s_x + d_x) in - let s_y = max 0 (s_y + d_y) in - Lwd.set offset (s_x, s_y) ; - `Handled in - let focus_handler = function - | `Arrow `Left, [] -> scroll (-scroll_step) 0 - | `Arrow `Right, [] -> scroll (+scroll_step) 0 - | `Arrow `Up, [] -> scroll 0 (-scroll_step) - | `Arrow `Down, [] -> scroll 0 (+scroll_step) - | `Page `Up, [] | `ASCII 'v', [`Ctrl] -> - scroll 0 (-scroll_step * 8) - | `Page `Down, [] | `ASCII 'v', [`Meta] -> - scroll 0 (+scroll_step * 8) - | _ -> `Unhandled in - let scroll_handler ~x:_ ~y:_ = function - | `Scroll `Up -> scroll 0 (-scroll_step) - | `Scroll `Down -> scroll 0 (+scroll_step) - | _ -> `Unhandled in - Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) -> - t |> Ui.shift_area s_x s_y - |> Ui.mouse_area scroll_handler - |> Ui.keyboard_area focus_handler ) - - (* let menu (items : 'a Lwd_table.t) : ui Lwd.t = - Lwd_table.map_reduce - (fun row r -> Ui.keyboard_area) - Ui.pack_y items*) - - let panel wm () = - let events, push_event = Lwt_stream.create () in - let size = ref (200, 200) in - let check_size ?(scale = 10.) {box; _} = - let newsize = - ( int_of_float (Box2.w box /. scale) - , int_of_float (Box2.h box /. scale) ) in - if newsize <> !size then size := newsize ; - push_event (Some (`Resize !size)) in - let pane = ref Display.pane_empty in - let images = Nottui_lwt.render ~size:!size events wm in - Lwt.return - { act= - (fun _panel ev -> - List.iter push_event (convert_events ev) ; - Lwt_stream.last_new images - >>= fun img -> - (pane := - fun s -> - check_size s ; - draw_pp 20.0 - (fun pp -> - (Notty.Render.pp Notty.Cap.dumb pp) img ; - F.flush pp () ) - s ) ; - Lwt.return !pane ) - ; subpanels= [] - ; tag= "binding-state" } + let test = + panel + (Lwd.pure + (style Style.dark + (join_y + (join_y + (Text.of_string + "-- welcome to the land of idiots ---" ) + (join_x + (Text.of_string "hello bitch") + (Text.of_string "! sup dude") ) ) + (Text.of_string "test 1 2 3 4 5 6") ) ) ) end end @@ -1814,9 +1737,10 @@ module Toplevel = struct t.eval ppf (str ^ ";;") ; (*HACK to prevent getting stuck in parser*) let b = Buffer.create 69 in - Panel.format_symbolic_output_buffer - (Format.formatter_of_buffer b) - t.res + Panel.( + format_symbolic_output_buffer + (Format.formatter_of_buffer b) + t.res) with e -> F.pf ppf "Exception in pane_top//eval@." ; Location.report_exception ppf e ; @@ -1826,8 +1750,6 @@ module Toplevel = struct end module Store = struct - module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String) - (* storeview shows items of the selected level *) type storeview = @@ -1932,7 +1854,7 @@ module Store = struct ~info:(Irmin_unix.info "editor-save") path content ) in let editbinds = - let open Input.Bind in + let open Key.Bind in add [([Ctrl], Char 'c')] [ Custom @@ -2012,7 +1934,7 @@ module Store = struct Lwt.return_unit | None -> Lwt.return_unit in let navbinds = - let open Input.Bind in + let open Key.Bind in let new_contents name content = Lwt.async (fun () -> let s = @@ -2083,7 +2005,7 @@ module Store = struct (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ] empty in - let bindstate = Input.Bind.init navbinds in + let bindstate = Key.Bind.init navbinds in Lwt.return Panel. { act= @@ -2092,7 +2014,7 @@ module Store = struct (not sv.editmode) && not (Panel.Modal.is_active modalstate) then - Input.Bind.process bindstate events + Key.Bind.process bindstate events >>= fun () -> Lwt.join [update_storeview (); update_textedit ()] else Lwt.return_unit ) @@ -2132,11 +2054,27 @@ let std_actor (root_panel : Panel.t Lwt.t) = (s, Display.fill_box (Display.gray 0.125) s.box) ) ; root_panel ] ) -let root_actor = ref (std_actor (Store.editor "../rootstore")) +let image_pane (f : (Event.events -> Panel.Ui.image Lwt.t) Lwt.t) : + Panel.t Lwt.t = + f (* do the initialization (lol what?) *) + >>= fun f -> + Lwt.return + Panel. + { act= + (fun _ events -> + f events + >>= fun i -> + Lwt.return (fun s -> + (s, (Gg.Box2.of_pts Gg.V2.zero (snd i), fst i)) ) ) + ; subpanels= [] + ; tag= "irc" } + +let root_actor = + ref + (std_actor + (image_pane Panel.Ui.test) (*Store.editor "../rootstore"*) ) let start () = - (* root_actor := - std_actor Panel.Nottui.(panel (simple_edit "hello edit") ()) ;*) Display.( run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ()) diff --git a/irc.ml b/irc.ml index ba0b068..f504853 100644 --- a/irc.ml +++ b/irc.ml @@ -244,6 +244,9 @@ module Communicator = struct end module Panel = struct + open Panel + open Panel.Ui + type viewer = { step: string ; var: view Lwd.var @@ -355,13 +358,6 @@ module Communicator = struct >>= fun t' -> Lwd.set root t' ; Lwt.return_unit ) >>= fun watch -> Lwt.return (watch, root) - open Nottui - module P = Nottui_pretty - - let string ?attr text = P.ui (Nottui_widgets.string ?attr text) - let ( ^^ ) = P.( ^^ ) - let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b) - let channelview (store, path) = storeview store path >>= fun (_watch, root) -> @@ -382,7 +378,7 @@ module Communicator = struct v'.node ) in Lwd.map sub ~f:(fun sub -> Ui.join_y - (Nottui_widgets.string + (Ui.string ( String.make indent '>' ^ " " ^ v'.step ) ) sub ) ) in @@ -433,39 +429,31 @@ module Communicator = struct messagelist ch mlist >>= fun watch -> update_messagelist (Some watch) () in Lwt.async (update_messagelist None) ; - let doc = - Lwd.map (Lwd.get mlist) ~f:(fun mlist -> - List.fold_left - (fun doc ((year, month, day, hour, sec), content) -> - F.epr "Communicator.Panel.messagelist ch.content=%s@." - content ; - doc - ^^ P.group - ( string - (F.str "%s.%s.%s.%s.%s" year month day hour - sec ) - ^^ string " | " ^^ string content ) - ^^ P.hardline ) - P.empty mlist ) in Lwt.return - (Panel.Nottui.scroll_area (Lwd.map doc ~f:(P.pretty 100))) + (Lwd.map (Lwd.get mlist) ~f:(fun mlist -> + scroll + (List.fold_left + (fun doc ((year, month, day, hour, sec), content) -> + F.epr + "Communicator.Panel.messagelist ch.content=%s@." + content ; + doc + ^/^ Ui.string + (F.str "%s.%s.%s.%s.%s" year month day hour + sec ) + ^^ Ui.string " | " ^^ string content ) + Ui.empty mlist ) ) ) let commview (store, path) = channelview (store, List.rev (List.tl (List.rev path))) >>= fun (ch, cv) -> messageview ch >>= fun mv -> - Lwt.return - (Nottui_widgets.h_pane (Panel.Nottui.scroll_area cv) mv) + Lwt.return (Lwd.map2 cv mv ~f:(fun c m -> join_x c m)) - open Nottui_widgets - - let panel ({store; view} : Tree.t) = - let base = Lwd.var Nottui_widgets.empty_lwd in - commview (store, view) - >>= fun cv -> - Lwd.set base cv ; - Panel.Nottui.panel (Lwd.join (Lwd.get base)) () + let panel ({store; view} : Tree.t) : (Event.t -> atom Lwt.t) Lwt.t + = + commview (store, view) >>= fun cv -> Panel.Ui.panel cv end end @@ -481,8 +469,26 @@ let _ = >>= fun comm -> Communicator.Irc.Config.make_connection comm "irc.hackint.org" 6697 "cqcaml" - >|= fun () -> + >>= fun () -> Lwt.async (fun () -> Communicator.Irc.connect comm) ; F.epr "root_actor := std_actor (Communicator.Panel.panel comm)@." ; - root_actor := std_actor (Communicator.Panel.panel comm) ) + Communicator.Panel.panel comm + >|= fun f -> + root_actor := + std_actor + (Lwt.return + Panel. + { act= + (fun _ events -> + Lwt_list.fold_left_s + (fun _ ev -> + f ev + >>= fun i -> + Lwt.return (fun s -> + ( s + , ( Gg.Box2.of_pts Gg.V2.zero (snd i) + , fst i ) ) ) ) + Display.pane_empty events ) + ; subpanels= [] + ; tag= "irc" } ) )