From 7e01c8ce2126e4774e4381bb299519a0beab4800 Mon Sep 17 00:00:00 2001 From: Antoine Pouille Date: Thu, 5 Sep 2024 17:44:33 +0200 Subject: [PATCH] Webapp: separate ui and logic, fixes by moving to Hooked from React --- .ocamlformat | 2 +- dune-project | 1 + gui/dune | 40 +-- gui/dune_js_of_ocaml_flags.inc | 12 + gui/hooked.ml | 113 ------ gui/hooked.mli | 27 -- gui/{ => lib}/codemirror.ml | 0 gui/{ => lib}/common.ml | 17 +- gui/{ => lib}/common.mli | 0 gui/lib/dune | 28 ++ gui/lib/hooked.ml | 11 + gui/lib/hooked.mli | 6 + gui/{ => lib}/js_contact.ml | 0 gui/{ => lib}/js_flux.ml | 0 gui/{ => lib}/js_graphlogger.ml | 0 gui/{ => lib}/js_plot.ml | 0 gui/{ => lib}/js_snapshot.ml | 0 gui/{ => lib}/js_story.ml | 0 gui/{ => lib}/ui_common.ml | 0 gui/{ => lib}/ui_common.mli | 0 gui/{ => lib}/utility.ml | 0 gui/{ => lib}/utility.mli | 0 gui/{ => lib}/widget_export.ml | 0 gui/{ => lib}/widget_export.mli | 0 gui/lib_no_js/dune | 17 + gui/lib_no_js/hooked.ml | 335 ++++++++++++++++++ gui/lib_no_js/hooked.mli | 55 +++ gui/{ => state}/common_state.ml | 0 gui/{ => state}/common_state.mli | 0 gui/state/dune | 44 +++ gui/{ => state}/runtime_processes.ml | 0 gui/{ => state}/runtime_processes.mli | 0 gui/{ => state}/runtime_web_workers.ml | 2 +- gui/{ => state}/runtime_web_workers.mli | 0 gui/{ => state}/state_error.ml | 18 +- gui/{ => state}/state_error.mli | 0 gui/{ => state}/state_file.ml | 39 +- gui/{ => state}/state_file.mli | 9 +- gui/{ => state}/state_perturbation.ml | 0 gui/{ => state}/state_perturbation.mli | 0 gui/{ => state}/state_project.ml | 0 gui/{ => state}/state_project.mli | 0 gui/{ => state}/state_runtime.ml | 0 gui/{ => state}/state_runtime.mli | 0 gui/{ => state}/state_settings.ml | 0 gui/{ => state}/state_settings.mli | 0 gui/{ => state}/state_simulation.ml | 0 gui/{ => state}/state_simulation.mli | 0 gui/{ => state}/state_ui.ml | 0 gui/{ => state}/state_ui.mli | 0 gui/ui/dune | 48 +++ gui/{ => ui}/menu_editor_file.ml | 0 gui/{ => ui}/menu_editor_file.mli | 0 gui/{ => ui}/menu_editor_file_controller.ml | 0 gui/{ => ui}/menu_editor_file_controller.mli | 0 gui/{ => ui}/modal_preferences.ml | 0 gui/{ => ui}/modal_preferences.mli | 0 gui/{ => ui}/panel_projects.ml | 0 gui/{ => ui}/panel_projects.mli | 0 gui/{ => ui}/panel_projects_controller.ml | 0 gui/{ => ui}/panel_projects_controller.mli | 0 gui/{ => ui}/panel_settings.ml | 24 +- gui/{ => ui}/panel_settings.mli | 0 gui/{ => ui}/panel_settings_controller.ml | 0 gui/{ => ui}/panel_settings_controller.mli | 0 gui/{ => ui}/panel_tab.ml | 0 gui/{ => ui}/panel_tab.mli | 0 gui/{ => ui}/subpanel_editor.ml | 6 +- gui/{ => ui}/subpanel_editor.mli | 2 +- gui/{ => ui}/subpanel_editor_controller.ml | 0 gui/{ => ui}/subpanel_editor_controller.mli | 0 gui/{ => ui}/tab_about.ml | 0 gui/{ => ui}/tab_about.mli | 0 gui/{ => ui}/tab_constraints.ml | 0 gui/{ => ui}/tab_constraints.mli | 0 gui/{ => ui}/tab_contact_map.ml | 0 gui/{ => ui}/tab_contact_map.mli | 0 gui/{ => ui}/tab_editor.ml | 0 gui/{ => ui}/tab_editor.mli | 0 gui/{ => ui}/tab_flux.ml | 2 +- gui/{ => ui}/tab_flux.mli | 0 gui/{ => ui}/tab_influences.ml | 234 ++++++++---- gui/{ => ui}/tab_influences.mli | 0 gui/{ => ui}/tab_log.ml | 2 +- gui/{ => ui}/tab_log.mli | 0 gui/{ => ui}/tab_outputs.ml | 4 +- gui/{ => ui}/tab_outputs.mli | 0 gui/{ => ui}/tab_plot.ml | 4 +- gui/{ => ui}/tab_plot.mli | 0 gui/{ => ui}/tab_polymers.ml | 0 gui/{ => ui}/tab_polymers.mli | 0 gui/{ => ui}/tab_snapshot.ml | 4 +- gui/{ => ui}/tab_snapshot.mli | 0 gui/{ => ui}/tab_stories.ml | 0 gui/{ => ui}/tab_stories.mli | 0 .../ui_react_sim_status.ml} | 0 .../ui_react_sim_status.mli} | 0 kappa-webapp.opam | 1 + 98 files changed, 814 insertions(+), 293 deletions(-) create mode 100644 gui/dune_js_of_ocaml_flags.inc delete mode 100644 gui/hooked.ml delete mode 100644 gui/hooked.mli rename gui/{ => lib}/codemirror.ml (100%) rename gui/{ => lib}/common.ml (90%) rename gui/{ => lib}/common.mli (100%) create mode 100644 gui/lib/dune create mode 100644 gui/lib/hooked.ml create mode 100644 gui/lib/hooked.mli rename gui/{ => lib}/js_contact.ml (100%) rename gui/{ => lib}/js_flux.ml (100%) rename gui/{ => lib}/js_graphlogger.ml (100%) rename gui/{ => lib}/js_plot.ml (100%) rename gui/{ => lib}/js_snapshot.ml (100%) rename gui/{ => lib}/js_story.ml (100%) rename gui/{ => lib}/ui_common.ml (100%) rename gui/{ => lib}/ui_common.mli (100%) rename gui/{ => lib}/utility.ml (100%) rename gui/{ => lib}/utility.mli (100%) rename gui/{ => lib}/widget_export.ml (100%) rename gui/{ => lib}/widget_export.mli (100%) create mode 100644 gui/lib_no_js/dune create mode 100644 gui/lib_no_js/hooked.ml create mode 100644 gui/lib_no_js/hooked.mli rename gui/{ => state}/common_state.ml (100%) rename gui/{ => state}/common_state.mli (100%) create mode 100644 gui/state/dune rename gui/{ => state}/runtime_processes.ml (100%) rename gui/{ => state}/runtime_processes.mli (100%) rename gui/{ => state}/runtime_web_workers.ml (99%) rename gui/{ => state}/runtime_web_workers.mli (100%) rename gui/{ => state}/state_error.ml (80%) rename gui/{ => state}/state_error.mli (100%) rename gui/{ => state}/state_file.ml (95%) rename gui/{ => state}/state_file.mli (92%) rename gui/{ => state}/state_perturbation.ml (100%) rename gui/{ => state}/state_perturbation.mli (100%) rename gui/{ => state}/state_project.ml (100%) rename gui/{ => state}/state_project.mli (100%) rename gui/{ => state}/state_runtime.ml (100%) rename gui/{ => state}/state_runtime.mli (100%) rename gui/{ => state}/state_settings.ml (100%) rename gui/{ => state}/state_settings.mli (100%) rename gui/{ => state}/state_simulation.ml (100%) rename gui/{ => state}/state_simulation.mli (100%) rename gui/{ => state}/state_ui.ml (100%) rename gui/{ => state}/state_ui.mli (100%) create mode 100644 gui/ui/dune rename gui/{ => ui}/menu_editor_file.ml (100%) rename gui/{ => ui}/menu_editor_file.mli (100%) rename gui/{ => ui}/menu_editor_file_controller.ml (100%) rename gui/{ => ui}/menu_editor_file_controller.mli (100%) rename gui/{ => ui}/modal_preferences.ml (100%) rename gui/{ => ui}/modal_preferences.mli (100%) rename gui/{ => ui}/panel_projects.ml (100%) rename gui/{ => ui}/panel_projects.mli (100%) rename gui/{ => ui}/panel_projects_controller.ml (100%) rename gui/{ => ui}/panel_projects_controller.mli (100%) rename gui/{ => ui}/panel_settings.ml (97%) rename gui/{ => ui}/panel_settings.mli (100%) rename gui/{ => ui}/panel_settings_controller.ml (100%) rename gui/{ => ui}/panel_settings_controller.mli (100%) rename gui/{ => ui}/panel_tab.ml (100%) rename gui/{ => ui}/panel_tab.mli (100%) rename gui/{ => ui}/subpanel_editor.ml (98%) rename gui/{ => ui}/subpanel_editor.mli (93%) rename gui/{ => ui}/subpanel_editor_controller.ml (100%) rename gui/{ => ui}/subpanel_editor_controller.mli (100%) rename gui/{ => ui}/tab_about.ml (100%) rename gui/{ => ui}/tab_about.mli (100%) rename gui/{ => ui}/tab_constraints.ml (100%) rename gui/{ => ui}/tab_constraints.mli (100%) rename gui/{ => ui}/tab_contact_map.ml (100%) rename gui/{ => ui}/tab_contact_map.mli (100%) rename gui/{ => ui}/tab_editor.ml (100%) rename gui/{ => ui}/tab_editor.mli (100%) rename gui/{ => ui}/tab_flux.ml (99%) rename gui/{ => ui}/tab_flux.mli (100%) rename gui/{ => ui}/tab_influences.ml (77%) rename gui/{ => ui}/tab_influences.mli (100%) rename gui/{ => ui}/tab_log.ml (96%) rename gui/{ => ui}/tab_log.mli (100%) rename gui/{ => ui}/tab_outputs.ml (97%) rename gui/{ => ui}/tab_outputs.mli (100%) rename gui/{ => ui}/tab_plot.ml (98%) rename gui/{ => ui}/tab_plot.mli (100%) rename gui/{ => ui}/tab_polymers.ml (100%) rename gui/{ => ui}/tab_polymers.mli (100%) rename gui/{ => ui}/tab_snapshot.ml (99%) rename gui/{ => ui}/tab_snapshot.mli (100%) rename gui/{ => ui}/tab_stories.ml (100%) rename gui/{ => ui}/tab_stories.mli (100%) rename gui/{ui_common_with_sim.ml => ui/ui_react_sim_status.ml} (100%) rename gui/{ui_common_with_sim.mli => ui/ui_react_sim_status.mli} (100%) diff --git a/.ocamlformat b/.ocamlformat index d6edf85ecc..3eebd08b9a 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.26.1 +version = 0.26.2 profile=conventional margin=80 if-then-else=k-r diff --git a/dune-project b/dune-project index 5677cdfb33..a03f31a4dc 100644 --- a/dune-project +++ b/dune-project @@ -93,6 +93,7 @@ (js_of_ocaml-lwt ( = 5.7.0 )) (js_of_ocaml-ppx ( = 5.7.0 )) (js_of_ocaml-tyxml ( = 5.7.0 )) + (ppx_inline_test ( = v0.16.1 )) kappa-binaries kappa-agents ) diff --git a/gui/dune b/gui/dune index c88b56215f..da2603b926 100644 --- a/gui/dune +++ b/gui/dune @@ -1,11 +1,3 @@ -(library - (name kappa_js_lib) - (modules Common Hooked) - (libraries js_of_ocaml-lwt lwt_react) - (preprocess - (pps js_of_ocaml-ppx tyxml-ppx)) - (flags :standard -w +a -open Js_of_ocaml)) - (rule (with-stdout-to js_of_ocaml_flags @@ -18,7 +10,7 @@ (flags (:include js_of_ocaml_flags))) (modules KaSimWorker) - (libraries kappa_js_lib kappa_json_api) + (libraries kappa_webapp_lib kappa_json_api) (preprocess (pps js_of_ocaml-ppx tyxml-ppx)) (flags @@ -28,7 +20,7 @@ -open Js_of_ocaml -open - Kappa_js_lib + Kappa_webapp_lib -open Kappa_json_api)) @@ -39,7 +31,7 @@ (flags (:include js_of_ocaml_flags))) (modules KaSaWorker) - (libraries kappa_js_lib kappa_kasa_export) + (libraries kappa_webapp_lib kappa_kasa_export) (preprocess (pps js_of_ocaml-ppx tyxml-ppx)) (flags @@ -49,7 +41,7 @@ -open Js_of_ocaml -open - Kappa_js_lib + Kappa_webapp_lib -open Kappa_kasa_export)) @@ -60,7 +52,7 @@ (flags (:include js_of_ocaml_flags))) (modules KaStorWorker) - (libraries kappa_js_lib kappa_cflow) + (libraries kappa_webapp_lib kappa_cflow) (preprocess (pps js_of_ocaml-ppx tyxml-ppx)) (flags @@ -70,7 +62,7 @@ -open Js_of_ocaml -open - Kappa_js_lib + Kappa_webapp_lib -open Kappa_cflow)) @@ -81,7 +73,7 @@ (flags (:include js_of_ocaml_flags))) (modules KaMoHaWorker) - (libraries kappa_js_lib kappa_grammar) + (libraries kappa_webapp_lib kappa_grammar) (preprocess (pps js_of_ocaml-ppx tyxml-ppx)) (flags :standard -w +a)) @@ -95,8 +87,6 @@ (modules :standard \ - Common - Hooked KaSimWorker KaSaWorker KaStorWorker @@ -104,9 +94,10 @@ (libraries js_of_ocaml-tyxml lwt_react - kappa_js_lib + kappa_webapp_lib kappa_json_api - kappa_parameters) + kappa_parameters + kappa_webapp_ui) (preprocess (pps js_of_ocaml-ppx tyxml-ppx)) (flags @@ -118,7 +109,7 @@ -open Js_of_ocaml_tyxml -open - Kappa_js_lib + Kappa_webapp_lib -open Kappa_json_api -open @@ -140,4 +131,11 @@ -open Kappa_logging -open - Kappa_cflow)) + Kappa_cflow + -open + Kappa_webapp_ui + -open + Kappa_webapp_ui + -open + Kappa_webapp_state + )) diff --git a/gui/dune_js_of_ocaml_flags.inc b/gui/dune_js_of_ocaml_flags.inc new file mode 100644 index 0000000000..6681064263 --- /dev/null +++ b/gui/dune_js_of_ocaml_flags.inc @@ -0,0 +1,12 @@ +; Windows build only has access to 4.0.0, where --disable flags don't exist yet in jsoo +; TODO: better distinguish this, as this should depend on jsoo version and not OS + +(rule + (with-stdout-to + js_of_ocaml_flags.Unix + (echo "(:standard --disable globaldeadcode --disable deadcode)"))) + +(rule + (with-stdout-to + js_of_ocaml_flags.Win32 + (echo ":standard"))) diff --git a/gui/hooked.ml b/gui/hooked.ml deleted file mode 100644 index e6cdcd620b..0000000000 --- a/gui/hooked.ml +++ /dev/null @@ -1,113 +0,0 @@ -let debug_printing = false - -module S = struct - type 'a t = { - mutable value: 'a; - mutable hooks: ('a -> unit) list; - eq: 'a -> 'a -> bool; - signal: 'a React.signal; - set_signal: ?step:React.step -> 'a -> unit; - debug: string; - } - - let _debug_string (hooked : 'a t) : string = hooked.debug - - let _log hooked s = - if debug_printing then ( - let () = - Common.debug ~loc:__LOC__ - (Printf.sprintf "[Hooked.S %s] %s" (_debug_string hooked) s) - in - () - ) - - let create ?(debug : string = "unnamed signal") - ?(eq : 'a -> 'a -> bool = ( = )) (a : 'a) : 'a t = - let signal, set_signal = React.S.create a in - let s = { value = a; hooks = []; eq; signal; set_signal; debug } in - _log s "create"; - s - - let register hooked f = - _log hooked "register"; - hooked.hooks <- f :: hooked.hooks - - let v hooked = - _log hooked "value"; - hooked.value - - let set ?(debug = "") hooked value = - if not (hooked.eq value hooked.value) then ( - _log hooked - (Printf.sprintf "SET WITH CHANGES%s, running %d hooks" - (if debug <> "" then - ": " ^ debug - else - "") - (List.length hooked.hooks)); - hooked.value <- value; - List.iter (fun f -> f value) hooked.hooks; - hooked.set_signal value - ) else - _log hooked "set NO change" - - let bind ?(debug : string = "unnamed signal") ?(eq : 'a -> 'a -> bool = ( = )) - hooked f = - let new_hooked = create ~debug ~eq (f (v hooked)) in - _log hooked (Printf.sprintf "bind %s from" (_debug_string new_hooked)); - register hooked (fun value -> - _log hooked - (Printf.sprintf "set from bind %s from" (_debug_string new_hooked)); - set - ~debug:(Printf.sprintf "bind from %s" (_debug_string hooked)) - new_hooked (f value)); - new_hooked - - let to_react_signal hooked = hooked.signal -end - -module E = struct - type 'a t = { - mutable hooks: ('a -> unit) list; - event: 'a React.event; - send_event: ?step:React.step -> 'a -> unit; - debug: string; - } - - let _debug_string (hooked : 'a t) : string = hooked.debug - - let _log hooked s = - if debug_printing then ( - let () = - Common.debug ~loc:__LOC__ - (Printf.sprintf "[Hooked.E %s] %s" (_debug_string hooked) s) - in - () - ) - - let create ?(debug : string = "unnamed event") () : 'a t = - let event, send_event = React.E.create () in - let e = { hooks = []; event; send_event; debug } in - _log e "create"; - e - - let register hooked f = - _log hooked "register"; - hooked.hooks <- f :: hooked.hooks - - let send hooked value = - _log hooked "send"; - List.iter (fun f -> f value) hooked.hooks; - hooked.send_event value - - let map ?(debug : string = "unnamed event") hooked f = - let new_hooked = create ~debug () in - register hooked (fun value -> - _log hooked - (Printf.sprintf "map send %s from" (_debug_string new_hooked)); - send new_hooked (f value)); - _log hooked (Printf.sprintf "map %s from" (_debug_string new_hooked)); - new_hooked - - let to_react_event hooked = hooked.event -end diff --git a/gui/hooked.mli b/gui/hooked.mli deleted file mode 100644 index 624cfe53b8..0000000000 --- a/gui/hooked.mli +++ /dev/null @@ -1,27 +0,0 @@ -(** Hooks with React-like syntax to avoid 'GC' issues *) - -module S : sig - type 'a t - - val create : ?debug:string -> ?eq:('a -> 'a -> bool) -> 'a -> 'a t - val register : 'a t -> ('a -> unit) -> unit - val v : 'a t -> 'a - val set : ?debug:string -> 'a t -> 'a -> unit - - val bind : - ?debug:string -> ?eq:('a -> 'a -> bool) -> 'b t -> ('b -> 'a) -> 'a t - - val to_react_signal : 'a t -> 'a React.signal -end - -module E : sig - type 'a t - - val create : ?debug:string -> unit -> 'a t - val register : 'a t -> ('a -> unit) -> unit - val send : 'a t -> 'a -> unit - val map : ?debug:string -> 'a t -> ('a -> 'b) -> 'b t - val to_react_event : 'a t -> 'a React.event -end - -(* TODO : Add lwt to it? *) diff --git a/gui/codemirror.ml b/gui/lib/codemirror.ml similarity index 100% rename from gui/codemirror.ml rename to gui/lib/codemirror.ml diff --git a/gui/common.ml b/gui/lib/common.ml similarity index 90% rename from gui/common.ml rename to gui/lib/common.ml index 00a51fdc82..96e229556e 100644 --- a/gui/common.ml +++ b/gui/lib/common.ml @@ -139,9 +139,22 @@ let async loc (task : unit -> 'a Lwt.t) : unit = Js_of_ocaml_lwt.Lwt_js_events.async (fun () -> Lwt.catch task (fun exn -> let () = - info ~loc:__LOC__ (Js.string (loc ^ Printexc.to_string exn)) + warn ~loc:__LOC__ + (Js.string + ("Async error at " ^ loc ^ ":\n" ^ Printexc.to_string exn)) in - let () = debug ~loc:__LOC__ (Js.string (Printexc.get_backtrace ())) in + let log_trace = + if Printexc.backtrace_status () then ( + let trace = Printexc.get_backtrace () in + if String.length trace > 0 then + "Backtrace: " ^ trace + else + "Couldn't get backtrace while backtrace record is enabled, \ + might be because of jsoo or react :/" + ) else + "Enable backtrace recording to (hopefully?) get backtrace" + in + let () = warn ~loc:__LOC__ (Js.string log_trace) in Lwt.return_unit)) let guid () : string = diff --git a/gui/common.mli b/gui/lib/common.mli similarity index 100% rename from gui/common.mli rename to gui/lib/common.mli diff --git a/gui/lib/dune b/gui/lib/dune new file mode 100644 index 0000000000..7b17cbfd73 --- /dev/null +++ b/gui/lib/dune @@ -0,0 +1,28 @@ +(library + (name kappa_webapp_lib) + (preprocess + (pps + js_of_ocaml-ppx + tyxml-ppx + ppx_inline_test + )) + (libraries + js_of_ocaml-lwt + lwt_react + js_of_ocaml-tyxml + ppx_inline_test + kappa_webapp_lib_no_js + kappa_parameters + kappa_kasa_type_interface) + (flags :standard -w +a + -open + Js_of_ocaml + -open + Js_of_ocaml_tyxml + -open + Kappa_kasa_type_interface + -open + Kappa_parameters + )) + + diff --git a/gui/lib/hooked.ml b/gui/lib/hooked.ml new file mode 100644 index 0000000000..12b4d37ba1 --- /dev/null +++ b/gui/lib/hooked.ml @@ -0,0 +1,11 @@ +module DebugPrint : Kappa_webapp_lib_no_js.Hooked.DebugPrint = struct + let debug_print s = + let () = Common.debug ~loc:__LOC__ s in + () +end + +module S = Kappa_webapp_lib_no_js.Hooked.MakeS (DebugPrint) +module E = Kappa_webapp_lib_no_js.Hooked.MakeE (DebugPrint) + +type 'a signal = 'a S.t +type 'a event = 'a E.t diff --git a/gui/lib/hooked.mli b/gui/lib/hooked.mli new file mode 100644 index 0000000000..3f723c571b --- /dev/null +++ b/gui/lib/hooked.mli @@ -0,0 +1,6 @@ +module DebugPrint : Kappa_webapp_lib_no_js.Hooked.DebugPrint +module S : Kappa_webapp_lib_no_js.Hooked.S +module E : Kappa_webapp_lib_no_js.Hooked.E + +type 'a signal = 'a S.t +type 'a event = 'a E.t diff --git a/gui/js_contact.ml b/gui/lib/js_contact.ml similarity index 100% rename from gui/js_contact.ml rename to gui/lib/js_contact.ml diff --git a/gui/js_flux.ml b/gui/lib/js_flux.ml similarity index 100% rename from gui/js_flux.ml rename to gui/lib/js_flux.ml diff --git a/gui/js_graphlogger.ml b/gui/lib/js_graphlogger.ml similarity index 100% rename from gui/js_graphlogger.ml rename to gui/lib/js_graphlogger.ml diff --git a/gui/js_plot.ml b/gui/lib/js_plot.ml similarity index 100% rename from gui/js_plot.ml rename to gui/lib/js_plot.ml diff --git a/gui/js_snapshot.ml b/gui/lib/js_snapshot.ml similarity index 100% rename from gui/js_snapshot.ml rename to gui/lib/js_snapshot.ml diff --git a/gui/js_story.ml b/gui/lib/js_story.ml similarity index 100% rename from gui/js_story.ml rename to gui/lib/js_story.ml diff --git a/gui/ui_common.ml b/gui/lib/ui_common.ml similarity index 100% rename from gui/ui_common.ml rename to gui/lib/ui_common.ml diff --git a/gui/ui_common.mli b/gui/lib/ui_common.mli similarity index 100% rename from gui/ui_common.mli rename to gui/lib/ui_common.mli diff --git a/gui/utility.ml b/gui/lib/utility.ml similarity index 100% rename from gui/utility.ml rename to gui/lib/utility.ml diff --git a/gui/utility.mli b/gui/lib/utility.mli similarity index 100% rename from gui/utility.mli rename to gui/lib/utility.mli diff --git a/gui/widget_export.ml b/gui/lib/widget_export.ml similarity index 100% rename from gui/widget_export.ml rename to gui/lib/widget_export.ml diff --git a/gui/widget_export.mli b/gui/lib/widget_export.mli similarity index 100% rename from gui/widget_export.mli rename to gui/lib/widget_export.mli diff --git a/gui/lib_no_js/dune b/gui/lib_no_js/dune new file mode 100644 index 0000000000..6db38fee5c --- /dev/null +++ b/gui/lib_no_js/dune @@ -0,0 +1,17 @@ +(library + (name kappa_webapp_lib_no_js) + (inline_tests) + (preprocess + (pps + ppx_inline_test + )) + (libraries + unix + lwt_react + ppx_inline_test) + (flags :standard -w +a-69 + -open + Ppx_inline_test + )) + + diff --git a/gui/lib_no_js/hooked.ml b/gui/lib_no_js/hooked.ml new file mode 100644 index 0000000000..88ad404986 --- /dev/null +++ b/gui/lib_no_js/hooked.ml @@ -0,0 +1,335 @@ +(* TODO: move this as a parameter *) +let debug_printing = true + +module type DebugPrint = sig + val debug_print : string -> unit +end + +module type S = sig + type 'a t + + val create : + ?debug:string -> + ?eq:('a -> 'a -> bool) -> + 'a -> + 'a t * (?debug:string -> 'a -> unit) + + val register : 'a t -> ('a -> unit) -> unit + val value : 'a t -> 'a + val set : ?debug:string -> 'a t -> 'a -> unit + + val map : + ?debug:string -> ?eq:('a -> 'a -> bool) -> ('b -> 'a) -> 'b t -> 'a t + + val fmap : + ?debug:string -> + ?eq:('a -> 'a -> bool) -> + ('b -> 'a option) -> + 'a -> + 'b t -> + 'a t + + val on : ?eq:('a -> 'a -> bool) -> bool t -> 'a -> 'a t -> 'a t + val l2 : ?eq:('a -> 'a -> bool) -> ('b -> 'c -> 'a) -> 'b t -> 'c t -> 'a t + + val of_react_signal : + ?debug:string -> ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a t + + val to_react_signal : 'a t -> 'a React.signal + + (* attempt to avoid GC in case TODO: check *) + (* val number_linked_signals : unit -> int *) + + val const : 'a -> 'a t +end + +module type E = sig + type 'a t + + val create : ?debug:string -> unit -> 'a t * ('a -> unit) + val register : 'a t -> ('a -> unit) -> unit + val send : 'a t -> 'a -> unit + val map : ?debug:string -> 'a t -> ('a -> 'b) -> 'b t + val to_react_event : 'a t -> 'a React.event +end + +module MakeS (D : DebugPrint) : S = struct + type 'a t = { + mutable value: 'a; + mutable hooks: ('a -> unit) list; + eq: 'a -> 'a -> bool; + signal: 'a React.signal; + set_signal: ?step:React.step -> 'a -> unit; + debug: string; + (* store signal result of `map` with original React.signal, + flagged as a never read record *) + mutable link_to_original_signal: 'a React.signal option; + } + + let _debug_string (hooked : 'a t) : string = hooked.debug + + let _log hooked s = + if debug_printing then + D.debug_print (Printf.sprintf "[Hooked.S %s] %s" (_debug_string hooked) s) + + let create_no_set ?(debug : string = "unnamed signal") + ?(eq : 'a -> 'a -> bool = ( = )) (a : 'a) : 'a t = + let signal, set_signal = React.S.create ~eq a in + let hooked = + { + value = a; + hooks = []; + eq; + signal; + set_signal; + debug; + link_to_original_signal = None; + } + in + _log hooked "create"; + hooked + + let register hooked f = + _log hooked "register"; + hooked.hooks <- f :: hooked.hooks + + let value hooked = + _log hooked "value"; + hooked.value + + let set ?(debug = "") hooked value = + let value_changed = hooked.eq value hooked.value in + if not value_changed then ( + _log hooked + (Printf.sprintf "SET WITH CHANGES%s, running %d hooks" + (if debug <> "" then + ": " ^ debug + else + "") + (List.length hooked.hooks)); + hooked.value <- value; + List.iter (fun f -> f value) hooked.hooks; + hooked.set_signal value + ) else + _log hooked "set NO change" + + let create ?(debug : string = "unnamed signal") + ?(eq : 'a -> 'a -> bool = ( = )) (a : 'a) : + 'a t * (?debug:string -> 'a -> unit) = + let hooked : 'a t = create_no_set ~debug ~eq a in + let set_hooked : ?debug:string -> 'a -> unit = + fun ?(debug : string = "") -> set ~debug hooked + in + hooked, set_hooked + + let map ?(debug : string = "unnamed signal") ?(eq : 'a -> 'a -> bool = ( = )) + f hooked = + let new_hooked = create_no_set ~debug ~eq (f (value hooked)) in + _log hooked (Printf.sprintf "bind %s from" (_debug_string new_hooked)); + register hooked (fun value -> + _log hooked + (Printf.sprintf "set from bind %s from" (_debug_string new_hooked)); + set + ~debug:(Printf.sprintf "bind from %s" (_debug_string hooked)) + new_hooked (f value)); + new_hooked + + let fmap ?(debug : string = "unnamed signal") ?(eq : 'a -> 'a -> bool = ( = )) + f default hooked = + map ~debug ~eq + (fun x -> + match f x with + | Some v -> v + | None -> default) + hooked + + let on ?(eq : 'a -> 'a -> bool = ( = )) cond_hooked default hooked = + _log hooked + ("creating `on` with condition bool hooked `" ^ cond_hooked.debug ^ "`"); + let initial_value = + if value cond_hooked then + value hooked + else + default + in + let new_hooked = + create_no_set + ~debug: + ("`on` from `" ^ hooked.debug ^ "` with cond `" ^ cond_hooked.debug + ^ "`") + ~eq initial_value + in + register cond_hooked (fun (b : bool) -> + if b then + set ~debug:"`on` enable" new_hooked (value hooked) + else + set ~debug:"`on` disable" new_hooked default); + register hooked (fun new_value -> + if value cond_hooked then set ~debug:"`on` update" new_hooked new_value); + new_hooked + + let l2 ?(eq : 'a -> 'a -> bool = ( = )) (f : 'b -> 'c -> 'a) (hooked1 : 'b t) + (hooked2 : 'c t) : 'a t = + let new_hooked = + create_no_set + ~debug:("`combine from " ^ hooked1.debug ^ " and " ^ hooked2.debug) + ~eq + (f (value hooked1) (value hooked2)) + in + register hooked1 (fun new_value1 -> + set ~debug:"`combine` update" new_hooked (f new_value1 (value hooked2))); + register hooked2 (fun new_value2 -> + set ~debug:"`combine` update" new_hooked (f (value hooked1) new_value2)); + new_hooked + + (* + let react_signal_links = ref [] + + let number_linked_signals () = List.length !react_signal_links +*) + + let of_react_signal + ?(debug : string = "unnamed signal created with of_react_signal") + ?(eq : 'a -> 'a -> bool = ( = )) (signal : 'a React.signal) : 'a t = + let hooked = create_no_set ~debug ~eq (React.S.value signal) in + + (* Add map to update value in hooked and store it inside struct *) + let link_to_original_signal = + Some + (React.S.map ~eq + (* could be using `trace` here, but let's be safe with the GC? no clue *) + (fun new_value -> + set ~debug:"from of_react_signal signal" hooked new_value; + new_value) + signal) + in + + (* react_signal_links := link_to_original_signal :: !react_signal_links; *) + hooked.link_to_original_signal <- link_to_original_signal; + set ~debug:"update after link to react signal" hooked (React.S.value signal); + hooked + + let to_react_signal hooked = hooked.signal + + let const v = + let hooked = create_no_set v in + register hooked (fun _ -> + raise (Failure "const hooked.S has received an attempt to be modified")); + hooked +end + +module MakeE (D : DebugPrint) : E = struct + type 'a t = { + mutable hooks: ('a -> unit) list; + event: 'a React.event; + send_event: ?step:React.step -> 'a -> unit; + debug: string; + } + + let _debug_string (hooked : 'a t) : string = hooked.debug + + let _log hooked s = + if debug_printing then + D.debug_print (Printf.sprintf "[Hooked.E %s] %s" (_debug_string hooked) s) + + let create_no_send ?(debug : string = "unnamed event") () : 'a t = + let event, send_event = React.E.create () in + let hooked = { hooks = []; event; send_event; debug } in + _log hooked "create"; + hooked + + let register hooked f = + _log hooked "register"; + hooked.hooks <- f :: hooked.hooks + + let send hooked value = + _log hooked "send"; + List.iter (fun f -> f value) hooked.hooks; + hooked.send_event value + + let create ?(debug : string = "unnamed signal") () : 'a t * ('a -> unit) = + let hooked : 'a t = create_no_send ~debug () in + let send_hooked : 'a -> unit = send hooked in + hooked, send_hooked + + let map ?(debug : string = "unnamed event") hooked f = + let new_hooked = create_no_send ~debug () in + register hooked (fun value -> + _log hooked + (Printf.sprintf "map send %s from" (_debug_string new_hooked)); + send new_hooked (f value)); + _log hooked (Printf.sprintf "map %s from" (_debug_string new_hooked)); + new_hooked + + let to_react_event hooked = hooked.event +end + +(* Testing *) +module DebugPrint : DebugPrint = struct + let debug_print _ = () +end + +module S = MakeS (DebugPrint) +module E = MakeE (DebugPrint) + +let%test "signals basic" = + let a, set_a = S.create 0 in + set_a 10; + let b = S.map (fun v -> v + 1) a in + S.value b = 11 + +let%test "events basic" = + let r = ref 0 in + let event, send_event = E.create () in + E.register event (fun i -> r := i); + send_event 10; + !r = 10 + +let%test "to_react_signal" = + let a, set_a = S.create 0 in + let signal = S.to_react_signal a in + set_a 10; + Unix.sleepf 0.1; + React.S.value signal = 10 + +let%test "of_react_signal" = + let s, set_s = React.S.create 0 in + let h = S.of_react_signal s in + set_s 10; + while React.S.value s = 0 do + Unix.sleepf 0.1 + done; + Unix.sleepf 0.1; + S.value h = 10 + +let%test_module "on" = + (module struct + let a, set_a = S.create 0 + let cond, set_cond = S.create true + let out = S.on cond (-1) a + let%test _ = S.value out = 0 + + let%test _ = + set_a 10; + S.value out = 10 + + let%test _ = + set_cond false; + S.value out = -1 + + let%test _ = + set_a 42; + S.value out = -1 + + let%test _ = + set_cond true; + S.value out = 42 + + let%test _ = + set_a 1; + S.value out = 1 + + let%test _ = + set_cond false; + S.value out = -1 + end) diff --git a/gui/lib_no_js/hooked.mli b/gui/lib_no_js/hooked.mli new file mode 100644 index 0000000000..57ce68201d --- /dev/null +++ b/gui/lib_no_js/hooked.mli @@ -0,0 +1,55 @@ +(** Hooks with React-like syntax to avoid 'GC' issues *) + +module type DebugPrint = sig + val debug_print : string -> unit +end + +module type S = sig + type 'a t + + val create : + ?debug:string -> + ?eq:('a -> 'a -> bool) -> + 'a -> + 'a t * (?debug:string -> 'a -> unit) + + val register : 'a t -> ('a -> unit) -> unit + val value : 'a t -> 'a + val set : ?debug:string -> 'a t -> 'a -> unit + + val map : + ?debug:string -> ?eq:('a -> 'a -> bool) -> ('b -> 'a) -> 'b t -> 'a t + + val fmap : + ?debug:string -> + ?eq:('a -> 'a -> bool) -> + ('b -> 'a option) -> + 'a -> + 'b t -> + 'a t + + val on : ?eq:('a -> 'a -> bool) -> bool t -> 'a -> 'a t -> 'a t + val l2 : ?eq:('a -> 'a -> bool) -> ('b -> 'c -> 'a) -> 'b t -> 'c t -> 'a t + + (* `eq` need to be provided as it can't be extracted from React.signal *) + val of_react_signal : + ?debug:string -> ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a t + + val to_react_signal : 'a t -> 'a React.signal + val const : 'a -> 'a t +end + +module type E = sig + type 'a t + + val create : ?debug:string -> unit -> 'a t * ('a -> unit) + val register : 'a t -> ('a -> unit) -> unit + val send : 'a t -> 'a -> unit + val map : ?debug:string -> 'a t -> ('a -> 'b) -> 'b t + val to_react_event : 'a t -> 'a React.event +end + +module MakeS : functor (_ : DebugPrint) -> S +module MakeE : functor (_ : DebugPrint) -> E + +(* TODO : Add lwt to it? *) diff --git a/gui/common_state.ml b/gui/state/common_state.ml similarity index 100% rename from gui/common_state.ml rename to gui/state/common_state.ml diff --git a/gui/common_state.mli b/gui/state/common_state.mli similarity index 100% rename from gui/common_state.mli rename to gui/state/common_state.mli diff --git a/gui/state/dune b/gui/state/dune new file mode 100644 index 0000000000..3560d86ae8 --- /dev/null +++ b/gui/state/dune @@ -0,0 +1,44 @@ +(include ../dune_js_of_ocaml_flags.inc) + +(library + (name kappa_webapp_state) + (libraries + js_of_ocaml-tyxml + lwt_react + kappa_webapp_lib + kappa_json_api + kappa_parameters) + (preprocess + (pps js_of_ocaml-ppx tyxml-ppx)) + (flags + (:standard + -w + @a-7-70 + -open + Js_of_ocaml + -open + Js_of_ocaml_tyxml + -open + Kappa_webapp_lib + -open + Kappa_json_api + -open + Kappa_data_structures + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_runtime + -open + Kappa_errors + -open + Kappa_kasa_type_interface + -open + Kappa_parameters + -open + Kappa_classical_graphs + -open + Kappa_logging + -open + Kappa_cflow))) diff --git a/gui/runtime_processes.ml b/gui/state/runtime_processes.ml similarity index 100% rename from gui/runtime_processes.ml rename to gui/state/runtime_processes.ml diff --git a/gui/runtime_processes.mli b/gui/state/runtime_processes.mli similarity index 100% rename from gui/runtime_processes.mli rename to gui/state/runtime_processes.mli diff --git a/gui/runtime_web_workers.ml b/gui/state/runtime_web_workers.ml similarity index 99% rename from gui/runtime_web_workers.ml rename to gui/state/runtime_web_workers.ml index 726872d47d..bbe455ac4f 100644 --- a/gui/runtime_web_workers.ml +++ b/gui/state/runtime_web_workers.ml @@ -34,7 +34,7 @@ let worker_onmessage ~(debug_printing : bool) ~(worker_name : string) fun response_message -> try process_message response_message with _ as e -> - Ui_common.open_modal_error ~is_critical:true + Kappa_webapp_lib.Ui_common.open_modal_error ~is_critical:true ~error_content: ("Worker " ^ worker_name ^ " raised the following exception: \r" ^ Printexc.to_string e); diff --git a/gui/runtime_web_workers.mli b/gui/state/runtime_web_workers.mli similarity index 100% rename from gui/runtime_web_workers.mli rename to gui/state/runtime_web_workers.mli diff --git a/gui/state_error.ml b/gui/state/state_error.ml similarity index 80% rename from gui/state_error.ml rename to gui/state/state_error.ml index d06df3456e..ef8f6c9fe3 100644 --- a/gui/state_error.ml +++ b/gui/state/state_error.ml @@ -13,17 +13,17 @@ type t = { _state_error_location: string; } -let state_error = Hooked.S.create ~debug:"state_error" [] +let state_error, state_error_set = Hooked.S.create ~debug:"state_error" [] let clear_errors location = let () = Common.debug ~loc:__LOC__ (Js.string (Format.sprintf "Clear_errors %s " location)) in - Hooked.S.set ~debug:"[State_error.clear_errors]" state_error [] + state_error_set ~debug:"[State_error.clear_errors]" [] let has_errors () = - match Hooked.S.v state_error with + match Hooked.S.value state_error with | [] -> false | _ :: _ -> true @@ -38,21 +38,23 @@ let add_error (location : string) (errors : Result_util.message list) = (Pp.list Pp.space Result_util.print_message) errors)) in - let current_state_error : t list = Hooked.S.v state_error in + let current_state_error : t list = Hooked.S.value state_error in let new_state_error : t list = { state_error_errors = errors; _state_error_location = location } :: current_state_error in - Hooked.S.set ~debug:"add_error" state_error new_state_error + state_error_set ~debug:"add_error" new_state_error let errors = - Hooked.S.bind ~debug:"errors" state_error (fun state_error -> + Hooked.S.map ~debug:"errors" + (fun state_error -> List.fold_left (fun acc value -> value.state_error_errors @ acc) [] state_error) + state_error -let wrap : - 'a. ?append:bool -> string -> 'a Api.lwt_result -> 'a Api.lwt_result = +let wrap : 'a. ?append:bool -> string -> 'a Api.lwt_result -> 'a Api.lwt_result + = fun ?(append = false) loc r -> r >>= diff --git a/gui/state_error.mli b/gui/state/state_error.mli similarity index 100% rename from gui/state_error.mli rename to gui/state/state_error.mli diff --git a/gui/state_file.ml b/gui/state/state_file.ml similarity index 95% rename from gui/state_file.ml rename to gui/state/state_file.ml index addfa822cd..790ae12d5b 100644 --- a/gui/state_file.ml +++ b/gui/state/state_file.ml @@ -14,11 +14,13 @@ type model = { current: active option; directory: slot Mods.IntMap.t } let dummy_cursor_pos = { Loc.line = -1; Loc.chr = 0 } let blank_state = { current = None; directory = Mods.IntMap.empty } -let model, set_directory_state = React.S.create blank_state +let model_hooked, set_directory_state = Hooked.S.create blank_state +let model = Hooked.S.to_react_signal model_hooked type refresh = { filename: string; content: string; line: int option } -let refresh_file_hook = Hooked.E.create ~debug:"refresh_file_hook" () +let refresh_file_hook, refresh_file_hook_send = + Hooked.E.create ~debug:"refresh_file_hook" () let current_filename = React.S.map @@ -31,17 +33,20 @@ let current_filename = m.current) model -let with_current_pos ?eq ?(on = React.S.const true) f default = - React.S.fmap ?eq - (fun m -> - Option_util.bind - (fun x -> - Option_util.bind - (fun { name; _ } -> f name x.cursor_pos) - (Mods.IntMap.find_option x.rank m.directory)) - m.current) +let apply_on_current_pos_of_model f m = + let () = Common.warn ~loc:__LOC__ "apply_on_pos_of_model" in + Option_util.bind + (fun x -> + Option_util.map + (fun { name; _ } -> f name x.cursor_pos) + (Mods.IntMap.find_option x.rank m.directory)) + m.current + +let with_current_pos ?eq ?(on = Hooked.S.const true) f default = + Hooked.S.fmap ?eq + (apply_on_current_pos_of_model f) default - (React.S.on on blank_state model) + (Hooked.S.on on blank_state model_hooked) let with_current_file f = let state = React.S.value model in @@ -87,9 +92,7 @@ let send_refresh (line : int option) : unit Api.lwt_result = let () = Common.log_group "Refresh file" in let () = Common.debug ~loc:__LOC__ content in let () = Common.log_group_end () in - let () = - Hooked.E.send refresh_file_hook { filename; content; line } - in + let () = refresh_file_hook_send { filename; content; line } in Lwt.return (Result_util.ok ())) let update_directory ~reset current catalog = @@ -106,8 +109,7 @@ let update_directory ~reset current catalog = in set_directory_state { current; directory } -let create_file ~(filename : string) ~(content : string) : unit Api.lwt_result - = +let create_file ~(filename : string) ~(content : string) : unit Api.lwt_result = State_project.eval_with_project ~label:"create_file" (fun manager -> manager#file_catalog >>= Api_common.result_bind_with_lwt ~ok:(fun catalog -> @@ -159,8 +161,7 @@ let rec choose_file choice = function else choose_file choice t -let select_file (filename : string) (line : int option) : unit Api.lwt_result - = +let select_file (filename : string) (line : int option) : unit Api.lwt_result = State_project.eval_with_project ~label:"select_file" (fun manager -> manager#file_catalog >>= Api_common.result_bind_with_lwt ~ok:(fun catalog -> diff --git a/gui/state_file.mli b/gui/state/state_file.mli similarity index 92% rename from gui/state_file.mli rename to gui/state/state_file.mli index dab2821cd0..4c1da382e3 100644 --- a/gui/state_file.mli +++ b/gui/state/state_file.mli @@ -45,12 +45,15 @@ type model = { current: active option; directory: slot Mods.IntMap.t } val model : model React.signal val current_filename : string option React.signal +val apply_on_current_pos_of_model : + (string -> Loc.position -> 'a) -> model -> 'a option + val with_current_pos : ?eq:('a -> 'a -> bool) -> - ?on:bool React.signal -> - (string -> Loc.position -> 'a option) -> + ?on:bool Hooked.signal -> + (string -> Loc.position -> 'a) -> 'a -> - 'a React.signal + 'a Hooked.signal val init : unit -> unit Lwt.t (** run on application init *) diff --git a/gui/state_perturbation.ml b/gui/state/state_perturbation.ml similarity index 100% rename from gui/state_perturbation.ml rename to gui/state/state_perturbation.ml diff --git a/gui/state_perturbation.mli b/gui/state/state_perturbation.mli similarity index 100% rename from gui/state_perturbation.mli rename to gui/state/state_perturbation.mli diff --git a/gui/state_project.ml b/gui/state/state_project.ml similarity index 100% rename from gui/state_project.ml rename to gui/state/state_project.ml diff --git a/gui/state_project.mli b/gui/state/state_project.mli similarity index 100% rename from gui/state_project.mli rename to gui/state/state_project.mli diff --git a/gui/state_runtime.ml b/gui/state/state_runtime.ml similarity index 100% rename from gui/state_runtime.ml rename to gui/state/state_runtime.ml diff --git a/gui/state_runtime.mli b/gui/state/state_runtime.mli similarity index 100% rename from gui/state_runtime.mli rename to gui/state/state_runtime.mli diff --git a/gui/state_settings.ml b/gui/state/state_settings.ml similarity index 100% rename from gui/state_settings.ml rename to gui/state/state_settings.ml diff --git a/gui/state_settings.mli b/gui/state/state_settings.mli similarity index 100% rename from gui/state_settings.mli rename to gui/state/state_settings.mli diff --git a/gui/state_simulation.ml b/gui/state/state_simulation.ml similarity index 100% rename from gui/state_simulation.ml rename to gui/state/state_simulation.ml diff --git a/gui/state_simulation.mli b/gui/state/state_simulation.mli similarity index 100% rename from gui/state_simulation.mli rename to gui/state/state_simulation.mli diff --git a/gui/state_ui.ml b/gui/state/state_ui.ml similarity index 100% rename from gui/state_ui.ml rename to gui/state/state_ui.ml diff --git a/gui/state_ui.mli b/gui/state/state_ui.mli similarity index 100% rename from gui/state_ui.mli rename to gui/state/state_ui.mli diff --git a/gui/ui/dune b/gui/ui/dune new file mode 100644 index 0000000000..bca4651b4d --- /dev/null +++ b/gui/ui/dune @@ -0,0 +1,48 @@ +(include ../dune_js_of_ocaml_flags.inc) + +(library + (name kappa_webapp_ui) + (libraries + js_of_ocaml-tyxml + lwt_react + kappa_webapp_lib + kappa_json_api + kappa_parameters + kappa_webapp_state) + (preprocess + (pps js_of_ocaml-ppx tyxml-ppx)) + (flags + (:standard + -w + @a-7-70 + -open + Js_of_ocaml + -open + Js_of_ocaml_tyxml + -open + Kappa_webapp_lib + -open + Kappa_json_api + -open + Kappa_data_structures + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_runtime + -open + Kappa_errors + -open + Kappa_kasa_type_interface + -open + Kappa_parameters + -open + Kappa_classical_graphs + -open + Kappa_logging + -open + Kappa_cflow + -open + Kappa_webapp_state + ))) diff --git a/gui/menu_editor_file.ml b/gui/ui/menu_editor_file.ml similarity index 100% rename from gui/menu_editor_file.ml rename to gui/ui/menu_editor_file.ml diff --git a/gui/menu_editor_file.mli b/gui/ui/menu_editor_file.mli similarity index 100% rename from gui/menu_editor_file.mli rename to gui/ui/menu_editor_file.mli diff --git a/gui/menu_editor_file_controller.ml b/gui/ui/menu_editor_file_controller.ml similarity index 100% rename from gui/menu_editor_file_controller.ml rename to gui/ui/menu_editor_file_controller.ml diff --git a/gui/menu_editor_file_controller.mli b/gui/ui/menu_editor_file_controller.mli similarity index 100% rename from gui/menu_editor_file_controller.mli rename to gui/ui/menu_editor_file_controller.mli diff --git a/gui/modal_preferences.ml b/gui/ui/modal_preferences.ml similarity index 100% rename from gui/modal_preferences.ml rename to gui/ui/modal_preferences.ml diff --git a/gui/modal_preferences.mli b/gui/ui/modal_preferences.mli similarity index 100% rename from gui/modal_preferences.mli rename to gui/ui/modal_preferences.mli diff --git a/gui/panel_projects.ml b/gui/ui/panel_projects.ml similarity index 100% rename from gui/panel_projects.ml rename to gui/ui/panel_projects.ml diff --git a/gui/panel_projects.mli b/gui/ui/panel_projects.mli similarity index 100% rename from gui/panel_projects.mli rename to gui/ui/panel_projects.mli diff --git a/gui/panel_projects_controller.ml b/gui/ui/panel_projects_controller.ml similarity index 100% rename from gui/panel_projects_controller.ml rename to gui/ui/panel_projects_controller.ml diff --git a/gui/panel_projects_controller.mli b/gui/ui/panel_projects_controller.mli similarity index 100% rename from gui/panel_projects_controller.mli rename to gui/ui/panel_projects_controller.mli diff --git a/gui/panel_settings.ml b/gui/ui/panel_settings.ml similarity index 97% rename from gui/panel_settings.ml rename to gui/ui/panel_settings.ml index 06213ab28d..9f92a80e6c 100644 --- a/gui/panel_settings.ml +++ b/gui/ui/panel_settings.ml @@ -178,15 +178,15 @@ module DivErrorMessage : Ui_common.Div = struct let message_nav_inc_id = "panel_settings_message_nav_inc_id" let message_nav_dec_id = "panel_settings_message_nav_dec_id" let message_file_label_id = "panel_settings_message_file_label" - let error_index = Hooked.S.create ~debug:"error_index" None + let error_index, error_index_set = Hooked.S.create ~debug:"error_index" None let () = Hooked.S.register State_error.errors (fun errors -> match errors with | [] -> () | _ :: _ -> - (match Hooked.S.v error_index with - | None -> Hooked.S.set error_index (Some 0) + (match Hooked.S.value error_index with + | None -> error_index_set (Some 0) | Some _ -> ())) (* if there are less or no errors the index needs to be updated *) @@ -198,11 +198,11 @@ module DivErrorMessage : Ui_common.Div = struct | Some index, error -> let length = List.length error in if index > length then ( - let () = Hooked.S.set error_index (Some 0) in + let () = error_index_set (Some 0) in Some 0 ) else if 0 > index then ( let index = Some (List.length error - 1) in - let () = Hooked.S.set error_index index in + let () = error_index_set index in index ) else Some index @@ -306,8 +306,9 @@ module DivErrorMessage : Ui_common.Div = struct (Js.string "[Panel_settings] clicked file_click_handler") in let message : Api_types_t.message option = - get_message (Hooked.S.v error_index) - (Hooked.S.v State_error.errors) + get_message + (Hooked.S.value error_index) + (Hooked.S.value State_error.errors) in let range = Option_util.bind @@ -332,14 +333,15 @@ module DivErrorMessage : Ui_common.Div = struct (Js.string "[Panel_settings] clicked index_click_handler") in let index : int option = - sanitize_index (Hooked.S.v error_index) - (Hooked.S.v State_error.errors) + sanitize_index + (Hooked.S.value error_index) + (Hooked.S.value State_error.errors) in let index = Option_util.map delta index in let index : int option = - sanitize_index index (Hooked.S.v State_error.errors) + sanitize_index index (Hooked.S.value State_error.errors) in - let () = Hooked.S.set error_index index in + let () = error_index_set index in Js._true) in () diff --git a/gui/panel_settings.mli b/gui/ui/panel_settings.mli similarity index 100% rename from gui/panel_settings.mli rename to gui/ui/panel_settings.mli diff --git a/gui/panel_settings_controller.ml b/gui/ui/panel_settings_controller.ml similarity index 100% rename from gui/panel_settings_controller.ml rename to gui/ui/panel_settings_controller.ml diff --git a/gui/panel_settings_controller.mli b/gui/ui/panel_settings_controller.mli similarity index 100% rename from gui/panel_settings_controller.mli rename to gui/ui/panel_settings_controller.mli diff --git a/gui/panel_tab.ml b/gui/ui/panel_tab.ml similarity index 100% rename from gui/panel_tab.ml rename to gui/ui/panel_tab.ml diff --git a/gui/panel_tab.mli b/gui/ui/panel_tab.mli similarity index 100% rename from gui/panel_tab.mli rename to gui/ui/panel_tab.mli diff --git a/gui/subpanel_editor.ml b/gui/ui/subpanel_editor.ml similarity index 98% rename from gui/subpanel_editor.ml rename to gui/ui/subpanel_editor.ml index 99b084155b..a1f07a74fd 100644 --- a/gui/subpanel_editor.ml +++ b/gui/ui/subpanel_editor.ml @@ -11,7 +11,9 @@ module Html = Tyxml_js.Html5 let editor_full, set_editor_full = React.S.create (false : bool) let filename, set_filename = React.S.create (None : string option) -let move_cursor_hook = Hooked.E.create ~debug:"move_cursor_hook" () + +let move_cursor_hook, move_cursor_hook_send = + Hooked.E.create ~debug:"move_cursor_hook" () let file_label = Tyxml_js.R.Html.txt @@ -137,7 +139,7 @@ let onload () : unit = let () = lint_config##.getAnnotations := fun _ _ _ -> - error_lint (Hooked.S.v State_error.errors) + error_lint (Hooked.S.value State_error.errors) in let () = lint_config##.lintOnChange := Js._false in let configuration = Codemirror.default_configuration in diff --git a/gui/subpanel_editor.mli b/gui/ui/subpanel_editor.mli similarity index 93% rename from gui/subpanel_editor.mli rename to gui/ui/subpanel_editor.mli index 96b7abff19..973e513a23 100644 --- a/gui/subpanel_editor.mli +++ b/gui/ui/subpanel_editor.mli @@ -7,6 +7,6 @@ (******************************************************************************) val editor_full : bool React.signal -val move_cursor_hook : Loc.t Hooked.E.t +val move_cursor_hook_send : Loc.t -> unit include Ui_common.Panel diff --git a/gui/subpanel_editor_controller.ml b/gui/ui/subpanel_editor_controller.ml similarity index 100% rename from gui/subpanel_editor_controller.ml rename to gui/ui/subpanel_editor_controller.ml diff --git a/gui/subpanel_editor_controller.mli b/gui/ui/subpanel_editor_controller.mli similarity index 100% rename from gui/subpanel_editor_controller.mli rename to gui/ui/subpanel_editor_controller.mli diff --git a/gui/tab_about.ml b/gui/ui/tab_about.ml similarity index 100% rename from gui/tab_about.ml rename to gui/ui/tab_about.ml diff --git a/gui/tab_about.mli b/gui/ui/tab_about.mli similarity index 100% rename from gui/tab_about.mli rename to gui/ui/tab_about.mli diff --git a/gui/tab_constraints.ml b/gui/ui/tab_constraints.ml similarity index 100% rename from gui/tab_constraints.ml rename to gui/ui/tab_constraints.ml diff --git a/gui/tab_constraints.mli b/gui/ui/tab_constraints.mli similarity index 100% rename from gui/tab_constraints.mli rename to gui/ui/tab_constraints.mli diff --git a/gui/tab_contact_map.ml b/gui/ui/tab_contact_map.ml similarity index 100% rename from gui/tab_contact_map.ml rename to gui/ui/tab_contact_map.ml diff --git a/gui/tab_contact_map.mli b/gui/ui/tab_contact_map.mli similarity index 100% rename from gui/tab_contact_map.mli rename to gui/ui/tab_contact_map.mli diff --git a/gui/tab_editor.ml b/gui/ui/tab_editor.ml similarity index 100% rename from gui/tab_editor.ml rename to gui/ui/tab_editor.ml diff --git a/gui/tab_editor.mli b/gui/ui/tab_editor.mli similarity index 100% rename from gui/tab_editor.mli rename to gui/ui/tab_editor.mli diff --git a/gui/tab_flux.ml b/gui/ui/tab_flux.ml similarity index 99% rename from gui/tab_flux.ml rename to gui/ui/tab_flux.ml index 05988e682e..425e235d2a 100644 --- a/gui/tab_flux.ml +++ b/gui/ui/tab_flux.ml @@ -179,7 +179,7 @@ let content () : [> Html_types.div ] Html.elt list = ] let navli () : [> `PCDATA | `Span ] Html.elt ReactiveData.RList.t = - Ui_common_with_sim.badge (fun state -> + Ui_react_sim_status.badge (fun state -> match state with | None -> 0 | Some state -> diff --git a/gui/tab_flux.mli b/gui/ui/tab_flux.mli similarity index 100% rename from gui/tab_flux.mli rename to gui/ui/tab_flux.mli diff --git a/gui/tab_influences.ml b/gui/ui/tab_influences.ml similarity index 77% rename from gui/tab_influences.ml rename to gui/ui/tab_influences.ml index ed55e66821..3423aed549 100644 --- a/gui/tab_influences.ml +++ b/gui/ui/tab_influences.ml @@ -6,6 +6,15 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) +(* TODO: clean *) +let debug_warn (title : string) data = + if String.length title > 0 then ( + let () = Common.warn ~loc:__LOC__ ("Print `" ^ title ^ "`:") in + (); + let () = Common.warn ~loc:__LOC__ data in + () + ) + module Html = Tyxml_js.Html5 open Lwt.Infix @@ -43,9 +52,14 @@ type model = { } let navli () = ReactiveData.RList.empty -let tab_is_active, set_tab_is_active = React.S.create false + +let tab_is_active, set_tab_is_active = + Hooked.S.create ~debug:"tab_is_active" false + +let tab_is_active_signal = Hooked.S.to_react_signal tab_is_active let tab_was_active = ref false -let track_cursor, set_track_cursor = React.S.create false +let track_cursor, track_cursor_set = Hooked.S.create ~debug:"track_cursor" false +let track_cursor_signal = Hooked.S.to_react_signal track_cursor let dummy_model = { @@ -55,7 +69,8 @@ let dummy_model = origin_label = None; } -let model, set_model = React.S.create dummy_model +let model, set_model = Hooked.S.create ~debug:"model" dummy_model +let model_signal = Hooked.S.to_react_signal model let total_input_id = "total_input" let fwd_input_id = "fwd_input" let bwd_input_id = "bwd_input" @@ -73,12 +88,12 @@ let influence_node_label = function r.Public_data.var_label let update_model_graph f = - let m = React.S.value model in + let m = Hooked.S.value model in match m.rendering with | DrawTabular _ -> () | DrawGraph g -> set_model { m with rendering = DrawGraph (f g) } -let update_model f = set_model (f (React.S.value model)) +let update_model f = set_model (f (Hooked.S.value model)) let display_id = "influence_map_display" let influencemap = @@ -89,7 +104,7 @@ let influencemap = (Yojson.Basic.from_string (Js.to_string x)) in let () = - Hooked.E.send Subpanel_editor.move_cursor_hook + Subpanel_editor.move_cursor_hook_send (Public_data.position_of_refined_influence_node node) in let origin = Some (Public_data.short_node_of_refined_node node) in @@ -157,24 +172,46 @@ let recenter = ] [ Html.txt "First node" ] +(* TODO: clean this *) +let switch_class elt_id add_list remove_list = + let dom_elt : 'a Js.t = Ui_common.id_dom elt_id |> Js.Unsafe.coerce in + List.iter + (fun (class_str : string) -> + Js.Unsafe.meth_call dom_elt##.classList "add" + [| Js.string class_str |> Js.Unsafe.coerce |]) + add_list; + List.iter + (fun (class_str : string) -> + Js.Unsafe.meth_call dom_elt##.classList "remove" + [| Js.string class_str |> Js.Unsafe.coerce |]) + remove_list + let track_cursor_switch = + let track_cursor_switch_id = "track_cursor_switch_id" in + let () = + Hooked.S.register track_cursor (fun track_enabled -> + let add_list, remove_list = + if track_enabled then + [ "btn-light"; "active" ], [ "btn-default" ] + else + [ "btn-default" ], [ "btn-light"; "active" ] + in + switch_class track_cursor_switch_id add_list remove_list) + in + let on_click _ = + let () = track_cursor_set (not (Hooked.S.value track_cursor)) in + if Hooked.S.value track_cursor then + update_model (fun m -> { m with origin = None; origin_label = None }); + true + in + (* html*) Html.button ~a: [ + Html.a_id track_cursor_switch_id; Html.a_button_type `Button; - Tyxml_js.R.Html5.a_class - (React.S.map - (fun tc -> - "form-control" :: "btn" :: "btn-default" - :: - (if tc then - [ "active" ] - else - [])) - track_cursor); - Html.a_onclick (fun _ -> - let () = set_track_cursor (not (React.S.value track_cursor)) in - true); + Html.a_class [ "form-control"; "btn"; "btn-default" ]; + Html.a_onclick on_click; ] [ Html.txt "Track cursor" ] @@ -192,7 +229,7 @@ let export_config = ( State_error.wrap "influence_map_export" (State_project.eval_with_project ~label:__LOC__ (fun manager -> - let { accuracy; _ } = React.S.value model in + let { accuracy; _ } = Hooked.S.value model in manager#get_influence_map_raw accuracy >|= Result_util.map (fun influences_string -> let data = Js.string influences_string in @@ -210,7 +247,7 @@ let export_config = let rendering_chooser_id = "influence-rendering" let rendering_chooser = - let { rendering; _ } = React.S.value model in + let { rendering; _ } = Hooked.S.value model in Html.select ~a:[ Html.a_class [ "form-control" ]; Html.a_id rendering_chooser_id ] [ @@ -235,7 +272,7 @@ let rendering_chooser = let accuracy_chooser_id = "influence-accuracy" let accuracy_chooser = - let { accuracy; _ } = React.S.value model in + let { accuracy; _ } = Hooked.S.value model in let option_gen x = Html.option ~a: @@ -430,7 +467,7 @@ let pop_cell = function [ Html.a_onclick (fun _ -> let () = - Hooked.E.send Subpanel_editor.move_cursor_hook + Subpanel_editor.move_cursor_hook_send (Public_data.position_of_refined_influence_node node) in let origin = @@ -464,10 +501,13 @@ let rec fill_table acc by on = let draw_table origin_label_opt { positive_on; positive_by; negative_on; negative_by } = + let () = Common.warn ~loc:__LOC__ "DRAW TABLE" in + debug_warn "origin_label_opt" origin_label_opt; let origin_label, outs = match origin_label_opt with | None -> - if not (React.S.value track_cursor) then + debug_warn "track_cursor_when_draw_table" (track_cursor |> Hooked.S.value); + if not (track_cursor |> Hooked.S.value) then "Navigate through the nodes using the controls above.", [] else "Click on a rule or variable in the editor.", [] @@ -502,8 +542,12 @@ let draw_table origin_label_opt ]) [ Html.tbody outs ] -let influence_sphere = - State_project.on_project_change_async ~on:tab_is_active dummy_model model +let influence_sphere : + (influence_sphere, Result_util.message list) Result_util.t React.signal = + State_project.on_project_change_async + ~on:(tab_is_active_signal |> React.S.trace (debug_warn "tab_is_active")) + dummy_model + (model_signal |> React.S.trace (debug_warn "on project model_signal")) (Result_util.ok empty_sphere) (fun manager { rendering; accuracy; origin; origin_label = _ } -> match rendering with @@ -570,38 +614,69 @@ let content () = ]; ] in + let influence_style_id = "influence_style_id" in + (* + let () = + Hooked.S.register model (fun track_enabled -> + let dom_elt : 'a Js.t = + Ui_common.id_dom influence_style_id |> Js.Unsafe.coerce + in + dom_elt##.classList := + let meth = + if track_enabled then + "add" + else + "remove" + in + let out = + Js.Unsafe.meth_call dom_elt##.classList meth + [| Js.string "active" |> Js.Unsafe.coerce |] + in + let () = Common.warn ~loc:__LOC__ "CALL STUFF draw style" in + let () = Common.warn ~loc:__LOC__ dom_elt in + out) + in + +*) [ accuracy_form; Html.div ~a: [ + Html.a_id influence_style_id; Tyxml_js.R.Html5.a_class (React.S.map (fun { rendering; _ } -> match rendering with | DrawGraph _ -> [ "flex-content" ] | DrawTabular _ -> []) - model); + model_signal); + (* Hidden if tabular *) Tyxml_js.R.filter_attrib (Html.a_hidden ()) (React.S.map (fun { rendering; _ } -> match rendering with | DrawGraph _ -> false | DrawTabular _ -> true) - model); + model_signal); ] [ graph_form; Html.div ~a:[ Html.a_id display_id; Html.a_class [ "flex-content" ] ] []; ]; Tyxml_js.R.Html5.div - ~a:[ Html.a_class [ "panel-scroll" ] ] + ~a: + [ + Html.a_id "TODOTODOTODOTODOTODOTODOTODOTODOTODOTODOTODOTODOTODO"; + Html.a_class [ "panel-scroll" ]; + ] (ReactiveData.RList.from_signal - (React.S.l2 - (fun { rendering; origin_label; _ } sphere -> + (React.S.l3 + (fun { rendering; origin_label; _ } sphere _ -> match rendering with | DrawGraph _ -> [] | DrawTabular () -> + debug_warn "" "DRAW TABULAR"; Result_util.fold sphere ~ok:(fun sphere -> [ draw_table origin_label sphere ]) ~error:(fun error -> @@ -614,48 +689,50 @@ let content () = Result_util.print_message m); ]) error)) - model influence_sphere)); + model_signal influence_sphere track_cursor_signal)); Widget_export.content export_config; ] +(* TODO: graph stuff that might be BROKEN *) let neither_gc_me = - React.S.l2 + Hooked.S.l2 (fun _ { rendering; accuracy; origin; origin_label = _ } -> match rendering with | DrawTabular _ -> Lwt.return (Result_util.ok ()) | DrawGraph { fwd; bwd; total } -> - State_error.wrap ~append:true "influence_map" - (State_project.eval_with_project ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - manager#get_local_influence_map ?fwd ?bwd ?origin ~total accuracy - >|= Result_util.fold - ~ok:(fun influences -> - let buf = Buffer.create 1000 in - let fmt = Format.formatter_of_buffer buf in - let logger = - Loggers.open_logger_from_formatter - ~mode:Loggers.Js_Graph fmt - in - let logger_graph = - Graph_loggers_sig.extend_logger logger - in - let () = json_to_graph logger_graph influences in - let graph = - Graph_loggers_sig.graph_of_logger logger_graph - in - let graph_json = Graph_json.to_json graph in - let () = Loggers.flush_logger logger in - let () = Loggers.close_logger logger in - let () = - influencemap##setData - (Js.string (Yojson.Basic.to_string graph_json)) - in - Result_util.ok ()) - ~error:(fun e -> - let () = influencemap##clearData in - Result_util.error e)))) - (React.S.on ~eq:State_project.model_equal tab_is_active - State_project.dummy_model State_project.model) + State_project.eval_with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + let () = Common.warn ~loc:__LOC__ "influence_map logger" in + manager#get_local_influence_map ?fwd ?bwd ?origin ~total accuracy + >|= Result_util.fold + ~ok:(fun influences -> + let buf = Buffer.create 1000 in + let fmt = Format.formatter_of_buffer buf in + let logger = + Loggers.open_logger_from_formatter ~mode:Loggers.Js_Graph + fmt + in + let logger_graph = Graph_loggers_sig.extend_logger logger in + let () = json_to_graph logger_graph influences in + let graph = + Graph_loggers_sig.graph_of_logger logger_graph + in + let graph_json = Graph_json.to_json graph in + let () = Loggers.flush_logger logger in + let () = Loggers.close_logger logger in + let () = + influencemap##setData + (Js.string (Yojson.Basic.to_string graph_json)) + in + Result_util.ok ()) + ~error:(fun e -> + let () = influencemap##clearData in + Result_util.error e)) + |> State_error.wrap ~append:true "influence_map") + (Hooked.S.on ~eq:State_project.model_equal tab_is_active + State_project.dummy_model + (Hooked.S.of_react_signal ~eq:State_project.model_equal + ~debug:"State_project.model in state_project" State_project.model)) model let update_model_with_origin_refined origin_refined = @@ -665,24 +742,29 @@ let update_model_with_origin_refined origin_refined = let origin_label = Option_util.map influence_node_label origin_refined in update_model (fun m -> { m with origin; origin_label }) -let nor_gc_me = +(* Update influence map node according to cursor_pos *) +let _ = State_file.with_current_pos - ~on:(React.S.Bool.( && ) tab_is_active track_cursor) + ~on:(Hooked.S.l2 ( && ) tab_is_active track_cursor) (fun filename cursor_pos -> - Some - (State_error.wrap "influence_map_node_at" - (State_project.eval_with_project ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - manager#get_influence_map_node_at ~filename cursor_pos - >|= Result_util.map update_model_with_origin_refined)))) + let () = Common.warn ~loc:__LOC__ "track_cursor triggered" in + State_error.wrap "influence_map_node_at" + (State_project.eval_with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + let () = + Common.warn ~loc:__LOC__ "track_cursor eval_with_project" + in + manager#get_influence_map_node_at ~filename cursor_pos + >|= Result_util.map update_model_with_origin_refined))) (Lwt.return (Result_util.ok ())) + |> Hooked.S.to_react_signal let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active let dont_gc_me = ref [] let onload () = - let () = dont_gc_me := [ neither_gc_me; nor_gc_me ] in + let () = dont_gc_me := [ neither_gc_me ] in let () = Widget_export.onload export_config in let () = (Tyxml_js.To_dom.of_select rendering_chooser)##.onchange @@ -765,7 +847,7 @@ let onload () = let () = (Tyxml_js.To_dom.of_button next_node)##.onclick := Dom_html.full_handler (fun _ _ -> - let { origin; _ } = React.S.value model in + let { origin; _ } = Hooked.S.value model in let _ = State_error.wrap "influence_map_next_node" (State_project.eval_with_project ~label:__LOC__ @@ -778,7 +860,7 @@ let onload () = let () = (Tyxml_js.To_dom.of_button prev_node)##.onclick := Dom_html.full_handler (fun _ _ -> - let { origin; _ } = React.S.value model in + let { origin; _ } = Hooked.S.value model in let _ = State_error.wrap "influence_map_prev_node" (State_project.eval_with_project ~label:__LOC__ diff --git a/gui/tab_influences.mli b/gui/ui/tab_influences.mli similarity index 100% rename from gui/tab_influences.mli rename to gui/ui/tab_influences.mli diff --git a/gui/tab_log.ml b/gui/ui/tab_log.ml similarity index 96% rename from gui/tab_log.ml rename to gui/ui/tab_log.ml index 6acb83efcc..ab94adc2dc 100644 --- a/gui/tab_log.ml +++ b/gui/ui/tab_log.ml @@ -20,7 +20,7 @@ let line_count state = state.simulation_info_output.simulation_output_log_messages let navli () = - Ui_common_with_sim.label_news tab_is_active (fun state -> line_count state) + Ui_react_sim_status.label_news tab_is_active (fun state -> line_count state) let content () = let state_log = diff --git a/gui/tab_log.mli b/gui/ui/tab_log.mli similarity index 100% rename from gui/tab_log.mli rename to gui/ui/tab_log.mli diff --git a/gui/tab_outputs.ml b/gui/ui/tab_outputs.ml similarity index 97% rename from gui/tab_outputs.ml rename to gui/ui/tab_outputs.ml index fe3433e5f7..f9e2677436 100644 --- a/gui/tab_outputs.ml +++ b/gui/ui/tab_outputs.ml @@ -27,7 +27,7 @@ let file_count state = state.Api_types_t.simulation_info_output .Api_types_t.simulation_output_file_lines -let navli () = Ui_common_with_sim.badge (fun state -> file_count state) +let navli () = Ui_react_sim_status.badge (fun state -> file_count state) let xml () = let select (file_line_ids : string list) : [> Html_types.select ] Html.elt = @@ -126,7 +126,7 @@ let select_outputs () : unit = update_outputs fileindex let content () = - [ Ui_common_with_sim.toggle_element (fun t -> file_count t > 0) (xml ()) ] + [ Ui_react_sim_status.toggle_element (fun t -> file_count t > 0) (xml ()) ] let onload () = let () = diff --git a/gui/tab_outputs.mli b/gui/ui/tab_outputs.mli similarity index 100% rename from gui/tab_outputs.mli rename to gui/ui/tab_outputs.mli diff --git a/gui/tab_plot.ml b/gui/ui/tab_plot.ml similarity index 98% rename from gui/tab_plot.ml rename to gui/ui/tab_plot.ml index f814bd6327..0f11bb7f66 100644 --- a/gui/tab_plot.ml +++ b/gui/ui/tab_plot.ml @@ -279,7 +279,7 @@ let xml () = |}] let content () : [> Html_types.div ] Html.elt list = - [ Ui_common_with_sim.toggle_element (fun s -> has_plot s) (xml ()) ] + [ Ui_react_sim_status.toggle_element (fun s -> has_plot s) (xml ()) ] let onload () = let plot_offset_input_dom = Tyxml_js.To_dom.of_input plot_offset_input in @@ -330,7 +330,7 @@ let plot_count = function state.simulation_info_output.simulation_output_plot let navli () = - Ui_common_with_sim.label_news tab_is_active (fun state -> plot_count state) + Ui_react_sim_status.label_news tab_is_active (fun state -> plot_count state) let onresize () = (* recalcuate size *) diff --git a/gui/tab_plot.mli b/gui/ui/tab_plot.mli similarity index 100% rename from gui/tab_plot.mli rename to gui/ui/tab_plot.mli diff --git a/gui/tab_polymers.ml b/gui/ui/tab_polymers.ml similarity index 100% rename from gui/tab_polymers.ml rename to gui/ui/tab_polymers.ml diff --git a/gui/tab_polymers.mli b/gui/ui/tab_polymers.mli similarity index 100% rename from gui/tab_polymers.mli rename to gui/ui/tab_polymers.mli diff --git a/gui/tab_snapshot.ml b/gui/ui/tab_snapshot.ml similarity index 99% rename from gui/tab_snapshot.ml rename to gui/ui/tab_snapshot.ml index 6d723daca1..b3710ec8e3 100644 --- a/gui/tab_snapshot.ml +++ b/gui/ui/tab_snapshot.ml @@ -30,7 +30,7 @@ let snapshot_count (state : Api_types_j.simulation_info option) : int = state.Api_types_j.simulation_info_output .Api_types_j.simulation_output_snapshots -let navli () = Ui_common_with_sim.badge (fun state -> snapshot_count state) +let navli () = Ui_react_sim_status.badge (fun state -> snapshot_count state) let select_id = "snapshot-select-id" let display_id = "snapshot-map-display" @@ -353,7 +353,7 @@ let xml () = let content () = [ - Ui_common_with_sim.toggle_element + Ui_react_sim_status.toggle_element (fun state -> snapshot_count state > 0) (xml ()); ] diff --git a/gui/tab_snapshot.mli b/gui/ui/tab_snapshot.mli similarity index 100% rename from gui/tab_snapshot.mli rename to gui/ui/tab_snapshot.mli diff --git a/gui/tab_stories.ml b/gui/ui/tab_stories.ml similarity index 100% rename from gui/tab_stories.ml rename to gui/ui/tab_stories.ml diff --git a/gui/tab_stories.mli b/gui/ui/tab_stories.mli similarity index 100% rename from gui/tab_stories.mli rename to gui/ui/tab_stories.mli diff --git a/gui/ui_common_with_sim.ml b/gui/ui/ui_react_sim_status.ml similarity index 100% rename from gui/ui_common_with_sim.ml rename to gui/ui/ui_react_sim_status.ml diff --git a/gui/ui_common_with_sim.mli b/gui/ui/ui_react_sim_status.mli similarity index 100% rename from gui/ui_common_with_sim.mli rename to gui/ui/ui_react_sim_status.mli diff --git a/kappa-webapp.opam b/kappa-webapp.opam index 13254ba0c1..5a0ec1b880 100644 --- a/kappa-webapp.opam +++ b/kappa-webapp.opam @@ -38,6 +38,7 @@ depends: [ "js_of_ocaml-lwt" {= "5.7.0"} "js_of_ocaml-ppx" {= "5.7.0"} "js_of_ocaml-tyxml" {= "5.7.0"} + "ppx_inline_test" {= "v0.16.1"} "kappa-binaries" "kappa-agents" "odoc" {with-doc}