that was quite the breakup

.ocamlformat

@@ -0,0 +1 @@
+ 

bin/dune

@@ -1,7 +1,30 @@
 (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 topinf
+            tsdl
+            tgls.tgles2
+            wall
+            zed
+            irmin-unix
+            ocaml-compiler-libs.common
+            ocaml-compiler-libs.bytecomp
+            ocaml-compiler-libs.toplevel
+            findlib))
 
+(library
+ (name topinf)
+ (modes byte)
+ (modules topinf)
+ (libraries tsdl
+            tgls.tgles2
+            wall
+            zed
+            irmin-unix
+            ocaml-compiler-libs.common
+            ocaml-compiler-libs.bytecomp
+            ocaml-compiler-libs.toplevel
+            findlib))
   

bin/init.ml

@@ -0,0 +1,6 @@
+#directory "";;
+
+let x = 1.0;;
+
+assert (x = 1.0)
+  

bin/main.ml

@@ -1,111 +1,33 @@
-(*[@@@ocaml.warning "-6-9-26-27"] *)
+[@@@ocaml.warning "-6-9-26-27-32-34"]
+
 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 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 _ ->
-      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. *)
-      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 *)
-      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
-      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@.";
-    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
-
-  let preload_objects = ref ["komm.cma"]
-
-  let init ppf =
-    F.epr "Topmain.init: \n";
-    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
-      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));
-    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;
-    eval lb
-end
 
 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
+  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 +36,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 +147,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 +162,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 +211,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 +221,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 +247,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 +301,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 +317,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 +480,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 +505,155 @@ 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 : Topinf.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 =
+          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 ]; _ } ->
-        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);
+        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 [
+  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) ()

bin/topinf.mli

@@ -0,0 +1,12 @@
+(* Accessors for the table of toplevel value bindings.  These functions
+     must appear as first and second exported functions in this module.
+     (See module Translmod.) *)
+val getvalue : string -> Obj.t
+
+val setvalue : string -> Obj.t -> unit
+
+val print_toplevel_value_bindings : unit -> unit
+
+type evalenv = Format.formatter -> string -> unit
+
+val init : Format.formatter -> evalenv