wip, rewriting GUI_Settings.adrien/wip-gui-settings

7 files changed, 295 insertions, 115 deletions

diff --git a/.gitignore b/.gitignore
index 899f007..f560a53 100644
--- a/.gitignore
+++ b/.gitignore
@@ -13,3 +13,5 @@ donkey.png
 
 src/sexp/sexplib
 w
+
+icons-tests
diff --git a/Makefile b/Makefile
index 113a681..17cfa91 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
-export PATH := /home/adrien/projects/win-builds-1.6/win-builds/deps/prefix/bin/:$(PATH)
+export PATH := /home/adrien/projects/win-builds-1.6/win-builds/deps/prefix/bin/:/home/adrien/projects/win-builds-1.6/win-builds/opt/cross_toolchain_64/bin/:$(PATH)
 
 OCAMLBUILD := \
-  cd src && ocamlbuild -use-ocamlfind \
+  cd src && ocamlbuild -j 2 -use-ocamlfind \
     -cflags -ccopt,-Wall,-ccopt,-Wextra,-ccopt,-O2 \
     $(if $(WITH_ICON),-lflags $(WITH_ICON:=.o)) \
     -lflags yypkg/win.o \
diff --git a/src/_tags b/src/_tags
index 676a453..b41020c 100644
--- a/src/_tags
+++ b/src/_tags
@@ -10,7 +10,9 @@ true: debug, warn_A, warn(-4-9-23-44-58)
 
 <http_get/*>: package(libocaml_http)
 
-<yypkg/*>: package(fileutils.str), package(cryptokit), package(libocaml_http), thread
+<get.*>: package(libocaml_http)
+
+<yypkg/*>: package(fileutils.str), package(cryptokit), thread
 
 <yypkg/yypkg.{native,byte}>: package(bigarray), package(archive), package(libocaml_http), package(containers.data), package(containers), thread
 
diff --git a/src/yypkg/gui/GUI_InWin.ml b/src/yypkg/gui/GUI_InWin.ml
index 4594dbd..e424c7a 100644
--- a/src/yypkg/gui/GUI_InWin.ml
+++ b/src/yypkg/gui/GUI_InWin.ml
@@ -1,6 +1,6 @@
 module type Message = sig
   val message : string
-  val icon : string
+  val icon : string (* XXX: unused *)
   val label : string
 end
 
diff --git a/src/yypkg/gui/GUI_Packages.ml b/src/yypkg/gui/GUI_Packages.ml
index 1ad62a3..959112d 100644
--- a/src/yypkg/gui/GUI_Packages.ml
+++ b/src/yypkg/gui/GUI_Packages.ml
@@ -367,6 +367,7 @@ let statusbar box =
   let operation =
     let t_last = ref (Unix.gettimeofday ()) in
     let text_last = ref "" in
+    (* TODO: get rid of FakeNaviframe and use a progress bar directly *)
     let progress = Elm_progressbar.addx bar_table in
     Elm_progressbar.horizontal_set progress true;
     Elm_progressbar.unit_format_set progress "%0.f%%";
diff --git a/src/yypkg/gui/GUI_Settings.ml b/src/yypkg/gui/GUI_Settings.ml
index 4224ef3..2378a9f 100644
--- a/src/yypkg/gui/GUI_Settings.ml
+++ b/src/yypkg/gui/GUI_Settings.ml
@@ -7,32 +7,32 @@ let label = "Settings"
 
 open GUI_Message
 
-type setting = {
-  init : conf -> unit;
-  check : (conf * setting list) -> unit;
-}
-
-module type Setting = sig
-  val t : box:Evas_object.t -> setting
-end
-
+type next = (conf -> unit) option
+type check = [ `Check of conf * next ]
+type settings_ev = [ check | `Init of conf * next ]
+type checks_ev = [
+  | `Show
+  | `Hide
+  | `Push of (string * string)
+]
 type ev = [
   | `Show
   | `Hide
   | `BeAdopted of (Evas_object.t -> unit)
   | `Cancelled
-  | `Check of (conf option * setting list)
+  (* TODO: delete the line below and allow each setting module to return a
+   * meaningful value that will be stored at the end and re-used right away *)
+  | `Check of (conf option * check list)
   | `CheckFailed
+  | `Checks of checks_ev
+  | `Mirror of settings_ev
+  | `LocalPredicates of settings_ev
+  | `RepoPredicates of settings_ev
 ]
 
 type event += T of ev
 let send msg = send (T msg)
 
-type t = {
-  check_failed : unit -> unit;
-  box : Evas_object.t;
-}
-
 let entry ?text parent =
   let size_hint = [ `hexpand; `hfill ] in
   let e = Elm_entry.addx parent ?text ~size_hint in
@@ -41,51 +41,171 @@ let entry ?text parent =
   Elm_scroller.policy_set e `off `off;
   e
 
+module type Setting = sig
+  type t
+  val send : settings_ev -> unit
+  val t : box:Evas_object.t -> t
+  val state_machine : t -> settings_ev -> t
+end
+
+module Checks : sig
+  type t
+  type ev = [
+    | `Show
+    | `Hide
+    | `Push of (string * string)
+  ]
+  val t : shared -> t
+  val send : ev -> unit
+  val state_machine : t -> ev -> t
+end = struct
+  type ev = [
+    | `Show
+    | `Hide
+    | `Push of (string * string)
+  ]
+
+  let send msg = send (`Checks msg)
+
+  type t = {
+    iw : Evas_object.t;
+    box : Evas_object.t;
+    labels : (string * Evas_object.t) list;
+  }
+
+  let t shared =
+    let iw = Elm_inwin.add shared.ui.w in
+    let box = Elm_box.addx ~inwin:iw iw in
+    let scroller = Ep.Scroller.addx ~box box in
+    Elm_scroller.content_min_limit scroller true false;
+    let hbox = Elm_box.addx ~box ~size_hint:[ `hexpand; `fill ] box in
+    Elm_box.horizontal_set hbox true;
+    ignore @@ Elm_button.addx hbox ~box:hbox ~text:"Cancel";
+    Elm_object.disabled_set (Elm_button.addx hbox ~box:hbox ~text:"Apply"
+      ~cb:[ Elm.connect Elm_sig.clicked (fun _ -> Evas_object.hide iw);
+    ]) true;
+    { iw; box = Elm_box.addx ~content_of:scroller scroller; labels = [] }
+
+  let push ~t ~title ~text =
+    try
+      let label = List.assoc title t.labels in
+      Elm_object.(part_text_set label ((part_text_get label ()) ^ "<br>" ^ text));
+      t
+    with Not_found ->
+      let frame = Elm_frame.addx t.box ~box:t.box ~text:title in
+      let label = Elm_label.addx frame ~content_of:frame ~text in
+      { t with labels = (title, label) :: t.labels }
+
+  let state_machine t = function
+    | `Show ->
+        Evas_object.show t.iw; t
+    | `Hide ->
+        Evas_object.hide t.iw; t
+    | `Push (title, text) ->
+        push ~t ~title ~text
+end
+
 module Mirror : Setting = struct
+  type t = {
+    entry : Evas_object.t;
+  }
+
+  let reporter ~mirror =
+    let push_text s =
+      Checks.send (`Push ("Mirror", s))
+    in
+    Get.reporter_make ~size:0L ~report:(fun (msg : Get.ev) ->
+      push_text (match msg with
+      | `Progress (total, size, speed) ->
+          let pp_size sz = Lib.pretty_print_size ~pad:true sz in
+          Lib.sp "%s\t%s/s" (pp_size total) (pp_size speed)
+      | `Error s ->
+          Lib.sp "ERROR: %s." s
+      | `Downloaded ->
+          "Downloaded."
+      | `Success ->
+          "Success."
+      )
+    )
+
+  let check ~t (conf, next) =
+    let mirror = Elm_object.part_text_get t.entry () in
+    let reporter = reporter ~mirror in
+    ignore @@ Thread.create (fun () ->
+      try
+        ignore @@ Web.repository ~conf ~reporter ~source:(`OtherMirror mirror);
+        (match next with
+        | Some next -> next { conf with mirror }
+        | None -> ())
+      with _exn ->
+        send `CheckFailed
+    ) ();
+    t
+
+  let init ~t (conf, next) =
+    Elm_object.part_text_set t.entry
+      (if conf.mirror <> "" then conf.mirror else "http://");
+    (match next with | Some next -> next conf | None -> ());
+    t
+
   let t ~box =
-    let frame = Elm_frame.addx box ~box ~size_hint:[ `hfill; `hexpand ] ~text:"Mirror" in
+    let frame = Elm_frame.addx box ~box ~size_hint:[ `hfill; `hexpand ]
+      ~text:"Mirror" in
     Elm_frame.autocollapse_set frame true;
     let box =  Elm_box.addx ~content_of:frame frame in
-    ignore @@ Elm_label.addx box ~box ~size_hint:[ `halign 0. ] ~text:"Path to the current mirror; can be either a full windows path or a file:// or an http:// URL.";
+    ignore @@ Elm_label.addx box ~box
+      ~size_hint:[ `halign 0. ]
+      ~text:"Path to the current mirror; can be either a full windows path or a file:// or an http:// URL.";
     let sep = Elm_separator.addx ~size_hint:[ `hfill; `valign 0. ] ~box box in
     Elm_separator.horizontal_set sep true;
     let e = entry box in
     Elm_box.pack_end box e;
-    let init conf =
-      let mirror = conf.mirror in
-      Elm_object.part_text_set e (if mirror <> "" then mirror else "http://")
-    in
-    let check (conf, q) =
-      let mirror = Elm_object.part_text_get e () in
-      if mirror <> conf.mirror then
-        ignore (Thread.create (fun () ->
-          try
-            ignore (Web.repository ~conf ~reporter:(Web.Reporter.dummy ()) ~source:(`OtherMirror mirror));
-            send (`Check (Some { conf with mirror}, q))
-          with _exn ->
-            send `CheckFailed
-        ) ())
-      else
-        send (`Check (Some conf, q))
-    in
-    { init; check; }
+    (* TODO cancel a possibly running download check *)
+    { entry = e }
+
+  let state_machine t = function
+    | `Init conf -> init ~t conf
+    | `Check x -> check ~t x
+
+  let send msg = send (`Mirror msg)
 end
 
 module LocalPredicates : Setting = struct
-  let t ~box =
-    let frame = Elm_frame.addx box ~size_hint:[ `hfill; `hexpand ] ~box ~text:"Local predicates" in
-    Elm_frame.autocollapse_set frame true;
-    let box = Elm_box.addx ~content_of:frame frame in
-    let help = Elm_label.addx box ~box ~size_hint:[ `halign 0.; `hfill ] ~text:"Predicates make it possible to hide packages: if a packages lists a predicate 'p' with a value 'v', it will be visible if and only if the local configuration has a that predicate 'p' with 'v' one of its possible values." in
-    Elm_label.line_wrap_set help `word;
-    let sep = Elm_separator.addx ~size_hint:[ `hfill; `valign 0. ] ~box box in
-    Elm_separator.horizontal_set sep true;
-    let table = Elm_table.addx ~box ~size_hint:[ `hexpand; `fill] box in
-    Elm_table.homogeneous_set table false;
-    Elm_table.pack table (Elm_label.addx ~text:"Predicate" table) 0 0 1 1;
-    Elm_table.pack table (Elm_label.addx ~text:"Value" table) 1 0 1 1;
+  type t = {
+    table : Evas_object.t;
+    push_row : (string * string) -> unit
+  }
+
+  let check ~t (conf, next) =
+    let module PredMap =
+      Map.Make (struct type t = string let compare = compare end) in
+    let rec aux i m =
+      let get j = Elm_table.child_get t.table j i in
+      match get 0, get 1 with
+      | Some p, Some v ->
+          if not (Elm_object.disabled_get p) then
+            let p = Elm_object.part_text_get p () in
+            let v = Elm_object.part_text_get v () in
+            if p <> "" && v <> "" then
+              let lv = try PredMap.find p m with Not_found -> [] in
+              aux (i+1) (PredMap.add p (v :: lv) m)
+            else
+              aux (i+1) m
+          else
+            aux (i+1) m
+      | None, None ->
+          PredMap.bindings m
+      | _ ->
+          assert false
+    in
+    (match next with
+    | Some next -> next { conf with preds = aux 1 PredMap.empty };
+    | None -> ());
+    t
+
+  let push_row ~table =
     let i = ref 1 in
-    let push_row (predicate, value) =
+    fun (predicate, value) ->
       let entry_predicate = entry table ~text:predicate in
       let entry_value = entry table ~text:value in
       let disable_icon = Elm_icon.addx table in
@@ -105,54 +225,45 @@ module LocalPredicates : Setting = struct
       Elm_table.pack table disable 2 !i 1 1;
       Elm_object.focus_set entry_predicate true;
       incr i
-    in
-    ignore @@ Elm_button.addx ~box ~size_hint:[] ~text:"New predicate" box
-      ~cb:[ Elm.connect Elm_sig.clicked (fun _ -> push_row ("", "")) ];
-    let init conf =
-      i := 1;
-      List.iter (fun (p, l) -> List.iter (fun v -> push_row (p,v)) l) conf.preds
-    in
-    let check (conf, q) =
-      let module PredMap =
-        Map.Make (struct type t = string let compare = compare end) in
-      let rec aux i m =
-        let get j = Elm_table.child_get table j i in
-        match get 0, get 1 with
-        | Some p, Some v ->
-            if not (Elm_object.disabled_get p) then
-              let p = Elm_object.part_text_get p () in
-              let v = Elm_object.part_text_get v () in
-              if p <> "" && v <> "" then
-                let lv = try PredMap.find p m with Not_found -> [] in
-                aux (i+1) (PredMap.add p (v :: lv) m)
-              else
-                aux (i+1) m
-            else
-              aux (i+1) m
-        | None, None ->
-            PredMap.bindings m
-        | _ ->
-            assert false
-      in
-      send (`Check (Some { conf with preds = aux 1 PredMap.empty }, q))
-    in
-    { init; check; }
-end
 
-module RepoPredicates : Setting = struct
+  let init ~t (conf, next) =
+    List.iter (fun (p, l) -> List.iter (fun v -> t.push_row (p,v)) l) conf.preds;
+    (match next with | Some next -> next conf | None -> ());
+    t
+
   let t ~box =
-    let frame = Elm_frame.addx box ~box ~size_hint:[ `hfill; `hexpand ] ~text:"All repository predicates (informative)" in
+    let frame = Elm_frame.addx box ~size_hint:[ `hfill; `hexpand ] ~box ~text:"Local predicates" in
     Elm_frame.autocollapse_set frame true;
     let box = Elm_box.addx ~content_of:frame frame in
-    let help = Elm_label.addx box ~box ~size_hint:[ `halign 0.; `hfill ] ~text:"Below is the list of all predicates seen on the current mirror along with the list of values seen for each of them. The list is read-only." in
+    let help = Elm_label.addx box ~box ~size_hint:[ `halign 0.; `hfill ]
+      ~text:"Predicates make it possible to hide packages: if a packages lists a predicate 'p' with a value 'v', it will be visible if and only if the local configuration has a that predicate 'p' with 'v' one of its possible values." in
     Elm_label.line_wrap_set help `word;
     let sep = Elm_separator.addx ~size_hint:[ `hfill; `valign 0. ] ~box box in
     Elm_separator.horizontal_set sep true;
-    let table = Elm_table.addx ~size_hint:[ `hexpand; `fill] ~box box in
+    let table = Elm_table.addx ~box ~size_hint:[ `hexpand; `fill] box in
+    Elm_table.homogeneous_set table false;
     Elm_table.pack table (Elm_label.addx ~text:"Predicate" table) 0 0 1 1;
     Elm_table.pack table (Elm_label.addx ~text:"Value" table) 1 0 1 1;
+    let push_row = push_row ~table in
+    ignore @@ Elm_button.addx ~box ~size_hint:[] ~text:"New predicate" box
+      ~cb:[ Elm.connect Elm_sig.clicked (fun _ -> push_row ("", "")) ];
+    { push_row; table }
+
+    let state_machine t = function
+      | `Init conf -> init ~t conf
+      | `Check x -> check ~t x
+
+  let send msg = send (`LocalPredicates msg)
+end
+
+module RepoPredicates : Setting = struct
+  type t = {
+    push_row : string * string list -> unit
+  }
+
+  let push_row ~table =
     let i = ref 1 in
-    let push_row (k, vs) =
+    fun (k, vs) ->
       let b = Buffer.create 40 in
       let p = Format.formatter_of_buffer b in
       Format.fprintf p "%a%!" Log.F.(list string) vs;
@@ -163,44 +274,102 @@ module RepoPredicates : Setting = struct
       Elm_table.pack table entry_predicate 0 !i 1 1;
       Elm_table.pack table entry_values 1 !i 1 1;
       incr i
-    in
-    let init conf =
-      i := 1;
-      List.iter push_row (Yylib.repo_predicates (Web.repository ~conf ~reporter:(Web.Reporter.dummy ()) ~source:`Local))
-    in
-    let check (conf, q) = send (`Check (Some conf, q)) in
-    { init; check; }
+
+  let init ~t (conf, next) =
+    Web.repository ~conf ~reporter:(Web.Reporter.dummy ()) ~source:`Local
+      |> Yylib.repo_predicates
+      |> List.iter t.push_row;
+    (match next with | Some next -> next conf | None -> ());
+    t
+
+  let check ~t (conf, next) =
+    (match next with
+    | Some next -> next conf
+    | None -> ());
+    t
+
+  let t ~box =
+    let frame = Elm_frame.addx box ~box ~size_hint:[ `hfill; `hexpand ]
+      ~text:"All repository predicates (informative)" in
+    Elm_frame.autocollapse_set frame true;
+    let box = Elm_box.addx ~content_of:frame frame in
+    let help = Elm_label.addx box ~box ~size_hint:[ `halign 0.; `hfill ]
+      ~text:"Below is the list of all predicates seen on the current mirror along with the list of values seen for each of them. The list is read-only." in
+    Elm_label.line_wrap_set help `word;
+    let sep = Elm_separator.addx ~size_hint:[ `hfill; `valign 0. ] ~box box in
+    Elm_separator.horizontal_set sep true;
+    let table = Elm_table.addx ~size_hint:[ `hexpand; `fill] ~box box in
+    Elm_table.pack table (Elm_label.addx ~text:"Predicate" table) 0 0 1 1;
+    Elm_table.pack table (Elm_label.addx ~text:"Value" table) 1 0 1 1;
+    { push_row = push_row ~table }
+
+  let state_machine t = function
+    | `Init conf -> init ~t conf
+    | `Check x -> check ~t x
+
+  let send msg = send (`RepoPredicates msg)
 end
 
+let settings_message f =
+  let wrap next (module S : Setting) =
+    Some (fun conf -> S.send (f next conf))
+  in
+  let l = List.fold_left wrap None (List.rev [
+    (module Mirror : Setting);
+    (module LocalPredicates : Setting);
+    (module RepoPredicates : Setting);
+  ])
+  in
+  fun g ->
+    match l with
+    | None -> ()
+    | Some e -> e (g ())
+
+type t = {
+  check_failed : unit -> unit;
+  box : Evas_object.t;
+  checks_progress : Checks.t;
+  mirror : Mirror.t;
+  local_predicates : LocalPredicates.t;
+  repo_predicates : RepoPredicates.t;
+}
+
 let t shared =
+  let check_button_text = "Check validity (apply afterwards)" in
   let box = Elm_box.addx ~show:false shared.ui.box in
+  let checks_progress = Checks.t shared in
   let add =
     let scroller = Ep.Scroller.addx ~box box in
     let box = Elm_box.addx scroller in
     Elm_box.horizontal_set box false;
     Elm_object.content_set scroller box;
-    fun f -> (f ~box)
+    ()
   in
-  let l = List.map add [ Mirror.t; LocalPredicates.t; RepoPredicates.t ] in
+  let send_inits = settings_message (fun next conf -> `Init (conf, next)) in
+  let send_checks = settings_message (fun next conf -> `Check (conf, next)) in
   let apply =
     let box = Elm_box.addx ~box ~size_hint:[ `hfill; `hexpand ] box in
     Elm_box.horizontal_set box true;
     Elm_box.homogeneous_set box true;
-    let apply = Elm_button.addx box ~box ~text:"Apply" in
+    let apply = Elm_button.addx box ~box ~text:check_button_text in
     ignore (Elm_connect.Button.clicked apply (fun _o ->
       Elm_object.part_text_set apply "Validating...";
       Elm_object.disabled_set apply true;
-      send (`Check (None, l))
+      Checks.send `Show;
+      send_checks Config.read;
     ));
     Elm_object.focus_set apply true;
     apply
   in
-  List.iter (fun c -> c.init (Config.read ())) l;
   let check_failed () =
-    Elm_object.part_text_set apply "Apply";
+    Elm_object.part_text_set apply check_button_text;
     Elm_object.disabled_set apply false
   in
-  { check_failed; box }
+  send_inits Config.read;
+  let mirror = Mirror.t ~box in
+  let local_predicates = LocalPredicates.t ~box in
+  let repo_predicates = RepoPredicates.t ~box in
+  { check_failed; box; checks_progress; mirror; local_predicates; repo_predicates }
 
 let state_machine settings _shared = function
   | `Show ->
@@ -212,22 +381,26 @@ let state_machine settings _shared = function
   | `BeAdopted adoption ->
       adoption settings.box;
       settings
-  | `Check (Some conf, t :: q) ->
-      t.check (conf, q);
-      settings
-  | `Check (None, t :: q) ->
-      t.check (Config.read (), q);
-      settings
-  | `Check (Some conf, []) ->
+  (* | `Check (Some conf, []) ->
       (* XXX: this should be in-memory, not through disk *)
       let current_conf = Config.read () in
       (if conf <> current_conf then
         ignore (Config.update (fun _ -> conf)));
-      settings
-  | `Check (None, []) ->
-      settings
+      settings *)
   | `CheckFailed ->
       settings.check_failed ();
       settings
   | `Cancelled ->
       settings
+  | `Checks msg ->
+      { settings with checks_progress
+        = Checks.state_machine settings.checks_progress msg }
+  | `Mirror msg ->
+      { settings with mirror
+        = Mirror.state_machine settings.mirror msg }
+  | `LocalPredicates msg ->
+      { settings with local_predicates
+        = LocalPredicates.state_machine settings.local_predicates msg }
+  | `RepoPredicates msg ->
+      { settings with repo_predicates
+        = RepoPredicates.state_machine settings.repo_predicates msg }
diff --git a/src/yypkg/web.ml b/src/yypkg/web.ml
index 72d2021..ed6ced3 100644
--- a/src/yypkg/web.ml
+++ b/src/yypkg/web.ml
@@ -28,6 +28,7 @@ module Reporter = struct
   let package_list () =
     generic ~filename:"package_list.el.tar.gz" ~size:0L
 
+  (* TODO: get rid of this *)
   let dummy () =
     Get.reporter_make ~size:0L ~report:(fun _ -> ())
 end
@@ -45,7 +46,7 @@ let ua_system conf =
           let s' = String.concat "-" (List.assoc "host_system" conf.preds) in
           String.lowercase_ascii (Str.global_replace (Str.regexp " ") "_" s')
         with Not_found ->
-          s ^ "_windows_pre_1_9"
+          s ^ "_windows_pre_1_9" (* FIXME *)
       )
     | s -> s
   )
@@ -110,6 +111,7 @@ let repository ~conf ~reporter ~source =
     file
   in
   match source with
+  (* TODO: add `CurrentMirrorWithLocalFallback *)
   | `Local ->
       repo_of_file package_list_el_gz
   | `CurrentMirror ->