fix(log tab): remove infinite loop of log queries

core/api/kappa_facade.ml

@@ -159,7 +159,7 @@ let parse ~patternSharing (parsing_compil : Ast.parsing_compil) var_overwrite
       >>= fun (ast_compiled_data : LKappa_compiler.ast_compiled_data) ->
       yield () >>= fun () ->
       (* The last yield is updated after the last yield.
-         It is gotten here for the initial last yeild value. *)
+         It is gotten here for the initial last yield value. *)
       let lastyield = Sys.time () in
       try
         (* exception raised by compile must have used Lwt.fail.

core/api/kasim_client.ml

@@ -253,7 +253,7 @@ class virtual new_client ~post () : manager_simulation_mpi =
         in
         result
       ) else
-        Lwt.return (Api_common.err_result_of_string "Kappa has died")
+        Lwt.return (Api_common.err_result_of_string "Kasim has died")
 
     method private sim_is_computing = not (IntMap.is_empty context.mailboxes)
   end

gui/lib/ui_common.ml

@@ -236,6 +236,21 @@ let id_dom (id : string) : 'a Js.t =
            (Format.sprintf "ui_common.id_dom : could not find id %s" id))
       : Dom_html.element Js.t)
 
+let switch_class elt_id add_list remove_list =
+  let dom_elt : 'a Js.t = 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
+
+(* modals *)
+
 let create_modal_text_input ~(id : string) ~(title_label : string)
     ~(body : [< Html_types.div_content_fun ] Html.elt Html.list_wrap)
     ~(submit_label : string) ~(submit : ('self Js.t, _ Js.t) Dom.event_listener)

gui/lib/ui_common.mli

@@ -56,8 +56,12 @@ module type Panel = sig
   val onresize : unit -> unit
 end
 
-val id_dom : string -> 'a Js.t
 val document : Dom_html.document Js.t
+val id_dom : string -> 'a Js.t
+
+val switch_class : string -> string list -> string list -> unit
+(** [switch_class elt_id add_list remove_list] adds and removes classes 
+    to DOM element with id `elt_id` *)
 
 val navtabs :
   string ->

gui/lib_no_jsoo/hooked.ml

@@ -15,6 +15,7 @@ module type S = sig
     'a t * (?debug:string -> 'a -> unit)
 
   val register : 'a t -> ('a -> unit) -> unit
+  val register_lwt : 'a t -> ('a -> unit Lwt.t) -> unit
   val value : 'a t -> 'a
   val set : ?debug:string -> 'a t -> 'a -> unit
 
@@ -57,6 +58,7 @@ module MakeS (D : DebugPrint) : S = struct
   type 'a t = {
     mutable value: 'a;
     mutable hooks: ('a -> unit) list;
+    mutable hooks_lwt: ('a -> unit Lwt.t) list;
     eq: 'a -> 'a -> bool;
     signal: 'a React.signal;
     set_signal: ?step:React.step -> 'a -> unit;
@@ -79,6 +81,7 @@ module MakeS (D : DebugPrint) : S = struct
       {
         value = a;
         hooks = [];
+        hooks_lwt = [];
         eq;
         signal;
         set_signal;
@@ -93,10 +96,18 @@ module MakeS (D : DebugPrint) : S = struct
     _log hooked "register";
     hooked.hooks <- f :: hooked.hooks
 
+  let register_lwt hooked f =
+    _log hooked "register";
+    hooked.hooks_lwt <- f :: hooked.hooks_lwt
+
   let value hooked =
     _log hooked "value";
     hooked.value
 
+  let call_hooks hooked =
+    List.iter (fun f -> f hooked.value) hooked.hooks;
+    List.iter (fun f -> f hooked.value |> ignore) hooked.hooks_lwt
+
   let set ?(debug = "") hooked value =
     let value_changed = hooked.eq value hooked.value in
     if not value_changed then (
@@ -108,7 +119,7 @@ module MakeS (D : DebugPrint) : S = struct
               "")
            (List.length hooked.hooks));
       hooked.value <- value;
-      List.iter (fun f -> f value) hooked.hooks;
+      call_hooks hooked;
       hooked.set_signal value
     ) else
       _log hooked "set NO change"

gui/lib_no_jsoo/hooked.mli

@@ -14,6 +14,7 @@ module type S = sig
     'a t * (?debug:string -> 'a -> unit)
 
   val register : 'a t -> ('a -> unit) -> unit
+  val register_lwt : 'a t -> ('a -> unit Lwt.t) -> unit
   val value : 'a t -> 'a
   val set : ?debug:string -> 'a t -> 'a -> unit
 

gui/state/state_simulation.ml

@@ -8,6 +8,7 @@
 
 open Lwt.Infix
 
+(* private simulation state *)
 type simulation_state =
   | SIMULATION_STATE_STOPPED (* simulation is unavailable *)
   | SIMULATION_STATE_INITALIZING (* simulation is blocked on an operation *)
@@ -16,31 +17,25 @@ type simulation_state =
 
 type t = { simulation_state: simulation_state }
 
-let t_simulation_state simulation = simulation.simulation_state
-
-let t_simulation_info simulation : Api_types_j.simulation_info option =
+let get_simulation_info simulation : Api_types_j.simulation_info option =
   match simulation.simulation_state with
   | SIMULATION_STATE_STOPPED -> None
   | SIMULATION_STATE_INITALIZING -> None
   | SIMULATION_STATE_READY simulation_info -> Some simulation_info
 
-type state = t
-type model = state
-type model_state = STOPPED | INITALIZING | RUNNING | PAUSED
+(* public simulation status *)
+type simulation_status = STOPPED | INITALIZING | RUNNING | PAUSED
 
-let model_state_to_string = function
+let simulation_status_to_string = function
   | STOPPED -> "Stopped"
   | INITALIZING -> "Initalizing"
   | RUNNING -> "Running"
   | PAUSED -> "Paused"
 
 let dummy_model = { simulation_state = SIMULATION_STATE_STOPPED }
 
-let model_simulation_info model : Api_types_j.simulation_info option =
-  t_simulation_info model
-
-let model_simulation_state model : model_state =
-  match t_simulation_state model with
+let model_simulation_state model : simulation_status =
+  match model.simulation_state with
   | SIMULATION_STATE_STOPPED -> STOPPED
   | SIMULATION_STATE_INITALIZING -> INITALIZING
   | SIMULATION_STATE_READY simulation_info ->
@@ -52,14 +47,16 @@ let model_simulation_state model : model_state =
     else
       PAUSED
 
+(* private state *)
 let state, set_state = React.S.create dummy_model
 
+(* public model *)
+let model = state
+
 let update_simulation_state (simulation_state : simulation_state) : unit =
   let () = set_state { simulation_state } in
   ()
 
-let model : model React.signal = state
-
 let eval_with_sim_manager :
       'a.
       label:string ->

gui/state/state_simulation.mli

@@ -8,18 +8,14 @@
 
 type t
 
-val t_simulation_info : t -> Api_types_j.simulation_info option
+val get_simulation_info : t -> Api_types_j.simulation_info option
+val dummy_model : t
+val model : t React.signal
 
-type model = t
+type simulation_status = STOPPED | INITALIZING | RUNNING | PAUSED
 
-val dummy_model : model
-val model : model React.signal
-val model_simulation_info : model -> Api_types_j.simulation_info option
-
-type model_state = STOPPED | INITALIZING | RUNNING | PAUSED
-
-val model_state_to_string : model_state -> string
-val model_simulation_state : t -> model_state
+val simulation_status_to_string : simulation_status -> string
+val model_simulation_state : t -> simulation_status
 
 (* run on application init *)
 val init : unit -> unit Lwt.t

gui/ui/panel_preferences.ml

@@ -11,7 +11,8 @@ open Lwt.Infix
 open List_util.Infix
 
 let visible_on_states ?(a_class = [])
-    (state : State_simulation.model_state list) : string list React.signal =
+    (state : State_simulation.simulation_status list) : string list React.signal
+    =
   let hidden_class = [ "hidden" ] in
   let visible_class = [ "visible" ] in
   React.S.bind State_simulation.model (fun model ->
@@ -551,7 +552,7 @@ module DivStatusIndicator : Ui_common.Div = struct
           Tyxml_js.R.Html.txt
             (React.S.bind State_simulation.model (fun model ->
                  let label =
-                   State_simulation.model_state_to_string
+                   State_simulation.simulation_status_to_string
                      (State_simulation.model_simulation_state model)
                  in
                  React.S.const label));
@@ -589,7 +590,7 @@ module RunningPanelLayout : Ui_common.Div = struct
     progress_bar
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            let time_percent : int option =
              Option_util.bind
                (fun (status : Api_types_j.simulation_info) ->
@@ -602,7 +603,7 @@ module RunningPanelLayout : Ui_common.Div = struct
          State_simulation.model)
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            let time : float option =
              Option_util.map
                (fun (status : Api_types_j.simulation_info) ->
@@ -618,7 +619,7 @@ module RunningPanelLayout : Ui_common.Div = struct
     progress_bar
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            let event_percentage : int option =
              Option_util.bind
                (fun (status : Api_types_j.simulation_info) ->
@@ -633,7 +634,7 @@ module RunningPanelLayout : Ui_common.Div = struct
          State_simulation.model)
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            let event : int option =
              Option_util.map
                (fun (status : Api_types_j.simulation_info) ->
@@ -665,7 +666,7 @@ module RunningPanelLayout : Ui_common.Div = struct
     Tyxml_js.R.Html.txt
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            match tracked_events simulation_info with
            | Some tracked_events -> string_of_int tracked_events
            | None -> " ")
@@ -675,7 +676,7 @@ module RunningPanelLayout : Ui_common.Div = struct
     Tyxml_js.R.Html.txt
       (React.S.map
          (fun model ->
-           let simulation_info = State_simulation.model_simulation_info model in
+           let simulation_info = State_simulation.get_simulation_info model in
            match tracked_events simulation_info with
            | Some _ -> "tracked events"
            | None -> " ")

gui/ui/panel_tabs/tab_editor/subtab_influences.ml

@@ -163,32 +163,16 @@ 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
+  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
+      Ui_common.switch_class track_cursor_switch_id add_list remove_list);
   let on_click _ =
     let () = track_cursor_set (not (Hooked.S.value track_cursor)) in
     if Hooked.S.value track_cursor then

gui/ui/panel_tabs/tab_log.ml

@@ -9,7 +9,7 @@
 open Lwt.Infix
 module Html = Tyxml_js.Html5
 
-let tab_is_active, set_tab_is_active = React.S.create false
+let tab_is_active, set_tab_is_active = Hooked.S.create false
 let tab_was_active = ref false
 
 let line_count state =
@@ -20,32 +20,38 @@ let line_count state =
     state.simulation_info_output.simulation_output_log_messages
 
 let navli () =
-  Ui_track_sim_status.label_news tab_is_active (fun state -> line_count state)
+  Ui_track_sim_status.label_news (Hooked.S.to_react_signal tab_is_active)
+    (fun state -> line_count state)
 
 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 () ->
-               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))))
+  let content_log_id = "content_log_id" in
+  let update_log_content (log : string) =
+    let dom_elt : 'a Js.t = Ui_common.id_dom content_log_id in
+    dom_elt##.innerText := Js.string log
   in
+  Hooked.S.register_lwt
+    (Hooked.S.on tab_is_active State_simulation.dummy_model
+       (Hooked.S.of_react_signal State_simulation.model))
+    (fun _ ->
+      Common.debug ~loc:__LOC__ "[tab_log] Updating log";
+      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))
+      |> update_log_content);
   [
     Html.div
-      ~a:[ Html.a_class [ "panel-pre"; "panel-scroll" ] ]
-      [ Tyxml_js.R.Html.txt state_log ];
+      ~a:
+        [
+          Html.a_id content_log_id; Html.a_class [ "panel-pre"; "panel-scroll" ];
+        ]
+      [ Html.txt "No log yet." ];
   ]
 
 let parent_hide () = set_tab_is_active false