~~~ save ~~~ (C-x C-s)

dune

@@ -29,10 +29,11 @@
    irmin-git
    compiler-libs.toplevel
    re
-   lwd
+   lwt_react
  )
- (link_flags (-linkall))
- (ocamlopt_flags (:standard -O3 -unboxed-types))
+ (flags (-g))
+ (link_flags (-linkall -g))
+ ;;(ocamlopt_flags (:standard -O3 -unboxed-types))
  (ocamlc_flags (:standard -verbose))
  (modes byte_complete)
  (preprocess

ogui.ml

@@ -3,6 +3,77 @@ module Gv = Graphv_gles2_native
 module F = Fmt
 module Str = Re.Str
 
+module Lwd = struct
+  open Lwt_react
+
+  type 'a var = 'a React.signal * (?step:React.step -> 'a -> unit)
+  type 'a t = 'a React.signal
+
+  let eq = Stdlib.( == )
+  let var ?(eq = eq) (v : 'a) : 'a var = S.create ~eq v
+  let get (s, _) : 'a t = s
+  let peek (s, _) = S.value s
+  let set ?step (_, f) v = f ?step v
+  let pure = S.const
+  let return = S.return
+  let map ?(eq = eq) ~(f : 'a -> 'b) (a : 'a t) : 'b t = S.l1 ~eq f a
+
+  let map2 ?(eq = eq) ~(f : 'a -> 'b -> 'c) (a : 'a t) (b : 'b t) :
+      'c t =
+    S.l2 ~eq f a b
+
+  let map_s ?(eq = eq) ~(f : 'a -> 'b Lwt.t) (a : 'a t) : 'b t Lwt.t =
+    S.l1_s f a
+
+  let map2_s ?(eq = eq) ~(f : 'a -> 'b -> 'c Lwt.t) (a : 'a t)
+      (b : 'b t) : 'c t Lwt.t =
+    S.l2_s f a b
+
+  let bind ?(eq = eq) (a : 'a t) ~(f : 'a -> 'b t) : 'b t =
+    S.bind ~eq a f
+
+  let join ?(eq = eq) : 'a t t -> 'a t = S.switch ~eq
+
+  type 'a root = Root of 'a t
+
+  let observe (t : 'a t) : 'a root = Root t
+  let quick_sample = function Root t -> S.value t
+end
+
+module Lwd_utils = struct
+  (* stolen from Lwd_utils *)
+  type 'a monoid = 'a * ('a -> 'a -> 'a)
+
+  let lift_monoid (zero, plus) = (Lwd.return zero, Lwd.map2 ~f:plus)
+
+  let map_reduce inj (zero, plus) items =
+    let rec cons_monoid c xs v =
+      match xs with
+      | (c', v') :: xs when c = c' ->
+          cons_monoid (c + 1) xs (plus v' v)
+      | xs -> (c, v) :: xs
+    in
+    let cons_monoid xs v = cons_monoid 0 xs (inj v) in
+    match List.fold_left cons_monoid [] items with
+    | [] -> zero
+    | (_, x) :: xs ->
+        List.fold_left (fun acc (_, v) -> plus v acc) x xs
+
+  let reduce monoid items = map_reduce (fun x -> x) monoid items
+
+  let rec cons_lwd_monoid plus c xs v =
+    match xs with
+    | (c', v') :: xs when c = c' ->
+        cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v)
+    | xs -> (c, v) :: xs
+
+  let pack (zero, plus) items =
+    match List.fold_left (cons_lwd_monoid plus 0) [] items with
+    | [] -> Lwd.return zero
+    | (_, x) :: xs ->
+        List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs
+end
+
 type stroke = { width : float; color : Gv.Color.t }
 
 let stroke_none = { width = 0.; color = Gv.Color.transparent }
@@ -30,7 +101,7 @@ let pp_color : Gv.Color.t Fmt.t =
            field "a" (fun (s : Gv.Color.t) -> s.a) float;
          ])
 
-let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
+(* let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
    let root = Lwd.observe t in
    Lwd.quick_sample root >>= fun root' ->
    let var = Lwd.var root' in
@@ -38,7 +109,7 @@ let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
        Lwt.async (fun () ->
            Lwd.quick_sample root >>= fun root' ->
            Lwt.return @@ Lwd.set var root'));
-  Lwt.return (Lwd.get var)
+    Lwt.return (Lwd.get var) *)
 
 module Margin = struct
   open Gg
@@ -81,21 +152,32 @@ let pp_uchar : Uchar.t F.t =
  fun ppf u -> F.pf ppf "%S" (string_of_utf_8_uchar u)
 
 module TextBuffer = struct
+  let tree_eq (a : Store.S.tree) b =
+    F.epr "tree_eq (a=%s) (b=%s) @."
+      Store.(S.Tree.hash a |> S.Git.Hash.to_hex)
+      Store.(S.Tree.hash b |> S.Git.Hash.to_hex);
+    Store.(S.Git.Hash.equal (S.Tree.hash a) (S.Tree.hash b))
+
   type t = {
     path : string list Lwd.var;
     tree : Store.S.tree Lwd.var;
     repo : Store.Sync.db Lwt.t;
   }
 
-  let of_repo ~initial_path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
+  let of_repo ~(initial_path : string list)
+      ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
     repo >>= Store.S.tree >>= fun tree ->
     Lwt.return
-      { path = Lwd.var initial_path; tree = Lwd.var tree; repo }
+      {
+        path = Lwd.var initial_path;
+        tree = Lwd.var ~eq:tree_eq tree;
+        repo;
+      }
 
   let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str =
     {
       path = Lwd.var path;
-      tree = Lwd.var @@ Store.S.Tree.singleton path str;
+      tree = Lwd.var ~eq:tree_eq @@ Store.S.Tree.singleton path str;
       repo =
         ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
           Option.value ~default:Store.S.(empty repo') repo );
@@ -123,7 +205,9 @@ module TextBuffer = struct
           F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@.";
           Some (String.sub (Bytes.to_string ucbuf) 0 uclen))
     >>= fun t ->
+    F.epr "TextBuffer.insert_uchar Tree.update @.";
     Lwd.set tree t;
+    F.epr "TextBuffer.insert_uchar Lwd.set tree @.";
     Lwt.return_unit
 
   let insert { path; tree; _ } n str =
@@ -135,7 +219,7 @@ module TextBuffer = struct
             String.(
               cat (cat (sub src 0 n) str) (sub src n (srcn - n)))
       | None ->
-          F.epr "TextBuffer.insert Tree.update -> Nonep@.";
+          F.epr "TextBuffer.insert Tree.update -> None@.";
           Some str)
     >>= fun t ->
     Lwd.set tree t;
@@ -196,9 +280,8 @@ module TextBuffer = struct
     >>= fun text -> Lwt.return text
 
   let get { tree; path; _ } =
-    Lwd.map2 (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
+    Lwd.map2_s (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
         Store.S.Tree.get tree path)
-    |> lwt_lwd
 
   let peek { tree; path; _ } =
     Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
@@ -206,6 +289,29 @@ module TextBuffer = struct
   let length { path; tree; _ } =
     Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) >>= fun text ->
     Lwt.return (String.length text)
+
+  let save { path; tree; repo } =
+    Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
+    >>= fun contents ->
+    repo >>= fun r ->
+    Store.S.set
+      ~info:
+        Store.S.Info.(
+          fun () ->
+            v ~author:"me" ~message:"TextBuffer.save"
+              (Unix.time () |> Int64.of_float))
+      r (Lwd.peek path) contents
+    >>= fun r ->
+    (match r with
+    | Ok () -> ()
+    | Error (`Conflict s) ->
+        F.epr "TextBuffer.save Error `Conflict %s@." s
+    | Error (`Too_many_retries n) ->
+        F.epr "TextBuffer.save Error `Too_many_retries %d@." n
+    | Error (`Test_was n) ->
+        F.epr "TextBuffer.save Error `Test_was %s@."
+          "<not implemented>");
+    Lwt.return_unit
 end
 
 module Event = struct
@@ -604,7 +710,7 @@ module Ui = struct
     enabled : bool;
     gv : Gv.t;
     glfw_window : GLFW.window option;
-    bindings : action list Event.t Lwd.var;
+    bindings : (int * action list Event.t) Lwd.var;
   }
 
   and action = Custom of string * (unit -> unit Lwt.t)
@@ -617,11 +723,12 @@ module Ui = struct
 
   let window gv ?(window : GLFW.window option) rect : t =
     {
-      rect;
+      rect = Lwd.var ~eq:Gg.Box2.equal rect;
       enabled = true;
       gv;
       glfw_window = window;
-      bindings = Lwd.var Event.empty;
+      bindings =
+        Lwd.var ~eq:(fun (a, _) (b, _) -> a = b) (0, Event.empty);
     }
 
   let pp_action : action F.t =
@@ -647,11 +754,9 @@ module Ui = struct
       match resolver with
       | Event.Rejected | Event.Accepted _ ->
           [
-            (let bindings =
-               t.bindings |> Lwd.get |> Lwd.observe
-               |> Lwd.quick_sample
-             in
-             Event.pack Fun.id bindings);
+            t.bindings |> Lwd.peek
+            (*Lwd.get |> Lwd.observe |> Lwd.quick_sample *) |> snd
+            |> Event.pack Fun.id;
           ]
       | Event.Continue r -> r
     in
@@ -659,7 +764,7 @@ module Ui = struct
     (match res with
     | Event.Accepted actions ->
         let rec exec : action list -> unit Lwt.t = function
-          | Custom (_, f) :: actions ->
+          | Custom (name, f) :: actions ->
               f () >>= fun () -> exec actions
           | [] -> Lwt.return_unit
         in
@@ -669,7 +774,9 @@ module Ui = struct
 
   let update_bindings ui
       (f : action list Event.t -> action list Event.t) =
-    Lwd.set ui.bindings (f (Lwd.peek ui.bindings))
+    Lwd.set ui.bindings
+      ( Lwd.peek ui.bindings |> fst |> Int.add 1,
+        f (Lwd.peek ui.bindings |> snd) )
 
   let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
     ref (fun _c ->
@@ -685,11 +792,14 @@ module Ui = struct
             action list Event.result Lwt.t =
           Lwt_stream.last_new events >>= function
           | `Key (state, key, mods) ->
+              Event.(
+                F.epr "Ui.process_events `Key %a %a %a" pp_key_action
+                  state pp_key key pp_mods mods);
+
               process_key ui r state key mods
               >>= fun (res : action list Event.result) ->
               Event.(
-                F.epr "Ui.process_events `Key %a %a %a (%s)@."
-                  pp_key_action state pp_key key pp_mods mods
+                F.epr " (%s)@."
                   (match res with
                   | Accepted _ -> "Accepted"
                   | Continue _ -> "Continue"
@@ -699,7 +809,9 @@ module Ui = struct
                   (* junk the `Char that is sent with a `Key that has no mods *)
                   Lwt_stream.peek events
                   >>= function
-                  | Some (`Char _) -> Lwt_stream.junk events
+                  | Some (`Char _) ->
+                      F.epr "process_events: junking next event@.";
+                      Lwt_stream.junk events
                   | _ -> Lwt.return_unit)
               | Accepted _ | Continue _ | Rejected -> Lwt.return_unit)
               >>= fun () -> proc res
@@ -1050,6 +1162,17 @@ module TextEdit = struct
                    fun () ->
                      Lwd.set t.mark None;
                      Lwt.return_unit );
+             ]
+        |> adds
+             [
+               [
+                 Key (Press, X, [ Control ]);
+                 Key (Press, S, [ Control ]);
+               ];
+             ]
+             (* Save *)
+             [
+               Custom ("save_buffer", fun () -> TextBuffer.save t.text);
              ]);
 
     Ui.chrcallback_ref :=
@@ -1146,7 +1269,7 @@ module Layout = struct
     |> Lwt.return
 
   let system ui ?(style = textedit_style) d
-      (telist : TextEdit.t list Lwd.var) =
+      (telist : (int * TextEdit.t list) Lwd.var) =
     let cursor = Lwd.var 0 in
     Ui.update_bindings ui (fun a ->
         a
@@ -1159,11 +1282,14 @@ module Layout = struct
                      Lwd.set cursor
                        (if
                           Lwd.peek cursor
-                          < (List.length @@ Lwd.peek telist) - 1
+                          < (Lwd.peek telist |> snd |> List.length)
+                            - 1
                         then Lwd.peek cursor + 1
                         else 0);
                      TextEdit.default_bindings
-                       (List.nth (Lwd.peek telist) (Lwd.peek cursor))
+                       (List.nth
+                          (Lwd.peek telist |> snd)
+                          (Lwd.peek cursor))
                        ui;
                      Lwt.return_unit );
              ]
@@ -1176,16 +1302,17 @@ module Layout = struct
                      Lwd.set cursor
                        (if Lwd.peek cursor > 0 then
                           Lwd.peek cursor - 1
-                        else (Lwd.peek telist |> List.length) - 1);
+                        else
+                          (Lwd.peek telist |> snd |> List.length) - 1);
                      TextEdit.default_bindings
-                       (List.nth (Lwd.peek telist) (Lwd.peek cursor))
+                       (List.nth
+                          (Lwd.peek telist |> snd)
+                          (Lwd.peek cursor))
                        ui;
                      Lwt.return_unit );
              ]);
-    (* let teln = List.length telist in *)
-    (* let ratio n = `Ratio (1. /. float (teln - (n + 1))) in *)
-    Lwd.map
-      ~f:(fun tl ->
+    Lwd.map_s
+      ~f:(fun (_, tl) ->
         Lwt_list.mapi_s
           (fun n te ->
             textedit
@@ -1213,7 +1340,6 @@ module Layout = struct
           tl
         >>= fun framelist -> box ~style d framelist |> Lwt.return)
       (Lwd.get telist)
-    |> lwt_lwd
     >>= fun d -> Lwd.join d |> Lwt.return
 
   let pp_dir ppf (t : [ `X | `Y | `Z ]) =

oplevel.ml

@@ -76,8 +76,7 @@ let main =
   in
 
   let ui =
-    Ogui.Ui.window ctx ~window
-      (Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.)))
+    Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.))
   in
 
   load_fonts ui.gv;
@@ -178,10 +177,12 @@ let main =
       ~style:
         Style.{ default with margin = Margin.symmetric 10.0 10.0 }
       (Lwd.var
+         ~eq:(fun (a, _) (b, _) -> Int.equal a b)
+         ( 0,
            [
              TextEdit.multiline ui tb_init;
              TextEdit.multiline ui to_init;
-         ]))
+           ] )))
   >>= fun page ->
   let page_root = Lwd.observe page in
 
@@ -196,7 +197,7 @@ let main =
         [ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]);
 
   let bindings =
-    ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample
+    ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample |> snd
   in
   F.epr "Bindings:@.%a" Ui.pp_bindings bindings;
 
@@ -244,9 +245,19 @@ let main =
     if not GLFW.(windowShouldClose ~window) then draw_loop ()
     else Lwt.return_unit
   in
-  draw_loop () >>= fun () ->
+  (try draw_loop ()
+   with e ->
+     F.epr "draw_loop Exception: %s@.Backtrace:@.%s@."
+       (Printexc.to_string e)
+       (Printexc.get_backtrace ())
+     |> Lwt.return)
+  >>= fun () ->
   Printf.printf "MIN %.2f\n" !min_fps;
   Printf.printf "MAX %.2f\n%!" !max_fps;
   Lwt.return_unit
 
-let () = Lwt_main.run main
+let () =
+  try Lwt_main.run main
+  with e ->
+    F.epr "Exception: %s@.Backtrace:@.%s@." (Printexc.to_string e)
+      (Printexc.get_backtrace ())