From d557547f1b7aa1fb99b13f076020034125fb4d58 Mon Sep 17 00:00:00 2001 From: Antoine Pouille Date: Tue, 12 Mar 2024 14:56:26 +0100 Subject: [PATCH] Renaming and comment in state_simulation.mli --- gui/JsNode.ml | 4 +- gui/JsSim.ml | 2 +- gui/panel_settings.ml | 2 +- gui/panel_settings_controller.ml | 4 +- gui/state_file.ml | 20 ++++----- gui/state_project.ml | 2 +- gui/state_project.mli | 2 +- gui/state_simulation.ml | 28 ++++++------- gui/state_simulation.mli | 8 ++-- gui/tab_contact_map.ml | 16 +++++--- gui/tab_editor.ml | 40 +++++++++--------- gui/tab_flux.ml | 6 +-- gui/tab_influences.ml | 12 +++--- gui/tab_log.ml | 26 ++++++------ gui/tab_outputs.ml | 69 ++++++++++++++++---------------- gui/tab_plot.ml | 6 +-- gui/tab_snapshot.ml | 42 ++++++++++--------- gui/tab_stories.ml | 10 ++--- 18 files changed, 154 insertions(+), 145 deletions(-) diff --git a/gui/JsNode.ml b/gui/JsNode.ml index 037ea6996..2df296351 100644 --- a/gui/JsNode.ml +++ b/gui/JsNode.ml @@ -56,7 +56,9 @@ let spawn_process (configuration : process_configuration Js.t) : (Js.Unsafe.js_expr "spawnProcess") [| Js.Unsafe.inject configuration |] -let launch_agent onClose message_delimiter command args handler = +let launch_agent (onClose : unit -> unit) (message_delimiter : char) + (command : string) (args : string list) (handler : string -> unit) : + < kill : unit Js.meth ; write : Js.js_string Js.t -> unit Js.meth > Js.t = let buffer = Buffer.create 512 in let rec onStdout msg = match Tools.string_split_on_char message_delimiter (Js.to_string msg) with diff --git a/gui/JsSim.ml b/gui/JsSim.ml index 4ba17d394..1a6ba6d21 100644 --- a/gui/JsSim.ml +++ b/gui/JsSim.ml @@ -6,7 +6,7 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let onload _ = +let onload (_ : 'a) : bool Js.t = let () = State_ui.onload () in let main = Ui_common.id_dom "main" in let () = diff --git a/gui/panel_settings.ml b/gui/panel_settings.ml index b7723450b..adad0c905 100644 --- a/gui/panel_settings.ml +++ b/gui/panel_settings.ml @@ -754,7 +754,7 @@ module RunningPanelLayout : Ui_common.Div = struct [ Lwt_react.S.map_s (fun _ -> - State_simulation.with_simulation_info ~label:__LOC__ + State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ ~ready:(fun manager status -> manager#simulation_efficiency >>= Api_common.result_bind_lwt ~ok:(fun eff -> diff --git a/gui/panel_settings_controller.ml b/gui/panel_settings_controller.ml index 1d849f7ff..54ab466a5 100644 --- a/gui/panel_settings_controller.ml +++ b/gui/panel_settings_controller.ml @@ -78,7 +78,7 @@ let focus_range (range : Loc.t) : unit = >>= fun _ -> Lwt.return_unit) let simulation_trace () = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> State_error.wrap __LOC__ manager#simulation_raw_trace >>= Api_common.result_bind_lwt ~ok:(fun data_string -> let data = Js.string data_string in @@ -89,7 +89,7 @@ let simulation_trace () = Lwt.return (Result_util.ok ()))) let simulation_outputs () = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> State_error.wrap __LOC__ manager#simulation_outputs_zip >>= Api_common.result_bind_lwt ~ok:(fun data_bigstring -> let data = Typed_array.Bigstring.to_arrayBuffer data_bigstring in diff --git a/gui/state_file.ml b/gui/state_file.ml index 45818dc45..5944a4a4d 100644 --- a/gui/state_file.ml +++ b/gui/state_file.ml @@ -62,7 +62,7 @@ let with_current_file f = let get_file () : (string * string) Api.result Lwt.t = with_current_file (fun _state active -> function | { local = None; name } -> - State_project.with_project ~label:"get_file" (fun manager -> + State_project.eval_with_project ~label:"get_file" (fun manager -> manager#file_get name >>= Api_common.result_bind_lwt ~ok:(fun (text, rank') -> if active.rank = rank' then @@ -109,7 +109,7 @@ let update_directory ~reset current catalog = let create_file ~(filename : string) ~(content : string) : unit Api.result Lwt.t = - State_project.with_project ~label:"create_file" (fun manager -> + State_project.eval_with_project ~label:"create_file" (fun manager -> manager#file_catalog >>= Api_common.result_bind_lwt ~ok:(fun catalog -> let matching_file = @@ -162,7 +162,7 @@ let rec choose_file choice = function let select_file (filename : string) (line : int option) : unit Api.result Lwt.t = - State_project.with_project ~label:"select_file" (fun manager -> + State_project.eval_with_project ~label:"select_file" (fun manager -> manager#file_catalog >>= Api_common.result_bind_lwt ~ok:(fun catalog -> Api_common.result_bind_lwt @@ -204,7 +204,7 @@ let set_content (content : string) : unit Api.result Lwt.t = directory = state.directory; } in - State_project.with_project ~label:"set_content" (fun manager -> + State_project.eval_with_project ~label:"set_content" (fun manager -> manager#file_update name content)) let set_compile file_id (compile : bool) : unit Api.result Lwt.t = @@ -221,7 +221,7 @@ let set_compile file_id (compile : bool) : unit Api.result Lwt.t = Mods.IntMap.add rank { local = None; name } state.directory in let () = set_directory_state { current = state.current; directory } in - State_project.with_project ~label:"set_compile" (fun manager -> + State_project.eval_with_project ~label:"set_compile" (fun manager -> manager#file_create rank name content) ) else Lwt.return (Result_util.ok ()) @@ -229,7 +229,7 @@ let set_compile file_id (compile : bool) : unit Api.result Lwt.t = if compile then Lwt.return (Result_util.ok ()) else - State_project.with_project ~label:"set_compile" (fun manager -> + State_project.eval_with_project ~label:"set_compile" (fun manager -> manager#file_get name >>= Api_common.result_bind_lwt ~ok:(fun (content, rank') -> if rank = rank' then ( @@ -241,7 +241,7 @@ let set_compile file_id (compile : bool) : unit Api.result Lwt.t = let () = set_directory_state { current = state.current; directory } in - State_project.with_project ~label:"set_compile'" + State_project.eval_with_project ~label:"set_compile'" (fun manager -> manager#file_delete name) ) else ( let error_msg = @@ -264,7 +264,7 @@ let remove_file () : unit Api.result Lwt.t = match local with | Some _ -> x | None -> - State_project.with_project ~label:"remove_file" (fun manager -> + State_project.eval_with_project ~label:"remove_file" (fun manager -> manager#file_delete name >>= fun y -> x >>= fun x -> Lwt.return (Api_common.result_combine [ x; y ]))) @@ -286,7 +286,7 @@ let do_a_move state file_id rank = | x -> x in if local = None then - State_project.with_project ~label:"remove_file" (fun manager -> + State_project.eval_with_project ~label:"remove_file" (fun manager -> manager#file_move rank file_id >>= Api_common.result_bind_lwt ~ok:(fun () -> Lwt.return (Result_util.ok { current; directory }))) @@ -346,7 +346,7 @@ let out_of_sync out_of_sync = } let sync ?(reset = false) () : unit Api.result Lwt.t = - State_project.with_project ~label:"select_file" (fun manager -> + State_project.eval_with_project ~label:"select_file" (fun manager -> manager#file_catalog >>= Api_common.result_bind_lwt ~ok:(fun catalog -> let cand = (React.S.value model).current in diff --git a/gui/state_project.ml b/gui/state_project.ml index 015f89ffc..6a189c1be 100644 --- a/gui/state_project.ml +++ b/gui/state_project.ml @@ -543,7 +543,7 @@ let init existing_projects : unit Lwt.t = in add_projects existing_projects >>= fun () -> add_projects projects -let with_project : +let eval_with_project : 'a. label:string -> (Api.concrete_manager -> 'a Api.result Lwt.t) -> diff --git a/gui/state_project.mli b/gui/state_project.mli index 03fcd699b..1e27d15d2 100644 --- a/gui/state_project.mli +++ b/gui/state_project.mli @@ -48,7 +48,7 @@ val init : string list -> unit Lwt.t val sync : unit -> unit Api.result Lwt.t (* to sync state of application with runtime *) -val with_project : +val eval_with_project : label:string -> (Api.concrete_manager -> 'a Api.result Lwt.t) -> 'a Api.result Lwt.t diff --git a/gui/state_simulation.ml b/gui/state_simulation.ml index 81ff293f3..0c2490c8f 100644 --- a/gui/state_simulation.ml +++ b/gui/state_simulation.ml @@ -60,18 +60,18 @@ let update_simulation_state (simulation_state : simulation_state) : unit = let model : model React.signal = state -let with_simulation : +let eval_with_sim_manager : 'a. label:string -> (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> 'a Api.result Lwt.t = fun ~label handler -> let project_handler manager = handler manager (React.S.value state) in - State_project.with_project ~label project_handler + State_project.eval_with_project ~label project_handler let fail_lwt error_msg = Lwt.return (Api_common.result_error_msg error_msg) -let with_simulation_info ~(label : string) +let eval_with_sim_manager_and_info ~(label : string) ?(stopped : Api.concrete_manager -> 'a Api.result Lwt.t = fun _ -> fail_lwt "Simulation stopped") ?(initializing : Api.concrete_manager -> 'a Api.result Lwt.t = @@ -80,18 +80,18 @@ let with_simulation_info ~(label : string) Api.concrete_manager -> Api_types_j.simulation_info -> 'a Api.result Lwt.t = - fun _ _ -> fail_lwt "Simulation ready") () = - with_simulation ~label (fun manager s -> + fun _ _ -> fail_lwt "Simulation ready") () : 'a Api.result Lwt.t = + eval_with_sim_manager ~label (fun manager s -> match s.simulation_state with | SIMULATION_STATE_STOPPED -> stopped manager | SIMULATION_STATE_INITALIZING -> initializing manager | SIMULATION_STATE_READY simulation_info -> ready manager simulation_info) -let when_ready ~(label : string) +let eval_when_ready ~(label : string) ?(handler : unit Api.result -> unit Lwt.t = fun _ -> Lwt.return_unit) (operation : Api.concrete_manager -> unit Api.result Lwt.t) : unit = Common.async __LOC__ (fun () -> - with_simulation_info ~label + eval_with_sim_manager_and_info ~label ~stopped:(fun _ -> Lwt.return (Result_util.ok ())) ~initializing:(fun _ -> Lwt.return (Result_util.ok ())) ~ready:(fun manager _ : unit Api.result Lwt.t -> operation manager) @@ -106,7 +106,7 @@ let rec sync () = | SIMULATION_STATE_STOPPED | SIMULATION_STATE_INITALIZING -> Lwt.return (Result_util.ok ()) | SIMULATION_STATE_READY _ -> - State_project.with_project ~label:"sync" (fun manager -> + State_project.eval_with_project ~label:"sync" (fun manager -> (* get current directory *) manager#simulation_info >>= Api_common.result_bind_lwt ~ok:(fun simulation_info -> @@ -125,7 +125,7 @@ let rec sync () = Lwt.return (Result_util.ok ()))) let refresh () = - State_project.with_project ~label:"sync" (fun manager -> + State_project.eval_with_project ~label:"sync" (fun manager -> (* get current directory *) manager#simulation_info >>= Result_util.fold @@ -144,7 +144,7 @@ let refresh () = let init () : unit Lwt.t = Lwt.return_unit let continue_simulation (pause_condition : string) : unit Api.result Lwt.t = - with_simulation_info ~label:"continue_simulation" + eval_with_sim_manager_and_info ~label:"continue_simulation" ~stopped:(fun _ -> let error_msg : string = "Failed to continue simulation, simulation stopped" @@ -161,7 +161,7 @@ let continue_simulation (pause_condition : string) : unit Api.result Lwt.t = () let pause_simulation () : unit Api.result Lwt.t = - with_simulation_info ~label:"pause_simulation" + eval_with_sim_manager_and_info ~label:"pause_simulation" ~stopped:(fun _ -> let error_msg : string = "Failed to pause simulation, simulation stopped" @@ -177,7 +177,7 @@ let pause_simulation () : unit Api.result Lwt.t = () let stop_simulation () : unit Api.result Lwt.t = - with_simulation_info ~label:"stop_simulation" + eval_with_sim_manager_and_info ~label:"stop_simulation" ~stopped:(fun _ -> let error_msg : string = "Failed to pause simulation, simulation stopped" @@ -197,7 +197,7 @@ let stop_simulation () : unit Api.result Lwt.t = let start_simulation (simulation_parameter : Api_types_j.simulation_parameter) : unit Api.result Lwt.t = - with_simulation_info ~label:"start_simulation" + eval_with_sim_manager_and_info ~label:"start_simulation" ~stopped:(fun manager -> let on_error error_msgs : unit Api.result Lwt.t = let () = update_simulation_state SIMULATION_STATE_STOPPED in @@ -242,7 +242,7 @@ let start_simulation (simulation_parameter : Api_types_j.simulation_parameter) : () let intervene_simulation (code : string) : string Api.result Lwt.t = - with_simulation_info ~label:"perturb_simulation" + eval_with_sim_manager_and_info ~label:"perturb_simulation" ~stopped:(fun _ -> let error_msg : string = "Failed to start simulation, simulation running" diff --git a/gui/state_simulation.mli b/gui/state_simulation.mli index ff5ff8651..6f8098c0b 100644 --- a/gui/state_simulation.mli +++ b/gui/state_simulation.mli @@ -25,12 +25,13 @@ val model_simulation_state : t -> model_state val init : unit -> unit Lwt.t val refresh : unit -> unit Api.result Lwt.t -val with_simulation : +val eval_with_sim_manager : label:string -> (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> 'a Api.result Lwt.t +(** [eval_with_sim_manager ~label handler] evaluates the function [handler] applied to the [concrete_manager] of current project and current [simulation_state] *) -val with_simulation_info : +val eval_with_sim_manager_and_info : label:string -> ?stopped:(Api.concrete_manager -> 'a Api.result Lwt.t) -> ?initializing:(Api.concrete_manager -> 'a Api.result Lwt.t) -> @@ -38,8 +39,9 @@ val with_simulation_info : (Api.concrete_manager -> Api_types_j.simulation_info -> 'a Api.result Lwt.t) -> unit -> 'a Api.result Lwt.t +(** [eval_with_sim_manager_and_info ~label ~stopped ~initializing ~ready] evaluates the function in argument matching the current [simulation_state], applied to the [concrete_manager] of current project *) -val when_ready : +val eval_when_ready : label:string -> ?handler:(unit Api.result -> unit Lwt.t) -> (Api.concrete_manager -> unit Api.result Lwt.t) -> diff --git a/gui/tab_contact_map.ml b/gui/tab_contact_map.ml index 46b0c0692..2aad33cef 100644 --- a/gui/tab_contact_map.ml +++ b/gui/tab_contact_map.ml @@ -25,22 +25,25 @@ let extract_contact_map = function acc, contact | _ -> failwith "Wrong ugly contact_map extractor" -let contactmap : Js_contact.contact_map Js.t = +let contact_map_js : Js_contact.contact_map Js.t = Js_contact.create_contact_map display_id State_settings.agent_coloring -let contact_map_text = +let contact_map_text : string React.signal = State_project.on_project_change_async ~on:tab_is_active None accuracy "null" - (fun (manager : Api.concrete_manager) acc -> + (fun + (manager : Api.concrete_manager) + (acc : Public_data.accuracy_level option) + -> manager#get_contact_map acc >|= Result_util.fold ~error:(fun mh -> let () = State_error.add_error "tab_contact_map" mh in - let () = contactmap##clearData in + let () = contact_map_js##clearData in "null") ~ok:(fun contact_json -> let _, map_json = extract_contact_map contact_json in let data = Yojson.Basic.to_string map_json in - let () = contactmap##setData (Js.string data) in + let () = contact_map_js##setData (Js.string data) in data)) let configuration : Widget_export.configuration = @@ -129,4 +132,5 @@ let onload () = in () -let onresize () : unit = if React.S.value tab_is_active then contactmap##redraw +let onresize () : unit = + if React.S.value tab_is_active then contact_map_js##redraw diff --git a/gui/tab_editor.ml b/gui/tab_editor.ml index bf412fc6b..b3c94e534 100644 --- a/gui/tab_editor.ml +++ b/gui/tab_editor.ml @@ -41,6 +41,20 @@ let rightsubpanel () = ]; ] +(** [childs_hide b] triggers change the state of child tabs to hide if b is True, or else to show *) +let childs_hide (b : bool) : unit = + if b then ( + let () = Tab_contact_map.parent_hide () in + let () = Tab_influences.parent_hide () in + let () = Tab_constraints.parent_hide () in + Tab_polymers.parent_hide () + ) else ( + let () = Tab_contact_map.parent_shown () in + let () = Tab_influences.parent_shown () in + let () = Tab_constraints.parent_shown () in + Tab_polymers.parent_shown () + ) + let content () = [ Html.div @@ -48,6 +62,8 @@ let content () = [ Tyxml_js.R.Html.a_class (React.S.bind Subpanel_editor.editor_full (fun editor_full -> + (* child hiding set here to avoid "gc" *) + let () = childs_hide editor_full in React.S.const (if editor_full then [ "col-md-12"; "flex-content" ] @@ -58,24 +74,11 @@ let content () = rightsubpanel (); ] -let childs_hide b = - if b then ( - let () = Tab_contact_map.parent_hide () in - let () = Tab_influences.parent_hide () in - let () = Tab_constraints.parent_hide () in - Tab_polymers.parent_hide () - ) else ( - let () = Tab_contact_map.parent_shown () in - let () = Tab_influences.parent_shown () in - let () = Tab_constraints.parent_shown () in - Tab_polymers.parent_shown () - ) - let init_dead_rules () = React.S.l1 (fun model -> State_error.wrap ~append:true "tab_editor_dead_rule" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> if model.State_project.model_parameters @@ -121,7 +124,7 @@ let init_dead_agents () = React.S.l1 (fun model -> State_error.wrap ~append:true "tab_editor_dead_agent" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> if model.State_project.model_parameters @@ -163,7 +166,7 @@ let init_non_weakly_reversible_transitions () = React.S.l1 (fun model -> State_error.wrap ~append:true "tab_editor_dead_rule" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> if model.State_project.model_parameters @@ -219,8 +222,6 @@ let init_non_weakly_reversible_transitions () = Lwt.return (Result_util.ok ())))) State_project.model -let dont_gc_me = ref [] - let onload () = let () = Subpanel_editor.onload () in let _ = init_dead_rules () in @@ -230,9 +231,6 @@ let onload () = let () = Tab_influences.onload () in let () = Tab_constraints.onload () in let () = Tab_polymers.onload () in - let () = - dont_gc_me := [ React.S.map childs_hide Subpanel_editor.editor_full ] - in let () = Common.jquery_on "#naveditor" "hide.bs.tab" (fun _ -> childs_hide true) in diff --git a/gui/tab_flux.ml b/gui/tab_flux.ml index 3a4b176e1..3eaa1563f 100644 --- a/gui/tab_flux.ml +++ b/gui/tab_flux.ml @@ -26,7 +26,7 @@ let din_list = in ReactiveData.RList.Set out) ~error:(fun _ -> ReactiveData.RList.Set [])) - (State_simulation.with_simulation_info ~label:__LOC__ + (State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ ~stopped:(fun _ -> Lwt.return (Result_util.ok [])) ~initializing:(fun _ -> Lwt.return (Result_util.ok [])) ~ready:(fun manager _ -> manager#simulation_catalog_din) @@ -50,7 +50,7 @@ let din_data = (Lwt_react.E.from (fun () -> Lwt.map (Result_util.fold ~ok:(fun x -> x) ~error:(fun _ -> None)) - (State_simulation.with_simulation_info ~label:__LOC__ + (State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ ~stopped:(fun _ -> Lwt.return (Result_util.ok None)) ~initializing:(fun _ -> Lwt.return (Result_util.ok None)) ~ready:(fun manager _ -> @@ -126,7 +126,7 @@ let din = let export_current_din to_string mime filename = let din_id = Js.to_string (Tyxml_js.To_dom.of_select din_select)##.value in - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> manager#simulation_detail_din din_id >>= Api_common.result_bind_lwt ~ok:(fun din -> let data = Js.string (to_string din) in diff --git a/gui/tab_influences.ml b/gui/tab_influences.ml index 7072f21ce..7e55db8e9 100644 --- a/gui/tab_influences.ml +++ b/gui/tab_influences.ml @@ -190,7 +190,7 @@ let export_config = (fun filename -> Lwt.ignore_result ( State_error.wrap "influence_map_export" - (State_project.with_project ~label:__LOC__ (fun manager -> + (State_project.eval_with_project ~label:__LOC__ (fun manager -> let { accuracy; _ } = React.S.value model in manager#get_influence_map_raw accuracy >|= Result_util.map (fun influences_string -> @@ -618,7 +618,7 @@ let neither_gc_me = | DrawTabular _ -> Lwt.return (Result_util.ok ()) | DrawGraph { fwd; bwd; total } -> State_error.wrap ~append:true "influence_map" - (State_project.with_project ~label:__LOC__ + (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 @@ -656,7 +656,7 @@ let nor_gc_me = ~on:(React.S.Bool.( && ) tab_is_active track_cursor) (fun filename cursor_pos -> Some - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> manager#get_influence_map_node_at ~filename cursor_pos >|= Result_util.map (fun origin' -> @@ -742,7 +742,7 @@ let onload () = := Dom_html.full_handler (fun _ _ -> let _ = State_error.wrap "influence_map_recenter" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> manager#get_initial_node >|= Result_util.map (fun origin_refined -> @@ -766,7 +766,7 @@ let onload () = let { origin; _ } = React.S.value model in let _ = State_error.wrap "influence_map_next_node" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> manager#get_next_node origin >|= Result_util.map (fun origin_refined -> @@ -790,7 +790,7 @@ let onload () = let { origin; _ } = React.S.value model in let _ = State_error.wrap "influence_map_prev_node" - (State_project.with_project ~label:__LOC__ + (State_project.eval_with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> manager#get_previous_node origin >|= Result_util.map (fun origin_refined -> diff --git a/gui/tab_log.ml b/gui/tab_log.ml index ffe08e44d..696c4d032 100644 --- a/gui/tab_log.ml +++ b/gui/tab_log.ml @@ -6,6 +6,7 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) +open Lwt.Infix module Html = Tyxml_js.Html5 let tab_is_active, set_tab_is_active = React.S.create false @@ -23,24 +24,23 @@ let navli () = let content () = let state_log = + (* We get the signal of log messages for current simulation model. The bind allows to change the signal to the new simulation model when it changes *) React.S.bind (React.S.on tab_is_active State_simulation.dummy_model State_simulation.model) (fun _ -> React.S.hold "" (Lwt_react.E.from (fun () -> - Lwt.map - (fun x -> - match x.Result_util.value with - | Ok x -> x - | Error list -> - String.concat "\n" - (List.map (fun Result_util.{ text; _ } -> text) list)) - (State_simulation.with_simulation_info ~label:__LOC__ - ~ready:(fun manager _ -> - manager#simulation_detail_log_message) - ~stopped:(fun _ -> Lwt.return (Result_util.ok "")) - ~initializing:(fun _ -> Lwt.return (Result_util.ok "")) - ())))) + State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ + ~ready:(fun manager _ -> manager#simulation_detail_log_message) + ~stopped:(fun _ -> Lwt.return (Result_util.ok "")) + ~initializing:(fun _ -> Lwt.return (Result_util.ok "")) + () + >|= fun (x : string Api.result) -> + match x.Result_util.value with + | Ok x -> x + | Error list -> + String.concat "\n" + (List.map (fun Result_util.{ text; _ } -> text) list)))) in [ Html.div diff --git a/gui/tab_outputs.ml b/gui/tab_outputs.ml index b181d5a95..7d0ab5a40 100644 --- a/gui/tab_outputs.ml +++ b/gui/tab_outputs.ml @@ -13,8 +13,8 @@ let select_id = "output-select-id" let tab_is_active, set_tab_is_active = React.S.create false let current_file, set_current_file = React.S.create None -let update_outputs key : unit = - State_simulation.when_ready ~label:__LOC__ (fun manager -> +let update_outputs (key : string) : unit = + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> manager#simulation_detail_file_line key >>= Api_common.result_bind_lwt ~ok:(fun lines -> let () = set_current_file (Some (key, lines)) in @@ -31,14 +31,14 @@ let navli () = Ui_common.badge (fun state -> file_count state) let dont_gc_me = ref [] let xml () = - let select file_line_ids = - let lines = React.S.value current_file in + let select (file_line_ids : string list) : [> Html_types.select ] Html.elt = + let lines : (string * string list) option = React.S.value current_file in let current_file_id : string = match file_line_ids, lines with | [], _ -> assert false | file :: _, None | _ :: _, Some (file, _) -> file in - let file_options = + let file_options : [> Html_types.selectoption ] Html.elt list = List.map (fun key -> Html.option @@ -60,36 +60,37 @@ let xml () = let file_select = Tyxml_js.R.Html.div ~a:[ Html.a_class [ "list-group-item" ] ] - (let list, handle = ReactiveData.RList.create [] in - let () = - dont_gc_me := - [ - React.S.map - (fun _ -> - State_simulation.when_ready ~label:__LOC__ (fun manager -> - manager#simulation_catalog_file_line - >>= Api_common.result_bind_lwt - ~ok:(fun - (file_line_ids : Api_types_j.file_line_catalog) - -> - let () = - ReactiveData.RList.set handle - (match file_line_ids with - | [] -> [] - | key :: [] -> - let () = update_outputs key in - [ - Html.h4 - [ Html.txt (Ui_common.option_label key) ]; - ] - | _ :: _ :: _ -> [ select file_line_ids ]) - in - Lwt.return (Result_util.ok ())))) + (ReactiveData.RList.from_event [] + (Lwt_react.E.map_s + (fun _ -> + State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ + ~stopped:(fun _ -> Lwt.return (Result_util.ok [])) + ~initializing:(fun _ -> Lwt.return (Result_util.ok [])) + ~ready:(fun manager _ -> + manager#simulation_catalog_file_line + >>= Api_common.result_bind_lwt + ~ok:(fun + (file_line_ids : Api_types_j.file_line_catalog) -> + let select_file : [> `H4 | `Select ] Html.elt list = + (* TODO: name *) + match file_line_ids with + | [] -> [] + | key :: [] -> + let () = update_outputs key in + [ + Html.h4 + [ Html.txt (Ui_common.option_label key) ]; + ] + | _ :: _ :: _ -> [ select file_line_ids ] + in + Lwt.return (Result_util.ok select_file))) + () + >|= Result_util.fold + ~ok:(fun x -> ReactiveData.RList.Set x) + ~error:(fun _ -> ReactiveData.RList.Set [])) + (React.S.changes (React.S.on tab_is_active State_simulation.dummy_model - State_simulation.model); - ] - in - list) + State_simulation.model)))) in let file_content = [ diff --git a/gui/tab_plot.ml b/gui/tab_plot.ml index eec39ef03..239a6c443 100644 --- a/gui/tab_plot.ml +++ b/gui/tab_plot.ml @@ -28,7 +28,7 @@ let has_plot (state : Api_types_j.simulation_info option) : bool = > 0 let export_json filename = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> manager#simulation_detail_plot { Api_types_j.plot_limit_offset = None; @@ -42,7 +42,7 @@ let export_json filename = Lwt.return (Result_util.ok ()))) let export mime filename = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> manager#simulation_detail_plot { Api_types_j.plot_limit_offset = None; @@ -149,7 +149,7 @@ let plot_parameter () : Api_types_j.plot_parameter = } let update_plot (js_plot : Js_plot.observable_plot Js.t) : unit = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> let () = update_offset true in manager#simulation_detail_plot (plot_parameter ()) >>= Api_common.result_bind_lwt ~ok:(fun (plot : Api_types_t.plot) -> diff --git a/gui/tab_snapshot.ml b/gui/tab_snapshot.ml index 953d2417b..fcbaf30bd 100644 --- a/gui/tab_snapshot.ml +++ b/gui/tab_snapshot.ml @@ -110,27 +110,29 @@ let render_snapshot_graph (snapshot_js : Js_snapshot.snapshot Js.t) snapshot_js##setData ~contact_map:(Js.string contact_map) (Js.string json) | Kappa -> () -let select_snapshot snapshot_js = - let index = +let select_snapshot (snapshot_js : Js_snapshot.snapshot Js.t) : unit = + let index : int Js.opt = Js.Opt.bind (Ui_common.document##getElementById (Js.string select_id)) (fun dom -> let snapshot_select_dom : Dom_html.inputElement Js.t = Js.Unsafe.coerce dom in - let fileindex = Js.to_string snapshot_select_dom##.value in + let fileindex : string = Js.to_string snapshot_select_dom##.value in try Js.some (int_of_string fileindex) with _ -> Js.null) in let () = Common.debug index in - let model = React.S.value State_simulation.model in - let simulation_output = State_simulation.model_simulation_info model in + let model : State_simulation.t = React.S.value State_simulation.model in + let simulation_output : Api_types_t.simulation_info option = + State_simulation.model_simulation_info model + in match simulation_output with | None -> () | Some state -> - let index = Js.Opt.get index (fun _ -> 0) in + let index : int = Js.Opt.get index (fun _ -> 0) in if snapshot_count (Some state) > 0 then ( let () = - State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_simulation.eval_when_ready ~label:__LOC__ (fun manager -> manager#simulation_catalog_snapshot >>= Api_common.result_bind_lwt ~ok:(fun snapshot_ids -> try @@ -154,7 +156,8 @@ let select_snapshot snapshot_js = () ) -let select (snapshots : Api_types_j.snapshot_id list) = +let select (snapshots : Api_types_j.snapshot_id list) : + [> Html_types.selectoption ] Html.elt list = List.mapi (fun i snapshot_id -> Html.option @@ -197,18 +200,17 @@ let xml () = (Lwt_react.E.map_s (fun _ -> let () = select_snapshot snapshot_js in - Lwt.map - (Result_util.fold - ~ok:(fun x -> ReactiveData.RList.Set x) - ~error:(fun _ -> ReactiveData.RList.Set [])) - (State_simulation.with_simulation_info ~label:__LOC__ - ~stopped:(fun _ -> Lwt.return (Result_util.ok [])) - ~initializing:(fun _ -> Lwt.return (Result_util.ok [])) - ~ready:(fun manager _ -> - manager#simulation_catalog_snapshot - >>= Api_common.result_bind_lwt ~ok:(fun snapshot_ids -> - Lwt.return (Result_util.ok (select snapshot_ids)))) - ())) + State_simulation.eval_with_sim_manager_and_info ~label:__LOC__ + ~stopped:(fun _ -> Lwt.return (Result_util.ok [])) + ~initializing:(fun _ -> Lwt.return (Result_util.ok [])) + ~ready:(fun manager _ -> + manager#simulation_catalog_snapshot + >>= Api_common.result_bind_lwt ~ok:(fun snapshot_ids -> + Lwt.return (Result_util.ok (select snapshot_ids)))) + () + >|= Result_util.fold + ~ok:(fun x -> ReactiveData.RList.Set x) + ~error:(fun _ -> ReactiveData.RList.Set [])) (React.S.changes (React.S.on tab_is_active State_simulation.dummy_model State_simulation.model))) diff --git a/gui/tab_stories.ml b/gui/tab_stories.ml index 6549cf67e..cf8b668b9 100644 --- a/gui/tab_stories.ml +++ b/gui/tab_stories.ml @@ -113,7 +113,7 @@ let lift_result = function | Result.Error e -> Api_common.result_error_msg e let do_update_compression_level () = - State_project.with_project ~label:"Config compression" (fun manager -> + State_project.eval_with_project ~label:"Config compression" (fun manager -> let causal = Js.to_bool none_box##.checked in let weak = Js.to_bool weak_box##.checked in let strong = Js.to_bool strong_box##.checked in @@ -136,7 +136,7 @@ let set_a_story = let id = int_of_string va in if !pred_id <> id then ( let () = pred_id := id in - State_project.with_project ~label:"Launch stories" (fun manager -> + State_project.eval_with_project ~label:"Launch stories" (fun manager -> match Mods.IntMap.find_option id manager#story_list with | None -> Lwt.return (Result_util.ok ()) | Some (_cm, d, v) -> @@ -169,7 +169,7 @@ let set_a_story = ) let rec inspect_stories () = - State_project.with_project ~label:"Stories list" (fun manager -> + State_project.eval_with_project ~label:"Stories list" (fun manager -> let () = list_control (Mods.IntMap.fold @@ -179,7 +179,7 @@ let rec inspect_stories () = let () = log_control manager#story_log in set_a_story ()) >>= fun _ -> - State_project.with_project ~label:"Stories computing" (fun manager -> + State_project.eval_with_project ~label:"Stories computing" (fun manager -> Lwt.return (Result_util.ok manager#is_computing)) >>= Result_util.fold ~ok:(fun b -> @@ -218,7 +218,7 @@ let onload () = (Tyxml_js.To_dom.of_button launch_button)##.onclick := Dom_html.handler (fun _ -> let _ = - State_project.with_project ~label:"Launch stories" (fun manager -> + State_project.eval_with_project ~label:"Launch stories" (fun manager -> if manager#story_is_computing then Lwt.return (Result_util.ok ()) else