From 281351371df8ac6cbb61299080ec7ccef6133a98 Mon Sep 17 00:00:00 2001 From: cqc Date: Thu, 6 Oct 2022 12:18:32 -0500 Subject: [PATCH] Irmin_git.KV (Irmin_git.Mem) (Git.Mem.Sync (Irmin_git.Mem)) results in a.caml_thread_initialize is not a function --- .ocamlformat | 1 - boot_js.ml | 78 ++++-- dune | 8 +- human.ml | 747 ++++++++++++++++++++++++++++----------------------- 4 files changed, 469 insertions(+), 365 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index e605134..e69de29 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1 +0,0 @@ -profile = compact \ No newline at end of file diff --git a/boot_js.ml b/boot_js.ml index 8387760..9e6e767 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -1,4 +1,5 @@ open Js_of_ocaml +open Lwt.Infix module NVG = Graphv_webgl (* This scales the canvas to match the DPI of the window, @@ -8,48 +9,55 @@ let scale_canvas (canvas : Dom_html.canvasElement Js.t) = let rect = canvas##getBoundingClientRect in let width = rect##.right -. rect##.left in let height = rect##.bottom -. rect##.top in - canvas##.width := width *. dpr |> int_of_float ; - canvas##.height := height *. dpr |> int_of_float ; + canvas##.width := width *. dpr |> int_of_float; + canvas##.height := height *. dpr |> int_of_float; let width = - Printf.sprintf "%dpx" (int_of_float width) |> Js.string in + Printf.sprintf "%dpx" (int_of_float width) |> Js.string + in let height = - Printf.sprintf "%dpx" (int_of_float height) |> Js.string in - canvas##.style##.width := width ; + Printf.sprintf "%dpx" (int_of_float height) |> Js.string + in + canvas##.style##.width := width; canvas##.style##.height := height let _ = let canvas = - Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas") in - scale_canvas canvas ; + Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas") + in + scale_canvas canvas; let webgl_ctx = (* Graphv requires a stencil buffer to work properly *) let attrs = WebGL.defaultContextAttributes in - attrs##.stencil := Js._true ; + attrs##.stencil := Js._true; match WebGL.getContextWithAttributes canvas attrs |> Js.Opt.to_option with | None -> - print_endline "Sorry your browser does not support WebGL" ; + print_endline "Sorry your browser does not support WebGL"; raise Exit - | Some ctx -> ctx in + | Some ctx -> ctx + in let open NVG in let vg = create ~flags:CreateFlags.(antialias lor stencil_strokes) - webgl_ctx in + webgl_ctx + in (* File in this case is actually the CSS font name *) - Text.create vg ~name:"sans" ~file:"sans" |> ignore ; - webgl_ctx##clearColor 0.3 0.3 0.32 1. ; - let render ev = + Text.create vg ~name:"sans" ~file:"sans" |> ignore; + webgl_ctx##clearColor 0.3 0.3 0.32 1.; + + (* + let render ev = webgl_ctx##clear - ( webgl_ctx##._COLOR_BUFFER_BIT_ + (webgl_ctx##._COLOR_BUFFER_BIT_ lor webgl_ctx##._DEPTH_BUFFER_BIT_ - lor webgl_ctx##._STENCIL_BUFFER_BIT_ ) ; + lor webgl_ctx##._STENCIL_BUFFER_BIT_); let device_ratio = Dom_html.window##.devicePixelRatio in begin_frame vg ~width:canvas##.width ~height:canvas##.height - ~device_ratio ; - Transform.scale vg ~x:device_ratio ~y:device_ratio ; - ignore Human.Panel.Ui.(panel vg Gg.P2.o test ev) ; + ~device_ratio; + Transform.scale vg ~x:device_ratio ~y:device_ratio; + ignore Human.Panel.Ui.(panel vg Gg.P2.o test ev); (* Path.begin_ vg ; Path.rect vg ~x:40. ~y:40. ~w:320. ~h:320. ; @@ -62,11 +70,31 @@ let _ = Text.set_align vg ~align:Align.(center lor middle) ; set_fill_color vg ~color:Color.white ; Text.text vg ~x:0. ~y:0. "Hello World!" ; *) - NVG.end_frame vg in + NVG.end_frame vg + in Dom_html.window##requestAnimationFrame (Js.wrap_callback (fun _ -> render Human.Event.empty)) - |> ignore ; - Dom_html.document##.onkeydown - := Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) -> - render (Human.Event_js.evt_of_jskey `Press evt) ; - Js._false ) + |> ignore;*) + let open Js_of_ocaml_lwt.Lwt_js_events in + async (fun () -> + buffered_loop (make_event Dom_html.Event.keydown) + Dom_html.document (fun ev _ -> + webgl_ctx##clear + (webgl_ctx##._COLOR_BUFFER_BIT_ + lor webgl_ctx##._DEPTH_BUFFER_BIT_ + lor webgl_ctx##._STENCIL_BUFFER_BIT_); + let device_ratio = Dom_html.window##.devicePixelRatio in + begin_frame vg ~width:canvas##.width ~height:canvas##.height + ~device_ratio; + Transform.scale vg ~x:device_ratio ~y:device_ratio; + Human.Panel.Ui.( + render_lwt vg Gg.P2.o + (Human.Event_js.evt_of_jskey `Press ev)) + >>= fun () -> + NVG.end_frame vg; + Lwt.return_unit)) + +(* Dom_html.document##.onkeydown + := Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) -> + render (Human.Event_js.evt_of_jskey `Press evt) ; + Js._false ) *) diff --git a/dune b/dune index fda4166..ade5a62 100644 --- a/dune +++ b/dune @@ -11,10 +11,10 @@ (libraries fmt graphv_webgl - js_of_ocaml - lwt - irmin - irmin-git + js_of_ocaml-lwt + digestif.ocaml + irmin.mem + irmin-git.unix zed gg diff --git a/human.ml b/human.ml index a1d6e93..c3d880e 100644 --- a/human.ml +++ b/human.ml @@ -34,20 +34,28 @@ module NVG = Graphv_webgl module Nav = struct open Lwt.Infix - - module S = Irmin_mem.KV.Make(Irmin.Contents.String) + + module Maker = + Irmin_git.KV (Irmin_git.Mem) (Git.Mem.Sync (Irmin_git.Mem)) + + module S = Maker.Make (Irmin.Contents.String) + module Sync = Irmin.Sync.Make (S) type t = S.tree - let init () : t Lwt.t = - S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree + let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree let test_populate () : t Lwt.t = let add p s t = S.Tree.add t p s in - add ["hello"] "world" (S.Tree.empty ()) >>= - add ["hello";"daddy"] "ily" >>= - add ["beep";"beep"] "motherfucker" + add [ "hello" ] "world" (S.Tree.empty ()) + >>= add [ "hello"; "daddy" ] "ily" + >>= add [ "beep"; "beep" ] "motherfucker" + let test_pull () : t Lwt.t = test_populate () + (* S.Repo.v (Irmin_git.config "") >>= fun repo -> + S.of_branch repo "master" >>= fun t -> + let upstream = Irmin.Sync.remote_store (module S) t in + Sync.pull_exn t upstream `Set >>= fun _ -> S.tree t *) end module Key = struct @@ -55,9 +63,9 @@ module Key = struct [ `Enter | `Escape | `Tab - | `Arrow of [`Up | `Down | `Left | `Right] + | `Arrow of [ `Up | `Down | `Left | `Right ] | `Function of int - | `Page of [`Up | `Down] + | `Page of [ `Up | `Down ] | `Home | `End | `Insert @@ -66,11 +74,18 @@ module Key = struct | `Unknown of string ] (* Type of key code. *) - type code = [`Uchar of Uchar.t (* A unicode character. *) | special] - type keyaction = [`Press | `Release | `Repeat] + type code = + [ `Uchar of Uchar.t (* A unicode character. *) | special ] - type keystate = - {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} + type keyaction = [ `Press | `Release | `Repeat ] + + type keystate = { + ctrl : bool; + meta : bool; + shift : bool; + super : bool; + code : code; + } module KeyS = struct type t = keystate @@ -86,11 +101,12 @@ module Key = struct type 'a resolver = 'a list S.resolver type 'a result = 'a list S.result - type 'a state = - { mutable bindings: 'a t - ; mutable state: 'a result - ; mutable last_keyseq: keystate list - ; mutable last_actions: 'a list } + type 'a state = { + mutable bindings : 'a t; + mutable state : 'a result; + mutable last_keyseq : keystate list; + mutable last_actions : 'a list; + } type mods = Ctrl | Meta | Super | Shift type key = C of char | U of code @@ -99,10 +115,10 @@ module Key = struct List.fold_left (fun ks m -> match m with - | Meta -> {ks with meta= true} - | Ctrl -> {ks with ctrl= true} - | Super -> {ks with super= true} - | Shift -> {ks with shift= true} ) + | Meta -> { ks with meta = true } + | Ctrl -> { ks with ctrl = true } + | Super -> { ks with super = true } + | Shift -> { ks with shift = true }) ks m let add events action bindings = @@ -110,25 +126,33 @@ module Key = struct List.map (fun (m, k) -> keystate_of_mods - { meta= false - ; ctrl= false - ; super= false - ; shift= false - ; code= - ( match k with + { + meta = false; + ctrl = false; + super = false; + shift = false; + code = + (match k with | C c -> `Uchar (Uchar.of_char c) - | U c -> c ) } - m ) - events in + | U c -> c); + } + m) + events + in S.add events action bindings - let default_resolver b = S.resolver [S.pack (fun x -> x) b] + let default_resolver b = S.resolver [ S.pack (fun x -> x) b ] let get_resolver result default = match result with S.Continue r -> r | _ -> default let init bindings = - {bindings; state= S.Rejected; last_keyseq= []; last_actions= []} + { + bindings; + state = S.Rejected; + last_keyseq = []; + last_actions = []; + } let resolve = S.resolve let empty = S.empty @@ -141,24 +165,24 @@ module Key = struct (fun e -> match e with | `Key (`Press, (k : keystate)) -> ( - ( match state.state with + (match state.state with | Continue _ -> () - | _ -> state.last_keyseq <- [] ) ; + | _ -> state.last_keyseq <- []); state.state <- resolve k (get_resolver state.state - (default_resolver state.bindings) ) ; - state.last_keyseq <- k :: state.last_keyseq ; + (default_resolver state.bindings)); + state.last_keyseq <- k :: state.last_keyseq; match state.state with | Accepted a -> - state.last_actions <- a ; + state.last_actions <- a; Some a | Rejected -> - state.last_actions <- [] ; + state.last_actions <- []; None - | _ -> None ) - | _ -> None ) - events ) + | _ -> None) + | _ -> None) + events) let actions_of_events (state : action state) events = List.flatten @@ -166,24 +190,24 @@ module Key = struct (fun e -> match e with | `Key (`Press, (k : keystate)) -> ( - ( match state.state with + (match state.state with | Continue _ -> () - | _ -> state.last_keyseq <- [] ) ; + | _ -> state.last_keyseq <- []); state.state <- resolve k (get_resolver state.state - (default_resolver state.bindings) ) ; - state.last_keyseq <- k :: state.last_keyseq ; + (default_resolver state.bindings)); + state.last_keyseq <- k :: state.last_keyseq; match state.state with | Accepted a -> - state.last_actions <- a ; + state.last_actions <- a; Some a | Rejected -> - state.last_actions <- [] ; + state.last_actions <- []; None - | _ -> None ) - | _ -> None ) - events ) + | _ -> None) + | _ -> None) + events) let process bindstate events = List.iter @@ -211,7 +235,7 @@ module Key = struct | `Insert -> "Insert" | `Delete -> "Delete" | `Backspace -> "Backspace" - | `Unknown s -> String.concat "Unknown " ["\""; s; "\""] + | `Unknown s -> String.concat "Unknown " [ "\""; s; "\"" ] let to_string key = Printf.sprintf @@ -221,11 +245,11 @@ module Key = struct let to_string_compact key = let buffer = Buffer.create 32 in - if key.ctrl then Buffer.add_string buffer "Ctrl-" ; - if key.meta then Buffer.add_string buffer "Meta-" ; - if key.shift then Buffer.add_string buffer "Shift-" ; - if key.super then Buffer.add_string buffer "Super-" ; - ( match key.code with + if key.ctrl then Buffer.add_string buffer "Ctrl-"; + if key.meta then Buffer.add_string buffer "Meta-"; + 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.to_int ch in if Uchar.is_char ch then @@ -246,7 +270,7 @@ module Key = struct | `Page `Up -> Buffer.add_string buffer "pgdn" | code -> Buffer.add_string buffer - (String.lowercase_ascii (string_of_code code)) ) ; + (String.lowercase_ascii (string_of_code code))); Buffer.contents buffer end @@ -269,10 +293,10 @@ module Event = struct let to_string : t -> string = function | `Key (x, k) -> "`Key " - ^ ( match x with + ^ (match x with | `Press -> "`Press " | `Release -> "`Release " - | `Repeat -> "`Repeat " ) + | `Repeat -> "`Repeat ") ^ Key.to_string k | `Mouse m -> F.str "`Mouse %a" V2.pp m | `Quit -> "`Quit" @@ -295,16 +319,17 @@ module Event_js = struct match Uutf.decode dec with | `Malformed b -> F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@." - (String.escaped b) ; + (String.escaped b); None | `Await -> decode dec d | `End -> d | `Uchar u -> - if Option.is_none d then decode dec (Some u) else None in + if Option.is_none d then decode dec (Some u) else None + in decode (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str) ) + (`String str)) None let of_jskey = function @@ -323,22 +348,24 @@ module Event_js = struct | "Delete" -> `Delete | "Backspace" -> `Backspace | s -> ( - match decode_single_uchar s with - | Some s -> `Uchar s - | None -> `Unknown s ) + match decode_single_uchar s with + | Some s -> `Uchar s + | None -> `Unknown s) let evt_of_jskey (p : Key.keyaction) (evt : Dom_html.keyboardEvent Js.t) : Event.t = match Js.Optdef.to_option evt##.key with | Some s -> `Key - ( p - , Key. - { meta= Js.to_bool evt##.altKey - ; shift= Js.to_bool evt##.shiftKey - ; ctrl= Js.to_bool evt##.ctrlKey - ; super= Js.to_bool evt##.metaKey - ; code= of_jskey (Js.to_string s) } ) + ( p, + Key. + { + meta = Js.to_bool evt##.altKey; + shift = Js.to_bool evt##.shiftKey; + ctrl = Js.to_bool evt##.ctrlKey; + super = Js.to_bool evt##.metaKey; + code = of_jskey (Js.to_string s); + } ) | None -> `Unknown "keypress .key is None?" end @@ -347,10 +374,11 @@ module Panel = struct open NVG (* current window state to be passed to window renderer *) - type state = - { box: box2 - (* This is cannonically box within which the next element should draw *) - ; renderer: NVG.t } + type state = { + box : box2; + (* This is cannonically box within which the next element should draw *) + renderer : NVG.t; + } (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) @@ -360,12 +388,16 @@ module Panel = struct let pane_empty s = (s, Box2.of_pts (Box2.o s.box) (Box2.o s.box)) let on_failure ~cleanup result = - (match result with Ok _ -> () | Error _ -> cleanup ()) ; + (match result with Ok _ -> () | Error _ -> cleanup ()); result let draw_pane vg pane width height = let _, _ = - pane {box= Box2.v (P2.v 0. 0.) (P2.v width height); renderer= vg} + pane + { + box = Box2.v (P2.v 0. 0.) (P2.v width height); + renderer = vg; + } in Ok () @@ -378,137 +410,159 @@ module Panel = struct let fill_box vg color b = let module Path = NVG.Path in let open NVG in - Path.begin_ vg ; + Path.begin_ vg; Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) - ~h:(Box2.h b) ; - set_fill_color vg ~color ; - fill vg ; + ~h:(Box2.h b); + set_fill_color vg ~color; + fill vg; Box2.max b let path_box vg color ?(width = 0.) b = let module Path = NVG.Path in - Path.begin_ vg ; + Path.begin_ vg; Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) - ~h:(Box2.h b) ; - if width != 0. then NVG.set_stroke_width vg ~width ; - NVG.set_stroke_color vg ~color ; - NVG.stroke vg ; + ~h:(Box2.h b); + if width != 0. then NVG.set_stroke_width vg ~width; + NVG.set_stroke_color vg ~color; + NVG.stroke vg; Box2.max b 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] } + type t = { + size : float option; + font : [ `Sans | `Serif | `Mono | `None ]; + weight : [ `Bold | `Regular | `Light | `None ]; + italic : [ `Italic | `None ]; + underline : [ `Underline | `None ]; + } let empty = - { size= None - ; font= `None - ; weight= `None - ; italic= `None - ; underline= `None } + { + size = None; + font = `None; + weight = `None; + italic = `None; + underline = `None; + } let default = ref - { size= Some 20. - ; font= `Sans - ; weight= `Regular - ; italic= `None - ; underline= `None } + { + size = Some 20.; + font = `Sans; + weight = `Regular; + italic = `None; + underline = `None; + } - let size {size; _} = + let size { size; _ } = match (size, !default.size) with | None, None -> 20. | None, Some s | Some s, _ -> s let merge a b = - { size= - ( match (a.size, b.size) with + { + size = + (match (a.size, b.size) with | None, None -> None | Some s, None | None, Some s -> Some s - | Some s1, Some s2 -> Some (Float.max_num s1 s2) ) - ; font= - ( match (a.font, b.font) with + | Some s1, Some s2 -> Some (Float.max_num s1 s2)); + font = + (match (a.font, b.font) with | `Sans, _ | _, `Sans -> `Sans | `Serif, (`Serif | `Mono | `None) - |(`Mono | `None), `Serif -> + | (`Mono | `None), `Serif -> `Serif | `Mono, (`Mono | `None) | `None, `Mono -> `Mono - | `None, `None -> `None ) - ; weight= - ( match (a.weight, b.weight) with + | `None, `None -> `None); + weight = + (match (a.weight, b.weight) with | `Bold, _ | _, `Bold -> `Bold | `Regular, (`Regular | `Light | `None) - |(`Light | `None), `Regular -> + | (`Light | `None), `Regular -> `Regular | `Light, (`Light | `None) | `None, `Light -> `Light - | `None, `None -> `None ) - ; italic= - ( match (a.italic, b.italic) with + | `None, `None -> `None); + italic = + (match (a.italic, b.italic) with | `Italic, _ | _, `Italic -> `Italic - | _ -> `None ) - ; underline= - ( match (a.underline, b.underline) with + | _ -> `None); + underline = + (match (a.underline, b.underline) with | `Underline, _ | _, `Underline -> `Underline - | _ -> `None ) } + | _ -> `None); + } let set vg t = - ( match t.size with + (match t.size with | Some size -> Text.set_size vg ~size - | None -> () ) ; + | None -> ()); match t.font with | `Sans -> Text.set_font_face vg ~name:"sans" | _ -> () end - type t = {fg: Color.t; bg: Color.t; font: Font.t} + type t = { fg : Color.t; bg : Color.t; font : Font.t } type attr = t let gray a = Color.rgbf ~r:a ~g:a ~b:a let empty = - {fg= Color.transparent; bg= Color.transparent; font= Font.empty} + { + fg = Color.transparent; + bg = Color.transparent; + font = Font.empty; + } - let light = {empty with fg= gray 0.2} - let dark = {empty with fg= gray 0.8} + let light = { empty with fg = gray 0.2 } + let dark = { empty with fg = gray 0.8 } let equal = ( == ) let ( ++ ) a1 a2 = if a1 == empty then a2 else if a2 == empty then a1 else - { a1 with - fg= Color.lerp a1.fg a2.fg ~a:0.5 - ; bg= Color.lerp a1.bg a2.bg ~a:0.5 } + { + a1 with + fg = Color.lerp a1.fg a2.fg ~a:0.5; + bg = Color.lerp a1.bg a2.bg ~a:0.5; + } - let fg fg = {empty with fg} - let bg bg = {empty with bg} + let fg fg = { empty with fg } + let bg bg = { empty with bg } let merge a b = - { fg= Color.lerp a.fg b.fg ~a:0.5 - ; bg= Color.lerp a.bg b.bg ~a:0.5 - ; font= Font.merge a.font b.font } + { + fg = Color.lerp a.fg b.fg ~a:0.5; + bg = Color.lerp a.bg b.bg ~a:0.5; + font = Font.merge a.font b.font; + } let set vg s = - F.epr "Style.set @." ; - NVG.set_fill_color vg ~color:s.bg ; - NVG.set_stroke_color vg ~color:s.fg ; + F.epr "Style.set @."; + NVG.set_fill_color vg ~color:s.bg; + NVG.set_stroke_color vg ~color:s.fg; Font.set vg s.font end module Pad = struct - type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1} + type t = { + t : Gg.size1; + b : Gg.size1; + l : Gg.size1; + r : Gg.size1; + } let empty = - { t= Gg.Size1.zero - ; b= Gg.Size1.zero - ; l= Gg.Size1.zero - ; r= Gg.Size1.zero } + { + t = Gg.Size1.zero; + b = Gg.Size1.zero; + l = Gg.Size1.zero; + r = Gg.Size1.zero; + } - let all v = {t= v; b= v; l= v; r= v} + let all v = { t = v; b = v; l = v; r = v } end module Ui = struct @@ -524,15 +578,15 @@ module Panel = struct | `Attr of attr * node | `Join of dir * node * node ] - and node = {mutable parent: parent; mutable t: t; n: int} - and parent = [`Left of node | `Right of node | `None] - and cursor = {root: node; mutable sel: node} + and node = { mutable parent : parent; mutable t : t; n : int } + and parent = [ `Left of node | `Right of node | `None ] + and cursor = { root : node; mutable sel : node } and atom = [ `Image of image | `Uchar of Uchar.t | `Boundary of boundary - | `Hint of [`Line | `Other] + | `Hint of [ `Line | `Other ] | `Empty ] and attr = @@ -541,27 +595,27 @@ module Panel = struct | `Handler of handler | `Draw of draw ] - and dir = [`X | `Y | `Z] + and dir = [ `X | `Y | `Z ] and image = NVG.Image.image - and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text] + and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ] and style = Style.t and handler = node -> Event.t -> Event.t option - and draw_context = {vg: NVG.t; style: Style.t} + and draw_context = { vg : NVG.t; style : Style.t } and draw = draw_context -> P2.t -> P2.t let node_count = ref 0 let node_n () = - node_count := !node_count + 1 ; + node_count := !node_count + 1; !node_count - 1 let set_parent_on_children n : node = - ( match n.t with + (match n.t with | `Atom _ -> () | `Attr (_, a) -> a.parent <- `Left n | `Join (_, a, b) -> - a.parent <- `Left n ; - b.parent <- `Right n ) ; + a.parent <- `Left n; + b.parent <- `Right n); n let sub (n : node) : node = @@ -575,15 +629,15 @@ module Panel = struct let set_children_on_parent n = match n.parent with - | `Left ({t= `Attr (a, _); _} as s) - |`Right ({t= `Attr (a, _); _} as s) -> - s.t <- `Attr (a, n) ; + | `Left ({ t = `Attr (a, _); _ } as s) + | `Right ({ t = `Attr (a, _); _ } as s) -> + s.t <- `Attr (a, n); n - | `Left ({t= `Join (d, _, b); _} as s) -> - s.t <- `Join (d, n, b) ; + | `Left ({ t = `Join (d, _, b); _ } as s) -> + s.t <- `Join (d, n, b); n - | `Right ({t= `Join (d, a, _); _} as s) -> - s.t <- `Join (d, a, n) ; + | `Right ({ t = `Join (d, a, _); _ } as s) -> + s.t <- `Join (d, a, n); n | _ -> n @@ -592,7 +646,7 @@ module Panel = struct | `Left a | `Right a -> Some a let node (t : t) = - set_parent_on_children {parent= `None; t; n= node_n ()} + set_parent_on_children { parent = `None; t; n = node_n () } let atom (a : atom) = node (`Atom a) let attr (a : attr) (child : node) = node (`Attr (a, child)) @@ -602,22 +656,22 @@ module Panel = struct let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) let pad v n = attr (`Pad (Pad.all v)) n - let rec node_up_ (d : [`Left | `Right]) n' = + let rec node_up_ (d : [ `Left | `Right ]) n' = match (d, n'.parent) with | _, `None -> None - | ( _ - , ( `Left ({t= `Attr _; _} as p) - | `Right ({t= `Attr _; _} as p) ) ) -> + | ( _, + ( `Left ({ t = `Attr _; _ } as p) + | `Right ({ t = `Attr _; _ } as p) ) ) -> node_up_ d p - | `Right, `Right ({t= `Join _; _} as p) - |`Left, `Left ({t= `Join _; _} as p) -> + | `Right, `Right ({ t = `Join _; _ } as p) + | `Left, `Left ({ t = `Join _; _ } as p) -> node_up_ d p - | `Left, `Right {t= `Join (_, l, _); _} -> Some l - | `Right, `Left {t= `Join (_, _, r); _} -> Some r - | _, (`Left {t= `Atom _; _} | `Right {t= `Atom _; _}) -> + | `Left, `Right { t = `Join (_, l, _); _ } -> Some l + | `Right, `Left { t = `Join (_, _, r); _ } -> Some r + | _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) -> assert false - let node_next_ (d : [`Left | `Right]) (n : node) = + let node_next_ (d : [ `Left | `Right ]) (n : node) = match (d, n.t) with | _, `Atom _ -> node_up_ d n | _, `Attr (_, n') -> Some n' @@ -628,31 +682,31 @@ module Panel = struct 'a option = match f n with | None -> ( - match node_next_ `Left n with - | Some n -> search_preorder f n - | None -> None ) + match node_next_ `Left n with + | Some n -> search_preorder f n + | None -> None) | x -> x let rec search_reverse_preorder (f : node -> 'a option) (n : node) : 'a option = match f n with | None -> ( - match node_next_ `Right n with - | Some n -> search_reverse_preorder f n - | None -> None ) + match node_next_ `Right n with + | Some n -> search_reverse_preorder f n + | None -> None) | x -> x let replace_parents_child parent n : node = match parent with - | `Left ({t= `Attr (a, _); _} as p) - |`Right ({t= `Attr (a, _); _} as p) -> - p.t <- `Attr (a, n) ; + | `Left ({ t = `Attr (a, _); _ } as p) + | `Right ({ t = `Attr (a, _); _ } as p) -> + p.t <- `Attr (a, n); n - | `Left ({t= `Join (d, _, r); _} as p) -> - p.t <- `Join (d, n, r) ; + | `Left ({ t = `Join (d, _, r); _ } as p) -> + p.t <- `Join (d, n, r); n - | `Right ({t= `Join (d, l, _); _} as p) -> - p.t <- `Join (d, l, n) ; + | `Right ({ t = `Join (d, l, _); _ } as p) -> + p.t <- `Join (d, l, n); n | _ -> n @@ -663,7 +717,7 @@ module Panel = struct let search_backward f (n : node) = search_reverse_preorder f n let is_atom_uchar = function - | {t= `Atom (`Uchar _); _} as n -> Some n + | { t = `Atom (`Uchar _); _ } as n -> Some n | _ -> None let tree_uchar_fwd n = @@ -675,10 +729,10 @@ module Panel = struct let is_boundary b n = match (b, n.t) with | `Char, `Atom (`Uchar _) - |`Word, `Atom (`Boundary `Word) - |`Phrase, `Atom (`Boundary `Phrase) - |`Line, `Atom (`Boundary `Line) - |`Page, `Atom (`Boundary `Page) -> + | `Word, `Atom (`Boundary `Word) + | `Phrase, `Atom (`Boundary `Phrase) + | `Line, `Atom (`Boundary `Line) + | `Page, `Atom (`Boundary `Page) -> Some n | _ -> None @@ -690,24 +744,25 @@ module Panel = struct let rec traverse_nodes ~(f : node -> node option) (n : node) : unit = match f n with - | Some {t= `Atom _; _} -> () - | Some {t= `Attr (_, n'); _} -> traverse_nodes ~f n' - | Some {t= `Join (_, a, b); _} -> - traverse_nodes ~f a ; traverse_nodes ~f b + | Some { t = `Atom _; _ } -> () + | Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n' + | Some { t = `Join (_, a, b); _ } -> + traverse_nodes ~f a; + traverse_nodes ~f b | None -> () let insert_join_l (d : dir) (n : node) (n' : node) : node = let p = n.parent in let n'' = join d n' n in - n''.parent <- p ; + n''.parent <- p; set_children_on_parent n'' let remove_join_l (n : node) : node = match n.parent with - | `Left ({t= `Attr (_, n'); _} as s) - |`Right ({t= `Attr (_, n'); _} as s) - |`Left ({t= `Join (_, _, n'); _} as s) -> - s.t <- n'.t ; + | `Left ({ t = `Attr (_, n'); _ } as s) + | `Right ({ t = `Attr (_, n'); _ } as s) + | `Left ({ t = `Join (_, _, n'); _ } as s) -> + s.t <- n'.t; n' | _ -> n @@ -718,24 +773,24 @@ module Panel = struct let insert_attr (a : attr) (n : node) : node = let p = n.parent in let n' = node (`Attr (a, n)) in - n'.parent <- p ; + n'.parent <- p; set_children_on_parent n' let remove_attr (n : node) : node = match n.t with | `Attr (_, n') -> - ( match n.parent with - | `Left ({t= `Join (d, _, b); _} as p) -> - p.t <- `Join (d, n', b) ; + (match n.parent with + | `Left ({ t = `Join (d, _, b); _ } as p) -> + p.t <- `Join (d, n', b); ignore (set_parent_on_children p) - | `Right ({t= `Join (d, a, _); _} as p) -> - p.t <- `Join (d, a, n') ; + | `Right ({ t = `Join (d, a, _); _ } as p) -> + p.t <- `Join (d, a, n'); ignore (set_parent_on_children p) - | `Left ({t= `Attr (a, _); _} as p) - |`Right ({t= `Attr (a, _); _} as p) -> - p.t <- `Attr (a, n') ; + | `Left ({ t = `Attr (a, _); _ } as p) + | `Right ({ t = `Attr (a, _); _ } as p) -> + p.t <- `Attr (a, n'); ignore (set_parent_on_children p) - | _ -> () ) ; + | _ -> ()); n' | _ -> assert false @@ -761,7 +816,7 @@ module Panel = struct let pp_boundary ppf v = F.any - ( match v with + (match v with | `Char -> "`Char" | `Word -> "`Word" | `Phrase -> "`Phrase" @@ -769,33 +824,34 @@ module Panel = struct | `Page -> "`Page" | `Text -> "`Text" - (* text is like a file (unicode calls it End Of Text) *) - ) + (* text is like a file (unicode calls it End Of Text) *)) ppf () let pp_atom ppf v = let open Fmt in - ( match v with + (match v with | `Image _ -> any "`Image" | `Uchar c -> any "`Uchar " ++ const pp_uchar c | `Boundary b -> any "`Boundary " ++ const pp_boundary b | `Hint h -> any "`Hint " ++ any - (match h with `Line -> "`Line" | `Other -> "`Other") - | `Empty -> any "`Empty" ) + (match h with + | `Line -> "`Line" + | `Other -> "`Other") + | `Empty -> any "`Empty") ppf () let pp_attr ppf v = let open Fmt in (any - ( match v with + (match v with | `Style _ -> "`Style ..." | `Pad _ -> "`Pad ..." | `Shift _ -> "`Shift ..." | `Cursor -> "`Cursor" | `Handler _ -> "`Handler ..." - | `Draw _ -> "`Draw ..." ) ) + | `Draw _ -> "`Draw ...")) ppf () let pp_dir ppf v = @@ -815,8 +871,8 @@ module Panel = struct | `Join (d, a, b) -> pf ppf "`Join %a" (parens - ( const pp_dir d ++ comma ++ const child a ++ comma - ++ const child b ) ) + (const pp_dir d ++ comma ++ const child a ++ comma + ++ const child b)) () and _pp_parent ppf v = @@ -831,15 +887,18 @@ module Panel = struct pf ppf "@[%a@]" (braces (record - [ field "n" (fun v -> v.n) int - ; field "t" (fun v -> v.t) (_pp_t child) - ; field "parent" (fun v -> v.parent) _pp_parent ] ) ) + [ + field "n" (fun v -> v.n) int; + field "t" (fun v -> v.t) (_pp_t child); + field "parent" (fun v -> v.parent) _pp_parent; + ])) v and pp_node_n_record = F.( braces - (record ~sep:semi [field "n" Fun.id pp_node_n; any "..."])) + (record ~sep:semi + [ field "n" Fun.id pp_node_n; any "..." ])) and pp_node ppf = _pp_node pp_node_n ppf and pp_dump_node ppf = _pp_node pp_dump_node ppf @@ -854,13 +913,16 @@ module Panel = struct const int v.n ++ parens (concat ~sep:comma - ( match v.t with - | `Atom a -> [const pp_atom a] + (match v.t with + | `Atom a -> [ const pp_atom a ] | `Attr (a, n) -> - [const pp_attr a; const pp_node_structure n] + [ const pp_attr a; const pp_node_structure n ] | `Join (d, l, r) -> - [ const pp_dir d; const pp_node_structure l - ; const pp_node_structure r ] ) )) + [ + const pp_dir d; + const pp_node_structure l; + const pp_node_structure r; + ]))) ppf () end @@ -868,11 +930,11 @@ module Panel = struct module Text = struct let rec decode dec (l : 'a) : - 'a * [< `Await | `End | `Uchar of Uchar.t] = + 'a * [< `Await | `End | `Uchar of Uchar.t ] = match Uutf.decode dec with | `Malformed b -> F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." - (String.escaped b) ; + (String.escaped b); decode dec (append_x l (of_string (String.escaped b))) | (`Await | `End | `Uchar _) as s -> (l, s) @@ -886,7 +948,7 @@ module Panel = struct _of_string (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str) ) + (`String str)) empty_append and _lines u d ly (lx, s) = @@ -907,9 +969,8 @@ module Panel = struct (Uuseg.create `Line_break) (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str) ) - empty_append - (empty_append, `Await) + (`String str)) + empty_append (empty_append, `Await) let text = of_string let nl = atom (`Boundary `Line) @@ -918,7 +979,7 @@ module Panel = struct module Draw = struct open NVG - type d = [`X | `Y | `Z] + type d = [ `X | `Y | `Z ] type t = draw_context let vcat d a b = @@ -939,19 +1000,20 @@ module Panel = struct let rec encode c = match Uutf.encode enc c with | `Ok -> () - | `Partial -> encode `Await in - encode (`Uchar uc) ; - encode `End ; + | `Partial -> encode `Await + in + encode (`Uchar uc); + encode `End; let text = Bytes.to_string (Buffer.to_bytes b) in let open NVG in let bounds = Text.bounds vg ~x:(V2.x t) ~y:(V2.y t) text in let metrics = Text.metrics vg in let x, y = (V2.x t, V2.y t +. metrics.ascender) in - Text.text vg ~x ~y text ; + Text.text vg ~x ~y text; P2.v (P2.x t +. bounds.advance) - ( P2.y t +. metrics.ascender +. metrics.descender - +. metrics.line_height ) + (P2.y t +. metrics.ascender +. metrics.descender + +. metrics.line_height) let rec atom vg b (a : atom) : P2.t = let vg = vg.vg in @@ -959,13 +1021,14 @@ module Panel = struct | `Image image -> let wi, hi = Image.size vg image in let w, h = (float wi, float hi) in - Path.begin_ vg ; - Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h ; + Path.begin_ vg; + Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h; let img_paint = Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h - ~angle:0.0 ~image ~alpha:0. in - set_fill_paint vg ~paint:img_paint ; - fill vg ; + ~angle:0.0 ~image ~alpha:0. + in + set_fill_paint vg ~paint:img_paint; + fill vg; P2.v (P2.x b +. w) (P2.y b +. h) | `Uchar uc -> uchar vg b uc | `Boundary _ -> b @@ -977,7 +1040,7 @@ module Panel = struct | `Style s -> path_box t.vg s.bg (Box2.of_pts b - (node {t with style= Style.merge t.style s} b n) ) + (node { t with style = Style.merge t.style s } b n)) | `Pad p -> pad t b p n | `Draw d -> d t b | `Handler _ -> node t b n @@ -990,11 +1053,12 @@ module Panel = struct let av = node vg t a in let bv = node vg - ( match d with + (match d with | `X -> P2.v (P2.x av) (P2.y t) | `Y -> P2.v (P2.x t) (P2.y av) - | `Z -> t ) - b in + | `Z -> t) + b + in match d with | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv)) | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv) @@ -1008,7 +1072,8 @@ module Panel = struct match n.t with | `Atom a -> atom t b a | `Attr a -> attr t b a - | `Join a -> join t b a in + | `Join a -> join t b a + in (*ignore (Display.path_box t.vg (Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) @@ -1049,7 +1114,7 @@ module Panel = struct let pp_dir ppf v = any - ( match v with + (match v with | `Next -> "`Next" | `Prev -> "`Prev" | `Up -> "`Up" @@ -1059,19 +1124,19 @@ module Panel = struct | `Fwd -> "`Fwd" | `Enter -> "`Enter" | `In -> "`In" - | `Out -> "`Out" ) + | `Out -> "`Out") ppf () let pp_segment ppf v = - ( match v with + (match v with | `Beginning s -> any "`Beginning " ++ const pp_boundary s | `Forward s -> any "`Forward " ++ const pp_boundary s | `Backward s -> any "`Backward " ++ const pp_boundary s - | `End s -> any "`End " ++ const pp_boundary s ) + | `End s -> any "`End " ++ const pp_boundary s) ppf () let pp_t ppf v = - ( match v with + (match v with | `Move s -> any "`Move " ++ const pp_segment s | `Insert n -> any "`Insert " ++ const pp_node n | `Overwrite n -> any "`Overwrite " ++ const pp_node n @@ -1080,7 +1145,7 @@ module Panel = struct | `Ascend -> any "`Ascend" | `Descend -> any "`Descend" | `Custom (s, _) -> - fun ppf () -> pf ppf "`Custom \"%a\"" string s ) + fun ppf () -> pf ppf "`Custom \"%a\"" string s) ppf () end @@ -1091,10 +1156,12 @@ module Panel = struct ignore (search_backward (function - | {t= `Atom (`Boundary `Line); _} -> Some () - | {t= `Atom (`Uchar _); _} -> incr i ; None - | _ -> None ) - c.sel ) ; + | { t = `Atom (`Boundary `Line); _ } -> Some () + | { t = `Atom (`Uchar _); _ } -> + incr i; + None + | _ -> None) + c.sel); match search_forward (is_boundary `Line) c.sel with | Some n' -> Some @@ -1102,24 +1169,26 @@ module Panel = struct (fun nn -> Option.value (search_forward (is_boundary `Char) nn) - ~default:nn ) - n' !i ) - | None -> None ) + ~default:nn) + n' !i) + | None -> None) | `Move (`Backward `Line) -> ( let i = ref 0 in match search_backward (function - | {t= `Atom (`Boundary `Line); _} as n' -> Some n' - | {t= `Atom (`Uchar _); _} -> incr i ; None - | _ -> None ) + | { t = `Atom (`Boundary `Line); _ } as n' -> Some n' + | { t = `Atom (`Uchar _); _ } -> + incr i; + None + | _ -> None) c.sel with | Some n' -> Option.map (fun n -> tree_iter tree_uchar_back n !i) (search_backward (is_boundary `Line) n') - | None -> None ) + | None -> None) | `Move (`Forward b) -> Option.map tree_uchar_fwd (search_forward (is_boundary b) c.sel) @@ -1133,7 +1202,7 @@ module Panel = struct Option.map tree_uchar_fwd (search_backward (is_boundary b) c.sel) | `Insert n -> - ignore (insert_join_l `X (super c.sel) n) ; + ignore (insert_join_l `X (super c.sel) n); Some c.sel | `Overwrite _s -> None | `Yank _s -> None @@ -1144,41 +1213,41 @@ module Panel = struct | `Ascend -> option_of_parent c.sel.parent | `Custom _s -> None - type event_status = [`Handled | `Event of Event.t] + type event_status = [ `Handled | `Event of Event.t ] let textedit_bindings = let open Key.Bind in empty - |> add [([Ctrl], C 'f')] [`Move (`Forward `Char)] - |> add [([], U (`Arrow `Right))] [`Move (`Forward `Char)] - |> add [([Ctrl], C 'b')] [`Move (`Backward `Char)] - |> add [([], U (`Arrow `Left))] [`Move (`Backward `Char)] - |> add [([Meta], C 'f')] [`Move (`Forward `Word)] - |> add [([Meta], C 'b')] [`Move (`Backward `Word)] + |> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ] + |> add [ ([], U (`Arrow `Right)) ] [ `Move (`Forward `Char) ] + |> add [ ([ Ctrl ], C 'b') ] [ `Move (`Backward `Char) ] + |> add [ ([], U (`Arrow `Left)) ] [ `Move (`Backward `Char) ] + |> add [ ([ Meta ], C 'f') ] [ `Move (`Forward `Word) ] + |> add [ ([ Meta ], C 'b') ] [ `Move (`Backward `Word) ] |> add - [([Ctrl], C 'c'); ([Ctrl], C 'n')] - [`Move (`Forward `Phrase)] + [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'n') ] + [ `Move (`Forward `Phrase) ] |> add - [([Ctrl], C 'c'); ([Ctrl], C 'p')] - [`Move (`Backward `Phrase)] - |> add [([Ctrl], C 'n')] [`Move (`Forward `Line)] - |> add [([], U (`Arrow `Down))] [`Move (`Forward `Line)] - |> add [([Ctrl], C 'p')] [`Move (`Backward `Line)] - |> add [([], U (`Arrow `Up))] [`Move (`Backward `Line)] - |> add [([Ctrl], C 'v')] [`Move (`Forward `Page)] - |> add [([Meta], C 'v')] [`Move (`Backward `Page)] - |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)] - |> add [([Ctrl], C 'e')] [`Move (`End `Line)] - |> add [([Ctrl], C 'k')] [`Kill (`End `Line)] - |> add [([], U `Backspace)] [`Kill (`Backward `Char)] - |> add [([], U `Delete)] [`Kill (`Forward `Char)] - |> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)] - |> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)] + [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'p') ] + [ `Move (`Backward `Phrase) ] + |> add [ ([ Ctrl ], C 'n') ] [ `Move (`Forward `Line) ] + |> add [ ([], U (`Arrow `Down)) ] [ `Move (`Forward `Line) ] + |> add [ ([ Ctrl ], C 'p') ] [ `Move (`Backward `Line) ] + |> add [ ([], U (`Arrow `Up)) ] [ `Move (`Backward `Line) ] + |> add [ ([ Ctrl ], C 'v') ] [ `Move (`Forward `Page) ] + |> add [ ([ Meta ], C 'v') ] [ `Move (`Backward `Page) ] + |> add [ ([ Ctrl ], C 'a') ] [ `Move (`Beginning `Line) ] + |> add [ ([ Ctrl ], C 'e') ] [ `Move (`End `Line) ] + |> add [ ([ Ctrl ], C 'k') ] [ `Kill (`End `Line) ] + |> add [ ([], U `Backspace) ] [ `Kill (`Backward `Char) ] + |> add [ ([], U `Delete) ] [ `Kill (`Forward `Char) ] + |> add [ ([ Ctrl ], U `Backspace) ] [ `Kill (`Backward `Word) ] + |> add [ ([ Meta ], U `Backspace) ] [ `Kill (`Backward `Word) ] |> add - [([Ctrl], C 'x'); ([], U `Backspace)] - [`Kill (`Backward `Phrase)] - |> add [([Ctrl], C 'q')] [`Ascend] - |> add [([Ctrl], C 'z')] [`Descend] + [ ([ Ctrl ], C 'x'); ([], U `Backspace) ] + [ `Kill (`Backward `Phrase) ] + |> add [ ([ Ctrl ], C 'q') ] [ `Ascend ] + |> add [ ([ Ctrl ], C 'z') ] [ `Descend ] let cursor_attr = `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.)) @@ -1189,8 +1258,7 @@ module Panel = struct (`Draw (fun (t : draw_context) (b : P2.t) -> Draw.node t b - (Text.lines (Fmt.to_to_string pp_node_structure c.root)) - ) ) + (Text.lines (Fmt.to_to_string pp_node_structure c.root)))) (atom `Empty) let draw_cursor_sel (c : cursor) : node = @@ -1199,51 +1267,54 @@ module Panel = struct (`Draw (fun (t : draw_context) (b : P2.t) -> Draw.node t b - (Text.lines (Fmt.to_to_string pp_node (sub c.sel))) ) ) + (Text.lines (Fmt.to_to_string pp_node (sub c.sel))))) (atom `Empty) let textedit ?(bindings = textedit_bindings) (n : node) = - Format.pp_set_max_boxes F.stderr 64 ; + Format.pp_set_max_boxes F.stderr 64; (*full screen fynn *) - Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ; + Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230; let bind = Key.Bind.init bindings in let sel = insert_attr cursor_attr n in - let c = {root= attr (`Handler (fun _ _ -> None)) sel; sel} in + let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in c.root.t <- `Attr ( `Handler (fun (_ : node) (e : Event.t) : Event.t option -> let a = - match Key.Bind.resolve_events bind [e] with + match Key.Bind.resolve_events bind [ e ] with | x :: _ -> Some x | [] -> ( - match e with - | `Key (`Press, (k : Key.keystate)) -> ( - match k.code with - | `Uchar c -> Some (`Insert (atom (`Uchar c))) - | _ -> None ) - | _ -> None ) in + match e with + | `Key (`Press, (k : Key.keystate)) -> ( + match k.code with + | `Uchar c -> + Some (`Insert (atom (`Uchar c))) + | _ -> None) + | _ -> None) + in let r = match a with | Some x -> - c.sel <- remove_attr c.sel ; - ( match perform_action x c with + c.sel <- remove_attr c.sel; + (match perform_action x c with | Some n' -> F.epr "textedit action @[%a@] Success@." - Action.pp_t x ; + Action.pp_t x; c.sel <- n' | None -> F.epr "textedit action @[%a@] Failure@." - Action.pp_t x ) ; - c.sel <- insert_attr cursor_attr c.sel ; + Action.pp_t x); + c.sel <- insert_attr cursor_attr c.sel; None - | None -> None in - r ) - , n ) ; + | None -> None + in + r), + n ); join_y (pad 5. c.root) (join_y (pad 5. (draw_cursor_sel c)) - (pad 5. (draw_cursor_root c)) ) + (pad 5. (draw_cursor_root c))) let handler_of_node (n : node) : handler option = let f n = @@ -1254,27 +1325,33 @@ module Panel = struct let handle_event (n : node) (ev : Event.t) : event_status = match handler_of_node n with | Some f -> ( - match f n ev with Some ev -> `Event ev | None -> `Handled ) + match f n ev with Some ev -> `Event ev | None -> `Handled) | None -> `Event ev let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t = - ( match handle_event t ev with + (match handle_event t ev with | `Handled -> F.epr "Handled %s@." (Event.to_string ev) | `Event _e -> - F.epr "Unhandled event: %s@." (Event.to_string _e) ) ; - Draw.node {vg; style= Style.dark} p t + F.epr "Unhandled event: %s@." (Event.to_string _e)); + Draw.node { vg; style = Style.dark } p t - let test = - style Style.dark - (pad 20. - (textedit - Text.( - (* text "--- welcome to my land of idiocy ---" - ^/^ *) - text "hello bitch" - (*^^ text "! sup daddy" ^^ nl) - ^/^ lines "123")*)) ) ) + let storetree = ref (Nav.test_pull ()) + let storecursor = ref [] + + open Lwt.Infix + + let render_lwt (vg : NVG.t) (p : P2.t) (_ev : Event.t) : + unit Lwt.t = + !storetree >>= fun tree -> + Nav.S.Tree.list tree !storecursor >>= fun l -> + let contents = + String.concat "\n" (List.map (fun (step, _t') -> step) l) + in + + Draw.node { vg; style = Style.dark } p (Text.lines contents) + |> ignore; + Lwt.return_unit end end