boot/bin/main.ml

[@@@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
  open Ocaml_toplevel
  module Compenv = Ocaml_common.Compenv
  let preload_objects = ref []
  let first_nonexpanded_pos = ref 0 (* Position of the first non expanded argument *)
  let current = ref (!Arg.current)
  let argv = ref Sys.argv
  let is_expanded pos = pos < !first_nonexpanded_pos (* Test whether the option is part of a responsefile *)
  let expand_position pos len =
    if pos < !first_nonexpanded_pos then
      first_nonexpanded_pos := !first_nonexpanded_pos + len       (* Shift the position *)
    else
      (* New last position *)
      first_nonexpanded_pos := pos + len + 2

  let prepare ppf =
    Toploop.set_paths ();
    try
      let res =
        let objects =
          List.rev (!preload_objects @ !Compenv.first_objfiles)
        in
        List.for_all (Topdirs.load_file ppf) objects
      in
      Toploop.run_hooks Toploop.Startup;
      res
    with x ->
      try Location.report_exception ppf x; false
      with x ->
        Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
        false

  (* If [name] is "", then the "file" is stdin treated as a script file. *)
  let file_argument name =
    let ppf = Format.err_formatter in
    if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
    then preload_objects := name :: !preload_objects
    else if is_expanded !current then begin
        (* Script files are not allowed in expand options because otherwise the
       check in override arguments may fail since the new argv can be larger
       than the original argv.
         *)
        Printf.eprintf "For implementation reasons, the toplevel does not support\
                        \ having script files (here %S) inside expanded arguments passed through the\
                        \ -args{,0} command-line option.\n" name;
        raise Exit
      end else begin
        let newargs = Array.sub !argv !current
                        (Array.length !argv - !current)
        in
        Compenv.readenv ppf Before_link;
        Compmisc.read_clflags_from_env ();
        if prepare ppf && Toploop.run_script ppf name newargs
        then raise Exit
        else raise Not_found
      end
  
  
  let wrap_expand f s =
    let start = !current in
    let arr = f s in
    expand_position start (Array.length arr);
    arr
  
  module Options = Main_args.Make_bytetop_options (struct
                       include Main_args.Default.Topmain
                       let _stdin () = file_argument ""
                       let _args = wrap_expand Arg.read_arg
                       let _args0 = wrap_expand Arg.read_arg0
                       let anonymous s = file_argument s
                     end);;

  let () =
    let extra_paths =
      match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
      | exception Not_found -> []
      | s -> Misc.split_path_contents s
    in
    Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs

  let first_line = ref true
  let read_interactive_input = ref (fun _ _ _ -> (0, false))
  let refill_lexbuf buffer len = 
        let prompt =
          if !Clflags.noprompt then ""
          else if !first_line then "# "
          else if !Clflags.nopromptcont then ""
          else if Lexer.in_comment () then "* "
          else "  "
        in
        first_line := false;
        let (len, eof) = !read_interactive_input prompt buffer len in
        (*        F.epr "refill_lexbuf: %s %b \n" (Bytes.sub_string buffer 0 len) eof ; *)
        if eof then Location.echo_eof ();
        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 prompt buffer len ->
      F.epr "Topmain.eval: read_interactive_input \n";
      F.text ppf prompt; F.flush ppf ();
      let i = ref 0 in
      try
        (*if !i >= len then raise Exit; *)
        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. *)
        i := (String.length text);
        (*if c = '\n' then raise Exit;*)
        (!i, true)
      with
      | End_of_file ->
         (!i, true)
      | Exit ->
         (!i, false));
    let snap = Btype.snapshot () in
    try
      Buffer.reset phrase_buffer; (* Reset the phrase buffer, then flush the lexing buffer. *)
      Lexing.flush_input lb;
      F.epr "eval: 1. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
      Location.reset();
      Warnings.reset_fatal ();
      first_line := true;
      let phr = try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror in
      F.epr "eval: 2. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
      let phr = Toploop.preprocess_phrase ppf phr  in
      Env.reset_cache_toplevel ();
      F.epr "eval: 3. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
      ignore(Toploop.execute_phrase true ppf phr);
      F.epr "eval: 4. phrase_buffer=%s\n" (Buffer.contents phrase_buffer)
    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
  (*done*)
  
  let init ppf =
    F.epr "Topmain.init: \n";
    Compenv.readenv ppf Before_args;
    Compenv.readenv ppf Before_link;
    Compmisc.read_clflags_from_env ();
    if not (prepare ppf) then raise Exit;
    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
    Location.init lb "//toplevel//";
    Location.input_name := "//toplevel//";
    Location.input_lexbuf := Some lb;
    Location.input_phrase_buffer := Some phrase_buffer;
    Sys.catch_break true;
    Toploop.run_hooks Toploop.After_setup;
    (*Toploop.load_ocamlinit ppf;*)
    (*while true do*)
    eval lb
end

module Display = struct
  open Wall
  open Tgles2
  open Tsdl
  open Gg
  open CamomileLibrary
  let (>>=) x f = match x with
    | Ok a -> f a
    | Error x as result -> result
  
  let get_result = function
    | Ok x -> x
    | Error (`Msg msg) -> failwith msg

  type key = {
      char:char;
      uchar:CamomileLibrary.UChar.t;
      keycode:Sdl.keycode;
      scancode:Sdl.scancode;
      shift:bool;
      ctrl:bool;
      meta:bool;
      fn:bool; }
  type mouse = (int * int)
  type event = [ `Key_down of key
               | `Key_up of key
               | `Mouse of mouse
               | `Quit
               | `Fullscreen of bool
               | `None ]

  let prev_key = ref {char='\x00'; uchar=(CamomileLibrary.UChar.of_int 0);
                      keycode=0; scancode=0;
                      shift=false; ctrl=false; meta=false; fn=false}
  open Sdl.K
  let event_of_sdlevent ev =
    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
(*             | `App_did_enter_background  | `App_did_enter_foreground  | `App_low_memory | `App_terminating
               | `App_will_enter_background | `App_will_enter_foreground   | `Clipboard_update
               | `Dollar_gesture  | `Dollar_record  
               | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel | `Multi_gesture 
               | `Sys_wm_event | `Text_editing | `Text_input | `User_event | `Window_event | `Display_event  
               | `Sensor_update  | `Drop_file | `Finger_down  | `Finger_motion  | `Finger_up -> None (* LOG *)

             | `Unknown a -> None (* LOG *)
             
             | `Controller_axis_motion | `Controller_button_down | `Controller_button_up  | `Controller_device_added  
               | `Controller_device_remapped  | `Controller_device_removed
               | `Joy_axis_motion  | `Joy_ball_motion  | `Joy_button_down  | `Joy_button_up  | `Joy_device_added  
               | `Joy_device_removed  | `Joy_hat_motion  -> None
             
 *)
    | `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 k = { char=(UChar.char_of uchar); uchar; keycode;
                 scancode=Sdl.Event.get ev Sdl.Event.keyboard_scancode;
                 shift = (km land Sdl.Kmod.shift)>0;
                 ctrl = (km land Sdl.Kmod.ctrl)>0;
                 meta = (km land Sdl.Kmod.alt)>0;
                 fn = (km land Sdl.Kmod.gui)>0; } in
       (match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
       F.epr "keycode=%x uchar=%C scancode=%x keyname=%s (%s %s %s %s)\n" keycode
         (CamomileLibrary.UChar.char_of k.uchar) k.scancode
         (Sdl.get_key_name keycode)
         (if k.shift then " shift" else "")
         (if k.ctrl then " ctrl" else "")
         (if k.meta then " meta" else "")
         (if k.fn then " fn" else "");
       (match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k)
    | `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 str_of_scancode = Sdl.get_key_name
  let key_shift_map =
    [('1','!');('2','@');('3','#');('4','$');('5','%');
     ('6','^');('7','&');('8','*');('9','(');('0',')');
     ('`','~');('-','_');('+','+');('[','{');(']','}');
     ('\\','|');(';',':');('\'','"');(',','<');('.','>');
     ('/','?')]

  let key_to_uchar k : UChar.t =
    match (List.assoc_opt k.char key_shift_map), k with
    | _, {char='\x00'} -> (UChar.of_char '\x00')
    | Some k, {shift=true} -> (UChar.of_char k)
    | None, {shift=true} -> (UChar.of_char (Char.uppercase_ascii k.char))
    | _, {shift=false} -> k.uchar


  
  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.0
  
  let on_failure ~cleanup result = begin
      match result with
      | Ok _ -> ()
      | Error _ -> cleanup ()
    end; 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 ->
    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_up a)*) None
             | `Mouse a -> Some (`Mouse a)
             | e ->  None
            (*| a -> Some a*)) !el;
    if (List.length !el) > 0 then begin
        F.epr "Passing in %d events\n" (List.length !el);    
        
        let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
        let width = float width and height = float height in
        let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height));
                                             time = ticks (); events = !el; wall = frame.wall} in
        Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
        let (width, height) as physical_size = 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.2fms?\n" (ticks () -. tstart); Ok () end
    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 "entypo.ttf")
let font_sans = lazy (load_font "Roboto-Regular.ttf")
let font_sans_bold = lazy (load_font "Roboto-Bold.ttf")
let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf")

let str_of_pnt p = Printf.sprintf "(x:%0.1f y:%0.1f)" (P2.x p) (P2.y p)
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 (Box2.ox b) (Box2.oy b) (Box2.w b) (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 (Box2.ox b) (Box2.oy b) (Box2.w b) (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 (Box2.midx b) (Box2.midy b) ((Box2.w b) /. 2.))))

let layout_hor v () = []

let layout_ver v () = []

(* 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
        F.epr "pane_vbox: %s\n" (str_of_box br);
        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 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 (Box2.ox s.box) (Box2.oy s.box) (Box2.w s.box) height);
                  label_image; ])


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) =
  F.epr "draw_pp: %s\n" (str_of_box s.box);
  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 max_x = ref 0. in
  let out_string text o l =
    let text = String.sub text o l in
    let sp = !sc in
    push @@ simple_text f text !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 = 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;
    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 n -> 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 =
    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 ->
        (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 f " ")) in
  let max_indent = margin 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 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)*)

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_up (k:Display.key) ->
         (match k with
          | {keycode=0x40000052}(*up*)   -> ignore (Zed_edit.prev_line ctx) 
          | {keycode=0x40000051}(*down*) -> ignore (Zed_edit.next_line ctx)
          | {keycode=0x40000050}(*left*) -> ignore (Zed_edit.prev_char ctx)
          | {keycode=0x4000004f}(*right*)-> ignore (Zed_edit.next_char ctx)
          | {char='\r'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.newline ctx
          | {char='b';  ctrl=true;  shift=false; meta=false; fn=false} -> Zed_edit.prev_char ctx
          | {char='f';  ctrl=true;  shift=false; meta=false; fn=false} -> Zed_edit.next_char ctx
          | {char='a';  ctrl=true;  shift=false; meta=false; fn=false} -> Zed_edit.goto_bol ctx
          | {char='e';  ctrl=true;  shift=false; meta=false; fn=false} -> Zed_edit.goto_eol ctx
          | {char='d';  ctrl=true;  shift=false; meta=false; fn=false} -> Zed_edit.remove_next ctx 1
          | {char='d';  ctrl=false; shift=false; meta=true;  fn=false} -> Zed_edit.kill_next_word ctx
          | {char='\b'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.remove_prev ctx 1
          | {char='\b'; ctrl=false; shift=false; meta=true;  fn=false} -> Zed_edit.kill_prev_word ctx
          | {char='\t'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
          | {char='k'; ctrl=true;   shift=false; meta=false; fn=false} -> Zed_edit.kill_next_line ctx
          | _ ->
             let c = Display.key_to_uchar k in
             if Zed_char.is_printable c then Zed_edit.insert_char ctx (Display.key_to_uchar k); ())
      | `Key_down _ -> ()
      | _ -> ()) s.events;
  draw_pp 30. (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 from = [] in (* future optional arg *)
  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: Buffer.t; 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 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 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 
     | `Key_up {char='\r'; ctrl=true; shift=false; meta=false; fn=false} -> 
        Buffer.clear t.res; eval (Format.formatter_of_buffer t.res) (str_of_textedit t.te);
        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 30. (fun pp ->
          Format.pp_open_hvbox pp 0;
          F.text pp (Buffer.contents t.res);
          F.pf pp "@.";
          Format.pp_close_box pp ();
          F.flush pp ()
        );
      draw_storeview t.storeview height;
    ] 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 20.;
            ] {s with box = !state.box (*(Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))*)};
  (!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) ()