diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 798ee7c12..e8fcc0b65 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -95,7 +95,7 @@ jobs: - name: Make Javascript app run: | opam exec -- make Kappapp.tar.gz build/site/index.html - cp -r gui/viz . + cp -r gui/js_lib/viz . mv build/Kappapp.tar.gz . mv build/site . - name: Archive Javascript app diff --git a/.ocamlformat b/.ocamlformat index d6edf85ec..3eebd08b9 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/Makefile b/Makefile index 3e6f4235d..f2816916f 100644 --- a/Makefile +++ b/Makefile @@ -15,10 +15,14 @@ SCRIPTSSOURCE = $(wildcard $(MANSCRIPTREP)*.sh) SCRIPTSWITNESS = $(SCRIPTSSOURCE:.sh=.witness) $(MANGENREP)version.tex MODELS = $(wildcard $(MANKAPPAMODELSREP)*.ka) -RESOURCES_HTML=$(wildcard gui/shared/*.js) $(wildcard gui/viz/*.js) $(wildcard gui/viz/*.css) gui/favicon.ico gui/package.json +RESOURCES_HTML=$(wildcard gui/js_lib/*.js) $(wildcard gui/js_lib/viz/*.js) $(wildcard gui/resources/*.css) gui/resources/favicon.ico gui/entry_point/package.json gui/entry_point/main.js +# `APP_EXT` defines where to fetch the js libs. +# `local` is to download them from the dev website e.g. github and saving them locally. +# `cdn` uses `cdnjs.cloudfare.com` to fetch the libs +# `debian` and `deploy` are also available APP_EXT?=cdn -INDEX_HTML=gui/use-$(APP_EXT).html +INDEX_HTML=gui/entry_point/use-$(APP_EXT).html ifeq ($(APP_EXT),local) SITE_EXTRAS= build/site/external build/site/external/bootstrap-$(BOOTSTRAP_VERSION)-dist build/site/external/codemirror-$(CODEMIRROR_VERSION) build/site/external/dagre-d3 build/site/external/d3 build/site/external/jquery else @@ -174,7 +178,7 @@ Kappapp: build/Kappapp.tar.gz: build/Kappapp tar -C build -czf $@ Kappapp - rm -r build/Kappapp + rm -rf build/Kappapp Kappapp.tar.gz: build/Kappapp.tar.gz @@ -204,7 +208,7 @@ KappaBin: build/KappaBin.zip: build/KappaBin zip -y -r $@ build/KappaBin - rm -r build/KappaBin + rm -rf build/KappaBin KappaBin.zip: build/KappaBin.zip @@ -228,12 +232,12 @@ Kappapp.app: +$(MAKE) clean +$(MAKE) build/Kappapp.app -build/Info.plist: gui/Info.plist.skel $(wildcard .git/refs/heads/*) +build/Info.plist: gui/resources/Info.plist.skel $(wildcard .git/refs/heads/*) mkdir -p build sed -e s/'\(.*\)\".*tag: \([^,\"]*\)[,\"].*/\1\"\2\"'/g $< | \ sed -e 's/\$$Format:%D\$$'/"$$(git describe --always --dirty || echo unkown)"/ > $@ -build/Kappa.iconset: gui/Kappa-Logo.png +build/Kappa.iconset: gui/resources/Kappa-Logo.png mkdir -p build rm -rf $@ && mkdir $@ sips -z 16 16 $< --out $@/icon_16x16.png diff --git a/core/parameters/exception_without_parameter.ml b/core/parameters/exception_without_parameter.ml index 6ff75c776..0e10b10d2 100644 --- a/core/parameters/exception_without_parameter.ml +++ b/core/parameters/exception_without_parameter.ml @@ -243,7 +243,7 @@ let to_json exceptions_caught_and_uncaught = ( "caught", JsonUtil.of_list caught_exception_to_json exceptions_caught_and_uncaught.caught_error_list ); - ( "caught", + ( "caught_to_ui", JsonUtil.of_list caught_exception_to_json exceptions_caught_and_uncaught.caught_error_list_to_ui ); ( "uncaught", diff --git a/core/parameters/exception_without_parameter.mli b/core/parameters/exception_without_parameter.mli index 718e398e5..9ef88d12e 100644 --- a/core/parameters/exception_without_parameter.mli +++ b/core/parameters/exception_without_parameter.mli @@ -12,6 +12,13 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) +(* The logic in this files describes a `degraded` mode for exceptions, before + the remanent_parameters were loaded. + these exceptions did not stop execution, so `uncaught` and `caught` may not + be good naming here. `caught` here basically add a trace to uncaught info + TODO: revamp/rename this? + *) + type uncaught_exception exception Uncaught_exception of uncaught_exception @@ -31,7 +38,10 @@ val build_caught_exception : string option -> string option -> exn -> string list -> caught_exception val add_uncaught_error : - ?to_ui:bool -> uncaught_exception -> exceptions_caught_and_uncaught -> exceptions_caught_and_uncaught + ?to_ui:bool -> + uncaught_exception -> + exceptions_caught_and_uncaught -> + exceptions_caught_and_uncaught val stringlist_of_exception : exn -> string list -> string list val stringlist_of_uncaught : uncaught_exception -> string list -> string list @@ -41,10 +51,18 @@ val pp_exception : Format.formatter -> exn -> unit val pp_uncaught : Format.formatter -> uncaught_exception -> unit val pp_caught : Format.formatter -> caught_exception -> unit val empty_exceptions_caught_and_uncaught : exceptions_caught_and_uncaught -val is_empty_exceptions_caught_and_uncaught : exceptions_caught_and_uncaught -> bool -val get_caught_exception_list : exceptions_caught_and_uncaught -> caught_exception list -val get_caught_exception_list_to_ui : exceptions_caught_and_uncaught -> caught_exception list -val get_uncaught_exception_list : exceptions_caught_and_uncaught -> uncaught_exception list + +val is_empty_exceptions_caught_and_uncaught : + exceptions_caught_and_uncaught -> bool + +val get_caught_exception_list : + exceptions_caught_and_uncaught -> caught_exception list + +val get_caught_exception_list_to_ui : + exceptions_caught_and_uncaught -> caught_exception list + +val get_uncaught_exception_list : + exceptions_caught_and_uncaught -> uncaught_exception list val get_uncaught_exception_list_to_ui : exceptions_caught_and_uncaught -> uncaught_exception list diff --git a/core/simulation/dune b/core/simulation/dune index 5a0efe983..4b76e3451 100644 --- a/core/simulation/dune +++ b/core/simulation/dune @@ -19,8 +19,8 @@ (targets resource_strings.ml) (deps ../../dev/load_files_into_ocaml_string_vars.sh - ../../gui/shared/flux.js - ../../gui/viz/common.js) + ../../gui/js_lib/flux.js + ../../gui/js_lib/viz/common.js) (action (with-stdout-to %{targets} diff --git a/dune-project b/dune-project index 5677cdfb3..3aa2349f3 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.15.1 )) kappa-binaries kappa-agents ) diff --git a/gui/JsSim.ml b/gui/JsSim.ml index 1a6ba6d21..1faf32360 100644 --- a/gui/JsSim.ml +++ b/gui/JsSim.ml @@ -12,22 +12,22 @@ let onload (_ : 'a) : bool Js.t = let () = Dom.appendChild main (Tyxml_js.To_dom.of_div (Panel_projects.content ())) in - let () = Dom.appendChild main (Panel_tab.navtabs ()) in - let () = Dom.appendChild main (Panel_tab.navcontents ()) in + let () = Dom.appendChild main (Panel_tabs.navtabs ()) in + let () = Dom.appendChild main (Panel_tabs.navcontents ()) in let () = - Dom.appendChild main (Tyxml_js.To_dom.of_div (Panel_settings.content ())) + Dom.appendChild main (Tyxml_js.To_dom.of_div (Panel_preferences.content ())) in let () = Panel_projects.onload () in - let () = Panel_tab.onload () in - let () = Panel_settings.onload () in + let () = Panel_tabs.onload () in + let () = Panel_preferences.onload () in let _ = Dom_html.window##.onresize := Dom_html.handler (fun _ -> let () = Panel_projects.onresize () in - let () = Panel_tab.onresize () in - let () = Panel_settings.onresize () in + let () = Panel_tabs.onresize () in + let () = Panel_preferences.onresize () in Js._true) in Js._true diff --git a/gui/README.md b/gui/README.md index 1adcd8100..7d7c02cc2 100644 --- a/gui/README.md +++ b/gui/README.md @@ -1,34 +1,46 @@ -In this dir is the code for the webapp and electron app +In this dir is the code for the _Kappapp_ webapp and electron app! -`.ml` files starting by a capital, as `KaSimWorker.ml` are executable files. +### Directory structure -TODO: revamp this as it's really imprecise and incomplete -`viz/main.js` contains the code for the main electron process -`runtime_processes.ml` setups the manager and runs the local subprocesses on electron -`JsSim.ml` defines the window DOM and its different components - - Panel_tab contains all tabs from a project, other panels manages settings, projects... - - tabs are the tabs of different tools in a given project, some are in fact subtabs in the right hand side of the editor, which is called subpanel_editor -- state_* files manages in part the logic in the given app parts +The `.ml` files in this directory , as `KaSimWorker.ml` are executable files, as indicated by their capitalization. +`JsSim.ml` defines the main executable, with the window DOM and its different components, +while the other are the different workers that can be ran as webworkers/threads in the app. -`secret_method_name` indicate a method that should be called only by inherited classes. However this was not respected thoroughly so it has not be replaced -by `inherit parent as super ... super#private_method` which fills this need in the language +`ui` contains the different panels and tabs making the interface, along with their logic. The logic tries to match in limited fashion the view and controller roles in a Control/Model/View architecture (controller for controller_* files in `ui/tab_editor`) -`_mpi` indicates the message passing interface of the different processes and web workers (threads) used +Files in `state` manages state logic from different app part, similar to a `model` in a Control/Model/View architecture. + +`entry_point` contains the entry point info for the html main page of the webapp and electron app config + +`lib`, `lib_no_jsoo`, `js_lib` contain libs used by the webapp. Those in `lib_no_jsoo` do not depend on js_of_ocaml. Libs in `js_lib` are written in javascript`, while the other are in ocaml. + +`resources` contains resources used to build the webapp and electron app. ### Runtime The app is divided in : - the interface - the agents: kasim, kamoha, kasa, kastor. Which are handling respectively the simulation, the project files, the static analysis, the analysis of traces and computation of stories -There are two different runtimes for the agents (see `state_runtime.ml`) : -- webworkers/threads for the agents (`runtime_web_workers.ml`). +There are two different runtimes for the agents (see `state/state_runtime.ml`) : +- webworkers/threads for the agents (`state/runtime_web_workers.ml`). This is the mode ran in the browser. The app uses a matching client to communicate with each thread e.g. `kasa_client` which are writing _messages_ to the agents. The threads are spawned as _workers_ e.g. `KaSaWorker`, which use the _message passing interface_ logic e.g. `kasa_mpi`, which parses the messages and compute what is asked by the clients. There is a special case for the kasim agent. There is an `KaSimAsEmbedded` option that run it in the main thread and not in a separated web worker thread. The logic for the agent is then not in the `_mpi` but in `kasim_runtime` as it is used in both the _worker_ and in the main thread. Mode with kasim in a separated thread is called `KasimAsWebWorker` -- processes for the agents (`runtime_processes.ml`) +- processes for the agents (`state/runtime_processes.ml`) This is the mode ran in the electron app. The app uses clients to communicate with agent processes. Agents processes are defined in `core/agent` with a name starting with a capital letter. `mpi` files are in in different directories of `core` . Kamoha agent and kastor agent have names that doesn't end in agent, which can be misleading. (TODO: change this?) The app here spawns two processes, Kastor and KappaSwitchman. The KappaSwitchman one then spawns the other agents and manages the communication between them and the app. Kastor is not included with the others as it can be communicated to in raw, and it doesn't have an internal state. +### Misc notes + +This code uses js_of_ocaml, the React lib for reactive programming, and lwt. +Some changes in the code might cause parts of the code to not be called. This happens even with the removal of the dead code elimination in js_of_ocaml. A way to fix these issues is to use the Hooked lib in `lib_no_jsoo`, that is meant to replace the React lib with hooks, which don't have this issue. Replacing `React` by `Hooked` in place, and converting the signals to Hooked and back should help if this issue arise again. +Feel free to add an implementation for needed `React` functions that are not yet implemented in `lib_no_jsoo/hooked.ml`. + +`secret_method_name` indicate a method that should be called only by inherited classes. However this was not respected thoroughly so it has not be replaced +by `inherit parent as super ... super#private_method` which fills this need in the language + +`_mpi` indicates the message passing interface of the different processes and web workers (threads) used + diff --git a/gui/dune b/gui/dune index c88b56215..da2603b92 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/entry_point/README.md b/gui/entry_point/README.md new file mode 100644 index 000000000..6b0dc41c6 --- /dev/null +++ b/gui/entry_point/README.md @@ -0,0 +1 @@ +`entry_point` contains the entry point info for the html main page of the webapp and electron app config diff --git a/gui/viz/main.js b/gui/entry_point/main.js similarity index 100% rename from gui/viz/main.js rename to gui/entry_point/main.js diff --git a/gui/package.json b/gui/entry_point/package.json similarity index 100% rename from gui/package.json rename to gui/entry_point/package.json diff --git a/gui/use-cdn.html b/gui/entry_point/use-cdn.html similarity index 100% rename from gui/use-cdn.html rename to gui/entry_point/use-cdn.html diff --git a/gui/use-debian.html b/gui/entry_point/use-debian.html similarity index 100% rename from gui/use-debian.html rename to gui/entry_point/use-debian.html diff --git a/gui/use-deploy.html b/gui/entry_point/use-deploy.html similarity index 100% rename from gui/use-deploy.html rename to gui/entry_point/use-deploy.html diff --git a/gui/use-local.html b/gui/entry_point/use-local.html similarity index 100% rename from gui/use-local.html rename to gui/entry_point/use-local.html diff --git a/gui/hooked.ml b/gui/hooked.ml deleted file mode 100644 index e6cdcd620..000000000 --- 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 624cfe53b..000000000 --- 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/js_lib/README.md b/gui/js_lib/README.md new file mode 100644 index 000000000..09d3acc12 --- /dev/null +++ b/gui/js_lib/README.md @@ -0,0 +1,9 @@ +This directory contains javascript libraries. + +`viz` contains js libs for vizualization from kappa tools. + +`flux.js` is used by the webapp, and by the html generation in ./core/simulation + +`graphlogger.js` by the webapp. + +`parser.js` might be unused. diff --git a/gui/shared/flux.js b/gui/js_lib/flux.js similarity index 100% rename from gui/shared/flux.js rename to gui/js_lib/flux.js diff --git a/gui/shared/graphlogger.js b/gui/js_lib/graphlogger.js similarity index 100% rename from gui/shared/graphlogger.js rename to gui/js_lib/graphlogger.js diff --git a/gui/shared/parser.js b/gui/js_lib/parser.js similarity index 100% rename from gui/shared/parser.js rename to gui/js_lib/parser.js diff --git a/gui/viz/CONTRIBUTING.md b/gui/js_lib/viz/CONTRIBUTING.md similarity index 100% rename from gui/viz/CONTRIBUTING.md rename to gui/js_lib/viz/CONTRIBUTING.md diff --git a/gui/viz/Kappa.js b/gui/js_lib/viz/Kappa.js similarity index 100% rename from gui/viz/Kappa.js rename to gui/js_lib/viz/Kappa.js diff --git a/gui/js_lib/viz/README.md b/gui/js_lib/viz/README.md new file mode 100644 index 000000000..95884894f --- /dev/null +++ b/gui/js_lib/viz/README.md @@ -0,0 +1,7 @@ +This directory contains js libs for vizualization from kappa tools. + +Some files here are used in the webapp. + +`common.js` is also included by the html generation in `core/simulation` + +`Kappa.js` might be unused, and includes info for kappa language syntax highlighting. diff --git a/gui/viz/class.js b/gui/js_lib/viz/class.js similarity index 100% rename from gui/viz/class.js rename to gui/js_lib/viz/class.js diff --git a/gui/viz/common.js b/gui/js_lib/viz/common.js similarity index 100% rename from gui/viz/common.js rename to gui/js_lib/viz/common.js diff --git a/gui/viz/index.html b/gui/js_lib/viz/index.html similarity index 100% rename from gui/viz/index.html rename to gui/js_lib/viz/index.html diff --git a/gui/viz/plot.js b/gui/js_lib/viz/plot.js similarity index 100% rename from gui/viz/plot.js rename to gui/js_lib/viz/plot.js diff --git a/gui/viz/render-contactmap.js b/gui/js_lib/viz/render-contactmap.js similarity index 100% rename from gui/viz/render-contactmap.js rename to gui/js_lib/viz/render-contactmap.js diff --git a/gui/viz/render-dummy.js b/gui/js_lib/viz/render-dummy.js similarity index 100% rename from gui/viz/render-dummy.js rename to gui/js_lib/viz/render-dummy.js diff --git a/gui/viz/render-snapshot.js b/gui/js_lib/viz/render-snapshot.js similarity index 100% rename from gui/viz/render-snapshot.js rename to gui/js_lib/viz/render-snapshot.js diff --git a/gui/viz/render-story.js b/gui/js_lib/viz/render-story.js similarity index 100% rename from gui/viz/render-story.js rename to gui/js_lib/viz/render-story.js diff --git a/gui/viz/tooltip-contactmap.js b/gui/js_lib/viz/tooltip-contactmap.js similarity index 100% rename from gui/viz/tooltip-contactmap.js rename to gui/js_lib/viz/tooltip-contactmap.js diff --git a/gui/viz/tooltip-snapshot.js b/gui/js_lib/viz/tooltip-snapshot.js similarity index 100% rename from gui/viz/tooltip-snapshot.js rename to gui/js_lib/viz/tooltip-snapshot.js diff --git a/gui/viz/utils.js b/gui/js_lib/viz/utils.js similarity index 100% rename from gui/viz/utils.js rename to gui/js_lib/viz/utils.js 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 00a51fdc8..96e229556 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 000000000..4c8027d3d --- /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_jsoo + 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 000000000..52ffe8b93 --- /dev/null +++ b/gui/lib/hooked.ml @@ -0,0 +1,11 @@ +module DebugPrint : Kappa_webapp_lib_no_jsoo.Hooked.DebugPrint = struct + let debug_print s = + let () = Common.debug ~loc:__LOC__ s in + () +end + +module S = Kappa_webapp_lib_no_jsoo.Hooked.MakeS (DebugPrint) +module E = Kappa_webapp_lib_no_jsoo.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 000000000..3d84a2cb4 --- /dev/null +++ b/gui/lib/hooked.mli @@ -0,0 +1,6 @@ +module DebugPrint : Kappa_webapp_lib_no_jsoo.Hooked.DebugPrint +module S : Kappa_webapp_lib_no_jsoo.Hooked.S +module E : Kappa_webapp_lib_no_jsoo.Hooked.E + +type 'a signal = 'a S.t +type 'a event = 'a E.t diff --git a/gui/utility.ml b/gui/lib/html_utility.ml similarity index 100% rename from gui/utility.ml rename to gui/lib/html_utility.ml diff --git a/gui/utility.mli b/gui/lib/html_utility.mli similarity index 100% rename from gui/utility.mli rename to gui/lib/html_utility.mli 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/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_jsoo/README.md b/gui/lib_no_jsoo/README.md new file mode 100644 index 000000000..fdb3e1159 --- /dev/null +++ b/gui/lib_no_jsoo/README.md @@ -0,0 +1,3 @@ +Here are libs used by the webapp that don't use js_of_ocaml. + +This allows to use ppx_inline_test on them. diff --git a/gui/lib_no_jsoo/dune b/gui/lib_no_jsoo/dune new file mode 100644 index 000000000..cc7f5dda0 --- /dev/null +++ b/gui/lib_no_jsoo/dune @@ -0,0 +1,17 @@ +(library + (name kappa_webapp_lib_no_jsoo) + (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_jsoo/hooked.ml b/gui/lib_no_jsoo/hooked.ml new file mode 100644 index 000000000..88ad40498 --- /dev/null +++ b/gui/lib_no_jsoo/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_jsoo/hooked.mli b/gui/lib_no_jsoo/hooked.mli new file mode 100644 index 000000000..57ce68201 --- /dev/null +++ b/gui/lib_no_jsoo/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/Info.plist.skel b/gui/resources/Info.plist.skel similarity index 100% rename from gui/Info.plist.skel rename to gui/resources/Info.plist.skel diff --git a/gui/viz/JsSim.css b/gui/resources/JsSim.css similarity index 100% rename from gui/viz/JsSim.css rename to gui/resources/JsSim.css diff --git a/gui/Kappa-Logo.png b/gui/resources/Kappa-Logo.png similarity index 100% rename from gui/Kappa-Logo.png rename to gui/resources/Kappa-Logo.png diff --git a/gui/resources/README.md b/gui/resources/README.md new file mode 100644 index 000000000..dad038c4f --- /dev/null +++ b/gui/resources/README.md @@ -0,0 +1 @@ +Here are resources used to build the webapp diff --git a/gui/favicon.ico b/gui/resources/favicon.ico similarity index 100% rename from gui/favicon.ico rename to gui/resources/favicon.ico diff --git a/gui/shared/README.md b/gui/shared/README.md deleted file mode 100644 index 930bc6dfd..000000000 --- a/gui/shared/README.md +++ /dev/null @@ -1,3 +0,0 @@ -This directory contains javascript code both used by -- the webapp ./gui -- html generation in ./core/simulation diff --git a/gui/state/README.md b/gui/state/README.md new file mode 100644 index 000000000..cb9ed14fc --- /dev/null +++ b/gui/state/README.md @@ -0,0 +1,13 @@ +Files in `state` manages state logic from different app part, similar to a `model` in a Control/Model/View architecture. + +`state_error.ml` manages errors at the webapp level + +`state_ui.ml` call _init_ and _sync_ for `state_*` files + +`state_file.ml` mainly manages editor & kasa stuff, but is accessed too from settings, state_ui + +`state_perturbation.ml` manages simulation perturbations, only used from panel preferences + +`state_runtime.ml` defines worker runtime, used from other `states_*` + preferences + projects controller + +`state_simulation.ml` sets simulation controls and functions to interact with simulation data 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 000000000..a0770bc27 --- /dev/null +++ b/gui/state/dune @@ -0,0 +1,42 @@ +(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 726872d47..bbe455ac4 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 d06df3456..ef8f6c9fe 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 addfa822c..790ae12d5 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 dab2821cd..4c1da382e 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_settings.ml b/gui/state/state_preferences.ml similarity index 100% rename from gui/state_settings.ml rename to gui/state/state_preferences.ml diff --git a/gui/state_settings.mli b/gui/state/state_preferences.mli similarity index 100% rename from gui/state_settings.mli rename to gui/state/state_preferences.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_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 85% rename from gui/state_ui.ml rename to gui/state/state_ui.ml index 8fbd216f7..60f7263c0 100644 --- a/gui/state_ui.ml +++ b/gui/state/state_ui.ml @@ -9,12 +9,12 @@ open Lwt.Infix let sync () : unit Lwt.t = - State_settings.sync () >>= State_runtime.sync >>= State_project.sync + State_preferences.sync () >>= State_runtime.sync >>= State_project.sync >>= fun _ -> State_file.sync () >>= fun _ -> Lwt.return_unit let init () : unit Lwt.t = - Lwt.return_unit >>= State_settings.init >>= State_runtime.init + Lwt.return_unit >>= State_preferences.init >>= State_runtime.init >>= State_project.init >>= State_file.init >>= State_simulation.init >>= sync let onload () : unit = Common.async __LOC__ (fun () -> Lwt.return_unit >>= init) 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 000000000..41c013019 --- /dev/null +++ b/gui/ui/dune @@ -0,0 +1,48 @@ +(include_subdirs unqualified) + +(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/panel_settings.ml b/gui/ui/panel_preferences.ml similarity index 93% rename from gui/panel_settings.ml rename to gui/ui/panel_preferences.ml index 06213ab28..c8f8c02da 100644 --- a/gui/panel_settings.ml +++ b/gui/ui/panel_preferences.ml @@ -23,7 +23,7 @@ let visible_on_states ?(a_class = []) a_class @ hidden_class)) module FormPerturbation : Ui_common.Div = struct - let id = "panel_settings_perturbation" + let id = "panel_preferences_perturbation" let input = Html.input @@ -71,7 +71,7 @@ module FormPerturbation : Ui_common.Div = struct let () = form_dom##.onsubmit := Dom.handler (fun _ -> - let () = Panel_settings_controller.intervene_simulation () in + let () = Panel_preferences_controller.intervene_simulation () in Js._false) in let () = input_dom##.onchange := Dom.handler handler in @@ -85,7 +85,7 @@ let signal_change input_dom signal_handler = Js._true) module InputPauseCondition : Ui_common.Div = struct - let id = "panel_settings_pause_condition" + let id = "panel_preferences_pause_condition" let input = Html.input @@ -121,7 +121,7 @@ module InputPauseCondition : Ui_common.Div = struct end module InputPlotPeriod : Ui_common.Div = struct - let id = "panel_settings_plot_period" + let id = "panel_preferences_plot_period" let format_float_string value = let n = string_of_float value in @@ -175,18 +175,18 @@ end module DivErrorMessage : Ui_common.Div = struct let id = "configuration_error_div" - 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 message_nav_inc_id = "panel_preferences_message_nav_inc_id" + let message_nav_dec_id = "panel_preferences_message_nav_dec_id" + let message_file_label_id = "panel_preferences_message_file_label" + 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 @@ -303,11 +303,12 @@ module DivErrorMessage : Ui_common.Div = struct Dom.handler (fun _ -> let () = Common.debug ~loc:__LOC__ - (Js.string "[Panel_settings] clicked file_click_handler") + (Js.string "[Panel_preferences] 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 @@ -316,7 +317,7 @@ module DivErrorMessage : Ui_common.Div = struct in let () = match range with - | Some range -> Panel_settings_controller.focus_range range + | Some range -> Panel_preferences_controller.focus_range range | None -> () in Js._true) @@ -329,17 +330,18 @@ module DivErrorMessage : Ui_common.Div = struct Dom.handler (fun _ -> let () = Common.debug ~loc:__LOC__ - (Js.string "[Panel_settings] clicked index_click_handler") + (Js.string "[Panel_preferences] 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 () @@ -362,7 +364,7 @@ module DivErrorMessage : Ui_common.Div = struct end module ButtonStart : Ui_common.Div = struct - let id = "panel_settings_start_button" + let id = "panel_preferences_start_button" let button = Html.button @@ -391,7 +393,7 @@ module ButtonStart : Ui_common.Div = struct let () = start_button_dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.start_simulation () in + let () = Panel_preferences_controller.start_simulation () in Js._true) in @@ -399,7 +401,7 @@ module ButtonStart : Ui_common.Div = struct end module ButtonClear : Ui_common.Div = struct - let id = "panel_settings_clear_button" + let id = "panel_preferences_clear_button" let button = Html.button @@ -418,14 +420,14 @@ module ButtonClear : Ui_common.Div = struct let () = dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.stop_simulation () in + let () = Panel_preferences_controller.stop_simulation () in Js._true) in () end module ButtonPause : Ui_common.Div = struct - let id = "panel_settings_pause_button" + let id = "panel_preferences_pause_button" let button = Html.button @@ -444,14 +446,14 @@ module ButtonPause : Ui_common.Div = struct let () = button_dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.pause_simulation () in + let () = Panel_preferences_controller.pause_simulation () in Js._true) in () end module ButtonTrace : Ui_common.Div = struct - let id = "panel_settings_get_trace_button" + let id = "panel_preferences_get_trace_button" let button = Html.button @@ -481,14 +483,14 @@ module ButtonTrace : Ui_common.Div = struct let () = button_dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.simulation_trace () in + let () = Panel_preferences_controller.simulation_trace () in Js._true) in () end module ButtonOutputs : Ui_common.Div = struct - let id = "panel_settings_outputs_button" + let id = "panel_preferences_outputs_button" let button = Html.button @@ -507,14 +509,14 @@ module ButtonOutputs : Ui_common.Div = struct let () = button_dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.simulation_outputs () in + let () = Panel_preferences_controller.simulation_outputs () in Js._true) in () end module ButtonContinue : Ui_common.Div = struct - let id = "panel_settings_continue_button" + let id = "panel_preferences_continue_button" let button = Html.button @@ -533,7 +535,7 @@ module ButtonContinue : Ui_common.Div = struct let () = button_dom##.onclick := Dom.handler (fun _ -> - let () = Panel_settings_controller.continue_simulation () in + let () = Panel_preferences_controller.continue_simulation () in Js._true) in () diff --git a/gui/panel_projects.mli b/gui/ui/panel_preferences.mli similarity index 100% rename from gui/panel_projects.mli rename to gui/ui/panel_preferences.mli diff --git a/gui/panel_settings_controller.ml b/gui/ui/panel_preferences_controller.ml similarity index 100% rename from gui/panel_settings_controller.ml rename to gui/ui/panel_preferences_controller.ml diff --git a/gui/panel_settings_controller.mli b/gui/ui/panel_preferences_controller.mli similarity index 100% rename from gui/panel_settings_controller.mli rename to gui/ui/panel_preferences_controller.mli diff --git a/gui/modal_preferences.ml b/gui/ui/panel_preferences_modal.ml similarity index 97% rename from gui/modal_preferences.ml rename to gui/ui/panel_preferences_modal.ml index 40522de2e..b37d9378b 100644 --- a/gui/modal_preferences.ml +++ b/gui/ui/panel_preferences_modal.ml @@ -205,7 +205,7 @@ let set_action () = let set_and_save_action () = set_action (); - State_settings.set_parameters_as_default (); + State_preferences.set_parameters_as_default (); State_project.set_parameters_as_default () let onload () = @@ -252,12 +252,12 @@ let onload () = Js._false); - let () = State_settings.updateFontSize ~delta:0. in + let () = State_preferences.updateFontSize ~delta:0. in (Tyxml_js.To_dom.of_button increase_font)##.onclick := Dom_html.handler (fun _ -> - let () = State_settings.updateFontSize ~delta:0.2 in + let () = State_preferences.updateFontSize ~delta:0.2 in Js._false); (Tyxml_js.To_dom.of_button decrease_font)##.onclick := Dom_html.handler (fun _ -> - let () = State_settings.updateFontSize ~delta:(-0.2) in + let () = State_preferences.updateFontSize ~delta:(-0.2) in Js._false) diff --git a/gui/modal_preferences.mli b/gui/ui/panel_preferences_modal.mli similarity index 100% rename from gui/modal_preferences.mli rename to gui/ui/panel_preferences_modal.mli diff --git a/gui/panel_projects.ml b/gui/ui/panel_projects.ml similarity index 97% rename from gui/panel_projects.ml rename to gui/ui/panel_projects.ml index 88c09a66a..08963f401 100644 --- a/gui/panel_projects.ml +++ b/gui/ui/panel_projects.ml @@ -22,7 +22,7 @@ let project_id_input = () let li_new = Html.li [ Html.a [ Html.cdata "New project" ] ] -let li_prefs = Html.li (Modal_preferences.content ()) +let li_prefs = Html.li (Panel_preferences_modal.content ()) let project_id_input_dom = Tyxml_js.To_dom.of_input project_id_input let content () = @@ -121,7 +121,7 @@ let content () = ] let onload () = - let () = Modal_preferences.onload () in + let () = Panel_preferences_modal.onload () in let () = Common.jquery_on ("#" ^ project_id_modal_id) diff --git a/gui/panel_settings.mli b/gui/ui/panel_projects.mli similarity index 100% rename from gui/panel_settings.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_tab.ml b/gui/ui/panel_tabs/panel_tabs.ml similarity index 93% rename from gui/panel_tab.ml rename to gui/ui/panel_tabs/panel_tabs.ml index 0d8354483..afd366633 100644 --- a/gui/panel_tab.ml +++ b/gui/ui/panel_tabs/panel_tabs.ml @@ -25,7 +25,7 @@ let navtabs () = "editor", None, Tab_editor.navli (); "log", None, Tab_log.navli (); "plot", None, Tab_plot.navli (); - "DIN", None, Tab_flux.navli (); + "DIN", None, Tab_din.navli (); "snapshot", None, Tab_snapshot.navli (); "outputs", None, Tab_outputs.navli (); "stories", story_class, Tab_stories.navli (); @@ -41,7 +41,7 @@ let navcontents () = "editor", [ "row" ], Tab_editor.content (); "log", [], Tab_log.content (); "plot", [], Tab_plot.content (); - "DIN", [], Tab_flux.content (); + "DIN", [], Tab_din.content (); "snapshot", [], Tab_snapshot.content (); "outputs", [], Tab_outputs.content (); "stories", [ "row" ], Tab_stories.content (); @@ -52,7 +52,7 @@ let onload () = let () = Tab_editor.onload () in let () = Tab_log.onload () in let () = Tab_plot.onload () in - let () = Tab_flux.onload () in + let () = Tab_din.onload () in let () = Tab_snapshot.onload () in let () = Tab_outputs.onload () in let () = Tab_stories.onload () in @@ -63,7 +63,7 @@ let onresize () = let () = Tab_editor.onresize () in let () = Tab_log.onresize () in let () = Tab_plot.onresize () in - let () = Tab_flux.onresize () in + let () = Tab_din.onresize () in let () = Tab_snapshot.onresize () in let () = Tab_outputs.onresize () in let () = Tab_stories.onresize () in diff --git a/gui/panel_tab.mli b/gui/ui/panel_tabs/panel_tabs.mli similarity index 100% rename from gui/panel_tab.mli rename to gui/ui/panel_tabs/panel_tabs.mli diff --git a/gui/tab_about.ml b/gui/ui/panel_tabs/tab_about.ml similarity index 100% rename from gui/tab_about.ml rename to gui/ui/panel_tabs/tab_about.ml diff --git a/gui/tab_about.mli b/gui/ui/panel_tabs/tab_about.mli similarity index 100% rename from gui/tab_about.mli rename to gui/ui/panel_tabs/tab_about.mli diff --git a/gui/tab_flux.ml b/gui/ui/panel_tabs/tab_din.ml similarity index 99% rename from gui/tab_flux.ml rename to gui/ui/panel_tabs/tab_din.ml index 05988e682..31bb2febf 100644 --- a/gui/tab_flux.ml +++ b/gui/ui/panel_tabs/tab_din.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_track_sim_status.badge (fun state -> match state with | None -> 0 | Some state -> diff --git a/gui/tab_editor.mli b/gui/ui/panel_tabs/tab_din.mli similarity index 100% rename from gui/tab_editor.mli rename to gui/ui/panel_tabs/tab_din.mli diff --git a/gui/subpanel_editor.ml b/gui/ui/panel_tabs/tab_editor/editor.ml similarity index 96% rename from gui/subpanel_editor.ml rename to gui/ui/panel_tabs/tab_editor/editor.ml index 99b084155..f3329eab7 100644 --- a/gui/subpanel_editor.ml +++ b/gui/ui/panel_tabs/tab_editor/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 @@ -38,7 +40,7 @@ let panel_heading = [ Html.a_class [ "btn-group" ]; Html.Unsafe.string_attrib "role" "group"; ] - Menu_editor_file.content + Editor_menu_file.content in let buttons = menu_editor_file_content :: [ toggle_button ] in [%html @@ -132,12 +134,12 @@ let jump_to_line (codemirror : codemirror Js.t) (line : int) : unit = () let onload () : unit = - let () = Menu_editor_file.onload () in + let () = Editor_menu_file.onload () in let lint_config = Codemirror.create_lint_configuration () in 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 @@ -163,7 +165,7 @@ let onload () : unit = in let () = codemirror##setValue (Js.string "") in let () = - Subpanel_editor_controller.with_file + Editor_controller.with_file (Result_util.fold ~ok:(fun (content, id) -> let () = set_filename (Some id) in @@ -175,7 +177,7 @@ let onload () : unit = in let () = Codemirror.commands##.save := - fun _ -> Menu_editor_file_controller.export_current_file () + fun _ -> Editor_menu_file_controller.export_current_file () in let timeout : Dom_html.timeout_id option ref = ref None in let handler codemirror change = @@ -197,7 +199,7 @@ let onload () : unit = match React.S.value filename with | None -> () | Some filename -> - Subpanel_editor_controller.set_content ~filename + Editor_controller.set_content ~filename ~filecontent:(Js.to_string codemirror##getValue) in let () = diff --git a/gui/subpanel_editor.mli b/gui/ui/panel_tabs/tab_editor/editor.mli similarity index 93% rename from gui/subpanel_editor.mli rename to gui/ui/panel_tabs/tab_editor/editor.mli index 96b7abff1..973e513a2 100644 --- a/gui/subpanel_editor.mli +++ b/gui/ui/panel_tabs/tab_editor/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/panel_tabs/tab_editor/editor_controller.ml similarity index 100% rename from gui/subpanel_editor_controller.ml rename to gui/ui/panel_tabs/tab_editor/editor_controller.ml diff --git a/gui/subpanel_editor_controller.mli b/gui/ui/panel_tabs/tab_editor/editor_controller.mli similarity index 100% rename from gui/subpanel_editor_controller.mli rename to gui/ui/panel_tabs/tab_editor/editor_controller.mli diff --git a/gui/menu_editor_file.ml b/gui/ui/panel_tabs/tab_editor/editor_menu_file.ml similarity index 94% rename from gui/menu_editor_file.ml rename to gui/ui/panel_tabs/tab_editor/editor_menu_file.ml index dd713d995..627502adb 100644 --- a/gui/menu_editor_file.ml +++ b/gui/ui/panel_tabs/tab_editor/editor_menu_file.ml @@ -204,7 +204,7 @@ let content = ~submit: (Dom_html.handler (fun _ -> let filename : string = Js.to_string file_new_input_dom##.value in - let () = Menu_editor_file_controller.create_file filename in + let () = Editor_menu_file_controller.create_file filename in let () = Common.modal ~id:("#" ^ file_new_modal_id) ~action:"hide" in @@ -214,7 +214,7 @@ let content = let order_files (element : Dom_html.element Js.t) = let filenames : string list = Common.children_value element "li[data-file-id]" (fun element -> - let () = Common.log_group "[Menu_editor_file.order_files]" in + let () = Common.log_group "[Editor_menu_file.order_files]" in let () = Common.debug ~loc:__LOC__ element in let () = Common.log_group_end () in Js.Opt.case @@ -222,7 +222,7 @@ let order_files (element : Dom_html.element Js.t) = (fun () -> failwith "missing filename") Js.to_string) in - let () = Menu_editor_file_controller.order_files filenames in + let () = Editor_menu_file_controller.order_files filenames in () let file_select_handler _ _ : unit Lwt.t = @@ -231,7 +231,7 @@ let file_select_handler _ _ : unit Lwt.t = let file = Js.Opt.get (files##item 0) (fun () -> assert false) in let file_id = Js.to_string file##.name in let () = - Menu_editor_file_controller.create_file + Editor_menu_file_controller.create_file ~text:(Js_of_ocaml_lwt.File.readAsText file) file_id in @@ -256,13 +256,13 @@ let onload () = let () = Common.jquery_on ("#" ^ file_close_li_id) "click" (Dom_html.handler (fun _ -> - let () = Menu_editor_file_controller.close_file () in + let () = Editor_menu_file_controller.close_file () in Js._false)) in let () = Common.jquery_on ("#" ^ file_export_li_id) "click" (Dom_html.handler (fun _ -> - let () = Menu_editor_file_controller.export_current_file () in + let () = Editor_menu_file_controller.export_current_file () in Js._false)) in let () = @@ -270,7 +270,7 @@ let onload () = (Dom_html.handler (fun (event : Dom_html.event Js.t) -> (* let () = - Common.log_group "[Menu_editor_file] clicked span[data-file-id]" + Common.log_group "[Editor_menu_file] clicked span[data-file-id]" in let () = Common.debug ~loc:__LOC__ event in let () = Common.log_group_end () in @@ -284,7 +284,7 @@ let onload () = Js.Opt.case file_id (fun _ -> ()) (fun file_id -> - Menu_editor_file_controller.set_file (Js.to_string file_id)) + Editor_menu_file_controller.set_file (Js.to_string file_id)) in Js._false)) in @@ -300,7 +300,7 @@ let onload () = else Common.debug ~loc:__LOC__ (Format.sprintf - "[Menu_editor_file] file dropdown : unexpected id %s" id))) + "[Editor_menu_file] file dropdown : unexpected id %s" id))) in let () = Common.jquery_on @@ -325,13 +325,13 @@ let onload () = (fun file_id -> let () = Common.log_group - "[Menu_editor_file] triggered \ + "[Editor_menu_file] triggered \ input.file_compile_checkbox, file_id:" in let () = Common.debug ~loc:__LOC__ file_id in let () = Common.log_group_end () in let () = - Menu_editor_file_controller.set_file_compile + Editor_menu_file_controller.set_file_compile (Js.to_string file_id) is_checked in ()) diff --git a/gui/menu_editor_file.mli b/gui/ui/panel_tabs/tab_editor/editor_menu_file.mli similarity index 100% rename from gui/menu_editor_file.mli rename to gui/ui/panel_tabs/tab_editor/editor_menu_file.mli diff --git a/gui/menu_editor_file_controller.ml b/gui/ui/panel_tabs/tab_editor/editor_menu_file_controller.ml similarity index 97% rename from gui/menu_editor_file_controller.ml rename to gui/ui/panel_tabs/tab_editor/editor_menu_file_controller.ml index 457849587..00b533e90 100644 --- a/gui/menu_editor_file_controller.ml +++ b/gui/ui/panel_tabs/tab_editor/editor_menu_file_controller.ml @@ -24,7 +24,7 @@ let set_file (file_id : string) : unit = let () = Common.debug ~loc:__LOC__ (Js.string - (Format.sprintf "[Menu_editor_file_controller.set_file] file `%s`" + (Format.sprintf "[Editor_menu_file_controller.set_file] file `%s`" file_id)) in Common.async __LOC__ (fun () -> diff --git a/gui/menu_editor_file_controller.mli b/gui/ui/panel_tabs/tab_editor/editor_menu_file_controller.mli similarity index 100% rename from gui/menu_editor_file_controller.mli rename to gui/ui/panel_tabs/tab_editor/editor_menu_file_controller.mli diff --git a/gui/tab_constraints.ml b/gui/ui/panel_tabs/tab_editor/subtab_constraints.ml similarity index 87% rename from gui/tab_constraints.ml rename to gui/ui/panel_tabs/tab_editor/subtab_constraints.ml index 628340d56..941158a37 100644 --- a/gui/tab_constraints.ml +++ b/gui/ui/panel_tabs/tab_editor/subtab_constraints.ml @@ -40,32 +40,32 @@ let content () = let list = match conclusion with | [ site_graph ] -> - Utility.print_site_graph site_graph - (Utility.print_newline list) + Html_utility.print_site_graph site_graph + (Html_utility.print_newline list) | _ :: _ | [] -> - let list = Utility.print_newline list in - let list = Utility.print_string " ]" list in + let list = Html_utility.print_newline list in + let list = Html_utility.print_string " ]" list in let list = snd (List.fold_left (fun (bool, list) a -> let list = if bool then - Utility.print_string " v " list + Html_utility.print_string " v " list else list in let list = - Utility.print_site_graph a list + Html_utility.print_site_graph a list in true, list) (false, list) (List.rev conclusion)) in - let list = Utility.print_string "[ " list in + let list = Html_utility.print_string "[ " list in list in - let list = Utility.print_string " => " list in - let list = Utility.print_site_graph hyp list in + let list = Html_utility.print_string " => " list in + let list = Html_utility.print_site_graph hyp list in list) [] (List.rev b) in diff --git a/gui/tab_constraints.mli b/gui/ui/panel_tabs/tab_editor/subtab_constraints.mli similarity index 100% rename from gui/tab_constraints.mli rename to gui/ui/panel_tabs/tab_editor/subtab_constraints.mli diff --git a/gui/tab_contact_map.ml b/gui/ui/panel_tabs/tab_editor/subtab_contact_map.ml similarity index 98% rename from gui/tab_contact_map.ml rename to gui/ui/panel_tabs/tab_editor/subtab_contact_map.ml index 2aad33cef..1711661d1 100644 --- a/gui/tab_contact_map.ml +++ b/gui/ui/panel_tabs/tab_editor/subtab_contact_map.ml @@ -26,7 +26,7 @@ let extract_contact_map = function | _ -> failwith "Wrong ugly contact_map extractor" let contact_map_js : Js_contact.contact_map Js.t = - Js_contact.create_contact_map display_id State_settings.agent_coloring + Js_contact.create_contact_map display_id State_preferences.agent_coloring let contact_map_text : string React.signal = State_project.on_project_change_async ~on:tab_is_active None accuracy "null" diff --git a/gui/tab_contact_map.mli b/gui/ui/panel_tabs/tab_editor/subtab_contact_map.mli similarity index 100% rename from gui/tab_contact_map.mli rename to gui/ui/panel_tabs/tab_editor/subtab_contact_map.mli diff --git a/gui/tab_influences.ml b/gui/ui/panel_tabs/tab_editor/subtab_influences.ml similarity index 77% rename from gui/tab_influences.ml rename to gui/ui/panel_tabs/tab_editor/subtab_influences.ml index ed55e6682..d1d7b8f3f 100644 --- a/gui/tab_influences.ml +++ b/gui/ui/panel_tabs/tab_editor/subtab_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 + 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 + 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/panel_tabs/tab_editor/subtab_influences.mli similarity index 100% rename from gui/tab_influences.mli rename to gui/ui/panel_tabs/tab_editor/subtab_influences.mli diff --git a/gui/tab_polymers.ml b/gui/ui/panel_tabs/tab_editor/subtab_polymers.ml similarity index 90% rename from gui/tab_polymers.ml rename to gui/ui/panel_tabs/tab_editor/subtab_polymers.ml index 576344bbb..90cdebb64 100644 --- a/gui/tab_polymers.ml +++ b/gui/ui/panel_tabs/tab_editor/subtab_polymers.ml @@ -15,7 +15,7 @@ let tab_was_active = ref false let site a = [ a, None, Some (Public_data.Bound_to 1), None ] let print_edge ((a, b), (c, d)) list = - Utility.print_newline (Utility.print_site_graph [ a, site b; c, site d ] list) + Html_utility.print_newline (Html_utility.print_site_graph [ a, site b; c, site d ] list) let content () = let scc = @@ -29,23 +29,23 @@ let content () = let scc = List.rev_map List.rev scc in let output = if scc = [] || scc = [ [] ] then - Utility.print_string + Html_utility.print_string "The size of biomolecular compounds is uniformly bounded." [] else ( let list = List.fold_left (fun list list_edges -> - let list = Utility.print_newline list in + let list = Html_utility.print_newline list in List.fold_left (fun list ((a, b), (c, d)) -> print_edge ((a, b), (c, d)) list) list list_edges) [] scc in - let list = Utility.print_newline list in + let list = Html_utility.print_newline list in let list = - Utility.print_string + Html_utility.print_string "The following bonds may form arbitrary long chains of \ agents:" list diff --git a/gui/tab_polymers.mli b/gui/ui/panel_tabs/tab_editor/subtab_polymers.mli similarity index 100% rename from gui/tab_polymers.mli rename to gui/ui/panel_tabs/tab_editor/subtab_polymers.mli diff --git a/gui/tab_editor.ml b/gui/ui/panel_tabs/tab_editor/tab_editor.ml similarity index 86% rename from gui/tab_editor.ml rename to gui/ui/panel_tabs/tab_editor/tab_editor.ml index ea3350717..320299aaf 100644 --- a/gui/tab_editor.ml +++ b/gui/ui/panel_tabs/tab_editor/tab_editor.ml @@ -17,7 +17,7 @@ let rightsubpanel () = ~a: [ Tyxml_js.R.Html.a_class - (React.S.bind Subpanel_editor.editor_full (fun editor_full -> + (React.S.bind Editor.editor_full (fun editor_full -> React.S.const (if editor_full then [ "hidden" ] @@ -27,32 +27,32 @@ let rightsubpanel () = [ Ui_common.navtabs "subnavtab" [ - "contact_map", None, Tab_contact_map.navli (); - "influences", None, Tab_influences.navli (); - "constraints", None, Tab_constraints.navli (); - "polymers", None, Tab_polymers.navli (); + "contact_map", None, Subtab_contact_map.navli (); + "influences", None, Subtab_influences.navli (); + "constraints", None, Subtab_constraints.navli (); + "polymers", None, Subtab_polymers.navli (); ]; Ui_common.navcontent ~id:rightsubpanel_id [] [ - "contact_map", [], Tab_contact_map.content (); - "influences", [], Tab_influences.content (); - "constraints", [], Tab_constraints.content (); - "polymers", [], Tab_polymers.content (); + "contact_map", [], Subtab_contact_map.content (); + "influences", [], Subtab_influences.content (); + "constraints", [], Subtab_constraints.content (); + "polymers", [], Subtab_polymers.content (); ]; ] (** [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 () + let () = Subtab_contact_map.parent_hide () in + let () = Subtab_influences.parent_hide () in + let () = Subtab_constraints.parent_hide () in + Subtab_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 () = Subtab_contact_map.parent_shown () in + let () = Subtab_influences.parent_shown () in + let () = Subtab_constraints.parent_shown () in + Subtab_polymers.parent_shown () ) let content () = @@ -61,7 +61,7 @@ let content () = ~a: [ Tyxml_js.R.Html.a_class - (React.S.bind Subpanel_editor.editor_full (fun editor_full -> + (React.S.bind Editor.editor_full (fun editor_full -> (* child hiding set here to avoid "gc" *) let () = childs_hide editor_full in React.S.const @@ -70,7 +70,7 @@ let content () = else [ "col-md-6"; "flex-content" ]))); ] - [ Subpanel_editor.content () ]; + [ Editor.content () ]; rightsubpanel (); ] @@ -225,14 +225,14 @@ let init_non_weakly_reversible_transitions () = let dont_gc_me = ref [] let onload () = - let () = Subpanel_editor.onload () in + let () = Editor.onload () in dont_gc_me := init_dead_rules () :: !dont_gc_me; dont_gc_me := init_dead_agents () :: !dont_gc_me; dont_gc_me := init_non_weakly_reversible_transitions () :: !dont_gc_me; - let () = Tab_contact_map.onload () in - let () = Tab_influences.onload () in - let () = Tab_constraints.onload () in - let () = Tab_polymers.onload () in + let () = Subtab_contact_map.onload () in + let () = Subtab_influences.onload () in + let () = Subtab_constraints.onload () in + let () = Subtab_polymers.onload () in let () = Common.jquery_on "#naveditor" "hide.bs.tab" (fun _ -> childs_hide true) in @@ -242,9 +242,9 @@ let onload () = () let onresize () : unit = - let () = Subpanel_editor.onresize () in - let () = Tab_contact_map.onresize () in - let () = Tab_influences.onresize () in - let () = Tab_constraints.onresize () in - let () = Tab_polymers.onresize () in + let () = Editor.onresize () in + let () = Subtab_contact_map.onresize () in + let () = Subtab_influences.onresize () in + let () = Subtab_constraints.onresize () in + let () = Subtab_polymers.onresize () in () diff --git a/gui/tab_flux.mli b/gui/ui/panel_tabs/tab_editor/tab_editor.mli similarity index 100% rename from gui/tab_flux.mli rename to gui/ui/panel_tabs/tab_editor/tab_editor.mli diff --git a/gui/tab_log.ml b/gui/ui/panel_tabs/tab_log.ml similarity index 96% rename from gui/tab_log.ml rename to gui/ui/panel_tabs/tab_log.ml index 6acb83efc..d868df30c 100644 --- a/gui/tab_log.ml +++ b/gui/ui/panel_tabs/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_track_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/panel_tabs/tab_log.mli similarity index 100% rename from gui/tab_log.mli rename to gui/ui/panel_tabs/tab_log.mli diff --git a/gui/tab_outputs.ml b/gui/ui/panel_tabs/tab_outputs.ml similarity index 97% rename from gui/tab_outputs.ml rename to gui/ui/panel_tabs/tab_outputs.ml index fe3433e5f..4b6671df8 100644 --- a/gui/tab_outputs.ml +++ b/gui/ui/panel_tabs/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_track_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_track_sim_status.toggle_element (fun t -> file_count t > 0) (xml ()) ] let onload () = let () = diff --git a/gui/tab_outputs.mli b/gui/ui/panel_tabs/tab_outputs.mli similarity index 100% rename from gui/tab_outputs.mli rename to gui/ui/panel_tabs/tab_outputs.mli diff --git a/gui/tab_plot.ml b/gui/ui/panel_tabs/tab_plot.ml similarity index 98% rename from gui/tab_plot.ml rename to gui/ui/panel_tabs/tab_plot.ml index f814bd632..3612effbe 100644 --- a/gui/tab_plot.ml +++ b/gui/ui/panel_tabs/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_track_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_track_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/panel_tabs/tab_plot.mli similarity index 100% rename from gui/tab_plot.mli rename to gui/ui/panel_tabs/tab_plot.mli diff --git a/gui/tab_snapshot.ml b/gui/ui/panel_tabs/tab_snapshot.ml similarity index 97% rename from gui/tab_snapshot.ml rename to gui/ui/panel_tabs/tab_snapshot.ml index 6d723daca..cf9c0c383 100644 --- a/gui/tab_snapshot.ml +++ b/gui/ui/panel_tabs/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_track_sim_status.badge (fun state -> snapshot_count state) let select_id = "snapshot-select-id" let display_id = "snapshot-map-display" @@ -110,7 +110,7 @@ let render_snapshot_graph (snapshot_js : Js_snapshot.snapshot Js.t) match React.S.value display_format with | Graph -> let json : string = Data.string_of_snapshot snapshot in - let contact_map = React.S.value Tab_contact_map.contact_map_text in + let contact_map = React.S.value Subtab_contact_map.contact_map_text in snapshot_js##setData ~contact_map:(Js.string contact_map) (Js.string json) | Kappa -> () @@ -155,7 +155,8 @@ let select_snapshot (snapshot_js : Js_snapshot.snapshot Js.t) : unit = in Lwt.return (Result_util.ok ())) with - | Failure f -> Lwt.return (Api_common.err_result_of_string f) + | Failure f -> + Lwt.return (Api_common.err_result_of_string f) | Invalid_argument f -> Lwt.return (Api_common.err_result_of_string f))) in @@ -198,7 +199,7 @@ let snapshot_class : State_simulation.model) let snapshot_js : Js_snapshot.snapshot Js.t = - Js_snapshot.create_snapshot display_id State_settings.agent_coloring + Js_snapshot.create_snapshot display_id State_preferences.agent_coloring let xml () = let list = @@ -353,7 +354,7 @@ let xml () = let content () = [ - Ui_common_with_sim.toggle_element + Ui_track_sim_status.toggle_element (fun state -> snapshot_count state > 0) (xml ()); ] diff --git a/gui/tab_snapshot.mli b/gui/ui/panel_tabs/tab_snapshot.mli similarity index 100% rename from gui/tab_snapshot.mli rename to gui/ui/panel_tabs/tab_snapshot.mli diff --git a/gui/tab_stories.ml b/gui/ui/panel_tabs/tab_stories.ml similarity index 100% rename from gui/tab_stories.ml rename to gui/ui/panel_tabs/tab_stories.ml diff --git a/gui/tab_stories.mli b/gui/ui/panel_tabs/tab_stories.mli similarity index 100% rename from gui/tab_stories.mli rename to gui/ui/panel_tabs/tab_stories.mli diff --git a/gui/ui_common_with_sim.ml b/gui/ui/ui_track_sim_status.ml similarity index 100% rename from gui/ui_common_with_sim.ml rename to gui/ui/ui_track_sim_status.ml diff --git a/gui/ui_common_with_sim.mli b/gui/ui/ui_track_sim_status.mli similarity index 100% rename from gui/ui_common_with_sim.mli rename to gui/ui/ui_track_sim_status.mli diff --git a/kappa-webapp.opam b/kappa-webapp.opam index 13254ba0c..a2487609b 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.15.1"} "kappa-binaries" "kappa-agents" "odoc" {with-doc}