660 lines
22 KiB
OCaml
660 lines
22 KiB
OCaml
[@@@ocaml.warning "-6-9-26-27-32-34"]
|
|
|
|
open Lwt.Infix
|
|
module F = Fmt
|
|
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
|
|
|
|
module Display = struct
|
|
open Tgles2
|
|
open Tsdl
|
|
open Gg
|
|
open CamomileLibrary
|
|
|
|
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
|
|
|
|
type keymod = Shift | Ctrl | Meta | Fn
|
|
|
|
type key = {
|
|
char : char;
|
|
uchar : CamomileLibrary.UChar.t;
|
|
keycode : Sdl.keycode;
|
|
scancode : Sdl.scancode;
|
|
mods : keymod list;
|
|
}
|
|
|
|
type mouse = int * int
|
|
|
|
type event =
|
|
[ `Key_down of key
|
|
| `Key_up of key
|
|
| `Text_editing of string
|
|
| `Text_input of string
|
|
| `Mouse of mouse
|
|
| `Quit
|
|
| `Fullscreen of bool
|
|
| `None ]
|
|
|
|
let str_of_key k =
|
|
Printf.sprintf
|
|
"(char=%C;uchar=%C;keycode=%x;scancode=%x;name=%s;(%s%s%s%s))" k.char
|
|
(CamomileLibrary.UChar.char_of k.uchar)
|
|
k.keycode k.scancode
|
|
(Sdl.get_key_name k.keycode)
|
|
(if List.mem Shift k.mods then "shift" else "")
|
|
(if List.mem Ctrl k.mods then "ctrl" else "")
|
|
(if List.mem Meta k.mods then "meta" else "")
|
|
(if List.mem Fn k.mods then " fn" else "")
|
|
|
|
let event_of_sdlevent ev =
|
|
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
|
|
| `Text_editing ->
|
|
F.epr
|
|
"event_of_sdlevent: `Text_editing\n\
|
|
\twindow_id=%d\n\
|
|
\ttext=%s\n\
|
|
\tstart=%d\n\
|
|
\tlength=%d@."
|
|
(Sdl.Event.get ev Sdl.Event.text_editing_window_id)
|
|
(Sdl.Event.get ev Sdl.Event.text_editing_text)
|
|
(Sdl.Event.get ev Sdl.Event.text_editing_start)
|
|
(Sdl.Event.get ev Sdl.Event.text_editing_length);
|
|
`None
|
|
| `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
|
|
| (`Key_down | `Key_up) as w ->
|
|
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
|
let keycode = Sdl.Event.get ev Sdl.Event.keyboard_keycode in
|
|
let uchar =
|
|
CamomileLibrary.UChar.of_int
|
|
(if keycode land Sdl.K.scancode_mask > 0 then 0 else keycode)
|
|
in
|
|
let mods =
|
|
List.filter_map
|
|
(fun (m, v) -> if km land m > 0 then Some v else None)
|
|
Sdl.Kmod.[ (shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn) ]
|
|
in
|
|
let k =
|
|
{
|
|
char = UChar.char_of uchar;
|
|
uchar;
|
|
keycode;
|
|
scancode = Sdl.Event.get ev Sdl.Event.keyboard_scancode;
|
|
mods;
|
|
}
|
|
in
|
|
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
|
|
(* (match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
|
|
F.epr "%s@." (str_of_key k);
|
|
F.epr "\tkeyboard_repeat=%d\n" repeat ; *)
|
|
if repeat < 1 then
|
|
match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k
|
|
else `None
|
|
| `Mouse_motion ->
|
|
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
|
|
`Mouse mouse_xy
|
|
| `Quit ->
|
|
F.epr "Quit Event\n";
|
|
`Quit
|
|
| _ -> (*F.epr "Unknown Event@." ; *) `None
|
|
|
|
let key_up : Sdl.keycode = 0x40000052
|
|
|
|
let key_down : Sdl.keycode = 0x40000051
|
|
|
|
let key_left : Sdl.keycode = 0x40000050
|
|
|
|
let key_right : Sdl.keycode = 0x4000004f
|
|
|
|
let handle_keyevents (el : event list) f = List.iter f el
|
|
|
|
(* current window state to be passed to window renderer *)
|
|
type state = {
|
|
box : box2;
|
|
(* This is cannonically box within which the next element should draw *)
|
|
time : float;
|
|
events : event list;
|
|
wall : Wall.renderer;
|
|
}
|
|
|
|
type image = box2 * Wall.image
|
|
(* the box2 here is cannonically the place the returner drew
|
|
(the Wall.image extents) *)
|
|
|
|
type pane = state -> state * image
|
|
|
|
type frame = {
|
|
sdl_win : Sdl.window;
|
|
gl : Sdl.gl_context;
|
|
wall : Wall.renderer;
|
|
mutable quit : bool;
|
|
mutable fullscreen : bool;
|
|
}
|
|
|
|
let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.
|
|
|
|
let on_failure ~cleanup result =
|
|
(match result with Ok _ -> () | Error _ -> cleanup ());
|
|
result
|
|
|
|
let video_initialized = lazy (Sdl.init Sdl.Init.video)
|
|
|
|
let make_frame ?(title = "komm") ~w ~h () =
|
|
Lazy.force video_initialized >>= fun () ->
|
|
Sdl.create_window ~w ~h title
|
|
Sdl.Window.(opengl + allow_highdpi + resizable (*+ input_grabbed*))
|
|
>>= fun sdl_win ->
|
|
Sdl.set_window_title sdl_win title;
|
|
ignore (Sdl.gl_set_swap_interval (-1));
|
|
ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1);
|
|
on_failure
|
|
( Sdl.gl_create_context sdl_win >>= fun gl ->
|
|
let wall =
|
|
Wall.Renderer.create ~antialias:true ~stencil_strokes:true ()
|
|
in
|
|
Ok { sdl_win; gl; wall; quit = false; fullscreen = false } )
|
|
~cleanup:(fun () -> Sdl.destroy_window sdl_win)
|
|
|
|
let display_frame frame render =
|
|
(* create and fill event list *)
|
|
let tstart = ticks () in
|
|
let ev = Sdl.Event.create () in
|
|
let el = ref [ `None ] in
|
|
while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
|
|
let e = event_of_sdlevent ev in
|
|
if e != `None then el := !el @ [ e ]
|
|
(* HACK? *)
|
|
done;
|
|
(* Filter the events *)
|
|
el :=
|
|
List.filter_map
|
|
(function
|
|
| `Quit ->
|
|
frame.quit <- true;
|
|
None
|
|
| `Fullscreen a ->
|
|
if a then (
|
|
frame.fullscreen <- not frame.fullscreen;
|
|
ignore (Sdl.show_cursor (not frame.fullscreen) : _ result);
|
|
ignore
|
|
(Sdl.set_window_fullscreen frame.sdl_win
|
|
(if frame.fullscreen then Sdl.Window.fullscreen_desktop
|
|
else Sdl.Window.windowed)
|
|
: _ result));
|
|
None
|
|
| `Key_up a -> Some (`Key_up a)
|
|
| `Key_down a -> Some (`Key_down a)
|
|
| `Mouse a -> Some (`Mouse a)
|
|
| a -> Some a (*| a -> Some a*))
|
|
!el;
|
|
if List.length !el > 0 then (
|
|
(* F.epr "Passing in %d events\n" (List.length !el); *)
|
|
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
|
|
let _, (_, image) =
|
|
render
|
|
{
|
|
box = Box2.v (P2.v 0. 0.) (P2.v (float width) (float height));
|
|
time = ticks ();
|
|
events = !el;
|
|
wall = frame.wall;
|
|
}
|
|
in
|
|
Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
|
|
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
|
|
Gl.viewport 0 0 width height;
|
|
Gl.clear_color 0.0 0.0 0.0 1.0;
|
|
Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit));
|
|
Gl.enable Gl.blend;
|
|
Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha;
|
|
Gl.enable Gl.cull_face_enum;
|
|
Gl.disable Gl.depth_test;
|
|
let width = float width and height = float height in
|
|
Wall.Renderer.render frame.wall ~width ~height image;
|
|
Sdl.gl_swap_window frame.sdl_win;
|
|
(*F.epr "event loop took %0.6f seconds\n" (ticks () -. tstart); *) Ok ())
|
|
else Ok ()
|
|
|
|
let run frame render () =
|
|
let frame = get_result frame in
|
|
Sdl.show_window frame.sdl_win;
|
|
while not frame.quit do
|
|
ignore (display_frame frame render)
|
|
done;
|
|
print_endline "quit";
|
|
Sdl.hide_window frame.sdl_win;
|
|
()
|
|
|
|
let gray ?(a = 1.0) v = Color.v v v v a
|
|
end
|
|
|
|
open Wall
|
|
open Gg
|
|
module I = Image
|
|
module P = Path
|
|
module Text = Wall_text
|
|
|
|
let load_font name =
|
|
let ic = open_in_bin name in
|
|
let dim = in_channel_length ic in
|
|
let fd = Unix.descr_of_in_channel ic in
|
|
let buffer =
|
|
Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [| dim |]
|
|
|> Bigarray.array1_of_genarray
|
|
in
|
|
let offset = List.hd (Stb_truetype.enum buffer) in
|
|
match Stb_truetype.init buffer offset with
|
|
| None -> assert false
|
|
| Some font -> 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_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")
|
|
|
|
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 = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in
|
|
( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b)),
|
|
I.paint
|
|
(Paint.color (Display.gray ~a:0.5 1.0))
|
|
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 c b (s : Display.state) =
|
|
( s,
|
|
( 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 path_box c b (s : Display.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) )
|
|
) )
|
|
|
|
let path_circle c b (s : Display.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.) )
|
|
) )
|
|
|
|
(* draws the second item below if there's room *)
|
|
let pane_vbox (subpanes : Display.pane list) (so : Display.state) =
|
|
let sr, (br, ir) =
|
|
List.fold_left
|
|
(fun (sp, (_, ip)) (pane : Display.pane) ->
|
|
let sr, (br, ir) = pane sp in
|
|
let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
|
|
( { sr with box = Box2.of_pts (Box2.tl_pt br) (Box2.max sp.box) },
|
|
(br, Image.seq [ ip; sir; ir ]) ))
|
|
(so, (so.box, Image.empty))
|
|
subpanes
|
|
in
|
|
let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in
|
|
let _, (_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
|
|
(sr, (b, Image.stack i_redbox ir))
|
|
|
|
(* draws second item to right if there's room *)
|
|
let pane_hbox (subpanes : Display.pane list) (so : Display.state) =
|
|
let sr, (br, ir) =
|
|
List.fold_left
|
|
(fun (sp, (_, ip)) (pane : Display.pane) ->
|
|
let sr, (br, ir) = pane sp in
|
|
let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
|
|
( { sr with box = Box2.of_pts (Box2.br_pt br) (Box2.max sp.box) },
|
|
(br, Image.seq [ ip; sir; ir ]) ))
|
|
(so, (so.box, Image.empty))
|
|
subpanes
|
|
in
|
|
let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in
|
|
let _, (_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
|
|
(sr, (b, Image.stack i_redbox ir))
|
|
|
|
let simple_text f text (s : Display.state) =
|
|
let fm = Text.Font.font_metrics f in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
let tm = Text.Font.text_measure f text in
|
|
let 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.v 0.5 0.125 0.125 1.0) 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 (Display.gray ~a:0.5 1.0))
|
|
Text.(
|
|
simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box)
|
|
~y:(Box2.oy s.box +. fm.ascent)
|
|
text)) ) )
|
|
|
|
type Format.stag += Color_bg of Wall.color
|
|
|
|
type Format.stag += Color_fg of Wall.color
|
|
|
|
type Format.stag += Cursor of Wall.color
|
|
|
|
let draw_pp height fpp (s : Display.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 = Text.Font.make ~size:height (Lazy.force font_sans) in
|
|
let fm = 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 =
|
|
(* F.epr "\tout_string: %s %s@." (String.sub text o l) (str_of_box !sc.box);*)
|
|
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 () =
|
|
(*epr "\tout_flush: %s@." (str_of_box !sc.box); *)
|
|
()
|
|
in
|
|
let out_newline () =
|
|
(* F.epr "\tout_newline: %s@." (str_of_box !sc.box);)*)
|
|
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 =
|
|
(* F.epr "\tout_spaces: n=%d %s@." n (str_of_box !sc.box);*)
|
|
let wpx = Text.Font.text_width font " " in
|
|
if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then (
|
|
(* WRAP *)
|
|
F.epr "out_spaces: ===== WRAP =======@.";
|
|
out_newline ());
|
|
let so = !sc in
|
|
let bo = Box2.v (Box2.o !sc.box) (P2.v (float n *. wpx) height) in
|
|
let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
|
|
push
|
|
@@ pane_hbox
|
|
(List.init n (fun _ -> path_circle (Color.v 0.125 1.0 0.125 0.125) bsp))
|
|
!sc;
|
|
box := bo;
|
|
sc := { !sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box) }
|
|
in
|
|
let out_indent n =
|
|
(* F.epr "\tout_indent: n=%d %s@." n (str_of_box !sc.box);*)
|
|
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
|
|
@@ fill_box c
|
|
(Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height))
|
|
!sc
|
|
| Color_bg c -> push @@ fill_box c !box !sc
|
|
| _ -> ());
|
|
"");
|
|
mark_close_stag =
|
|
(function
|
|
| _ ->
|
|
();
|
|
"");
|
|
print_open_stag = (fun _ -> (*"<open_stag>"*) ());
|
|
(* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
|
|
print_close_stag = (fun _ -> (*"<close_stag>"*) ());
|
|
};
|
|
Format.pp_set_tags pp true;
|
|
let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in
|
|
let max_indent = margin - 1 in
|
|
Format.pp_safe_set_geometry pp ~max_indent ~margin;
|
|
(* F.epr "draw_pp: margin = %d, max_indent = %d@." (Format.pp_get_margin pp ()) (Format.pp_get_max_indent pp ());*)
|
|
fpp pp;
|
|
Format.pp_force_newline pp ();
|
|
(!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node))
|
|
|
|
type textedit = { ze : unit Zed_edit.t; zc : Zed_cursor.t }
|
|
|
|
let make_textedit () =
|
|
let z = Zed_edit.create () in
|
|
{ ze = z; zc = Zed_edit.new_cursor z }
|
|
|
|
let draw_textedit (te : textedit) height (s : Display.state) =
|
|
let ctx = Zed_edit.context te.ze te.zc in
|
|
List.iter
|
|
(function
|
|
| `Key_down (k : Display.key) -> (
|
|
match k with
|
|
| { keycode = kc; mods = []; _ } when kc = Display.key_up ->
|
|
Zed_edit.prev_line ctx
|
|
| { keycode = kc; mods = []; _ } when kc = Display.key_down ->
|
|
Zed_edit.next_line ctx
|
|
| { keycode = kc; mods = []; _ } when kc = Display.key_left ->
|
|
Zed_edit.prev_char ctx
|
|
| { keycode = kc; mods = []; _ } when kc = Display.key_right ->
|
|
Zed_edit.next_char ctx
|
|
| { char = '\r'; mods = []; _ } -> Zed_edit.newline ctx
|
|
| { char = 'b'; mods = [ Ctrl ]; _ } -> Zed_edit.prev_char ctx
|
|
| { char = 'f'; mods = [ Ctrl ]; _ } -> Zed_edit.next_char ctx
|
|
| { char = 'a'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_bol ctx
|
|
| { char = 'e'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_eol ctx
|
|
| { char = 'd'; mods = [ Ctrl ]; _ } -> Zed_edit.remove_next ctx 1
|
|
| { char = 'd'; mods = [ Meta ]; _ } -> Zed_edit.kill_next_word ctx
|
|
| { char = '\b'; mods = []; _ } -> Zed_edit.remove_prev ctx 1
|
|
| { char = '\b'; mods = [ Meta ]; _ } -> Zed_edit.kill_prev_word ctx
|
|
| { char = '\t'; mods = []; _ } ->
|
|
Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
|
|
| { char = 'k'; mods = [ Ctrl ]; _ } -> Zed_edit.kill_next_line ctx
|
|
| _ -> ())
|
|
| `Key_up _ -> ()
|
|
| `Text_input s ->
|
|
F.epr "draw_textedit: `Text_input %s@." s;
|
|
Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s));
|
|
()
|
|
| _ -> ())
|
|
s.events;
|
|
draw_pp height
|
|
(fun pp ->
|
|
let zrb, zra =
|
|
Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc)
|
|
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
|
|
Format.pp_open_hvbox pp 0;
|
|
F.text pp before_cursor;
|
|
Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3));
|
|
F.pf pp "";
|
|
Format.pp_close_stag pp ();
|
|
F.text pp after_cursor;
|
|
F.pf pp "@.";
|
|
Format.pp_close_box pp ())
|
|
s
|
|
|
|
let str_of_textedit (te : textedit) =
|
|
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
|
|
|
|
type storeview = { s : Store.t; path : string list }
|
|
|
|
let make_storeview storepath branch ?(path = []) () =
|
|
{
|
|
s =
|
|
Lwt_main.run
|
|
(Store.of_branch
|
|
(Lwt_main.run (Store.Repo.v (Irmin_git.config storepath)))
|
|
branch);
|
|
path;
|
|
}
|
|
|
|
let draw_storeview (r : storeview) height (s : Display.state) =
|
|
let indent = ref 0 in
|
|
let rec draw_levels (tree : (string * Store.tree) list) pp =
|
|
indent := !indent + 1;
|
|
List.iter
|
|
(fun (step, node) ->
|
|
Format.pp_open_vbox pp 0;
|
|
Format.pp_open_hbox pp ();
|
|
for _ = 0 to !indent do
|
|
Format.pp_print_space pp ()
|
|
done;
|
|
Format.fprintf pp "%d-%s@." !indent step;
|
|
Format.pp_close_box pp ();
|
|
let subtree = Lwt_main.run (Store.Tree.list node []) in
|
|
draw_levels subtree pp;
|
|
Format.pp_close_box pp ())
|
|
tree;
|
|
indent := !indent - 1
|
|
in
|
|
let root =
|
|
Lwt_main.run (Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n [])
|
|
in
|
|
draw_pp height (draw_levels root) s
|
|
|
|
type top = {
|
|
te : textedit;
|
|
res : Format.symbolic_output_buffer;
|
|
mutable eval : Topinf.evalenv option;
|
|
path : string list;
|
|
storeview : storeview;
|
|
}
|
|
|
|
let make_top storepath ?(branch = "current") () =
|
|
let t =
|
|
{
|
|
te = make_textedit ();
|
|
res = Format.make_symbolic_output_buffer ();
|
|
eval = None;
|
|
path = [ "init" ];
|
|
storeview = make_storeview storepath branch ();
|
|
}
|
|
in
|
|
let zctx = Zed_edit.context t.te.ze t.te.zc in
|
|
Zed_edit.insert zctx
|
|
(Zed_rope.of_string
|
|
(Zed_string.of_utf8 (Lwt_main.run (Store.get t.storeview.s t.path))));
|
|
t
|
|
|
|
let format_symbolic_output_buffer (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 out_funs_of_sob sob =
|
|
Format.
|
|
{
|
|
out_string =
|
|
(fun s p n ->
|
|
add_symbolic_output_item sob (Output_string (String.sub s p n)));
|
|
out_flush = (fun () -> add_symbolic_output_item sob Output_flush);
|
|
out_indent = (fun n -> add_symbolic_output_item sob (Output_indent n));
|
|
out_newline = (fun () -> add_symbolic_output_item sob Output_newline);
|
|
out_spaces = (fun n -> add_symbolic_output_item sob (Output_spaces n));
|
|
}
|
|
|
|
let draw_top (t : top) height (s : Display.state) =
|
|
let eval =
|
|
match t.eval with
|
|
| None ->
|
|
let e =
|
|
Topinf.init (Format.formatter_of_symbolic_output_buffer t.res)
|
|
in
|
|
t.eval <- Some e;
|
|
e
|
|
| Some e -> e
|
|
in
|
|
(* HACK use Lazy.? *)
|
|
Display.handle_keyevents s.events (function
|
|
| `Key_up { char = '\r'; mods = [ Ctrl ]; _ } ->
|
|
F.epr "draw_top: previous t.res=@.";
|
|
format_symbolic_output_buffer F.stderr
|
|
(Format.flush_symbolic_output_buffer t.res);
|
|
Topinf.print_toplevel_value_bindings ();
|
|
(* HACK overwriting stdout formatter because fucking ocaml/toplevel/topdirs.ml hardcodes it *)
|
|
Format.pp_set_formatter_out_functions Format.std_formatter
|
|
(out_funs_of_sob t.res);
|
|
eval
|
|
(Format.formatter_of_symbolic_output_buffer t.res)
|
|
(str_of_textedit t.te ^ ";;");
|
|
(*HACK to prevent getting stuck in parser*)
|
|
ignore
|
|
(Lwt_main.run
|
|
( Store.tree t.storeview.s >>= fun tree ->
|
|
Store.Tree.add tree t.path (str_of_textedit t.te) ));
|
|
ignore
|
|
(Lwt_main.run
|
|
(Store.set_exn t.storeview.s
|
|
~info:(Irmin_unix.info "executed")
|
|
t.path (str_of_textedit t.te)))
|
|
| _ -> ());
|
|
pane_vbox
|
|
[
|
|
draw_textedit t.te height;
|
|
draw_pp height (fun pp ->
|
|
Format.pp_open_hovbox pp 0;
|
|
format_symbolic_output_buffer pp
|
|
(Format.get_symbolic_output_buffer t.res);
|
|
Format.pp_close_box pp ();
|
|
F.flush pp ());
|
|
draw_storeview t.storeview height;
|
|
]
|
|
s
|
|
|
|
let top_1 = make_top "../../rootstore" ()
|
|
|
|
let draw_komm (s : Display.state) =
|
|
let node, state, box = (ref I.empty, ref s, ref s.box) in
|
|
let push (s, (b, i)) =
|
|
node := I.stack !node i;
|
|
state := s;
|
|
box := b
|
|
in
|
|
push @@ fill_box (Display.gray 0.125) s.box !state;
|
|
(* gray bg *)
|
|
push @@ draw_top top_1 30. { s with box = !state.box };
|
|
(!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node))
|
|
|
|
let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) draw_komm) ()
|