diff --git a/boot_js.ml b/boot_js.ml index 031700c..8387760 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -40,7 +40,7 @@ let _ = (* 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 rec render (time : float) = + let render ev = webgl_ctx##clear ( webgl_ctx##._COLOR_BUFFER_BIT_ lor webgl_ctx##._DEPTH_BUFFER_BIT_ @@ -49,7 +49,7 @@ let _ = begin_frame vg ~width:canvas##.width ~height:canvas##.height ~device_ratio ; Transform.scale vg ~x:device_ratio ~y:device_ratio ; - Human.Display.render vg canvas##.width canvas##.height ; + 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,8 +62,11 @@ 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 ; - Dom_html.window##requestAnimationFrame (Js.wrap_callback render) - |> ignore in - Dom_html.window##requestAnimationFrame (Js.wrap_callback render) - |> ignore + 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 ) diff --git a/dune b/dune index f254a42..08f7608 100644 --- a/dune +++ b/dune @@ -1,19 +1,26 @@ (env - (dev - (flags (:standard -warn-error -A)))) + (dev (flags (:standard -warn-error -A)) + (js_of_ocaml (flags --pretty --no-inline --source-map --debug-info) (compilation_mode separate))) + + +) + (executable (name boot_js) (modes byte js) (preprocess (pps js_of_ocaml-ppx)) - (modules boot_js backend backend_js human) + + (modules boot_js human) (libraries + fmt graphv_webgl js_of_ocaml lwt - irmin-git - irmin-indexeddb +; irmin-git +; irmin-indexeddb zed gg + )) diff --git a/dune-project b/dune-project index e5d4aa9..df5cbec 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,2 @@ -(lang dune 2.8) -(name komm) -(wrapped_executables false) +(lang dune 3.4) +(name boot) diff --git a/human.ml b/human.ml index 1657e9d..41c9dbd 100644 --- a/human.ml +++ b/human.ml @@ -22,26 +22,226 @@ some options: open Lwt.Infix module F = Fmt +module NVG = Graphv_webgl (* module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)*) - -module Istore = +(*module Istore = Irmin_git.Generic (Irmin_indexeddb.Content_store) (Irmin_indexeddb.Branch_store) (Irmin.Contents.String) (Irmin.Path.String_list) - (Irmin.Branch.String) + (Irmin.Branch.String)*) -open Backend_js +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 + | `Unknown of string ] + + (* Type of key code. *) + type code = [`Uchar of Uchar.t (* A unicode character. *) | special] + type keyaction = [`Press | `Release | `Repeat] + + type keystate = + {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} + + module KeyS = struct + type t = keystate + + let compare = compare + end + + module Bind = struct + (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) + module S = Zed_input.Make (KeyS) + + type 'a t = 'a list S.t + 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 mods = Ctrl | Meta | Super | Shift + type key = C of char | U of code + + let keystate_of_mods ks m = + 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} ) + ks m + + let add events action bindings = + let events = + List.map + (fun (m, k) -> + keystate_of_mods + { 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 + S.add events action bindings + + 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= []} + + let resolve = S.resolve + let empty = S.empty + + type action = Custom of (unit -> unit) | Zed of Zed_edit.action + + let resolve_events (state : 'a state) events = + List.flatten + (List.filter_map + (fun e -> + match e with + | `Key (`Press, (k : keystate)) -> ( + ( match state.state with + | Continue _ -> () + | _ -> state.last_keyseq <- [] ) ; + state.state <- + resolve k + (get_resolver state.state + (default_resolver state.bindings) ) ; + state.last_keyseq <- k :: state.last_keyseq ; + match state.state with + | Accepted a -> + state.last_actions <- a ; + Some a + | Rejected -> + state.last_actions <- [] ; + None + | _ -> None ) + | _ -> None ) + events ) + + let actions_of_events (state : action state) events = + List.flatten + (List.filter_map + (fun e -> + match e with + | `Key (`Press, (k : keystate)) -> ( + ( match state.state with + | Continue _ -> () + | _ -> state.last_keyseq <- [] ) ; + state.state <- + resolve k + (get_resolver state.state + (default_resolver state.bindings) ) ; + state.last_keyseq <- k :: state.last_keyseq ; + match state.state with + | Accepted a -> + state.last_actions <- a ; + Some a + | Rejected -> + state.last_actions <- [] ; + None + | _ -> None ) + | _ -> None ) + events ) + + let process bindstate events = + List.iter + (function Custom f -> f () | Zed _ -> ()) + (actions_of_events bindstate events) + end + + (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) + let string_of_code = function + | `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" + | `Unknown s -> String.concat "Unknown " ["\""; s; "\""] + + let to_string key = + Printf.sprintf + "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" + key.ctrl key.meta key.shift key.super + (string_of_code key.code) + + 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 + | `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' + | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' + | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' + | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch -> + Buffer.add_char buffer ch + | ' ' -> Buffer.add_string buffer "space" + | _ -> Printf.bprintf buffer "U+%02x" code + else if code <= 0xffff then + Printf.bprintf buffer "U+%04x" code + else Printf.bprintf buffer "U+%06x" code + | `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)) ) ; + Buffer.contents buffer +end module Event = struct open Gg type mouse = V2.t + type keystate = Key.keystate + type keyaction = Key.keyaction type t = - [ `Key of [`Press | `Release | `Repeat] * Key.keystate + [ `Key of keyaction * keystate | `Mouse of mouse | `Quit | `Fullscreen of bool @@ -49,7 +249,7 @@ module Event = struct type events = t list - let to_string = function + let to_string : t -> string = function | `Key (x, k) -> "`Key " ^ ( match x with @@ -63,20 +263,73 @@ module Event = struct | `Unknown s -> F.str "`Unknown %s" s let handle_keyevents (el : events) f = List.iter f el + let empty = `Unknown "empty" +end + +module Event_js = struct + include Event + open Js_of_ocaml + + type t = Dom_html.Keyboard_code.t + + let decode_single_uchar (str : string) = + (* yea we return None if there is more than one Uchar bitch **) + let rec decode dec (d : Uchar.t option) : Uchar.t option = + match Uutf.decode dec with + | `Malformed b -> + F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@." + (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 + decode + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str) ) + None + + let of_jskey = function + | "Enter" -> `Enter + | "Escape" -> `Escape + | "Tab" -> `Tab + | "ArrowUp" -> `Arrow `Up + | "ArrowDown" -> `Arrow `Down + | "ArrowLeft" -> `Arrow `Left + | "ArrowRight" -> `Arrow `Right + | "PageUp" -> `Page `Up + | "PageDown" -> `Page `Down + | "Home" -> `Home + | "End" -> `End + | "Insert" -> `Insert + | "Delete" -> `Delete + | "Backspace" -> `Backspace + | 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) } ) + | None -> `Unknown "keypress .key is None?" end module Display = struct open Gg - module NVG = Graphv_webgl module I = NVG.Image module P = NVG.Path - - let ( >>>= ) x f = - match x with Ok a -> f a | Error _ as result -> result - - let get_result = function - | Ok x -> x - | Error (`Msg msg) -> failwith msg + module Color = NVG.Color (* current window state to be passed to window renderer *) type state = @@ -86,204 +339,67 @@ module Display = struct (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) - type image = box2 * NVG.Image.image - type pane = state -> state * image - type actor = (Event.events -> pane Lwt.t) ref + type pane = state -> state * box2 + type actor = (Event.t -> P2.t) ref - let pane_empty s = - (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), I.dummy)) + 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 ()) ; result let draw_pane vg pane width height = - let _, (b, image) = + let _, _ = pane {box= Box2.v (P2.v 0. 0.) (P2.v width height); renderer= vg} in - let w, h = (Box2.w b, Box2.h b) in - let paint = - NVG.Paint.image_pattern vg ~cx:0. ~cy:0. ~w ~h ~angle:0. ~image - ~alpha:1. in - NVG.set_fill_paint vg ~paint ; - NVG.fill vg ; Ok () - let successful_actor = ref (fun _ -> Lwt.return pane_empty) - - let render (vg : NVG.t) (w : float) (h : float) (actor : actor) = - if List.length events > 0 then ( - (* recompute the actor definition with the new events to return a new pane *) - ( try - !actor events - >|= fun p -> - successful_actor := !actor ; - p - with e -> - F.epr - "Display.display_frame (!actor events) failed with:@. %s \ - @." - (Printexc.to_string e) ; - actor := !successful_actor ; - !actor events ) - >>= fun p -> - (* call draw_pane because we should redraw now that we have updated *) - ignore (draw_pane vg p w h) ; - Lwt.return_unit ) - else Lwt.return_unit - - 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 = - 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") - let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") - let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") - let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf") - - let font_sans_bold_italic = - lazy (load_font "fonts/Roboto-BoldItalic.ttf") - - let font_serif = - lazy (load_font "fonts/ScheherazadeNew-Regular.ttf") - - let font_serif_bold = - lazy (load_font "fonts/ScheherazadeNew-Bold.ttf") - - let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular") - - let font_mono_bold = - lazy (load_font "fonts/static/RobotoMono-Regular") - - let font_mono_light = - lazy (load_font "fonts/static/RobotoMono-Regular") - - let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") + let gray ?(a = 1.0) v = Color.rgbaf ~r:v ~g:v ~b:v ~a let str_of_box b = Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) (Box2.oy b) (Box2.maxx b) (Box2.maxy b) - let draw_label text b = - let f = NVG.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)) - Wall_text.( - simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) - ~y:(Box2.oy b +. (Box2.h b *. 0.75)) - text) ) + let fill_box vg color b = + let open NVG in + 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 - let fill_box c b = - ( b - , I.paint (Paint.color c) - ( I.fill_path - @@ fun t -> - P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) - ~h:(Box2.h b) ) ) + let draw_filled_box c (s : state) = + fill_box s.renderer c s.box ; + (s, s.box) - let draw_filled_box c (s : state) = (s, fill_box c s.box) + let path_box vg color ?(width = 0.) b = + let module Path = NVG.Path in + NVG.save 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 ; + NVG.restore vg ; + Box2.max b - let path_box c b (s : state) = - ( s - , ( b - , I.paint (Paint.color c) - ( I.stroke_path (Outline.make ()) - @@ fun t -> - P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) - ~h:(Box2.h b) ) ) ) + (* Display.state.box as supplied to a widget defines the allowed drawing area for the widget. + This way basic widgets will just expand to the full area of a box, while other widgets can have + the express purpose of limiting the size of an object in a larger system of limitations. - let path_circle c b (s : state) = - ( s - , ( b - , I.paint (Paint.color c) - ( I.stroke_path (Outline.make ()) - @@ fun t -> - P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b) - ~r:(Box2.w b /. 2.) ) ) ) - - (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget. - This way basic widgets will just expand to the full area of a box, while other widgets can have - the express purpose of limiting the size of an object in a larger system of limitations. - - Panes return a tuple: (state, (box, image)) - state is the updated state, where state.box is always - - the top left corner of the box the pane drew in, and - - the bottom right corner of the state.box that was passed in - box is the area the widget actually drew in (or wants to sort of "use") - image is the Wall.image to compose with other panes and draw to the display + Panes return a tuple: (state, (box, image)) + state is the updated state, where state.box is always + - the top left corner of the box the pane drew in, and + - the bottom right corner of the state.box that was passed in + box is the area the widget actually drew in (or wants to sort of "use") + image is the Wall.image to compose with other panes and draw to the display *) - - let simple_text f text (s : state) = - let fm = Wall_text.Font.font_metrics f in - let font_height = fm.ascent -. fm.descent +. fm.line_gap 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 - let bextent = Box2.of_pts (Box2.o s.box) br_pt in - (* let _, (_, redbox) = path_box Color.red bextent s in*) - ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)} - , ( bextent - , (* I.stack redbox *) - I.paint - (Paint.color (gray ~a:0.5 1.0)) - Wall_text.( - simple_text f ~valign:`BASELINE ~halign:`LEFT - ~x:(Box2.ox s.box) - ~y:(Box2.oy s.box +. fm.ascent) - text) ) ) - - let pane_box next_point_func (subpanes : pane list) (so : state) = - let sr, (br, ir) = - List.fold_left - (fun (sp, (bp, ip)) (pane : pane) -> - (* uses br to hold max extent of boxes *) - let sr, (br, ir) = pane sp in - (* draw the pane *) - let _, (_, irb) = path_box Color.blue br sr in - (* draw the box around the pane *) - ( { sr with - box= Box2.of_pts (next_point_func br) (Box2.max sp.box) - } - , ( Box2.of_pts (Box2.o bp) - (P2.v - (max (Box2.maxx br) (Box2.maxx bp)) - (max (Box2.maxy br) (Box2.maxy bp)) ) - , Image.seq [ip; irb; ir] ) ) ) - ( so - , (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty) - ) - subpanes in - let _, (_, redbox) = path_box Color.red br sr in - (sr, (br, Image.stack redbox ir)) end module Panel = struct - open Display open Gg + open NVG type t = { mutable act: t -> Event.events -> Display.pane Lwt.t @@ -307,409 +423,6 @@ module Panel = struct fun events -> panel.act panel events >>= fun pane -> Lwt.return pane - let filter_events ef p = - p - >>= fun p' -> - Lwt.return - {p' with act= (fun panel events -> p'.act panel (ef events))} - - let resolve_panels events = - Lwt_list.map_s (fun s -> - s - >>= fun subpanel -> - subpanel.act subpanel events >>= fun pane -> Lwt.return pane ) - - (* draws subsequent items below *) - let vbox subpanels = - Lwt.return - { act= - (fun panel events -> - resolve_panels events panel.subpanels - >|= fun pl -> pane_box Box2.tl_pt pl ) - (* tl_pt is actually bl_pt in the Wall coordinate system *) - ; subpanels - ; tag= "vertical-box" } - - (* draws subsequent item to the right *) - let hbox subpanels = - Lwt.return - { act= - (fun panel events -> - resolve_panels events panel.subpanels - >|= fun pl -> pane_box Box2.br_pt pl ) - (* br_pt is actually tr_pt in the Wall coordinate system *) - ; subpanels - ; tag= "horizontal-box" } - - (* draws subsequent panels overtop each other *) - let obox (subpanels : t Lwt.t list) = - { act= - (fun panel events -> - resolve_panels events panel.subpanels - >|= fun pl -> pane_box Box2.o pl ) - ; subpanels - ; tag= "origin-box" } - - let g_text_height = ref 25. - - type Format.stag += Color_bg of Wall.color - type Format.stag += Color_fg of Wall.color - type Format.stag += Cursor of Wall.color - type Format.stag += None_tag - - let draw_pp height fpp (s : state) = - let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in - let push (s, (b, i)) = - node := I.stack !node i ; - sc := s ; - box := b 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 = - let sp = !sc in - push @@ simple_text font (String.sub text o l) !sc ; - max_x := max !max_x (Box2.maxx !box) ; - sc := - { !sc with - box= - Box2.of_pts - (P2.v (Box2.maxx !box) (Box2.oy sp.box)) - (Box2.max sp.box) } in - let out_flush () = () in - let out_newline () = - sc := - { !sc with - box= - Box2.of_pts - (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height)) - (Box2.max s.box) } in - let out_spaces n = - 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 () ; - let so = !sc in - (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in - push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*) - box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ; - sc := - {!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)} - in - let out_indent n = - let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in - sc := - { !sc with - box= - Box2.of_pts - (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box)) - (Box2.max !sc.box) } in - let out_funs = - Format. - {out_string; out_flush; out_newline; out_spaces; out_indent} - in - let pp = Format.formatter_of_out_functions out_funs in - Format.pp_set_formatter_stag_functions pp - { mark_open_stag= - (fun s -> - ( match s with - | Cursor c -> - push - @@ ( !sc - , fill_box c - (Box2.v (Box2.o !sc.box) - (P2.v (height *. 0.333) height) ) ) - | Color_bg c -> push @@ (!sc, fill_box c !box) - | _ -> () ) ; - "" ) - ; mark_close_stag= (function _ -> () ; "") - ; print_open_stag= (fun _ -> (*""*) ()) - ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *) - print_close_stag= (fun _ -> (*""*) ()) } ; - Format.pp_set_tags pp true ; - let margin = - 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 ; - fpp pp ; - Format.pp_force_newline pp () ; - ( !sc - , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)) - , !node ) ) - - let format_symbolic_output_items (ppf : Format.formatter) buf = - List.iter - Format.( - function - | Output_flush -> F.pf ppf "@?" - | Output_newline -> F.pf ppf "@." - | Output_string s -> Format.pp_print_string ppf s - | Output_spaces n | Output_indent n -> - Format.pp_print_string ppf (String.make n ' ')) - buf - - let format_symbolic_output_buffer (ppf : Format.formatter) buf = - format_symbolic_output_items ppf - (Format.get_symbolic_output_buffer buf) - - let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print") - fpp = - Lwt.return - { act= (fun _panel _events -> Lwt.return (draw_pp height fpp)) - ; subpanels= [] - ; tag } - - module Textedit = struct - type t = - { mutable zed: unit Zed_edit.context - ; mutable view: Zed_cursor.t - ; mutable keybind: Key.Bind.action Key.Bind.state } - - let bindings te = - let open Key.Bind in - add [([], U (`Arrow `Left))] [Zed Prev_char] - @@ add [([], U (`Arrow `Right))] [Zed Next_char] - @@ add [([], U (`Arrow `Up))] [Zed Prev_line] - @@ add [([], U (`Arrow `Down))] [Zed Next_line] - @@ add [([], U `Home)] [Zed Goto_bol] - @@ add [([], U `End)] [Zed Goto_eol] - @@ add [([], U `Insert)] [Zed Switch_erase_mode] - @@ add [([], U `Delete)] [Zed Delete_next_char] - @@ add [([], U `Enter)] [Zed Newline] - @@ add [([Ctrl], C ' ')] [Zed Set_mark] - @@ add [([Ctrl], C 'a')] [Zed Goto_bol] - @@ add [([Ctrl], C 'e')] [Zed Goto_eol] - @@ add [([Ctrl], C 'd')] [Zed Delete_next_char] - @@ add [([Ctrl], C 'h')] [Zed Delete_prev_char] - @@ add [([Ctrl], C 'k')] [Zed Kill_next_line] - @@ add [([Ctrl], C 'u')] [Zed Kill_prev_line] - @@ add [([Ctrl], C 'n')] [Zed Next_line] - @@ add [([Ctrl], C 'p')] [Zed Prev_line] - @@ add [([Ctrl], C 'w')] [Zed Kill] - @@ add [([Ctrl], C 'y')] [Zed Yank] - @@ add [([], U `Backspace)] [Zed Delete_prev_char] - @@ add [([Meta], C 'w')] [Zed Copy] - @@ add [([Meta], C 'c')] [Zed Capitalize_word] - @@ add [([Meta], C 'l')] [Zed Lowercase_word] - @@ add [([Meta], C 'u')] [Zed Uppercase_word] - @@ add [([Meta], C 'b')] [Zed Prev_word] - @@ add [([Meta], C 'f')] [Zed Next_word] - @@ add [([Meta], U (`Arrow `Right))] [Zed Next_word] - @@ add [([Meta], U (`Arrow `Left))] [Zed Prev_word] - @@ add [([Ctrl], U (`Arrow `Right))] [Zed Next_word] - @@ add [([Ctrl], U (`Arrow `Left))] [Zed Prev_word] - @@ add [([Meta], U `Backspace)] [Zed Kill_prev_word] - @@ add [([Meta], U `Delete)] [Zed Kill_prev_word] - @@ add [([Ctrl], U `Delete)] [Zed Kill_next_word] - @@ add [([Meta], C 'd')] [Zed Kill_next_word] - @@ add [([Ctrl], C '/')] [Zed Undo] - @@ add [([Ctrl], C 'x'); ([], C 'u')] [Zed Undo] - @@ add - [([Ctrl], C 'v')] - [ Custom - (fun () -> - let r = Zed_edit.text (Zed_edit.edit te.zed) in - let l = Zed_lines.of_rope r in - let i = Zed_cursor.get_line te.view in - Zed_cursor.goto te.view - (Zed_lines.line_start l i + 10) ) ] - @@ add - [([Meta], C 'v')] - [ Custom - (fun () -> - let r = Zed_edit.text (Zed_edit.edit te.zed) in - let l = Zed_lines.of_rope r in - let i = Zed_cursor.get_line te.view in - Zed_cursor.goto te.view - (Zed_lines.line_start l i - 10) ) ] - @@ empty - - let clear te = - let ze = Zed_edit.create () in - te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze) - - let insert te text = - Zed_edit.insert te.zed - (Zed_rope.of_string (Zed_string.of_utf8 text)) - - let contents (te : t) = - Zed_string.to_utf8 - (Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed))) - - let make ?(keybinds = bindings) initialtext () = - let ze = Zed_edit.create () in - let te = - { zed= Zed_edit.context ze (Zed_edit.new_cursor ze) - ; view= Zed_edit.new_cursor ze - ; keybind= Key.Bind.(init empty) } in - te.keybind.bindings <- keybinds te ; - insert te initialtext ; - te - - let panel ?(height = !g_text_height) te = - Lwt.return - { act= - (fun _panel events -> - (* collect events and update Zed context *) - Lwt_list.iter_s - (function - | `Key (`Press, (k : Key.keystate)) -> ( - let open Key.Bind in - ( match te.keybind.state with - | Accepted _ | Rejected -> - te.keybind.last_keyseq <- [] ; - te.keybind.last_actions <- [] - | Continue _ -> () ) ; - te.keybind.state <- - resolve k - (get_resolver te.keybind.state - (default_resolver te.keybind.bindings) ) ; - te.keybind.last_keyseq <- - k :: te.keybind.last_keyseq ; - match te.keybind.state with - | Accepted a -> - te.keybind.last_actions <- a ; - Lwt_list.iter_s - (function - | 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 ) - | _ -> Lwt.return_unit ) - events - >>= fun () -> - let draw_textedit = - draw_pp height (fun pp -> - let _, view = - Zed_rope.break - (Zed_edit.text (Zed_edit.edit te.zed)) - (Zed_cursor.get_position te.view) in - Format.pp_open_hvbox pp 0 ; - if - Zed_cursor.get_position te.view - > Zed_cursor.get_position - (Zed_edit.cursor te.zed) - then ( - let zrb, zra = - Zed_rope.break - (Zed_edit.text (Zed_edit.edit te.zed)) - (Zed_cursor.get_position - (Zed_edit.cursor te.zed) ) in - let before_cursor = - Zed_string.to_utf8 (Zed_rope.to_string zrb) - in - let after_cursor = - Zed_string.to_utf8 (Zed_rope.to_string zra) - in - F.text pp before_cursor ; - Format.pp_open_stag pp - (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; - F.pf pp "" ; - Format.pp_close_stag pp () ; - F.text pp after_cursor ) - else - F.text pp - (Zed_string.to_utf8 (Zed_rope.to_string view)) ; - F.pf pp "@." ; - Format.pp_close_box pp () ) in - Lwt.return draw_textedit ) - ; subpanels= [] - ; tag= "textedit" } - - (* pane that displays last key binding match state *) - let bindingstate ?(height = !g_text_height) - (b : Key.Bind.action Key.Bind.state) = - Lwt.return - { act= - (fun _panel _events -> - Lwt.return - (draw_pp height (fun pp -> - Format.pp_open_hbox pp () ; - F.text pp - (List.fold_left - (fun s x -> - Key.to_string_compact x ^ " " ^ s ) - "" b.last_keyseq ) ; - F.text pp "-> " ; - F.text pp - ( match b.state with - | Accepted a -> - "Accepted " - ^ List.fold_right - (fun x s -> - s - ^ Key.Bind.( - match x with - | Zed a -> - Zed_edit.name_of_action a - | CustomLwt _ -> "CustomLwt" - | Custom _ -> "Custom") - ^ "; " ) - a "" - | Rejected -> "Rejected" - | Continue _ -> "Continue" ) ; - Format.pp_close_box pp () ; - F.flush pp () ) ) ) - ; subpanels= [] - ; tag= "binding-state" } - end - - module Modal = struct - type t = - { te: Textedit.t - ; mutable input: string option - ; mutable handle: string -> unit - ; mutable prompt: string } - - let make () = - { te= Textedit.make "" () - ; input= None - ; handle= (fun _text -> ()) - ; prompt= "" } - - let panel ?(height = !g_text_height) me = - let keybinds = - let open Key.Bind in - add - [([], U `Enter)] - [ Custom - (fun () -> - (* set input first so a modal can trigger another modal *) - me.input <- None ; - me.handle (Textedit.contents me.te) ) ] - (Textedit.bindings me.te) in - me.te.keybind.bindings <- keybinds ; - Lwt.return - { act= - (fun panel events -> - match me.input with - | Some text -> - Textedit.insert me.te text ; - hbox panel.subpanels >>= fun p -> p.act panel events - | None -> Lwt.return Display.pane_empty - (* don't draw anything if modal isn't active *) ) - ; subpanels= - [ prettyprint (fun pp -> F.text pp me.prompt) - ; Textedit.panel ~height me.te ] - ; tag= "modal-edit" } - - let start me ?(prompt = "> ") text handler = - me.input <- Some text ; - Textedit.clear me.te ; - Textedit.insert me.te text ; - me.handle <- handler ; - me.prompt <- prompt - - let is_active me = - match me.input with Some _ -> true | None -> false - end - module Style = struct module Font = struct type t = @@ -739,29 +452,12 @@ module Panel = struct | None, None -> 20. | None, Some s | Some s, _ -> s - 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"*) - | _, _, _ -> "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) ) + | Some s1, Some s2 -> Some (Float.max_num s1 s2) ) ; font= ( match (a.font, b.font) with | `Sans, _ | _, `Sans -> `Sans @@ -786,14 +482,26 @@ module Panel = struct ( match (a.underline, b.underline) with | `Underline, _ | _, `Underline -> `Underline | _ -> `None ) } + + let set vg t = + ( match t.size with + | Some size -> Text.set_size vg ~size + | None -> () ) ; + match t.font with + | `Sans -> Text.set_font_face vg ~name:"sans" + | _ -> () end - type t = {fg: Wall.color; bg: Wall.color; font: Font.t} + type t = {fg: Color.t; bg: Color.t; font: Font.t} type attr = t - 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 gray a = Color.rgbf ~r:a ~g:a ~b:a + + let 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 equal = ( == ) let ( ++ ) a1 a2 = @@ -801,16 +509,22 @@ module Panel = struct else if a2 == empty then a1 else { a1 with - fg= Color.blend a1.fg a2.fg - ; bg= Color.blend a1.bg a2.bg } + 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 merge a b = - { fg= Wall.Color.blend a.fg b.fg - ; bg= Wall.Color.blend a.bg b.bg + { 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 ; + Font.set vg s.font end module Pad = struct @@ -830,7 +544,6 @@ module Panel = struct (* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *) open Gg - open Wall type t = [ `Atom of atom @@ -847,18 +560,12 @@ module Panel = struct | `Hint of [`Line | `Other] | `Empty ] - and attr = - [ `Style of style - | `Pad of Pad.t - | `Shift of dim - | `Handler of handler ] - + and attr = [`Style of style | `Pad of Pad.t | `Handler of handler] and dir = [`X | `Y | `Z] - and dim = Size2.t - and image = Wall.image * dim + and image = NVG.Image.image and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text] and style = Style.t - and handler = node -> Event.t -> Event.t option Lwt.t + and handler = node -> Event.t -> Event.t option let set_parent_on_children n : node = ( match n.t with @@ -881,7 +588,7 @@ module Panel = struct let atom (a : atom) = node (`Atom a) let attr (a : attr) (child : node) = node (`Attr (a, child)) let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b)) - let empty_image = (Image.empty, V2.zero) + let empty_image = V2.zero let empty_node () = node (`Atom `Empty) let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) @@ -1040,9 +747,6 @@ module Panel = struct 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 ( ^*^ ) = join_z @@ -1112,41 +816,25 @@ module Panel = struct let text = Text.lines module Draw = struct - type d = [`X | `Y | `Z] + open NVG - let cursor ((i, v) : image) = - ( I.stack - (I.paint (Paint.color Color.red) - ( I.stroke_path (Outline.make ()) - @@ fun t -> - P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) ) - i - , v ) + type d = [`X | `Y | `Z] + type t = {vg: NVG.t; style: Style.t} 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) + | `X -> + V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b)) + | `Y -> + V2.v (Float.max_num (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)) + (Float.max_num (V2.x a) (V2.x b)) + (Float.max_num (V2.y a) (V2.y b)) - 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 shift v (img, sv) = - ( I.transform - Transform.( - translate ~x:(Size2.w v) ~y:(Size2.h v) identity) - img - , sv ) - - 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 uchar vg t (uc : Uchar.t) : P2.t = + let module Buffer = Stdlib.Buffer in + let b = Stdlib.Buffer.create 1 in let enc = Uutf.encoder `UTF_8 (`Buffer b) in let rec encode c = match Uutf.encode enc c with @@ -1154,54 +842,72 @@ module Panel = struct | `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.bg) - ( I.fill_path - @@ fun t -> - P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) ) - (I.paint - (Wall.Paint.color style.fg) - (simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0. - str ) ) - , v ) + 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 + F.epr "Panel.Ui.Draw.uchar x=%f y=%f \"%s\" @." x y text ; + Text.text vg ~x ~y text ; + P2.v bounds.advance + ( P2.y t +. metrics.ascender +. metrics.descender + +. metrics.line_height ) - 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 rec atom ?(style = Style.empty) : atom -> image = function - | `Image i -> i - | `Uchar uc -> uchar style uc - | `Boundary _ -> empty_image - | `Hint _ -> empty_image - | `Empty -> empty_image - - and attr ?(style = Style.empty) (a, n) : image = + let rec atom vg b a : P2.t = + let vg = vg.vg in match a with - | `Style s -> node ~style:(Style.merge s style) n - | `Pad p -> pad p (node ~style n) - | `Shift s -> shift s (node ~style n) - | _ -> node ~style n + | `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 ; + 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 ; + P2.v (P2.x b +. w) (P2.y b +. h) + | `Uchar uc -> uchar vg b uc + | `Boundary _ -> b + | `Hint _ -> b + | `Empty -> b - and join ?(style = Style.empty) (d, a, b) : image = - cat d (node ~style a) (node ~style b) + and attr vg t (a, n) : P2.t = + match a with + | `Style s -> node {vg with style= Style.merge vg.style s} t n + | `Pad p -> pad vg t p n + | _ -> node vg t n - and node ?(style = Style.empty) (n : node) : image = - match n.t with - | `Atom a -> atom ~style a - | `Attr a -> attr ~style a - | `Join a -> join ~style a + and pad vg t (p : Pad.t) n = + let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in + P2.(v (x nv +. p.r) (y t +. p.b)) + + and join vg t (d, a, b) : P2.t = + let av = node vg t a in + let bv = + node vg + ( 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 + 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) + | `Z -> + V2.v + (Float.max_num (V2.x av) (V2.x bv)) + (Float.max_num (V2.y av) (V2.y bv)) + + and node t b (n : node) : P2.t = + let b2 = + match n.t with + | `Atom a -> atom t b a + | `Attr a -> attr t b a + | `Join a -> join t b a in + Display.path_box t.vg + (Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) + (Box2.v b b2) end module Action = struct @@ -1429,7 +1135,8 @@ module Panel = struct |> add [([Ctrl], C 'q')] [`Ascend] |> add [([Ctrl], C 'z')] [`Descend] - let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.)) + let cursor_attr = + `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.)) let textedit_handler ?(bindings = textedit_bindings) (n : node) = Format.pp_set_max_boxes F.stderr 64 ; @@ -1437,13 +1144,11 @@ module Panel = struct 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 _ _ -> Lwt.return_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 Lwt.t -> + (fun (_ : node) (e : Event.t) : Event.t option -> match Key.Bind.resolve_events bind [e] with | x :: _ -> c.sel <- remove_attr c.sel ; @@ -1459,8 +1164,8 @@ module Panel = struct F.epr "textedit action @[%a@] Failure@." Action.pp_t x ) ; c.sel <- insert_attr cursor_attr c.sel ; - Lwt.return_none - | [] -> Lwt.return_some e ) + None + | [] -> Some e ) , n ) ; set_parent_on_children c.root @@ -1470,411 +1175,36 @@ module Panel = struct in match f n with Some a -> Some a | None -> search_forward f n - let handle_event (n : node) (ev : Event.t) : event_status Lwt.t = + let handle_event (n : node) (ev : Event.t) : event_status = match handler_of_node n with | Some f -> ( - f n ev - >>= function - | Some ev -> Lwt.return (`Event ev) - | None -> Lwt.return `Handled ) - | None -> Lwt.return (`Event ev) + match f n ev with Some ev -> `Event ev | None -> `Handled ) + | None -> `Event ev - 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 - (* F.epr "Draw.pane: %a@." pp_ui r ; *) - Lwt_list.iter_s - (fun e -> - handle_event r e - >>= fun h -> - ( match h with - | `Handled -> F.epr "Handled %s@." (Event.to_string e) - | `Event _e -> - (* F.epr "Unhandled event: %s@." - (Event.to_string _e)*) - () ) ; - Lwt.return_unit ) - ev - >|= fun () -> Draw.node r ) + let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t + = + ( 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 let test = - panel - (Lwd.pure - (textedit_handler - (style Style.dark - (join_y - (join_y - (Text.of_string - "-- welcome to my land of idiocy ---" ) - ( ( Text.of_string "hello bitch" - ^^ Text.of_string "!\n sup daddy" ) - ^/^ (text "hello bitch" ^^ text "!\n sup daddy") - ^/^ text "hello bitch" ^/^ text "!\n sup daddy" - ) ) - (Text.of_string "123") ) ) ) ) + textedit_handler + (style Style.dark + (join_y + (join_y + (Text.of_string "-- welcome to my land of idiocy ---") + ( ( Text.of_string "hello bitch" + ^^ Text.of_string "!\n sup daddy" ) + ^/^ (text "hello bitch" ^^ text "!\n sup daddy") + ^/^ text "hello bitch" ^/^ text "!\n sup daddy" ) ) + (Text.of_string "123") ) ) end end -module Toplevel = struct - type t = - {mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer} - - let init () = - let sob = Format.make_symbolic_output_buffer () in - Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ; - {eval= !Topinf.eval; res= sob} - - let eval t str = - let ppf = Format.formatter_of_symbolic_output_buffer t.res in - Topinf.ppf := ppf ; - ignore (Format.flush_symbolic_output_buffer t.res) ; - try - 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) - with e -> - F.pf ppf "Exception in pane_top//eval@." ; - Location.report_exception ppf e ; - F.epr "Exception in pane_top//eval@." - - let result_sob t = t.res -end - -module Store = struct - (* storeview shows items of the selected level *) - - type storeview = - { store: Istore.t - ; mutable view: Istore.key - ; mutable selection: Istore.key - ; mutable editmode: bool - ; sob: Format.symbolic_output_buffer } - - let make_storeview ?(path = []) storepath branch = - Istore.Repo.v (Irmin_git.config storepath) - >>= fun repo -> - Istore.of_branch repo branch - >>= fun store -> - let view = Istore.Key.v path in - Istore.list store view - >>= fun viewlist -> - Lwt.return - { store - ; view - ; selection= Istore.Key.v [fst (List.hd viewlist)] - ; editmode= false - ; sob= Format.make_symbolic_output_buffer () } - - let directives (top : Toplevel.t) sv = - let dir_use_key key_lid = - (* TODO: currently causes a segfault :( *) - let key_obj = - try - match - Env.find_value_by_name key_lid !Topinf.toplevel_env - with - | path, _desc -> - Topinf.eval_value_path !Topinf.toplevel_env path - | exception Not_found -> - F.epr "Unbound value %a.@." Printtyp.longident key_lid ; - raise Exit - with Exit -> Obj.repr ["nofile"] in - let key = Obj.obj key_obj in - let contents = - Lwt_main.run - ( Istore.kind sv.store key - >>= function - | Some a -> ( - match a with - | `Contents -> Istore.get sv.store key - | `Node -> - Lwt.return "\"use_key on Node not implemented yet\"" ) - | None -> Lwt.return "Invalid Selection..." ) in - Toplevel.eval top contents in - Topinf.add_directive "use_key" (Directive_ident dir_use_key) - { section= "Console Store" - ; doc= - "Read, compile and execute source phrases from the given \ - store key." } - - let navigate sv action = - let rec findi value = function - | [] -> 0 - | a :: b -> (if a = value then -1 else findi value b) + 1 in - fun () -> - Istore.get_tree sv.store sv.view - >>= fun top -> - match Istore.Key.rdecons sv.selection with - | Some (ppath, step) -> - Istore.Tree.list top ppath - >>= fun neighbors -> - let steplist = fst (List.split neighbors) in - let stepi = findi step steplist in - Istore.Tree.list (snd (List.nth neighbors stepi)) [] - >>= fun subtreelist -> - Lwt.return - ( match action with - | `Next -> - let stepi = findi step steplist in - if List.length steplist - 1 > stepi then - sv.selection <- - Istore.Key.rcons ppath - (List.nth steplist (stepi + 1)) - | `Prev -> - if stepi > 0 then - sv.selection <- - Istore.Key.rcons ppath - (List.nth steplist (stepi - 1)) - | `Sub -> - if List.length subtreelist > 0 then - sv.selection <- - sv.selection @ [fst (List.hd subtreelist)] - | `Sup -> - if List.length ppath > 0 then sv.selection <- ppath ) - | None -> Lwt.return_unit - - let editor ?(branch = "current") storepath : Panel.t Lwt.t = - make_storeview storepath branch - >>= fun sv -> - let top = Toplevel.init () in - let modalstate = Panel.Modal.make () in - let te = Panel.Textedit.make "" () in - let save store path content = - Lwt.async (fun () -> - Istore.set_exn store - ~info:(Irmin_unix.info "editor-save") - path content ) in - let editbinds = - let open Key.Bind in - add - [([Ctrl], C 'c')] - [ Custom - (fun () -> - sv.editmode <- not sv.editmode ; - save sv.store - (sv.view @ sv.selection) - (Panel.Textedit.contents te) ) ] - @@ add - [([Ctrl], C 's')] - [ Custom - (fun () -> - save sv.store - (sv.view @ sv.selection) - (Panel.Textedit.contents te) ) ] - @@ add - [([Ctrl], C 'x'); ([], C 'x')] - [ Custom - (fun () -> - Toplevel.eval top (Panel.Textedit.contents te) ) ] - (Panel.Textedit.bindings te) in - te.keybind.bindings <- editbinds ; - let is_node path = - Istore.get_tree sv.store sv.view - >>= fun t -> - Istore.Tree.kind t path - >>= function - | Some `Node -> Lwt.return_true | _ -> Lwt.return_false in - let update_storeview () = - ignore (Format.flush_symbolic_output_buffer sv.sob) ; - let pp = Format.formatter_of_symbolic_output_buffer sv.sob in - let rec draw_levels ?(indent = 0) (sel : Istore.key) - (tree : Istore.tree) : unit Lwt.t = - Istore.Tree.list tree [] - >>= Lwt_list.iteri_s (fun _i (step, node) -> - Format.pp_open_box pp indent ; - if sel = [step] then ( - Format.pp_open_stag pp - (Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; - F.pf pp "@," ; - Format.pp_close_stag pp () ) ; - Istore.Tree.kind node [] - >>= fun k -> - ( match k with - | Some `Contents -> - F.pf pp "- %s@." step ; Lwt.return_unit - | Some `Node -> - F.pf pp "> %s@." step ; - let subsel = - match Istore.Key.decons sel with - | Some (_tstep, subkey) -> subkey - | None -> [] in - Format.pp_open_vbox pp 0 ; - draw_levels ~indent:(indent + 1) subsel node - >>= fun () -> - Format.pp_close_box pp () ; - Lwt.return_unit - | None -> F.pf pp "ERROR: None" ; Lwt.return_unit ) - >>= fun () -> - Format.pp_close_box pp () ; - Lwt.return_unit ) in - Istore.get_tree sv.store sv.view >>= draw_levels sv.selection - in - let update_textedit () = - Panel.Textedit.clear te ; - Istore.get_tree sv.store sv.view - >>= fun t -> - Istore.Tree.kind t sv.selection - >>= function - | Some `Contents -> - Istore.Tree.get t sv.selection - >>= fun content -> - Panel.Textedit.insert te content ; - Lwt.return_unit - | Some `Node -> - Panel.Textedit.insert te "Node..." ; - Lwt.return_unit - | None -> Lwt.return_unit in - let navbinds = - let open Key.Bind in - let new_contents name content = - Lwt.async (fun () -> - let s = - match Istore.Key.rdecons sv.selection with - | Some (t, _) -> t - | None -> Istore.Key.empty in - Istore.get_tree sv.store (sv.view @ s) - >>= fun tree -> - Istore.Tree.add tree name content - >>= fun newtree -> - Istore.set_tree_exn - ~info:(Irmin_unix.info "new Contents") - sv.store sv.view newtree ) in - add [([], C 'n')] [CustomLwt (navigate sv `Next)] - @@ add [([], C 'p')] [CustomLwt (navigate sv `Prev)] - @@ add [([], C 'w')] [CustomLwt (navigate sv `Prev)] - @@ add [([], C 's')] [CustomLwt (navigate sv `Next)] - @@ add [([], C 'd')] [CustomLwt (navigate sv `Sub)] - @@ add [([], C 'a')] [CustomLwt (navigate sv `Sup)] - @@ add - [([], C 'e')] (* enter edit mode *) - [ Custom - (fun () -> - Lwt.async (fun () -> - is_node sv.selection - >>= fun nb -> - if not nb then sv.editmode <- not sv.editmode ; - Lwt.return_unit ) ) ] - @@ add - [([], C 'f')] (* find: enter path in modal *) - [Custom (fun () -> ())] - @@ add - [([], C 'c')] (* contents: create new contents node *) - [ Custom - (fun () -> - Panel.Modal.start ~prompt:"Contents name > " - modalstate "" (fun name -> - new_contents (Istore.Key.v [name]) "" ) ) ] - @@ add - [([], C 't')] (* tree: create new subtree *) - [ Custom - (fun () -> - Panel.Modal.start ~prompt:"Node name > " modalstate - "" (fun nodename -> - Panel.Modal.start - ~prompt:"Initial Contents name > " modalstate - "" (fun contentsname -> - new_contents - (Istore.Key.v [nodename; contentsname]) - "" ) ) ) ] - @@ add - [([], C 'r')] (* remove contents/node *) - [ CustomLwt - (fun () -> - let selection = sv.selection in - navigate sv `Next () - >>= fun () -> - Istore.get_tree sv.store sv.view - >>= fun tree -> - Istore.Tree.remove tree selection - >>= fun newtree -> - Istore.set_tree_exn - ~info:(Irmin_unix.info "remove Contents/Node") - sv.store sv.view newtree ) ] - @@ add - [([], C 'x')] (* execute contents/node *) - [ Custom - (fun () -> - Toplevel.eval top (Panel.Textedit.contents te) ) ] - empty in - let bindstate = Key.Bind.init navbinds in - Lwt.return - Panel. - { act= - (fun panel events -> - ( if - (not sv.editmode) - && not (Panel.Modal.is_active modalstate) - then - Key.Bind.process bindstate events - >>= fun () -> - Lwt.join [update_storeview (); update_textedit ()] - else Lwt.return_unit ) - >>= fun () -> - Panel.vbox panel.subpanels - >>= fun p -> p.act panel events ) - ; subpanels= - [ Panel.filter_events - (fun ev -> - if Panel.Modal.is_active modalstate then ev else [] - ) - (Panel.Modal.panel modalstate) - ; Panel.hbox - [ Panel.prettyprint (fun pp -> - Panel.format_symbolic_output_buffer pp sv.sob ) - ; Panel.vbox - [ Panel.filter_events - (fun ev -> if sv.editmode then ev else []) - (Panel.Textedit.panel te) - ; Panel.prettyprint (fun pp -> - Format.pp_open_hovbox pp 0 ; - Panel.format_symbolic_output_buffer pp - (Toplevel.result_sob top) ; - Format.pp_close_box pp () ; - F.flush pp () ) ] ] - ; Panel.Textedit.bindingstate bindstate - ; Panel.prettyprint (fun pp -> - Format.fprintf pp "sv.editmode = %b @." sv.editmode ) - ] - ; tag= "store-editor" } -end - -let std_actor (root_panel : Panel.t Lwt.t) = - Panel.actor - (Panel.obox - [ Panel.draw (fun (s : Display.state) -> - (s, Display.fill_box (Display.gray 0.125) s.box) ) - ; root_panel ] ) - -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 () = - Display.( - run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ()) - (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) (* FUTURE: (thinking now this should be based on react for that sweet incremental compuation) diff --git a/index.html b/index.html index 84141f3..40e764d 100644 --- a/index.html +++ b/index.html @@ -17,8 +17,8 @@ div { } canvas { - width: 400px; - height: 400px; + width: 100%; + height: 100%; }