console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

more

Browse Source
This commit is contained in:
cqc
2021-07-27 20:24:03 -05:00
parent 5ad950a8ea
commit 99c9d92ecc
3 changed files with 567 additions and 341 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.ocamlformat Normal file
View File

@ -0,0 +1 @@

13
bin/dune
View File

@ -1,7 +1,14 @@
(executables
(names main)
(modes byte)
(modules main)
(link_flags (-linkall))
(libraries komm tsdl tgls.tgles2 wall irmin-unix compiler-libs.common compiler-libs.bytecomp compiler-libs.toplevel ocaml-compiler-libs.common ocaml-compiler-libs.toplevel zed))
(libraries tsdl
tgls.tgles2
wall
zed
irmin-unix
compiler-libs.toplevel
findlib_top
ocaml-compiler-libs.common
ocaml-compiler-libs.toplevel))

684
bin/main.ml
View File

@ -1,9 +1,8 @@
(*[@@@ocaml.warning "-6-9-26-27"] *)
[@@@ocaml.warning "-6-9-26-27"]
open Lwt.Infix
module F = Fmt
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
(* Store.set_exn t ~info:(info "Adding a new entry") log_file logs) *)
module Topmain = struct
open Ocaml_common
@ -11,68 +10,100 @@ module Topmain = struct
module Compenv = Ocaml_common.Compenv
let read_interactive_input = ref (fun _ _ -> 0)
let refill_lexbuf buffer len = !read_interactive_input buffer len
exception PPerror
(* Phase buffer that stores the last toplevel phrase (see [Location.input_phrase_buffer]). *)
let phrase_buffer = Buffer.create 1024
type evalenv = Format.formatter -> string -> unit
let eval lb ppf (text : string) =
F.epr "Topmain.eval: \n";
read_interactive_input := (fun buffer _ ->
(read_interactive_input :=
fun buffer _ ->
Bytes.blit_string text 0 buffer 0 (String.length text);
Buffer.add_string phrase_buffer text; (* Also populate the phrase buffer as new characters are added. *)
Buffer.add_string phrase_buffer text;
(* Also populate the phrase buffer as new characters are added. *)
String.length text);
let snap = Btype.snapshot () in
try
F.epr "Topmain.eval: 1 reset@.";
Buffer.reset phrase_buffer; (* Reset the phrase buffer, then flush the lexing buffer. *)
Lexing.flush_input lb; (* calls read_interactive_input to fill buffer again *)
Buffer.reset phrase_buffer;
(* Reset the phrase buffer, then flush the lexing buffer. *)
Lexing.flush_input lb;
(* calls read_interactive_input to fill buffer again *)
Location.reset ();
Warnings.reset_fatal ();
F.epr "Topmain.eval: 2 Toploop.parse_toplevel_phrase@.";
let phr = try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror in
let phr =
try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror
in
F.epr "Topmain.eval: 3 Toploop.preprocess_phrase@.";
let phr = Toploop.preprocess_phrase ppf phr in
F.epr "Topmain.eval: 4 Env.reset_cache_toplevel@.";
Env.reset_cache_toplevel ();
F.epr "Topmain.eval: 5 Toploop.execute_phrase@.";
ignore(Toploop.execute_phrase true ppf phr);
F.epr "Topmain.eval: 6 handle exceptions@.";
F.epr "Topmain.eval: 5 Toploop.execute_phrase=%b@."
(Toploop.execute_phrase true ppf phr);
F.epr "Topmain.eval: 6 handle exceptions@."
with
| End_of_file -> F.epr "Topmain.eval End_of_file exception\n"; Btype.backtrack snap
| Sys.Break -> F.epr "Topmain.eval Sys.Break exception\n"; F.pf ppf "Interrupted.@."; Btype.backtrack snap
| PPerror -> F.epr "Topmain.eval PPerror exception\n"; ()
| x -> F.epr "Topmain.eval unknown exception\n"; Location.report_exception ppf x; Btype.backtrack snap
| End_of_file ->
F.epr "Topmain.eval End_of_file exception\n";
Btype.backtrack snap
| Sys.Break ->
F.epr "Topmain.eval Sys.Break exception\n";
F.pf ppf "Interrupted.@.";
Btype.backtrack snap
| PPerror ->
F.epr "Topmain.eval PPerror exception\n";
()
| x ->
F.epr "Topmain.eval unknown exception\n";
Location.report_exception ppf x;
Btype.backtrack snap
let preload_objects = ref ["komm.cma"]
let preload_objects = ref [ (*"komm.cma"*) ]
let init ppf =
F.epr "Topmain.init: \n";
Clflags.include_dirs :=
List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs;
(* Topdirs.dir_directory ((Sys.getcwd ()) ^ "/topfind");*)
let extra_paths =
match Sys.getenv "OCAML_TOPLEVEL_PATH" with
| exception Not_found -> []
| s -> Misc.split_path_contents s
in
Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs;
Compenv.readenv ppf Before_args;
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
Toploop.set_paths ();
Load_path.add_dir "/home/cqc/.opam/default/lib/toplevel";
Load_path.add_dir "/home/cqc/p/pinephone/komm/komm/_build/default/lib/";
(try
F.epr "Load_path.get_paths: @."; List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ());
let res = List.for_all (fun name ->
F.epr "Topdirs.load_file: ppf name=%s@." name;
Topdirs.load_file ppf name) (List.rev !preload_objects @ !Compenv.first_objfiles) in
F.epr "Load_path.get_paths: @.";
List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ());
let res =
List.for_all
(fun name ->
F.epr "Topdirs.load_file: name=%s@." name;
Topdirs.load_file ppf name)
(List.rev !preload_objects @ !Compenv.first_objfiles)
in
Toploop.run_hooks Toploop.Startup;
if not res then raise Exit
with Exit as x -> Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x));
with Exit as x ->
Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n"
(Printexc.to_string x));
Compmisc.init_path ();
Clflags.debug := true;
Location.formatter_for_warnings := ppf;
if not !Clflags.noversion then
F.pf ppf "OCaml version %s@.@." Config.version;
begin
try Toploop.initialize_toplevel_env ()
with Env.Error _ | Typetexp.Error _ as exn ->
Location.report_exception ppf exn; raise Exit
end;
let lb = Lexing.from_function refill_lexbuf in
(try Toploop.initialize_toplevel_env ()
with (Env.Error _ | Typetexp.Error _) as exn ->
Location.report_exception ppf exn;
raise Exit);
let lb = Lexing.from_function (fun b l -> !read_interactive_input b l) in
Location.init lb "//toplevel//";
Location.input_name := "//toplevel//";
Location.input_lexbuf := Some lb;
@ -87,25 +118,25 @@ module Display = struct
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
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}
mods : keymod list;
}
type mouse = (int * int)
type event = [ `Key_down of key
type mouse = int * int
type event =
[ `Key_down of key
| `Key_up of key
| `Text_editing of string
| `Text_input of string
@ -114,69 +145,106 @@ module Display = struct
| `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 "")
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@."
| `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
(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 ->
| (`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
(match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
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);
let repeat = (Sdl.Event.get ev Sdl.Event.keyboard_repeat) in
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
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 _, 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 *)
type state = {
box : box2;
(* This is cannonically box within which the next element should draw *)
time : float;
events : event list;
wall: Wall.renderer; }
wall : Wall.renderer;
}
type image = (box2 * Wall.image) (* the box2 here is cannonically the place the returner drew
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;
type pane = state -> state * image
type frame = {
sdl_win : Sdl.window;
gl : Sdl.gl_context;
wall : Wall.renderer;
mutable quit : bool;
mutable fullscreen: bool; }
mutable fullscreen : bool;
}
let ticks () = (Int32.to_float (Sdl.get_ticks ())) /. 1000.
let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.
let on_failure ~cleanup result = begin
match result with
| Ok _ -> ()
| Error _ -> cleanup ()
end; result
let on_failure ~cleanup result =
(match result with Ok _ -> () | Error _ -> cleanup ());
result
let video_initialized = lazy (Sdl.init Sdl.Init.video)
@ -188,11 +256,13 @@ module Display = struct
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)
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 *)
@ -201,32 +271,43 @@ module Display = struct
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? *)
if e != `None then el := !el @ [ e ]
(* HACK? *)
done;
(* Filter the events *)
el := List.filter_map
el :=
List.filter_map
(function
| `Quit -> frame.quit <- true; None
| `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
ignore
(Sdl.set_window_fullscreen frame.sdl_win
(if frame.fullscreen then Sdl.Window.fullscreen_desktop
else Sdl.Window.windowed)
: _ result)); None
: _ 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 begin
F.epr "Passing in %d events\n" (List.length !el);
| 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
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;
@ -239,7 +320,7 @@ module Display = struct
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 () end
(*F.epr "event loop took %0.6f seconds\n" (ticks () -. tstart); *) Ok ())
else Ok ()
let run frame render () =
@ -249,7 +330,8 @@ module Display = struct
ignore (display_frame frame render)
done;
print_endline "quit";
Sdl.hide_window frame.sdl_win; ()
Sdl.hide_window frame.sdl_win;
()
let gray ?(a = 1.0) v = Color.v v v v a
end
@ -274,33 +356,52 @@ let load_font name =
| 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 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)))
( 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))))
( 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))))
( 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.))))
( 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) =
@ -309,12 +410,14 @@ let pane_vbox (subpanes:Display.pane list) (so:Display.state) =
(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
( { 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)))
(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) =
@ -323,123 +426,160 @@ let pane_hbox (subpanes:Display.pane list) (so:Display.state) =
(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))},
( { 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
(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 pane_label text height ~subpanes (s:Display.state) =
let label_box, label_image = draw_label text (Box2.v (Box2.o s.box) (P2.v (Box2.w s.box) height)) in
Box2.pp Format.std_formatter label_box;
(label_box, Image.seq [
List.fold_left (fun image pane -> Image.seq [image; (pane s)]) Image.empty subpanes;
I.paint (* red box *)
(Paint.color (Color.v 0.5 0.125 0.125 1.0))
(I.stroke_path (Outline.make ()) @@
fun t -> P.rect t ~x:(Box2.ox s.box) ~y:(Box2.oy s.box) ~w:(Box2.w s.box) ~h:height);
label_image; ])
(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))},
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)))))
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 f = Text.Font.make ~size:height (Lazy.force font_sans) in
let fm = Text.Font.font_metrics f in
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 =
let text = String.sub text o l in
(* F.epr "\tout_string: %s %s@." (String.sub text o l) (str_of_box !sc.box);*)
let sp = !sc in
push @@ simple_text f text !sc;
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))};
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_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)};
(* 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 =
let wpx = Text.Font.text_width f " " in
if ((Box2.ox !sc.box) +. ((float n) *. wpx)) > (Box2.maxx !sc.box) then (* WRAP *)
begin F.epr "out_spaces: ===== WRAP =======@."; out_newline () end;
(* 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;
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)};
sc := { !sc with box = Box2.of_pts (Box2.br_pt bo) (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)};
(* 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 pp = Format.formatter_of_out_functions {out_string; out_flush; out_newline; out_spaces; out_indent;} in
Format.pp_set_formatter_stag_functions pp {
mark_open_stag = (fun s ->
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
| 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 *)
| _ -> ());
"");
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 f " ")) in
let max_indent = margin in
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)
(*let draw_spp 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 f = Text.Font.make ~size:height (Lazy.force font_sans) in
let fm = Text.Font.font_metrics f in
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
let sob = Format.make_symbolic_output_buffer () in
let pp = Format.formatter_of_symbolic_output_buffer sob in
Format.flush_symbolic_output_buffer sob;
fpp pp;
!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)*)
(!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 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
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
@ -449,15 +589,22 @@ let draw_textedit (te:textedit) height (s:Display.state) =
| { 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 = '\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
| `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;
@ -467,83 +614,154 @@ let draw_textedit (te:textedit) height (s:Display.state) =
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))
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}
{
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) ->
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;
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;
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
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: Buffer.t; mutable eval: Topmain.evalenv option; path: string list; storeview: storeview}
type top = {
te : textedit;
res : Format.symbolic_output_buffer;
mutable eval : Topmain.evalenv option;
path : string list;
storeview : storeview;
}
let make_top storepath ?(branch = "current") () =
let t = {te=make_textedit (); res=Buffer.create 1024;
eval=None; path=["init"]; storeview=make_storeview storepath branch ()} in
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))));
(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 = (Topmain.init (Format.formatter_of_buffer t.res)) in t.eval <- Some e; e
| Some e -> e in
Display.handle_keyevents s.events
(function
let eval =
match t.eval with
| None ->
let e =
Topmain.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 ]; _ } ->
Buffer.clear t.res;
eval (Format.formatter_of_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")
F.epr "draw_top: previous t.res=@.";
format_symbolic_output_buffer F.stderr
(Format.flush_symbolic_output_buffer t.res);
(* 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 [
pane_vbox
[
draw_textedit t.te height;
draw_pp height (fun pp ->
Format.pp_open_hvbox pp 0;
F.text pp (Buffer.contents t.res);
F.pf 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 ()
);
F.flush pp ());
draw_storeview t.storeview height;
] s
]
s
let top_1 = make_top "../../rootstore" ()
let mouse_state = ref (0,0)
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
(* begin match List.find_opt (function `Mouse a -> true | _ -> false) s.events with
Some (`Mouse a) -> mouse_state := a
| _ -> (); end;*)
(* let mouse_x, mouse_y = !mouse_state in *)
push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *)
push @@ pane_vbox [
draw_top top_1 25.;
] {s with box = !state.box (*(Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))*)};
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) ()