Adding Hooked module to replace signals by hooks, apply to state_error

gui/common.ml

@@ -167,3 +167,34 @@ let hide_codemirror () : unit =
 
 let show_codemirror () : unit =
  Js.Unsafe.fun_call (Js.Unsafe.js_expr "showCodeMirror") [||]
+
+module Hooked = struct
+ type 'a t = {
+ value: 'a ref;
+ hooks: ('a -> unit) list ref;
+ eq: 'a -> 'a -> bool;
+ signal: 'a React.signal;
+ set_signal: ?step:React.step -> 'a -> unit;
+ }
+
+ let make ?(eq : 'a -> 'a -> bool = ( = )) (a : 'a) : 'a t =
+ let signal, set_signal = React.S.create a in
+ { value = ref a; hooks = ref []; eq; signal; set_signal }
+
+ let register hooked f = hooked.hooks := f :: !(hooked.hooks)
+ let v hooked = !(hooked.value)
+
+ let set hooked value =
+ if not (hooked.eq value !(hooked.value)) then (
+ List.iter (fun f -> f value) !(hooked.hooks);
+ hooked.value := value;
+ hooked.set_signal value
+ )
+
+ let create hooked f =
+ let new_hooked = make (f (v hooked)) in
+ register hooked (fun value -> set new_hooked (f value));
+ new_hooked
+
+ let to_signal hooked = hooked.signal
+end

gui/common.mli

@@ -43,3 +43,20 @@ val children_value :
 
 val hide_codemirror : unit -> unit
 val show_codemirror : unit -> unit
+
+(** Attach hooks to a value, called when value changes
+ *
+ * Can be used to imitate the React signals logic, but avoiding to be "GC'ed" *)
+module Hooked : sig
+ type 'a t
+
+ val make : ?eq:('a -> 'a -> bool) -> 'a -> 'a t
+ val register : 'a t -> ('a -> unit) -> unit
+ val v : 'a t -> 'a
+ val set : 'a t -> 'a -> unit
+
+ val create : 'a t -> ('a -> 'b) -> 'b t
+ (** Create new hooked built on changes of this one, mimicking the propagation of the signal *)
+
+ val to_signal : 'a t -> 'a React.signal
+end

gui/dune

@@ -1,7 +1,7 @@
 (library
  (name kappa_js_lib)
  (modules Common)
- (libraries js_of_ocaml-lwt)
+ (libraries js_of_ocaml-lwt lwt_react)
  (preprocess
  (pps js_of_ocaml-ppx tyxml-ppx))
  (flags :standard -w +a -open Js_of_ocaml))

gui/panel_settings.ml

@@ -178,33 +178,30 @@ 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, set_error_index = React.S.create None
-
- let dont_gc_me =
- React.S.l1
- (function
- | [] -> ()
- | _ :: _ ->
- (match React.S.value error_index with
- | None -> set_error_index (Some 0)
- | Some _ -> ()))
- State_error.errors
+ let error_index = Common.Hooked.make None
+
+ let () =
+ Common.Hooked.register State_error.errors (function
+ | [] -> ()
+ | _ :: _ ->
+ (match Common.Hooked.v error_index with
+ | None -> Common.Hooked.set error_index (Some 0)
+ | Some _ -> ()))
 
  (* if there are less or no errors the index needs to be updated *)
  let sanitize_index (index : int option) errors : int option =
- let () = ignore dont_gc_me in
  match index, errors with
  | None, [] -> None
  | None, _ :: _ -> Some 0
  | Some _, [] -> None
  | Some index, error ->
  let length = List.length error in
  if index > length then (
- let () = set_error_index (Some 0) in
+ let () = Common.Hooked.set error_index (Some 0) in
  Some 0
  ) else if 0 > index then (
  let index = Some (List.length error - 1) in
- let () = set_error_index index in
+ let () = Common.Hooked.set error_index index in
  index
  ) else
  Some index
@@ -214,7 +211,7 @@ module DivErrorMessage : Ui_common.Div = struct
  (fun n -> Some (List.nth errors n))
  (sanitize_index index errors)
 
- let mesage_nav_text =
+ let message_nav_text =
  React.S.l2
  (fun index error ->
  match index, error with
@@ -223,11 +220,12 @@ module DivErrorMessage : Ui_common.Div = struct
  | None, _ :: _ -> ""
  | Some index, (_ :: _ as errors) ->
  Format.sprintf "%d/%d" (index + 1) (List.length errors))
- error_index State_error.errors
+ (Common.Hooked.to_signal error_index)
+ (Common.Hooked.to_signal State_error.errors)
 
  let a_class =
  Tyxml_js.R.Html.a_class
- (React.S.bind State_error.errors (fun error ->
+ (React.S.bind (Common.Hooked.to_signal State_error.errors) (fun error ->
  React.S.const
  (match error with
  | [] | [ _ ] -> [ "hide" ]
@@ -240,7 +238,7 @@ module DivErrorMessage : Ui_common.Div = struct
  Html.span ~a:[ Html.a_id message_nav_inc_id; a_class ] [ Html.txt " » " ]
 
  let message_nav =
- [ message_nav_dec; Tyxml_js.R.Html.txt mesage_nav_text; message_nav_inc ]
+ [ message_nav_dec; Tyxml_js.R.Html.txt message_nav_text; message_nav_inc ]
 
  let file_label_text =
  React.S.l2
@@ -253,7 +251,8 @@ module DivErrorMessage : Ui_common.Div = struct
  match range with
  | None -> ""
  | Some range -> Format.sprintf "[%s]" range.Loc.file)
- error_index State_error.errors
+ (Common.Hooked.to_signal error_index)
+ (Common.Hooked.to_signal State_error.errors)
 
  let file_label =
  Html.span
@@ -270,7 +269,8 @@ module DivErrorMessage : Ui_common.Div = struct
  match get_message index error with
  | None -> ""
  | Some message -> Format.sprintf " %s " message.Result_util.text)
- error_index State_error.errors
+ (Common.Hooked.to_signal error_index)
+ (Common.Hooked.to_signal State_error.errors)
 
  let error_message =
  Html.span
@@ -283,7 +283,8 @@ module DivErrorMessage : Ui_common.Div = struct
  [
  Html.a_id id;
  Tyxml_js.R.Html.a_class
- (React.S.bind State_error.errors (fun error ->
+ (React.S.bind (Common.Hooked.to_signal State_error.errors)
+ (fun error ->
  React.S.const
  (match error with
  | [] -> [ "alert-sm"; "alert" ]
@@ -302,8 +303,8 @@ module DivErrorMessage : Ui_common.Div = struct
  let () = Common.debug (Js.string "file_click_handler") in
  let message : Api_types_t.message option =
  get_message
- (React.S.value error_index)
- (React.S.value State_error.errors)
+ (Common.Hooked.v error_index)
+ (Common.Hooked.v State_error.errors)
  in
  let range =
  Option_util.bind
@@ -326,14 +327,14 @@ module DivErrorMessage : Ui_common.Div = struct
  let () = Common.debug (Js.string "index_click_handler") in
  let index : int option =
  sanitize_index
- (React.S.value error_index)
- (React.S.value State_error.errors)
+ (Common.Hooked.v error_index)
+ (Common.Hooked.v State_error.errors)
  in
  let index = Option_util.map delta index in
  let index : int option =
- sanitize_index index (React.S.value State_error.errors)
+ sanitize_index index (Common.Hooked.v State_error.errors)
  in
- let () = set_error_index index in
+ let () = Common.Hooked.set error_index index in
  Js._true)
  in
  ()

gui/state_error.ml

@@ -13,7 +13,12 @@ type t = {
  _state_error_location: string;
 }
 
-let state_error, set_state_error = React.S.create ([] : t list)
+let state_error = Common.Hooked.make []
+
+(* TODO clean this *)
+(* TODO: move hook logic into a dedicated module *)
+let set_state_error state_error_new =
+ Common.Hooked.set state_error state_error_new
 
 let clear_errors location =
  let () =
@@ -22,7 +27,7 @@ let clear_errors location =
  set_state_error []
 
 let has_errors () =
- match React.S.value state_error with
+ match Common.Hooked.v state_error with
  | [] -> false
  | _ :: _ -> true
 
@@ -36,20 +41,18 @@ 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 = React.S.value state_error in
+ let current_state_error : t list = Common.Hooked.v state_error in
  let new_state_error : t list =
  { state_error_errors = errors; _state_error_location = location }
  :: current_state_error
  in
  set_state_error new_state_error
 
-let errors : Result_util.message list React.signal =
- React.S.map
- (fun (state_error : t list) ->
+let errors : Result_util.message list Common.Hooked.t =
+ Common.Hooked.create state_error (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.result Lwt.t -> 'a Api.result Lwt.t =

gui/state_error.mli

@@ -26,7 +26,7 @@ val set_errors : append:bool -> string -> Api_types_j.errors -> unit
 val has_errors : unit -> bool
 (** Return true if errors are present. *)
 
-val errors : Result_util.message list React.signal
+val errors : Result_util.message list Common.Hooked.t
 (** Signal containing the error. *)
 
 val add_error : string -> Result_util.message list -> unit

gui/subpanel_editor.ml

@@ -80,7 +80,8 @@ let content () =
  [ textarea ];
  ]
 
-let error_lint errors : Codemirror.lint Js.t Js.js_array Js.t =
+let error_lint (errors : Result_util.message list) :
+ Codemirror.lint Js.t Js.js_array Js.t =
  let position p = new%js Codemirror.position (p.Loc.line - 1) p.Loc.chr in
  let hydrate (error : Api_types_j.message) : lint Js.t option =
  match error.Result_util.range with
@@ -117,8 +118,6 @@ let error_lint errors : Codemirror.lint Js.t Js.js_array Js.t =
  | Some value -> value :: acc)
  [] errors))
 
-let setup_lint _ _ _ = error_lint (React.S.value State_error.errors)
-
 (* http:https://stackoverflow.com/questions/10575343/codemirror-is-it-possible-to-scroll-to-a-line-so-that-it-is-in-the-middle-of-w *)
 let jump_to_line (codemirror : codemirror Js.t) (line : int) : unit =
  let position : position Js.t = new%js Codemirror.position line 0 in
@@ -133,12 +132,14 @@ let jump_to_line (codemirror : codemirror Js.t) (line : int) : unit =
  let () = codemirror##scrollTo Js.null (Js.some scrollLine) in
  ()
 
-let dont_gc_me_signals = ref []
-
 let onload () : unit =
  let () = Menu_editor_file.onload () in
  let lint_config = Codemirror.create_lint_configuration () in
- let () = lint_config##.getAnnotations := setup_lint in
+ let () =
+ Common.Hooked.register State_error.errors (fun errors ->
+ let setup_lint _ _ _ = error_lint errors in
+ lint_config##.getAnnotations := setup_lint)
+ in
  let () = lint_config##.lintOnChange := Js._false in
  let configuration = Codemirror.default_configuration in
  let gutter_options =
@@ -231,8 +232,8 @@ let onload () : unit =
  Js._true)
  in
  let () =
- dont_gc_me_signals :=
- [ React.S.map (fun _ -> codemirror##performLint) State_error.errors ]
+ Common.Hooked.register State_error.errors (fun _errors ->
+  codemirror##performLint)
  in
  let () =
  State_file.register_refresh_file_hook (fun refresh ->