├── .gitignore ├── .merlin ├── .ocp-indent ├── B0.ml ├── BRZO ├── CHANGES.md ├── LICENSE.md ├── README.md ├── TODO.md ├── _tags ├── doc ├── index.mld ├── note_ui_sample.png └── semantics.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── brr │ ├── note_brr.ml │ ├── note_brr.mli │ ├── note_brr.mllib │ ├── note_brr_kit.ml │ ├── note_brr_kit.mli │ ├── note_brr_legacy.ml │ └── note_brr_legacy.mli ├── note.ml ├── note.mli └── note.mllib └── test ├── base.css ├── clock.ml ├── test.ml ├── test_key.ml ├── test_leak.ml ├── test_mouse.ml ├── test_mutobs.ml ├── todomvc.html └── todomvc.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *~ 5 | \.\#* 6 | \#*# 7 | *.install 8 | *.native 9 | *.byte -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit brr 2 | S src 3 | S test 4 | B _b0/** 5 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never 2 | -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | 3 | (* OCaml library names *) 4 | 5 | let unix = B0_ocaml.libname "unix" 6 | let brr = B0_ocaml.libname "brr" 7 | 8 | let note = B0_ocaml.libname "note" 9 | let note_brr = B0_ocaml.libname "note.brr" 10 | 11 | (* Libraries *) 12 | 13 | let note_lib = 14 | let srcs = [ `File ~/"src/note.mli"; `File ~/"src/note.ml" ] in 15 | B0_ocaml.lib note ~doc:"The note library" ~srcs 16 | 17 | let note_brr_lib = 18 | let srcs = [ `Dir ~/"src/brr" ] in 19 | let requires = [brr; note] in 20 | B0_ocaml.lib note_brr ~doc:"Brr Note support" ~srcs ~requires 21 | 22 | (* Tests *) 23 | 24 | let test_exe ?(requires = []) src ~doc = 25 | let srcs = [`File src] in 26 | let meta = B0_meta.empty |> B0_meta.(tag test) in 27 | let requires = note :: requires in 28 | B0_ocaml.exe (Fpath.basename ~strip_ext:true src) ~srcs ~doc ~meta ~requires 29 | 30 | let test = test_exe ~/"test/test.ml" ~doc:"Test suite" 31 | let clock = 32 | test_exe ~/"test/clock.ml" ~doc:"Reactive clock example" ~requires:[unix] 33 | 34 | let test_assets = [ `File ~/"test/base.css" ] 35 | let test_jsoo ?(requires = [brr]) n ~doc = 36 | let srcs = `File ~/(Fmt.str "test/%s.ml" n) :: test_assets in 37 | B0_jsoo.html_page n ~requires ~srcs ~doc 38 | 39 | let test_jsoo_module ?doc top m requires = 40 | let doc = match doc with 41 | | None -> Fmt.str "Test %s.%s module" top m | Some doc -> doc 42 | in 43 | let test = Fmt.str "test_%s" (String.Ascii.uncapitalize m) in 44 | let srcs = `File (Fpath.v (Fmt.str "test/%s.ml" test)) :: test_assets in 45 | let meta = 46 | B0_meta.empty 47 | |> B0_meta.add B0_jsoo.compile_opts Cmd.(arg "--pretty") 48 | in 49 | B0_jsoo.html_page test ~srcs ~requires ~meta ~doc 50 | 51 | let test_key = test_jsoo_module "Note_brr_kit" "Key" [brr; note; note_brr] 52 | let test_mouse = test_jsoo_module "Note_brr_kit" "Mouse" [brr; note; note_brr] 53 | let test_mutobs = 54 | let doc = "Test use of MutationObservers by Brr_note" in 55 | test_jsoo "test_mutobs" ~doc 56 | 57 | let test_leak = 58 | let requires = [brr; note; note_brr] in 59 | test_jsoo "test_leak" ~requires ~doc:"Tests reactive DOM gc strategy" 60 | 61 | let todomvc = 62 | let srcs = [ `File ~/"test/todomvc.ml"; `File ~/"test/todomvc.html" ] in 63 | let requires = [brr; note; note_brr;] in 64 | B0_jsoo.html_page "todomvc" ~requires ~srcs ~doc:"TodoMVC app" 65 | 66 | (* Packs *) 67 | 68 | let default = 69 | let meta = 70 | B0_meta.empty 71 | |> ~~ B0_meta.authors ["The note programmers"] 72 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 73 | |> ~~ B0_meta.homepage "https://erratique.ch/software/note" 74 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/note/doc/" 75 | |> ~~ B0_meta.licenses ["ISC"] 76 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/note.git" 77 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/note/issues" 78 | |> ~~ B0_meta.description_tags 79 | ["reactive"; "declarative"; "signal"; "event"; "frp"; "org:erratique"; 80 | "browser"; ] 81 | |> ~~ B0_opam.depends 82 | [ "ocaml", {|>= "4.08.0"|}; 83 | "ocamlfind", {|build|}; 84 | "ocamlbuild", {|build|}; 85 | "topkg", {|build & >= "1.0.3"|}; 86 | ] 87 | |> ~~ B0_opam.build 88 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%" 89 | "--with-brr" "%{brr:installed}%"]]|} 90 | |> ~~ B0_opam.depopts ["brr", ""] 91 | |> ~~ B0_opam.conflicts [ "brr", {|< "0.0.6"|}] 92 | |> B0_meta.tag B0_opam.tag 93 | in 94 | B0_pack.make "default" ~doc:"note package" ~meta ~locked:true @@ 95 | B0_unit.list () 96 | -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/note/fc38a91f7a8522e17fdc6d051eb81c7d89f51289/BRZO -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.0.3 2023-07-39 Zagreb 2 | ------------------------ 3 | 4 | - Add the `note.brr` experimental library. This used to be `brr.note` 5 | in `brr`. The toplevel modules have been renamed from `Brr_note*` to 6 | `Note_brr*`. `brr` becomes an optional dependency of `note`. 7 | 8 | v0.0.2 2022-02-10 La Forclaz (VS) 9 | --------------------------------- 10 | 11 | - Handle `Pervasives`'s deprecation (and thus support OCaml 5.00). 12 | 13 | v0.0.1 2020-10-08 Zagreb 14 | ------------------------ 15 | 16 | First release to support `brr`. 17 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 The note programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Note — Declarative events and signals for OCaml 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | Note is an OCaml library for functional reactive programming (FRP). It 6 | provides support to program with time varying values: declarative 7 | events and signals. 8 | 9 | Note also has (optional and experimental) support for reactive browser 10 | programming with the [brr] library. 11 | 12 | Note is distributed under the ISC license. 13 | 14 | Homepage: 15 | 16 | [brr]: https://erratique.ch/software/brr 17 | 18 | ## Installation 19 | 20 | Note can be installed with `opam`: 21 | 22 | opam install note 23 | opam install note brr # For the browser support 24 | 25 | If you don't use `opam` consult the [`opam`](opam) file for build 26 | instructions. 27 | 28 | ## Documentation 29 | 30 | The documentation can be consulted [online] or via `odig doc note`. 31 | 32 | Questions are welcome but better asked on the [OCaml forum] than on 33 | the issue tracker. 34 | 35 | [online]: http://erratique.ch/software/note/doc 36 | [OCaml forum]: https://discuss.ocaml.org/ 37 | 38 | ## Sample programs 39 | 40 | An implementation of the [TodoMVC] application with `note.brr` is 41 | in [todomvc.ml](test/todomvc.ml). 42 | 43 | You can run it with `b0 -- todomvc` see also `b0 list` for other 44 | tests to run. 45 | 46 | [TodoMVC]: http://todomvc.com/ 47 | 48 | ## History 49 | 50 | Note is a *potential* successor to the OCaml [React] library. 51 | 52 | On the plus side: 53 | 54 | * Uses a simpler push/pull implementation which does not uses weak 55 | references. Combinators are easier to implement and understand. 56 | * Provides a formal API to interface the outputs of the reactive 57 | system rather than rely on effectful events and signals. Enforces 58 | life-time management of the output of the reactive system 59 | and could provides (dynamic) detection of constant signals and never 60 | occuring events. 61 | * Provides (hopefully) a better combinator set. Especially with 62 | respect to the pain point of signal initialization in React: 63 | in Note, due the pull based strategy, `{E,S}.value` is safe and 64 | sound to use. 65 | 66 | On the minus side: 67 | 68 | * The life-time of the outputs of the reactive system have to be 69 | explicitely managed; but we argue this has to be done anyways in 70 | practice especially in browsers due to lack of weak references. 71 | * It is easier for code interfacing the outputs of the reactive system 72 | to break the FRP denotational semantics and thus equational 73 | reasoning. However the discipline needed not to do so is clear and 74 | simple: do not reobserve a signal/event that was no longer observed. 75 | * The depth first DAG update strategy of Note may be subject to 76 | stackoverflows on deep DAGs. We suspect however that this should not 77 | be a problem in practice. 78 | 79 | On the unknown side: 80 | 81 | * Memory footprint is likely to be smaller in Note. Nodes of the DAG 82 | do not keep track of the nodes that depend on them via weak 83 | references. They do keep track of the root nodes of the DAG they 84 | depend on, but these sets can be shared among nodes. 85 | * Lack of weak references in Note may improve performance. 86 | * On updates the number of nodes that have to be *visited* (not 87 | *recomputed*) is larger in Note. In React this is the minimal 88 | number of nodes *effectively* affected by the update, in Note this is 89 | all the nodes thay *may be* affected by the update. However 90 | react also needs a priority queue with weak references for its update, 91 | Note does not need this and allows to update the graph at any point where 92 | it might be needed. The latter brings API usability improvements, 93 | e.g. the sound and safe implementation of `{E,S}.value` in Note. 94 | 95 | [React]: http://erratique.ch/software/react 96 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | * Regarding the 4 | let s1 = ... 5 | let s2 = ... 6 | let S.swap (E.map (fun bool -> if bool then s1 else s2)) 7 | problem what about trying to update on reconnection ? 8 | This still breaks the semantics (e.g. for a state accumulating 9 | signal, what happened when disconnected will not be taken into 10 | account), but in many cases that may not matter. 11 | 12 | 13 | 14 | * Does `E.fix` work ? 15 | * `E.S.delay_dt` in practice one needs to deal with bounds (see 16 | e.g. `{E,S}.until ~limit` it would be nice to get an easy treatment 17 | of that. 18 | 19 | * `E.now` ??? `E.once`, `E.drop_once`. 20 | 21 | * Try to provide support for constant cells and their observation. 22 | I'd be nice though if it doesn't propagate in the high-level combinators, 23 | smart constructors are smart but it's a bit painful to make all the 24 | combining cases. 25 | The type for cells itself could be refined or maybe only the `value` 26 | field of cells could be made a variant or even a boolean attribute 27 | (or a special `update` function that we can test to save space). 28 | 29 | 30 | * Try to further simplify combinator implementation. In particular 31 | see if the init bits can be performed by [update] it's often 32 | almost a dupe. 33 | 34 | * Try to lazy cells at the top level `type 'a t = ... Lazy.t` and see if 35 | we can provide `delay : 'a -> 'a t Lazy.t -> 'a lazy` for recursive 36 | definitions rather than the horrible fix point operators. 37 | 38 | * Try to provide a story for primitive feedback. 39 | 40 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | 3 | <_b0> : -traverse 4 | : include 5 | 6 | : include 7 | : package(brr) 8 | 9 | : include 10 | : package(unix) -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Note {%html: %%VERSION%%%}} 2 | 3 | Note is a library for functional reactive programming (FRP). It 4 | provides support to program with time varying values: declarative 5 | events and signals. 6 | 7 | The semantics of events and signals is described in 8 | {{!page-semantics}this manual}. 9 | 10 | {b WARNING.} This package is experimental, it's documentation is 11 | subpar and the interfaces will likely change in the future. 12 | 13 | {1:note_library [note] library} 14 | 15 | {!modules: Note} 16 | 17 | {1:note_brr_library [note.brr] library} 18 | 19 | This library has the reactive infrastructure for browsers and 20 | a few higher-level APIs. 21 | 22 | {b Experimental, will break in the future}. 23 | 24 | {!modules: Note_brr Note_brr_kit Note_brr_legacy} 25 | -------------------------------------------------------------------------------- /doc/note_ui_sample.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/note/fc38a91f7a8522e17fdc6d051eb81c7d89f51289/doc/note_ui_sample.png -------------------------------------------------------------------------------- /doc/semantics.mld: -------------------------------------------------------------------------------- 1 | {0 Semantics of events and signals} 2 | 3 | This following defines the semantics and notations used to give 4 | precise meaning to events and signals. 5 | 6 | It is important to note that when these notation are used to describe 7 | event or signal combinators, the origin of time t = 0 is {e always} 8 | fixed at the time at which the combinator creates the event or the 9 | signal and the semantics of the dependents is evaluated relative to 10 | this timeline. 11 | 12 | We use dt to denote an infinitesimal amount of time. 13 | 14 | {1:events Events} 15 | 16 | An event is a value with discrete occurrences over time. 17 | 18 | The semantic function \[\] [: 'a event -> time -> 'a option] gives 19 | meaning to an event [e] by mapping it to a function of time \[[e]\] [: 20 | time -> 'a option] returning [Some v] whenever the event occurs with 21 | value [v] and [None] otherwise. We write \[[e]\]{_t} the evaluation of 22 | this {e semantic} function at time t. 23 | 24 | As a shortcut notation we also define \[\]{_ 'a 25 | option] (resp. \[\]{_≤t}) to denote the last occurrence, if any, of 26 | an event before (resp. before or at) t. More precisely : 27 | 28 | {ul 29 | {- \[[e]\]{_ None].} 31 | {- \[[e]\]{_ time -> 'a] gives meaning 40 | to a signal [s] by mapping it to a function of time \[[s]\] [ : time 41 | -> 'a] that returns its value at a given time. We write \[[s]\]{_t} 42 | the evaluation of this {e semantic} function at time t. 43 | 44 | {2:equality Equality} 45 | 46 | Most signal combinators have an optional [eq] parameter that defaults 47 | to structural equality {!Stdlib.( = )}. [eq] specifies the equality 48 | function used to detect changes in the value of the resulting signal. 49 | 50 | {2:continuity Continuity} 51 | 52 | Ultimately signal updates depend on primitives updates. Thus a signal 53 | can only approximate a real continuous signal. The accuracy of the 54 | approximation depends on the variation rate of the real signal and the 55 | primitive's update frequency. -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "note" 3 | synopsis: "Declarative events and signals for OCaml" 4 | description: """\ 5 | Note is an OCaml library for functional reactive programming (FRP). It 6 | provides support to program with time varying values: declarative 7 | events and signals. 8 | 9 | Note also has (optional and experimental) support for reactive browser 10 | programming with the [brr] library. 11 | 12 | Note is distributed under the ISC license. 13 | 14 | Homepage: 15 | 16 | [brr]: https://erratique.ch/software/brr""" 17 | maintainer: "Daniel Bünzli " 18 | authors: "The note programmers" 19 | license: "ISC" 20 | tags: [ 21 | "reactive" "declarative" "signal" "event" "frp" "org:erratique" "browser" 22 | ] 23 | homepage: "https://erratique.ch/software/note" 24 | doc: "https://erratique.ch/software/note/doc/" 25 | bug-reports: "https://github.com/dbuenzli/note/issues" 26 | depends: [ 27 | "ocaml" {>= "4.08.0"} 28 | "ocamlfind" {build} 29 | "ocamlbuild" {build} 30 | "topkg" {build & >= "1.0.3"} 31 | ] 32 | depopts: ["brr"] 33 | conflicts: [ 34 | "brr" {< "0.0.6"} 35 | ] 36 | build: [ 37 | "ocaml" 38 | "pkg/pkg.ml" 39 | "build" 40 | "--dev-pkg" 41 | "%{dev}%" 42 | "--with-brr" 43 | "%{brr:installed}%" 44 | ] 45 | dev-repo: "git+https://erratique.ch/repos/note.git" 46 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Declarative events and signals for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "note.cma" 5 | archive(native) = "note.cmxa" 6 | plugin(byte) = "note.cma" 7 | plugin(native) = "note.cmxs" 8 | 9 | package "brr" ( 10 | directory = "brr" 11 | description = "Brr Note support" 12 | version = "%%VERSION_NUM%%" 13 | requires = "note brr" 14 | archive(byte) = "note_brr.cma" 15 | archive(native) = "note_brr.cmxa" 16 | plugin(byte) = "note_brr.cma" 17 | plugin(native) = "note_brr.cmxs" 18 | ) -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let brr = Conf.with_pkg "brr" 7 | 8 | let () = 9 | Pkg.describe "note" @@ fun c -> 10 | let brr = Conf.value c brr in 11 | Ok [ Pkg.mllib "src/note.mllib"; 12 | Pkg.mllib "src/brr/note_brr.mllib" ~cond:brr ~dst_dir:"brr/"; 13 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 14 | Pkg.test "test/test"; 15 | Pkg.test ~run:false "test/clock"; 16 | Pkg.doc ~built:false "doc/note_ui_sample.png" ~dst:"odoc-assets/"; 17 | ] 18 | -------------------------------------------------------------------------------- /src/brr/note_brr.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open Note 8 | 9 | module Futr = struct 10 | let to_event f = 11 | let e, send_e = E.create () in 12 | let send_e v = ignore (G.set_timeout ~ms:0 @@ fun () -> send_e v) in 13 | Fut.await f send_e; e 14 | 15 | let of_event e = 16 | let fut, set_fut = Fut.create () in 17 | let logr = ref None in 18 | let set_fut v = 19 | (* N.B. this may be called immediately because of ~now:true. 20 | The delay ensure logr will be Some _ .*) 21 | ignore @@ G.set_timeout ~ms:0 @@ fun () -> 22 | match !logr with 23 | | None -> assert false 24 | | Some logr -> Logr.destroy logr; set_fut v 25 | in 26 | match E.log ~now:true e set_fut with 27 | | None -> None 28 | | Some _ as s -> logr := s; Some fut 29 | end 30 | 31 | module Consoler = struct 32 | let tick _ = Console.[Jstr.v "tick"] 33 | let log_value ?(l = Console.debug) ?(v = fun v -> Console.[v]) id x = 34 | l Console.(Jstr.(v id + v ":") :: (v x)); x 35 | 36 | module E = struct 37 | let log ?(obs = false) ?l ?v id e = match obs with 38 | | false -> E.map (log_value ?l ?v id) e 39 | | true -> 40 | Logr.may_hold (E.log e (fun ev -> ignore @@ log_value ?l ?v id ev)); e 41 | end 42 | 43 | module S = struct 44 | let log ?(obs = false) ?l ?v id s = match obs with 45 | | false -> S.map ~eq:(S.eq s) (log_value ?l ?v id) s 46 | | true -> Logr.hold (S.log s (fun sv -> ignore @@ log_value ?l ?v id sv)); s 47 | end 48 | end 49 | 50 | module Evr = struct 51 | let instruct ?(propagate = true) ?(default = true) e = 52 | (if default then () else Ev.prevent_default e); 53 | if propagate then () else Ev.stop_propagation e 54 | 55 | let endless_listen ?(capture = false) ?propagate ?default t type' f = 56 | let opts = match capture with 57 | | false -> None | true -> Some (Ev.listen_opts ~capture ()) 58 | in 59 | let f ev = instruct ?propagate ?default ev; f ev in 60 | ignore (Ev.listen ?opts type' f t) 61 | 62 | (* Note events *) 63 | 64 | let on_target ?(capture = false) ?propagate ?default type' f t = 65 | let opts = match capture with 66 | | false -> None | true -> Some (Ev.listen_opts ~capture ()) 67 | in 68 | let e, send_e = E.create () in 69 | let f ev = instruct ?propagate ?default ev; send_e (f ev) in 70 | ignore (Ev.listen ?opts type' f t); 71 | e 72 | 73 | let on_targets ?(capture = false) ?propagate ?default type' f ts = 74 | let opts = match capture with 75 | | false -> None | true -> Some (Ev.listen_opts ~capture ()) 76 | in 77 | let e, send_e = E.create () in 78 | let f ev = instruct ?propagate ?default ev; send_e (f (Ev.target ev) ev) in 79 | List.iter (fun t -> ignore (Ev.listen ?opts type' f t)) ts; 80 | e 81 | 82 | let on_el ?capture ?propagate ?default type' f el = 83 | on_target ?capture ?propagate ?default type' f (El.as_target el) 84 | 85 | let on_els ?(capture = false) ?propagate ?default type' f els = 86 | let opts = match capture with 87 | | false -> None | true -> Some (Ev.listen_opts ~capture ()) 88 | in 89 | let e, send_e = E.create () in 90 | let f ev = 91 | instruct ?propagate ?default ev; 92 | send_e (f (Obj.magic (* oh well *) (Ev.target ev) : El.t) ev) 93 | in 94 | List.iter 95 | (fun el -> ignore (Ev.listen ?opts type' f (El.as_target el))) els; 96 | e 97 | 98 | let unit e = () 99 | let stamp v e = v 100 | let listen ?(capture = false) ?propagate ?default t type' f = 101 | let opts = match capture with 102 | | false -> None | true -> Some (Ev.listen_opts ~capture ()) 103 | in 104 | let f ev = instruct ?propagate ?default ev; f ev in 105 | let k = Ev.listen ?opts type' f t in 106 | fun () -> Ev.unlisten k 107 | end 108 | 109 | module Elr = struct 110 | 111 | (* DOM garbage collection support. We observe HTML DOM additions and 112 | removals on body and invoke callback registered for the 113 | appropriate life cycle event. In particular Note loggers from 114 | nodes that are removed from the HTML DOM are destroyed. *) 115 | 116 | let xxx_funs xxx e : (unit -> unit) list = Obj.magic @@ Jv.get e xxx 117 | let add_xxx_fun xxx f e = 118 | let fs = Jv.get e xxx in 119 | let fs = if Jv.is_undefined fs then [f] else (f :: Obj.magic fs) in 120 | Jv.set e xxx (Jv.repr fs) 121 | 122 | let add_add_fun = add_xxx_fun "brr_add" 123 | let add_rem_fun = add_xxx_fun "brr_rem" 124 | let add_funs = xxx_funs "brr_add" 125 | let rem_funs = xxx_funs "brr_rem" 126 | 127 | let invoke_funs xxx node = 128 | let star = Jv.of_string "*" in 129 | let descendents n = Jv.call (El.to_jv n) "querySelectorAll" [| star |] in 130 | if not (El.is_el node) then () else 131 | let invoke_node_funs n = 132 | let funs = xxx_funs xxx n in 133 | List.iter (fun f -> f ()) funs; 134 | Jv.set n xxx (Jv.repr []) 135 | in 136 | let ns = descendents node in 137 | for i = 0 to (Jv.Int.get ns "length") - 1 do 138 | let n = Jv.call ns "item" [|Jv.of_int i|] in 139 | invoke_node_funs n 140 | done; 141 | invoke_node_funs (El.to_jv node) 142 | 143 | let () = (* Observe DOM additionals and removals *) 144 | let obs records _obs = 145 | let in_html_dom n = 146 | Jv.call (El.to_jv n) "getRootNode" [||] == Document.to_jv @@ G.document 147 | in 148 | for i = 0 to (Jv.Int.get records "length") - 1 do 149 | let r = Jv.Jarray.get records i in 150 | let adds = Jv.get r "addedNodes" in 151 | for i = 0 to (Jv.Int.get adds "length") - 1 do 152 | let n = El.of_jv @@ Jv.call adds "item" [|Jv.of_int i|] in 153 | if in_html_dom n then invoke_funs "brr_add" n 154 | done; 155 | let rems = Jv.get r "removedNodes" in 156 | for i = 0 to (Jv.Int.get rems "length") - 1 do 157 | let n = El.of_jv @@ Jv.call rems "item" [|Jv.of_int i|] in 158 | if not (in_html_dom n) then invoke_funs "brr_rem" n 159 | done 160 | done 161 | in 162 | let mutation_observer = Jv.get Jv.global "MutationObserver" in 163 | if Jv.is_none mutation_observer || Jv.is_none (Document.to_jv G.document) 164 | then ((* protect web worker *)) else 165 | let obs = Jv.new' mutation_observer [| Jv.callback ~arity:2 obs |] in 166 | let opts = Jv.obj [| "childList", Jv.true'; "subtree", Jv.true' |] in 167 | let root = El.to_jv @@ Document.root G.document in 168 | ignore @@ Jv.call obs "observe" [| root; opts |] 169 | 170 | (* Logr gc *) 171 | 172 | let add_logr e l = add_rem_fun (fun () -> Logr.destroy l) (El.to_jv e) 173 | let may_add_logr e = function None -> () | Some l -> add_logr e l 174 | 175 | (* Children *) 176 | 177 | let set_children e ~on = may_add_logr e (E.log on (El.set_children e)) 178 | let def_children e cs = add_logr e (S.log cs (El.set_children e)) 179 | 180 | (* Attributes *) 181 | 182 | let set_at a ~on e = may_add_logr e (E.log on (fun v -> El.set_at a v e)) 183 | let def_at a vs e = add_logr e (S.log vs (fun v -> El.set_at a v e)) 184 | 185 | (* Classes *) 186 | 187 | let set_class c ~on e = 188 | may_add_logr e (E.log on (fun v -> El.set_class c v e)) 189 | 190 | let def_class c bs e = 191 | add_logr e (S.log bs (fun v -> El.set_class c v e)) 192 | 193 | (* Properties *) 194 | 195 | let set_prop p ~on e = 196 | may_add_logr e (E.log on (fun v -> El.set_prop p v e)) 197 | 198 | let def_prop p vs e = 199 | add_logr e (S.log vs (fun v -> El.set_prop p v e)) 200 | 201 | (* Style *) 202 | 203 | let set_inline_style ?important p ~on e = 204 | may_add_logr e (E.log on (fun v -> El.set_inline_style ?important p v e)) 205 | 206 | let def_inline_style ?important p vs e = 207 | add_logr e (S.log vs (fun v -> El.set_inline_style ?important p v e)) 208 | 209 | (* Focus *) 210 | 211 | let set_has_focus ~on e = 212 | may_add_logr e (E.log on (fun v -> El.set_has_focus v e)) 213 | 214 | let def_has_focus b e = 215 | add_logr e (S.log b (fun v -> El.set_has_focus v e)) 216 | 217 | (* Life-cycle callbacks *) 218 | 219 | let on_add f e = add_add_fun f (El.to_jv e) 220 | let on_rem f e = add_rem_fun f (El.to_jv e) 221 | 222 | (* Note loggers *) 223 | 224 | let call f ~on e = may_add_logr e (E.log on (fun v -> f v e)) 225 | let hold_logr e l = add_logr e l 226 | let may_hold_logr e l = may_add_logr e l 227 | end 228 | -------------------------------------------------------------------------------- /src/brr/note_brr.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Infrastructure for reactive browser interaction. 7 | 8 | This is the low-level infrastructure to enable reactive 9 | browser programming. See {!Brr_note_kit} for more fancy stuff. *) 10 | 11 | open Note 12 | open Brr 13 | 14 | (** Futures as {!Note} events and vice-versa. *) 15 | module Futr : sig 16 | 17 | val to_event : 'a Fut.t -> 'a event 18 | (** [to_event fut] is an event that occurs {e once} an infinitesimal amount 19 | of time after [fut] does. This means at earliest at the next 20 | JavaScript event loop cycle, even if [fut] is already determined. *) 21 | 22 | val of_event : 'a event -> 'a Fut.t option 23 | (** [of_event e] is a future that determines an infinitesimal amount 24 | of time after the current or next occurence of [e]. This means 25 | at earliest at the next JavaScript event loop cycle, even if [e] 26 | occurs now. [e] is observed only once by the future. [None] is returned 27 | if [e] never occurs. *) 28 | end 29 | 30 | (** Support for logging Note events and signals. *) 31 | module Consoler : sig 32 | 33 | val tick : 'a Console.msgr 34 | (** [tick] formats ["tick"] on any value. *) 35 | 36 | val log_value : ?l:Console.log -> ?v:'a Console.msgr -> string -> 'a -> 'a 37 | (** [log_value ~l ~v id x] is [x] but logs [x] with [l] (defaults to 38 | {!Brr.Console.debug}) formatted by [v] (defaults 39 | {!Brr.Console.val-msg}) and prepended by [id]. *) 40 | 41 | (** Logging events. *) 42 | module E : sig 43 | val log : 44 | ?obs:bool -> ?l:Console.log -> ?v:'a Console.msgr -> string -> 45 | 'a event -> 'a event 46 | (** [event] is like {!log_value} on [e]'s occurences. If [obs] is 47 | [true] the returned value is [e] itself and the tracing occurs 48 | through a logger; note that this prevents [e] from being garbage 49 | collected. If [obs] is false, the return value is [e] mapped 50 | by a side effecting identity. *) 51 | end 52 | 53 | (** Logging signal changes. *) 54 | module S : sig 55 | val log : 56 | ?obs:bool -> ?l:Console.log -> ?v:'a Console.msgr -> string -> 57 | 'a signal -> 'a signal 58 | (** [signal] is like {!log_value} but on the changes of [s]. If 59 | [obs] is [true], the return value is [s] itself and the 60 | tracing occurs through a logger, note that this prevents [s] 61 | from being garbage collected. If [obs] is [false], the return 62 | value is [s] mapped by a tracing identity and using [s]'s 63 | equality function. *) 64 | end 65 | end 66 | 67 | (** DOM events as {!Note} events. *) 68 | module Evr : sig 69 | 70 | val on_target : 71 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 'b Ev.type' -> 72 | ('b Ev.t -> 'c) -> Ev.target -> 'c event 73 | (** [on_target ~capture ~propagate ~default et f t] is an event that 74 | reports events of type [et] transformed by [f] on target [t] such 75 | that: 76 | {ul 77 | {- If [capture] is [true] the event occurs during the capture phase. 78 | Defaults to [false].} 79 | {- If [propagate] is [true] the event is propagated. Defaults to [true].} 80 | {- If [default] is [true] the default behaviour is performed. Defaults 81 | to [true].}} *) 82 | 83 | val on_targets : 84 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 'b Ev.type' -> 85 | (Ev.target -> 'b Ev.t -> 'c) -> Ev.target list -> 'c event 86 | (** {!on_targets} is like {!on_target} except the event occurs 87 | for the event kind on the given list of targets. *) 88 | 89 | val on_el : 90 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 'b Ev.type' -> 91 | ('b Ev.t -> 'c) -> El.t -> 'c event 92 | (** [on_el et f el] is [for_target et f (El.as_target el)]. *) 93 | 94 | val on_els : 95 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 'b Ev.type' -> 96 | (El.t -> 'b Ev.t -> 'c) -> El.t list -> 'c event 97 | (** [on_els et f els] is [for_targets et f (List.map El.as_target els)]. *) 98 | 99 | (** {1:evmap Event mappers} *) 100 | 101 | val unit : 'b Ev.t -> unit 102 | (** [unit e] is [()]. *) 103 | 104 | val stamp : 'a -> 'b Ev.t -> 'a 105 | (** [stamp v e] is [v]. *) 106 | 107 | (** {1:low Low level functions} 108 | 109 | {b XXX.} Maybe move that to {!Brr.Ev} *) 110 | 111 | val instruct : ?propagate:bool -> ?default:bool -> 'a Ev.t -> unit 112 | (** [instruct ?propagate ?default e] defines the propagation and 113 | default behaviour of [e] according to [propagate] (defaults 114 | to [true]) and default (defaults to [true]). *) 115 | 116 | val listen : 117 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 118 | Brr.Ev.target -> 'a Brr.Ev.type' -> ('a Brr.Ev.t -> unit) -> (unit -> unit) 119 | 120 | val endless_listen : 121 | ?capture:bool -> ?propagate:bool -> ?default:bool -> 122 | Brr.Ev.target -> 'a Brr.Ev.type' -> ('a Brr.Ev.t -> unit) -> unit 123 | end 124 | 125 | (** Reactive DOM elements. 126 | 127 | {b Warning.} Reactive DOM element mutators ({!Elr.set_at}, 128 | {!Elr.set_children}, etc.) and definers ({!Elr.def_at}, 129 | {!Elr.def_children}, etc.) use {{!Note.Logr}[Note] loggers} to 130 | perform their action. To prevent memory leaks, these loggers, and 131 | thus their action, automatically get destroyed whenever the 132 | element is removed from the HTML DOM. *) 133 | module Elr : sig 134 | 135 | (** {1:children Children} *) 136 | 137 | val set_children : El.t -> on:El.t list event -> unit 138 | (** [set_children e ~on] sets [e]'s children with the value of [on] 139 | whenever it occurs. *) 140 | 141 | val def_children : El.t -> El.t list signal -> unit 142 | (** [def_children e cs] defines [e]'s children over time with the 143 | value of signal [cs]. {b Warning.} This assumes [cs] is the only 144 | entity interacting with the children. *) 145 | 146 | (** {1:ats Attributes and properties} *) 147 | 148 | val set_at : At.name -> on:Jstr.t option event -> El.t -> unit 149 | (** [set_at a ~on e] sets attribute [a] of [e] with the value 150 | of [e] whenever it occurs. If the value is [None] this removes 151 | the attribute. *) 152 | 153 | val def_at : At.name -> Jstr.t option signal -> El.t -> unit 154 | (** [def_at a v e] defines the attribute [a] of [e] over time 155 | with the value of [v]. Whenever the signal value is [None], 156 | the attribute is removed. {b Warning.} This assumes [v] is the 157 | only entity interacting with that attribute. *) 158 | 159 | val set_prop : 'a El.Prop.t -> on:'a event -> El.t -> unit 160 | (** [set_prop p ~on e] sets property [p] of [e] to the value 161 | of [on] whenever it occurs. *) 162 | 163 | val def_prop : 'a El.Prop.t -> 'a signal -> El.t -> unit 164 | (** [def_prop p v e] defines the property [p] of [e] over time with 165 | the value of [v]. {b Warning.} This assumes [v] is the only 166 | entity interacting with that property. *) 167 | 168 | (** {1:classes Classes} *) 169 | 170 | val set_class : Jstr.t -> on:bool event -> El.t -> unit 171 | (** [set_class a ~on e] sets the membership of [e] to class [e] 172 | with the value of [on] whenever it occurs. *) 173 | 174 | val def_class : Jstr.t -> bool signal -> El.t -> unit 175 | (** [rdef_class a b e] defines the membership of [e] to class [e] 176 | over time with the value of [b]. {b Warning.} This assumes [b] is 177 | the only entity interacting with that class. *) 178 | 179 | (** {1:styles Style} *) 180 | 181 | val set_inline_style : 182 | ?important:bool -> El.Style.prop -> on:Jstr.t event -> El.t -> unit 183 | (** [set_style ~important p ~on e] sets the inline style property [p] 184 | of [e] to the value of [on] whenever it occurs with priority 185 | [important] (defaults to [false]). *) 186 | 187 | val def_inline_style : 188 | ?important:bool -> El.Style.prop -> Jstr.t signal -> El.t -> unit 189 | (** [def_style p v e] sets the inline style property [p] of [e] over time 190 | with the value of [v]. {b Warning.} This assumes [v] is the only 191 | entity interacting with that property. *) 192 | 193 | (** {1:focus Focus} *) 194 | 195 | val set_has_focus : on:bool event -> El.t -> unit 196 | (** [set_focus e ~on] sets [e]'s focus with the value of [on] 197 | whenever it occurs. *) 198 | 199 | val def_has_focus : bool signal -> El.t -> unit 200 | (** [def_focus e v] defines the focus of [e] over time 201 | with the value of [v]. {b Warning.} This asumes [v] is the only 202 | entity interacting with [e]'s focus. *) 203 | 204 | (** {1:life_cycle Life-cycle callbacks} 205 | 206 | The browser document is watched for changes via a global 207 | {{:https://developer.mozilla.org/en-US/docs/Web/API/MutationObserver} 208 | MutationObserver}. Whenever an element is added in the HTML DOM, 209 | its {!on_add} callbacks get called and disposed. Whenever an 210 | element is removed from the HTML DOM, {!on_rem} callbacks get 211 | called and disposed. A element is deemed part of the HTML DOM if 212 | its root node is the browser document. *) 213 | 214 | val on_add : (unit -> unit) -> El.t -> unit 215 | (** [on_add f e] references [f] until [e] is inserted in 216 | the HTML DOM, at which point [f ()] is invoked. *) 217 | 218 | val on_rem : (unit -> unit) -> El.t -> unit 219 | (** [on_rem f e] references [f] until [e] is removed from 220 | the HTML DOM, at which point [f ()] is invoked. *) 221 | 222 | (** {1:note Note loggers} *) 223 | 224 | val call : ('a -> El.t -> unit) -> on:'a event -> El.t -> unit 225 | (** [call f ~on e] calls [f] on [e] with the value of [e] whenever 226 | [on] occurs. The underlying logger is held by [e]. *) 227 | 228 | val hold_logr : El.t -> Logr.t -> unit 229 | (** [hold_logr e l] lets [e] hold logger [l] and destroy it via 230 | {!on_rem} once [e] is removed from the document. *) 231 | 232 | val may_hold_logr : El.t -> Logr.t option -> unit 233 | (** [may_hold_logr e l] is like {!hold_logr} but does nothing on 234 | [None]. *) 235 | end 236 | -------------------------------------------------------------------------------- /src/brr/note_brr.mllib: -------------------------------------------------------------------------------- 1 | Note_brr 2 | Note_brr_kit 3 | Note_brr_legacy -------------------------------------------------------------------------------- /src/brr/note_brr_kit.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open Note 8 | open Note_brr 9 | 10 | module Key = struct 11 | type code = int 12 | type t = 13 | [ `Alt of [ `Left | `Right ] 14 | | `Arrow of [ `Up | `Down | `Left | `Right ] 15 | | `Ascii of Char.t 16 | | `Backspace 17 | | `Ctrl of [ `Left | `Right ] 18 | | `End 19 | | `Enter 20 | | `Escape 21 | | `Func of int 22 | | `Home 23 | | `Insert 24 | | `Key of code 25 | | `Meta of [ `Left | `Right ] 26 | | `Page of [ `Up | `Down ] 27 | | `Return 28 | | `Shift of [ `Left | `Right ] 29 | | `Spacebar 30 | | `Tab ] 31 | 32 | (* For browser keyboard handling see http://unixpapa.com/js/key.html *) 33 | 34 | let of_keycode kc = match kc with 35 | | c when 48 <= c && c <= 57 -> `Ascii (Char.chr c) 36 | | c when 65 <= c && c <= 90 -> `Ascii (Char.chr (c + 32) (* to lower *)) 37 | | c when 96 <= c && c <= 105 -> `Ascii (Char.chr (c - 96 + 48)) 38 | | c when 112 <= c && c <= 135 -> `Func (c - 111) 39 | | 8 -> `Backspace 40 | | 9 -> `Tab 41 | | 13 -> `Return 42 | | 16 -> `Shift `Left 43 | | 17 -> `Ctrl `Left 44 | | 18 -> `Alt `Left 45 | | 27 -> `Escape 46 | | 32 -> `Spacebar 47 | | 33 -> `Page `Up 48 | | 34 -> `Page `Down 49 | | 35 -> `End 50 | | 36 -> `Home 51 | | 37 -> `Arrow `Left 52 | | 38 -> `Arrow `Up 53 | | 39 -> `Arrow `Right 54 | | 40 -> `Arrow `Down 55 | | 45 -> `Enter 56 | | 91 | 224 -> `Meta `Left 57 | | 93 -> `Meta `Right 58 | | c -> `Key c 59 | 60 | let of_ev e = of_keycode (Jv.Int.get (Ev.to_jv e) "keyCode") 61 | let equal k0 k1 = k0 = k1 62 | let compare k0 k1 = compare k0 k1 63 | 64 | let dir_to_jstr = function 65 | | `Left -> Jstr.v "left" | `Right -> Jstr.v "right" 66 | | `Up -> Jstr.v "up" | `Down -> Jstr.v "down" 67 | 68 | let to_jstr = function 69 | | `Alt dir -> Jstr.(v "alt_" + dir_to_jstr dir) 70 | | `Arrow dir -> Jstr.(v "arrow_" + dir_to_jstr dir) 71 | | `Ascii c -> Jstr.(v "key_" + of_char c) (* FIXME escape *) 72 | | `Backspace -> Jstr.v "backspace" 73 | | `Ctrl dir -> Jstr.(v "ctrl_" + dir_to_jstr dir) 74 | | `End -> Jstr.v "end" 75 | | `Enter -> Jstr.v "enter" 76 | | `Escape -> Jstr.v "escape" 77 | | `Func n -> Jstr.(v "F" + of_int n) 78 | | `Home -> Jstr.v "home" 79 | | `Insert -> Jstr.v "insert" 80 | | `Key c -> Jstr.(v "key_" + of_int c) 81 | | `Meta dir -> Jstr.(v "meta_" + dir_to_jstr dir) 82 | | `Page dir -> Jstr.(v "page_" + dir_to_jstr dir) 83 | | `Return -> Jstr.v "return" 84 | | `Shift dir -> Jstr.(v "shift_" + dir_to_jstr dir) 85 | | `Spacebar -> Jstr.v "spacebar" 86 | | `Tab -> Jstr.v "tab" 87 | 88 | (* FIXME remove use of Hashtbl, do it in Js. *) 89 | 90 | type events = 91 | { any_down : t event; send_any_down : t E.send; 92 | any_up : t event; send_any_up : t E.send; 93 | mutable down_count : int; 94 | any_holds : bool signal; set_any_holds : bool S.set; 95 | down_event : (t, unit event * unit E.send) Hashtbl.t ; 96 | up_event : (t, unit event * unit E.send) Hashtbl.t; 97 | holds : (t, bool signal * bool S.set) Hashtbl.t; 98 | alt : bool signal; ctrl : bool signal; meta : bool signal; 99 | shift : bool signal; } 100 | 101 | let def_event event k = try fst (Hashtbl.find event k) with 102 | | Not_found -> let d = E.create () in Hashtbl.add event k d; fst d 103 | 104 | let send_event ?step event k = try snd (Hashtbl.find event k) ?step () with 105 | | Not_found -> () 106 | 107 | let def_holds holds k = try fst (Hashtbl.find holds k) with 108 | | Not_found -> let d = S.create false in Hashtbl.add holds k d; fst d 109 | 110 | let set_holds ?step holds k v = try snd (Hashtbl.find holds k) ?step v with 111 | | Not_found -> () 112 | 113 | let add_modifiers holds = 114 | let lalt = S.create false in 115 | let ralt = S.create false in 116 | let alt = S.Bool.(fst lalt || fst ralt) in 117 | let lctrl = S.create false in 118 | let rctrl = S.create false in 119 | let ctrl = S.Bool.(fst lctrl || fst rctrl) in 120 | let lmeta = S.create false in 121 | let rmeta = S.create false in 122 | let meta = S.Bool.(fst lmeta || fst rmeta) in 123 | let lshift = S.create false in 124 | let rshift = S.create false in 125 | let shift = S.Bool.(fst lshift || fst rshift) in 126 | Hashtbl.add holds (`Alt `Left) lalt; 127 | Hashtbl.add holds (`Alt `Right) ralt; 128 | Hashtbl.add holds (`Ctrl `Left) lctrl; 129 | Hashtbl.add holds (`Ctrl `Right) rctrl; 130 | Hashtbl.add holds (`Meta `Left) lmeta; 131 | Hashtbl.add holds (`Meta `Right) rmeta; 132 | Hashtbl.add holds (`Shift `Left) lshift; 133 | Hashtbl.add holds (`Shift `Right) rshift; 134 | alt, ctrl, meta, shift 135 | 136 | let handle_down evs ~step k = 137 | evs.down_count <- evs.down_count + 1 ; 138 | evs.send_any_down ~step k; 139 | evs.set_any_holds ~step true; 140 | send_event ~step evs.down_event k; 141 | set_holds ~step evs.holds k true; 142 | () 143 | 144 | let handle_up evs ~step k = 145 | evs.down_count <- evs.down_count - 1; 146 | evs.send_any_up ~step k; 147 | if evs.down_count <= 0 then 148 | (evs.down_count <- 0; evs.set_any_holds ~step false); 149 | send_event ~step evs.up_event k; 150 | set_holds ~step evs.holds k false; 151 | () 152 | 153 | (* Unclear how well that repeat works. Otherwise suppress 154 | repeats like we did in Useri. *) 155 | let down_cb evs e = 156 | if Ev.(Keyboard.repeat (as_type e)) then () else 157 | let step = Step.create () in 158 | handle_down evs ~step (of_ev e); 159 | Step.execute step 160 | 161 | let up_cb evs e = 162 | let step = Step.create () in 163 | handle_up evs ~step (of_ev e); 164 | Step.execute step 165 | 166 | let on_target ?capture ?propagate ?default t = 167 | let hsize = 47 in 168 | let any_down, send_any_down = E.create () in 169 | let any_up, send_any_up = E.create () in 170 | let any_holds, set_any_holds = S.create false in 171 | let down_event = Hashtbl.create hsize in 172 | let up_event = Hashtbl.create hsize in 173 | let holds = Hashtbl.create hsize in 174 | let alt, ctrl, meta, shift = add_modifiers holds in 175 | let evs = { any_down; send_any_down; any_up; 176 | send_any_up; down_count = 0; any_holds; set_any_holds; 177 | down_event; up_event; holds; alt; ctrl; meta; shift } 178 | in 179 | Evr.endless_listen ?capture ?propagate ?default t Ev.keydown (down_cb evs); 180 | Evr.endless_listen ?capture ?propagate ?default t Ev.keyup (up_cb evs); 181 | evs 182 | 183 | let on_el ?capture ?propagate ?default t = 184 | on_target ?capture ?propagate ?default (El.as_target t) 185 | 186 | let any_down evs = evs.any_down 187 | let any_up evs = evs.any_up 188 | let any_holds evs = evs.any_holds 189 | let down evs k = def_event evs.down_event k 190 | let up evs k = def_event evs.up_event k 191 | let holds evs k = def_holds evs.holds k 192 | let alt evs = evs.alt 193 | let ctrl evs = evs.ctrl 194 | let meta evs = evs.meta 195 | let shift evs = evs.shift 196 | end 197 | 198 | module Mouse = struct 199 | let warn_but () = Console.(warn [Jstr.v "unexpected e.which"]) 200 | let pt x y = (x, y) 201 | 202 | type 'a events = 203 | { t : Ev.target; 204 | normalize : bool; 205 | pt : float -> float -> 'a; 206 | mutable last_pos : float * float; 207 | mutable unlisten : (unit -> unit) list; 208 | pos : 'a signal; set_pos : 'a S.set; 209 | dpos : 'a event; send_dpos : 'a E.send; 210 | mem : bool signal; set_mem : bool S.set; 211 | left : bool signal; set_left : bool S.set; 212 | left_down : 'a event; send_left_down : 'a E.send; 213 | left_up : 'a event; send_left_up : 'a E.send; 214 | mid : bool signal; set_mid : bool S.set; 215 | mid_down : 'a event; send_mid_down : 'a E.send; 216 | mid_up : 'a event; send_mid_up : 'a E.send; 217 | right : bool signal; set_right : bool S.set; 218 | right_down : 'a event; send_right_down : 'a E.send; 219 | right_up : 'a event; send_right_up : 'a E.send; } 220 | 221 | let destroy evs = List.iter (fun f -> f ()) evs.unlisten 222 | 223 | let event_mouse_pos pt evs e = 224 | let t = (Obj.magic evs.t : El.t) (* XXX *) in 225 | let x = (Ev.Mouse.client_x e) -. El.bound_x t in 226 | let y = (Ev.Mouse.client_y e) -. El.bound_y t in 227 | if not evs.normalize then pt x y else 228 | let nx = x /. (El.bound_w t) in 229 | let ny = 1. -. (y /. (El.bound_h t)) in 230 | pt nx ny 231 | 232 | let set_mouse_pos ~step evs e = 233 | let x, y as l = event_mouse_pos pt evs e in 234 | let epos = evs.pt x y in 235 | let dx = x -. fst evs.last_pos in 236 | let dy = y -. snd evs.last_pos in 237 | evs.send_dpos ~step (evs.pt dx dy); 238 | evs.set_pos ~step epos; 239 | evs.last_pos <- l; 240 | epos 241 | 242 | let move_cb evs e = 243 | let step = Step.create () in 244 | let _ = set_mouse_pos ~step evs (Ev.as_type e) in 245 | Step.execute step 246 | 247 | let mem_cb mem evs e = 248 | let step = Step.create () in 249 | let _ = set_mouse_pos ~step evs (Ev.as_type e) in 250 | evs.set_mem ~step mem; 251 | Step.execute step 252 | 253 | let down_cb evs e = 254 | let step = Step.create () in 255 | let epos = set_mouse_pos ~step evs (Ev.as_type e) in 256 | let set, send_down = match Ev.Mouse.button (Ev.as_type e) with 257 | | 0 -> evs.set_left, evs.send_left_down 258 | | 1 -> evs.set_mid, evs.send_mid_down 259 | | 2 -> evs.set_right, evs.send_right_down 260 | | _ -> warn_but(); evs.set_left, evs.send_left_down 261 | in 262 | set ~step true; send_down ~step epos; 263 | Step.execute step 264 | 265 | let up_cb evs e = 266 | let step = Step.create () in 267 | let epos = set_mouse_pos ~step evs (Ev.as_type e) in 268 | let set, send_up = match Ev.Mouse.button (Ev.as_type e) with 269 | | 0 -> evs.set_left, evs.send_left_up 270 | | 1 -> evs.set_mid, evs.send_mid_up 271 | | 2 -> evs.set_right, evs.send_right_up 272 | | _ -> warn_but (); evs.set_left, evs.send_left_up 273 | in 274 | set ~step false; send_up ~step epos; 275 | Step.execute step 276 | 277 | let doc_up_cb evs e = 278 | (* [up_cb] will not fire if the mouse is no longer in the target; 279 | but this destroys the semantics of [left], [mid], [right]. 280 | A callback attached to the document handles this. *) 281 | if not (S.rough_value evs.mem) && 282 | (S.rough_value evs.left || S.rough_value evs.mid || 283 | S.rough_value evs.right) 284 | then up_cb evs e else () 285 | 286 | let on_target ?capture ?propagate ?default ?(normalize = true) pt t = 287 | let pos, set_pos = S.create (pt 0. 0.) in 288 | let dpos, send_dpos = E.create () in 289 | let mem, set_mem = S.create false in 290 | let left, set_left = S.create false in 291 | let left_down, send_left_down = E.create () in 292 | let left_up, send_left_up = E.create () in 293 | let mid, set_mid = S.create false in 294 | let mid_down, send_mid_down = E.create () in 295 | let mid_up, send_mid_up = E.create () in 296 | let right, set_right = S.create false in 297 | let right_down, send_right_down = E.create () in 298 | let right_up, send_right_up = E.create () in 299 | let evs = 300 | { t; normalize; pt; last_pos = (0., 0.); 301 | unlisten = []; 302 | pos; set_pos; 303 | dpos; send_dpos; 304 | mem; set_mem; 305 | left; set_left; left_down; send_left_down; left_up; send_left_up; 306 | mid; set_mid; mid_down; send_mid_down; mid_up; send_mid_up; 307 | right; set_right; right_down; send_right_down; right_up; send_right_up} 308 | in 309 | let l = Evr.listen in 310 | let unlisten = 311 | [ l ?capture ?propagate ?default evs.t Ev.mousedown (down_cb evs); 312 | l ?capture ?propagate ?default evs.t Ev.mouseup (up_cb evs); 313 | l ?capture ?propagate ?default evs.t Ev.mousemove (move_cb evs); 314 | l ?capture ?propagate ?default evs.t Ev.mouseenter (mem_cb true evs); 315 | l ?capture ?propagate ?default evs.t Ev.mouseleave (mem_cb false evs); 316 | l ?capture ?propagate ?default 317 | (Document.as_target G.document) Ev.mouseup (doc_up_cb evs) ] 318 | in 319 | evs.unlisten <- unlisten; evs 320 | 321 | let on_el ?capture ?propagate ?default ?normalize pt e = 322 | let t = El.as_target e in 323 | let evs = on_target ?capture ?propagate ?default ?normalize pt t in 324 | Elr.on_rem (fun () -> destroy evs) e; 325 | evs 326 | 327 | let pos evs = evs.pos 328 | let dpos evs = evs.dpos 329 | let mem evs = evs.mem 330 | let left evs = evs.left 331 | let left_down evs = evs.left_down 332 | let left_up evs = evs.left_up 333 | let mid evs = evs.mid 334 | let mid_down evs = evs.mid_down 335 | let mid_up evs = evs.mid_up 336 | let right evs = evs.right 337 | let right_down evs = evs.right_down 338 | let right_up evs = evs.right_up 339 | 340 | module Cursor = struct 341 | type t = Jstr.t 342 | let url ?(x = 0) ?(y = 0) url = match x = 0 && y = 0 with 343 | | true -> Jstr.(v "url(" + url + v ")") 344 | | false -> Jstr.(v "url(" + url + v ") " + of_int x + sp + of_int y) 345 | 346 | let auto = Jstr.v "auto" 347 | let default = Jstr.v "default" 348 | let none = Jstr.v "none" 349 | let context_menu = Jstr.v "context-menu" 350 | let help = Jstr.v "help" 351 | let pointer = Jstr.v "pointer" 352 | let progress = Jstr.v "progress" 353 | let wait = Jstr.v "wait" 354 | let cell = Jstr.v "cell" 355 | let crosshair = Jstr.v "crosshair" 356 | let text = Jstr.v "text" 357 | let vertical_text = Jstr.v "vertical-text" 358 | let alias = Jstr.v "alias" 359 | let copy = Jstr.v "copy" 360 | let move = Jstr.v "move" 361 | let no_drop = Jstr.v "no-drop" 362 | let not_allowed = Jstr.v "not-allowed" 363 | let grab = Jstr.v "grab" 364 | let grabbing = Jstr.v "grabbing" 365 | let e_resize = Jstr.v "e-resize" 366 | let n_resize = Jstr.v "n-resize" 367 | let ne_resize = Jstr.v "ne-resize" 368 | let nw_resize = Jstr.v "nw-resize" 369 | let s_resize = Jstr.v "s-resize" 370 | let se_resize = Jstr.v "se-resize" 371 | let sw_resize = Jstr.v "sw-resize" 372 | let w_resize = Jstr.v "w-resize" 373 | let ew_resize = Jstr.v "ew-resize" 374 | let ns_resize = Jstr.v "ns-resize" 375 | let nesw_resize = Jstr.v "nesw-resize" 376 | let nwse_resize = Jstr.v "nwse-resize" 377 | let col_resize = Jstr.v "col-resize" 378 | let row_resize = Jstr.v "row-resize" 379 | let all_scroll = Jstr.v "all-scroll" 380 | let zoom_in = Jstr.v "zoom-in" 381 | let zoom_out = Jstr.v "zoom-out" 382 | end 383 | end 384 | 385 | module Windowr = struct 386 | let in_fullscreen () = 387 | Option.is_some (Document.fullscreen_element G.document) 388 | 389 | let is_fullscreen = 390 | (* protect web workers *) 391 | if Jv.is_none (Document.to_jv G.document) then S.const false else 392 | let is_fullscreen, set_fullscreen = S.create (in_fullscreen ()) in 393 | let change _e = set_fullscreen (in_fullscreen ()) in 394 | ignore 395 | (Ev.listen Ev.fullscreenchange change (Document.as_target G.document)); 396 | is_fullscreen 397 | 398 | let quit = 399 | (* protect web workers *) 400 | if Jv.is_none (Document.to_jv G.document) then E.never else 401 | let quit, send_quit = E.create () in 402 | let send_quit _e = send_quit () in 403 | ignore (Ev.listen Ev.unload send_quit (Document.as_target G.document)); 404 | quit 405 | end 406 | 407 | module Time = struct 408 | type span = float 409 | 410 | let tick_now () = Performance.now_ms G.performance /. 1000. (* FIXME *) 411 | let start = tick_now () 412 | let elapsed () = tick_now () -. start 413 | 414 | type counter = span 415 | let counter () = tick_now () 416 | let counter_value c = tick_now () -. c 417 | 418 | let tick span = 419 | let e, send_e = E.create () in 420 | let c = counter () in 421 | let action () = send_e (counter_value c) in 422 | let ms = truncate @@ span *. 1000. in 423 | ignore (G.set_timeout action ~ms); 424 | e 425 | 426 | let delay span f = ignore (G.set_timeout f ~ms:(truncate @@ span *. 1000.)) 427 | let to_jstr u s = match u with 428 | | `S -> Jstr.(of_float s + v "s") 429 | | `Ms -> Jstr.(of_float (s *. 1e3) + v "ms") 430 | | `Mus -> Jstr.(of_float (s *. 1e6) + v "μs") 431 | end 432 | 433 | module Human = struct 434 | let noticed = 0.1 435 | let interrupted = 1. 436 | let left = 10. 437 | 438 | let rec feel_action feel set_feel () = 439 | let new_feel, delay = match S.value feel with 440 | | `Interacting -> `Interrupted, left -. interrupted 441 | | `Interrupted -> `Left, 0. 442 | | `Left -> assert false 443 | in 444 | set_feel new_feel; 445 | if delay = 0. then () else 446 | let action = feel_action feel set_feel in 447 | let ms = truncate @@ delay *. 1000. in 448 | ignore (G.set_timeout ~ms action); 449 | () 450 | 451 | let feel () = 452 | let feel, set_feel = S.create `Interacting in 453 | let action = feel_action feel set_feel in 454 | let ms = truncate @@ interrupted *. 1000. in 455 | ignore (G.set_timeout ~ms action); 456 | feel 457 | 458 | (* Sizes in mm. *) 459 | let touch_target_size = 9. 460 | let touch_target_size_min = 7. 461 | let touch_target_pad = 2. 462 | let average_finger_width = 11. 463 | end 464 | 465 | module Ui = struct 466 | (* CSS classes *) 467 | 468 | let ui_active = Jstr.v "ui-active" 469 | let ui_button = Jstr.v "ui-button" 470 | let ui_button_selector = Jstr.v "ui-button-selector" 471 | let ui_dir_align_center = Jstr.v "ui-dir-align-center" 472 | let ui_dir_align_distribute = Jstr.v "ui-dir-align-distribute" 473 | let ui_dir_align_end = Jstr.v "ui-dir-align-end" 474 | let ui_dir_align_justify = Jstr.v "ui-dir-align-justify" 475 | let ui_dir_align_start = Jstr.v "ui-dir-align-start" 476 | let ui_dir_align_stretch = Jstr.v "ui-dir-align-stretch" 477 | let ui_dir_h = Jstr.v "ui-dir-h" 478 | let ui_dir_v = Jstr.v "ui-dir-v" 479 | let ui_disabled = Jstr.v "ui-disabled" 480 | let ui_editing = Jstr.v "ui-editing" 481 | let ui_file_selector = Jstr.v "ui-file-selector" 482 | let ui_group = Jstr.v "ui-group" 483 | let ui_label = Jstr.v "ui-label" 484 | let ui_menu_selector = Jstr.v "ui-menu-selector" 485 | let ui_selected = Jstr.v "ui-selected" 486 | let ui_slider_selector = Jstr.v "ui-slider-selector" 487 | let ui_str_editor = Jstr.v "ui-str-editor" 488 | let ui_xdir_align_center = Jstr.v "ui-xdir-align-center" 489 | let ui_xdir_align_distribute = Jstr.v "ui-xdir-align-distribute" 490 | let ui_xdir_align_end = Jstr.v "ui-xdir-align-end" 491 | let ui_xdir_align_justify = Jstr.v "ui-xdir-align-justify" 492 | let ui_xdir_align_start = Jstr.v "ui-xdir-align-start" 493 | let ui_xdir_align_stretch = Jstr.v "ui-xdir-align-stretch" 494 | 495 | (* GUI elements. *) 496 | 497 | let disabled ~enabled = 498 | let is_disabled enabled = if enabled then None else Some Jstr.empty in 499 | S.map is_disabled enabled 500 | 501 | let el_def_tip ~tip el = match tip with 502 | | None -> () 503 | | Some tip -> Elr.def_at At.Name.title (S.Option.some tip) el 504 | 505 | module Group = struct 506 | type dir = [ `H | `V ] 507 | type align = [ `Start | `End | `Center | `Justify | `Distribute | `Stretch ] 508 | let dir_cls = [ `H, ui_dir_h; `V, ui_dir_v; ] 509 | let align_cls = 510 | [ `Start, ui_dir_align_start; `End, ui_dir_align_end; 511 | `Center, ui_dir_align_center; `Justify, ui_dir_align_justify; 512 | `Distribute, ui_dir_align_distribute; `Stretch, ui_dir_align_stretch; ] 513 | 514 | let xalign_cls = 515 | [ `Start, ui_xdir_align_start; `End, ui_xdir_align_end; 516 | `Center, ui_xdir_align_center; `Justify, ui_xdir_align_justify; 517 | `Distribute, ui_xdir_align_distribute; `Stretch, ui_xdir_align_stretch;] 518 | 519 | let set_class classes el v = El.set_class (List.assoc v classes) true el 520 | 521 | type 'a t = 522 | { el : El.t; 523 | enabled : bool signal; 524 | action : 'a event; 525 | dir : dir; 526 | dir_align : align; 527 | xdir_align : align; } 528 | 529 | let v 530 | ?class':cl ?(enabled = S.Bool.true') ?(action = E.never) 531 | ?(xdir_align = `Start) ?(dir_align = `Start) ~dir cs 532 | = 533 | let at = At.[if_some (Option.map class' cl); class' ui_group] in 534 | let el = El.div ~at [] in 535 | let () = Elr.def_children el cs 536 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) el 537 | and () = set_class dir_cls el dir 538 | and () = set_class align_cls el dir_align 539 | and () = set_class xalign_cls el xdir_align in 540 | { el; enabled; action; dir; dir_align; xdir_align } 541 | 542 | let dir g = g.dir 543 | let dir_align g = g.dir_align 544 | let xdir_align g = g.xdir_align 545 | let action g = g.action 546 | let enabled g = g.enabled 547 | let el g = g.el 548 | let with_action action g = { g with action } 549 | let hide_action g = with_action E.never g 550 | end 551 | 552 | module Label = struct 553 | type t = { el : El.t; enabled : bool signal } 554 | let v ?class':cl ?(enabled = S.Bool.true') ?tip cs = 555 | let at = At.[if_some (Option.map class' cl); class' ui_label] in 556 | let el = El.div ~at [] in 557 | let () = Elr.def_children el cs 558 | and () = el_def_tip ~tip el 559 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) el in 560 | {el; enabled} 561 | 562 | let el l = l.el 563 | let enabled l = l.enabled 564 | end 565 | 566 | module Button = struct 567 | type 'a t = 568 | { el : El.t; 569 | action : 'a event; 570 | active : bool signal; 571 | enabled : bool signal; } 572 | 573 | let button_str = Jstr.v "button" 574 | let at_base cl = 575 | At.[if_some (Option.map class' cl); type' button_str; class' ui_button] 576 | 577 | let v 578 | ?class':cl ?(active = S.Bool.false') ?(enabled = S.Bool.true') ?tip cs v 579 | = 580 | let el = El.button ~at:(at_base cl) [] in 581 | let action = Evr.on_el Ev.click (Evr.stamp v) el in 582 | let () = Elr.def_children el cs 583 | and () = el_def_tip ~tip el 584 | and () = Elr.def_at At.Name.disabled (disabled ~enabled) el 585 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) el 586 | and () = Elr.def_class ui_active active el in 587 | (* FIXME [active] only has client defined activity *) 588 | { el; action; active; enabled } 589 | 590 | let action b = b.action 591 | let enabled b = b.enabled 592 | let active b = b.active 593 | let el b = b.el 594 | 595 | (* Special buttons *) 596 | 597 | let file_str = Jstr.v "file" 598 | let accept_str = Jstr.v "accept" 599 | let multiple_str = Jstr.v "multiple" 600 | let _file_selector 601 | ~multiple get ?class':cl ?(active = S.Bool.false') 602 | ?(enabled = S.Bool.true') ?tip ?(exts = []) cs 603 | = 604 | (* File input elements can't be customized... hence we use a button that 605 | forwards its clicks to the input element. *) 606 | let input = 607 | let at = match exts with 608 | | [] -> [] 609 | | exts -> [ At.v accept_str (Jstr.v (String.concat "," exts)) ] 610 | in 611 | let at = At.if' multiple (At.v multiple_str Jstr.empty) :: at in 612 | let at = At.type' file_str :: at in 613 | El.input ~at () 614 | in 615 | let el = El.button ~at:At.(class' ui_file_selector :: at_base cl) [] in 616 | let () = El.set_inline_style El.Style.display (Jstr.v "none") input 617 | and () = 618 | let forward e = 619 | (* If the same file gets selected onchange/oninput events do not refire, 620 | reseting the value property here works around this problem. *) 621 | El.set_prop El.Prop.value Jstr.empty input; 622 | El.click input 623 | in 624 | ignore (Ev.listen Ev.click forward (El.as_target el)) 625 | and () = 626 | (* input at end for not applying * + el CSS rules, this will still disturb 627 | last-child and el + * though *) 628 | Elr.def_children el (S.map ~eq:(==) (fun cs -> cs @ [input]) cs) 629 | and () = el_def_tip ~tip el 630 | and () = Elr.def_at At.Name.disabled (disabled ~enabled) el 631 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) el 632 | and () = Elr.def_class ui_active active el 633 | and action = Evr.on_el Ev.change (get input) input in 634 | { el; enabled; action; active } 635 | 636 | let file_selector = 637 | _file_selector ~multiple:false (fun i _ -> List.hd (El.Input.files i)) 638 | 639 | let files_selector = 640 | _file_selector ~multiple:true (fun i _ -> El.Input.files i) 641 | end 642 | 643 | module Jstr_editor = struct 644 | let text_str = Jstr.v "text" 645 | type t = 646 | { el : El.t; 647 | enabled : bool signal; 648 | editing : bool signal; 649 | action : Jstr.t event } 650 | 651 | let att_size = Jstr.v "size" (* XXX add to brr ? *) 652 | 653 | let v ?class':cl ?(enabled = S.Bool.true') ?on:(edit = E.never) ?length str = 654 | let span = El.span [] in 655 | let editor = El.input ~at:At.[type' text_str] () in 656 | let div = 657 | let at = At.[if_some (Option.map class' cl); class' ui_str_editor] in 658 | El.div ~at [span; editor] 659 | in 660 | let edit = E.select [E.stamp edit (); Evr.on_el Ev.click Evr.unit div] in 661 | let edit = S.sample_filter enabled ~on:edit @@ fun enabled _ -> 662 | if enabled then Some () else None 663 | in 664 | let keys = Evr.on_el Ev.keydown Key.of_ev editor in 665 | let escape_key = E.stamp (E.filter (Key.equal `Escape) keys) false in 666 | let return_key = E.stamp (E.filter (Key.equal `Return) keys) true in 667 | let start_focus = Evr.on_el Ev.focus (Evr.stamp true) editor in 668 | let stop_focus = Evr.on_el Ev.blur (Evr.stamp false) editor in 669 | let focus = 670 | S.hold (El.has_focus editor) @@ E.select [start_focus;stop_focus] in 671 | let valid = S.hold true @@ E.select [start_focus; escape_key] in 672 | let start = E.stamp edit true in 673 | let key_stop = E.stamp (E.select [escape_key; return_key]) false in 674 | let stop = E.stamp (E.select [key_stop; stop_focus]) false in 675 | let editing = S.hold false (* FIXME *) (E.select [start; stop]) in 676 | let action = S.sample_filter valid ~on:stop_focus @@ fun valid _ -> 677 | if valid then Some (El.prop El.Prop.value editor) else None 678 | in 679 | let () = Elr.def_children span (S.map (fun s -> [El.txt s]) str) 680 | and () = (* FIXME the two following calls are racy. *) 681 | Elr.call (fun _ e -> El.select_text e) ~on:start editor 682 | and () = Elr.set_prop El.Prop.value ~on:(S.snapshot str ~on:edit) editor 683 | and () = Elr.def_has_focus focus editor 684 | and () = Elr.def_at At.Name.disabled (disabled ~enabled) editor 685 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) div 686 | and () = Elr.def_class ui_editing editing div 687 | and () = match length with 688 | | None -> () (* FIXME make that autogrowable. *) 689 | | Some l -> 690 | let size = S.map (fun l -> Some (Jstr.of_int l)) l in 691 | Elr.def_at att_size size editor 692 | in 693 | { el = div; enabled; editing; action } 694 | 695 | let action e = e.action 696 | let enabled e = e.enabled 697 | let editing e = e.editing 698 | let el e = e.el 699 | end 700 | 701 | module Value_selector = struct 702 | module Menu = struct 703 | type 'a t = 704 | { el : El.t; 705 | enabled : bool signal; 706 | action : 'a event } 707 | 708 | let v ?class':cl ?(enabled = S.Bool.true') label choices sel = 709 | let select = 710 | let at = At.[class' ui_menu_selector; class' ui_button] in 711 | let at = At.(if_some (Option.map class' cl)) :: at in 712 | El.select ~at [] 713 | in 714 | let sel_idx_change = 715 | let extract_value e _ = Jstr.to_int @@ El.prop El.Prop.value e in 716 | E.Option.on_some @@ 717 | Evr.(on_el Ev.change (extract_value select) select) 718 | in 719 | let sel_index = 720 | let find_sel_index eq selected choices = 721 | let rec loop i selected = function 722 | | c :: _ when eq c selected -> Jstr.of_int i 723 | | _ :: cs -> loop (i + 1) selected cs 724 | | [] -> Jstr.empty 725 | in 726 | loop 0 selected choices 727 | in 728 | S.l2 (find_sel_index (S.eq sel)) sel choices 729 | in 730 | let action = S.sample choices ~on:sel_idx_change List.nth in 731 | let opt i v = 732 | El.option ~at:At.[value (Jstr.of_int i)] [El.txt (label v)] 733 | in 734 | let opts = S.map (List.mapi opt) choices in 735 | let set_children opts sel_index = 736 | (* On children changes can't use El.def_children and El.def_prop 737 | it's racy. *) 738 | El.set_children select opts; 739 | El.set_prop El.Prop.value sel_index select 740 | in 741 | let set_children = 742 | Logr.(const set_children $ S.obs opts $ S.obs sel_index) 743 | in 744 | let () = Elr.hold_logr select (Logr.create set_children) 745 | and () = Elr.def_at At.Name.disabled (disabled ~enabled) select 746 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) select 747 | and () = Elr.def_prop El.Prop.value sel_index select in 748 | { el = select; enabled; action } 749 | 750 | let action e = e.action 751 | let enabled e = e.enabled 752 | let el e = e.el 753 | end 754 | 755 | module Button = struct 756 | type 'a t = 'a Group.t 757 | let v 758 | ?class' ?(enabled = S.Bool.true') ?button_class ?button_tip 759 | ?xdir_align ?dir_align ~dir label choices sel 760 | = 761 | let but v = 762 | let class' = match button_class with 763 | | Some f -> Some (f v)| None -> None 764 | in 765 | let tip = match button_tip with Some f -> Some (f v) | None -> None in 766 | let label = label v in 767 | Button.v ?class' ?tip ~enabled label v 768 | in 769 | let buts = S.map ~eq:( == ) (List.map but) choices in 770 | let els = S.map ~eq:( == ) (List.map Button.el) buts in 771 | let action = 772 | let select buts = E.select (List.map Button.action buts) in 773 | E.swap @@ S.map ~eq:( == ) select buts 774 | in 775 | let sel_obs = 776 | let find_sel_but eq sel choices buts = match sel with 777 | | None -> 778 | let deselect b = El.set_class ui_selected false (Button.el b) in 779 | List.iter deselect buts 780 | | Some sel -> 781 | let rec loop sel choices buts = match choices, buts with 782 | | c :: cs, b :: bs when eq (Some c) (Some sel) -> 783 | El.set_class ui_selected true (Button.el b); 784 | loop sel cs bs 785 | | _ :: cs, b :: bs -> 786 | El.set_class ui_selected false (Button.el b); 787 | loop sel cs bs 788 | | [], [] -> () 789 | | _, _ -> assert false 790 | in 791 | loop sel choices buts 792 | in 793 | Logr.(const (find_sel_but (S.eq sel)) $ S.obs sel $ S.obs choices $ 794 | S.obs buts) 795 | in 796 | let g = Group.v ?class' ~action ?xdir_align ?dir_align ~dir els in 797 | let () = El.set_class ui_button_selector true (Group.el g) in 798 | let () = Elr.hold_logr (Group.el g) (Logr.create sel_obs) in 799 | g 800 | end 801 | end 802 | 803 | module Float_selector = struct 804 | type t = 805 | { el : El.t; 806 | enabled : bool signal; 807 | action : float event; } 808 | 809 | let range_str = Jstr.v "range" 810 | let min_str = Jstr.v "min" 811 | let max_str = Jstr.v "max" 812 | let step_str = Jstr.v "step" 813 | 814 | let v 815 | ?class' ?(enabled = S.Bool.true') ?(min = S.const 0.) 816 | ?(max = S.const 1.) ?(step = S.const None) v 817 | = 818 | let v = S.map (fun v -> Jstr.of_float v) v in 819 | let at = At.[type' range_str; class' ui_slider_selector; tabindex (-1)] in 820 | let el = El.input ~at () in 821 | let extract_value e _ = match El.prop El.Prop.value e with 822 | | s when Jstr.is_empty s -> None 823 | | s -> Some (float_of_string (Jstr.to_string s)) 824 | in 825 | let action = 826 | E.Option.on_some @@ Evr.on_el Ev.input (extract_value el) el 827 | in 828 | let min_att = S.map (fun v -> Some (Jstr.of_float v)) min in 829 | let max_att = S.map (fun v -> Some (Jstr.of_float v)) max in 830 | let step_att = step |> S.map @@ function 831 | | None -> Some (Jstr.v "any") 832 | | Some f -> Some (Jstr.v @@ string_of_float f) 833 | in 834 | let () = Elr.def_at min_str min_att el 835 | and () = Elr.def_at max_str max_att el 836 | and () = Elr.def_at step_str step_att el 837 | and () = Elr.def_at At.Name.disabled (disabled ~enabled) el 838 | and () = Elr.def_class ui_disabled (S.Bool.not enabled) el 839 | and () = Elr.def_prop El.Prop.value v el 840 | and () = 841 | (* XXX isn't there a better way tabindex (-1) doesn't work 842 | also this is something that should be handled in the UI framework *) 843 | let unset_focus _ = El.set_has_focus false el in 844 | ignore (Ev.listen Ev.focus unset_focus (El.as_target el)) 845 | in 846 | { el; action; enabled } 847 | 848 | let action r = r.action 849 | let enabled r = r.enabled 850 | let el r = r.el 851 | end 852 | end 853 | -------------------------------------------------------------------------------- /src/brr/note_brr_kit.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Brr 8 | open Note 9 | 10 | (** {1:ui User interaction} *) 11 | 12 | (** Window reactions. *) 13 | module Windowr : sig 14 | 15 | (** {1:fullscreen Fullscreen} *) 16 | 17 | val is_fullscreen : bool signal 18 | (** [is_fullscreen] is [true] iff the application is in fullcreen mode. *) 19 | 20 | (** {1:userquit User requested quit} *) 21 | 22 | val quit : unit event 23 | (** [quit] occurs whenever the user requested to quit. The browser window 24 | is closing and it's your last chance to peform something. *) 25 | end 26 | 27 | (** User keyboard. *) 28 | module Key : sig 29 | 30 | (** {1:keys Physical keys} 31 | 32 | {b Note.} Physical keys are for using the keyboard as a {e 33 | controller}. Do not use them to derive text input, they are 34 | unrelated to the user's keyboard layout for text entry. Use 35 | {{!Brr.Ev.Input}input events} for text entry. *) 36 | 37 | type code = int 38 | (** The type for physical key codes. *) 39 | 40 | type t = 41 | [ `Alt of [ `Left | `Right ] 42 | | `Arrow of [ `Up | `Down | `Left | `Right ] 43 | | `Ascii of Char.t 44 | | `Backspace 45 | | `Ctrl of [ `Left | `Right ] 46 | | `End 47 | | `Enter 48 | | `Escape 49 | | `Func of int 50 | | `Home 51 | | `Insert 52 | | `Key of code 53 | | `Meta of [ `Left | `Right ] 54 | | `Page of [ `Up | `Down ] 55 | | `Return 56 | | `Shift of [ `Left | `Right ] 57 | | `Spacebar 58 | | `Tab ] 59 | (** The type for physical keys. 60 | 61 | {b Warning.} This type is overdefined for now. For example 62 | except for [`Shift], [`Ctrl] and [Alt], [`Left] and [`Right] 63 | modifiers cannot be distinguished; [`Left] is always returned. 64 | [`Enter] and [`Return] cannot be distinguished, [`Return] is 65 | always returned. *) 66 | 67 | val of_ev : Ev.Keyboard.t Ev.t -> t 68 | (** [of_ev e] is the physical key of the keyboard event [e]. *) 69 | 70 | val equal : t -> t -> bool 71 | (** [equal k0 k1] is [true] iff [k0] and [k1] are equal. *) 72 | 73 | val compare : t -> t -> int 74 | (** [compare] is a total order on keys compatible with {!equal}. *) 75 | 76 | val to_jstr : t -> Jstr.t 77 | 78 | (** {1:ev Keyboard events} *) 79 | 80 | type events 81 | (** The type for gathering keyboard events on a given target. *) 82 | 83 | val on_target : 84 | ?capture:bool -> ?propagate:bool -> ?default:bool -> Ev.target -> events 85 | (** [on_target t] is keyboard events for target [t]. The other 86 | parameters are those of {!Brr_note.Evr.on_target}. *) 87 | 88 | val on_el : 89 | ?capture:bool -> ?propagate:bool -> ?default:bool -> El.t -> events 90 | (** [on_el e] is like {!on_target} but for an element. *) 91 | 92 | (** {1:kev Key events} *) 93 | 94 | val any_down : events -> t event 95 | (** [any_down evs] occurs whenever a key goes down on the target. *) 96 | 97 | val any_up : events -> t event 98 | (** [any_down evs] occurs whenever a key goes up on the target. *) 99 | 100 | val any_holds : events -> bool signal 101 | (** [any_holds evs] is [true] whenever any key is down. *) 102 | 103 | val down : events -> t -> unit event 104 | (** [down evs k] occurs whenever key [k] goes down on the target. *) 105 | 106 | val up : events -> t -> unit event 107 | (** [up evs k] occurs whenever key [k] goes up on the target. *) 108 | 109 | val holds : events -> t -> bool signal 110 | (** [holds evs k] is [true] whenever [k] is held down on the target. *) 111 | 112 | (** {1:mods Modifiers signals} *) 113 | 114 | val alt : events -> bool signal 115 | (** [alt evs] is [true] whenver an alt key is down on the target. 116 | Equivalent to: 117 | {[ 118 | S.Bool.(holds evs (`Alt `Left) || holds evs (`Alt `Right)) 119 | ]} *) 120 | 121 | val ctrl : events -> bool signal 122 | (** [ctrl evs] is [true] whenver an ctrl key is down on the target. 123 | Equivalent to: 124 | {[ 125 | S.Bool.(holds evs (`Ctrl `Left) || holds evs (`Ctrl `Right)) 126 | ]} *) 127 | 128 | val meta : events -> bool signal 129 | (** [meta evs] is [true] whenver an meta key is down on the target. 130 | Equivalent to: 131 | {[ 132 | S.Bool.(holds evs (`Meta `Left) || holds evs (`Meta `Right)) 133 | ]} *) 134 | 135 | val shift : events -> bool signal 136 | (** [shift evs] is [true] whenver an shift key is down on the target. 137 | Equivalent to: 138 | {[ 139 | S.Bool.(holds evs (`Meta `Left) || holds evs (`Meta `Right)) 140 | ]} *) 141 | 142 | (** {1:semantics Semantic incoherences} 143 | 144 | {!holds} and {!any_holds} may be initially set to [false] even 145 | though they should be [true] if {!on_target} is invoked when the 146 | corresponding keys are depressed. *) 147 | 148 | (** {1:repeat Key repeat events} 149 | 150 | Key repeat events are not exposed. There are two main use cases 151 | for key repeat. First during text input, but his should be handled 152 | by text input events and is out of scope. Second for controlling 153 | changes to a variable over time, e.g. scrolling with a keyboard. 154 | In the latter case it is better to create a timing signal or event 155 | with a known rate while the key is held. *) 156 | end 157 | 158 | (** User mouse. 159 | 160 | Excepts for mouse ups, mouse events are only reported whenever the 161 | mouse is over the specified target. 162 | 163 | By default coordinates are in target normalized coordinates with 164 | (0, 0) corresponding to the bottom left corner and (1,1) to the 165 | top right corner. *) 166 | module Mouse : sig 167 | 168 | (** {1:mouse Mouse events} *) 169 | 170 | val pt : float -> float -> float * float 171 | (** [pt x y] is [(x, y)]. *) 172 | 173 | type 'a events 174 | (** The type for gathering mouse events on a given target and using 175 | ['a] to represent points. *) 176 | 177 | val on_target : 178 | ?capture:bool -> ?propagate:bool -> ?default:bool -> ?normalize:bool -> 179 | (float -> float -> 'a) -> Ev.target -> 'a events 180 | (** [on_target pt t] is mouse events for target [t] using [pt] to 181 | construct points. If [normalize] is [true] (default) coordinates 182 | are reported in target normalized coordinates (see above), if 183 | [false] they are reported in pixels with the origin at the 184 | top-left of the element. The other parameters are those from 185 | {!Brr_note.Evr.on_target}. *) 186 | 187 | val on_el : 188 | ?capture:bool -> ?propagate: bool -> ?default:bool -> ?normalize:bool -> 189 | (float -> float -> 'a) -> El.t -> 'a events 190 | (** [on_el] is like {!on_target} but for an element. Note that 191 | {!destroy} automatically gets called with the result whenever 192 | the element is removed from the HTML DOM. *) 193 | 194 | val destroy : 'a events -> unit 195 | (** [destroy evs] removes the callbacks registred by [evs]. It's 196 | important to perform this whenever you no longer need the events 197 | as [evs] needs to register callbacks with the document to 198 | correctly capture mouse ups. *) 199 | 200 | (** {1 Mouse position} *) 201 | 202 | val pos : 'a events -> 'a signal 203 | (** [pos evs] is the current mouse position in the target. *) 204 | 205 | val dpos : 'a events -> 'a event 206 | (** [dpos evs] occurs on mouse moves with current mouse position minus 207 | the previous position. *) 208 | 209 | val mem : 'a events -> bool signal 210 | (** [mem evs] is [true] whenever the mouse position is inside 211 | the target. *) 212 | 213 | (** {1 Mouse buttons} *) 214 | 215 | val left : 'a events -> bool signal 216 | (** [left evs] is [true] whenever the left mouse button went down in 217 | the target and did not go up yet. *) 218 | 219 | val left_down : 'a events -> 'a event 220 | (** [left_down evs] has an occurence with the mouse position 221 | whenever the button goes down in the target. *) 222 | 223 | val left_up : 'a events -> 'a event 224 | (** [left_up evs] is [true] whenever the left mouse button went down 225 | in the target and goes back up {e anywhere}. Note that the reported 226 | position might not be in the target. *) 227 | 228 | val mid : 'a events -> bool signal 229 | (** [mid] is like {!left} but the middle button. *) 230 | 231 | val mid_down : 'a events -> 'a event 232 | (** [mid_down]is like {!left_down} but for the middle button. *) 233 | 234 | val mid_up :'a events -> 'a event 235 | (** [mid_up] is like {!left_up} but for the middle button. *) 236 | 237 | val right : 'a events -> bool signal 238 | (** [right] is like {!left} but the right button. *) 239 | 240 | val right_down : 'a events -> 'a event 241 | (** [right_down]is like {!left_down} but for the right button. *) 242 | 243 | val right_up :'a events -> 'a event 244 | (** [right_up] is like {!left_up} but for the right button. *) 245 | 246 | (** {1:cursors Mouse cursors} *) 247 | 248 | (** Mouse cursors. 249 | 250 | To be used with {!Brr.El.Style.cursor}. *) 251 | module Cursor : sig 252 | 253 | (** {1:cursors Mouse cursors} *) 254 | 255 | type t = Jstr.t 256 | (** The type for specifying cusrors. *) 257 | 258 | val url : ?x:int -> ?y:int -> Jstr.t -> t 259 | (** [url ~x ~y u] is an image cursor using URL [u] for the image 260 | with [x,y] identifiying the position of the hotspot in the image 261 | relative to the top-left corner (defaults to [0,0]). *) 262 | 263 | (** {1:gen General purpose cursors} *) 264 | 265 | val auto : t 266 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-auto}auto} *) 267 | 268 | val default : t 269 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-default}default} *) 270 | 271 | val none : t 272 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-none}none} *) 273 | 274 | (** {1:links_status Links and status} *) 275 | 276 | val context_menu : t 277 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-context-menu} 278 | context-menu} *) 279 | 280 | val help : t 281 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-help}help} *) 282 | 283 | val pointer : t 284 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-pointer}pointer} *) 285 | 286 | val progress : t 287 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-progress}progress} *) 288 | 289 | val wait : t 290 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-wait}wait} *) 291 | 292 | (** {1:sel Selection cursors} *) 293 | 294 | val cell : t 295 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-cell}cell} *) 296 | 297 | val crosshair : t 298 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-crosshair}crosshair} *) 299 | 300 | val text : t 301 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-text}text} *) 302 | 303 | val vertical_text : t 304 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-vertical-text} 305 | vertical-text} *) 306 | 307 | (** {1:dd Drag and drop cursors} *) 308 | 309 | val alias : t 310 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-alias}alias} *) 311 | 312 | val copy : t 313 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-copy}copy} *) 314 | 315 | val move : t 316 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-move}move} *) 317 | 318 | val no_drop : t 319 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-no-drop}no-drop} *) 320 | 321 | val not_allowed : t 322 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-not-allowed} 323 | not-allowed} *) 324 | 325 | val grab : t 326 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-grab}grab} *) 327 | 328 | val grabbing : t 329 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-grabbing}grabbing} *) 330 | 331 | (** {1:resize_scroll Resizing and scrolling cursors} *) 332 | 333 | val e_resize : t 334 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-e-resize}e-resize} *) 335 | 336 | val n_resize : t 337 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-n-resize}n-resize} *) 338 | 339 | val ne_resize : t 340 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-ne-resize}ne-resize} *) 341 | 342 | val nw_resize : t 343 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-nw-resize}nw-resize} *) 344 | 345 | val s_resize : t 346 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-s-resize}s-resize} *) 347 | 348 | val se_resize : t 349 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-se-resize}se-resize} *) 350 | 351 | val sw_resize : t 352 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-sw-resize}sw-resize} *) 353 | 354 | val w_resize : t 355 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-w-resize}w-resize} *) 356 | 357 | val ew_resize : t 358 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-ew-resize}ew-resize} *) 359 | 360 | val ns_resize : t 361 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-ns-resize}ns-resize} *) 362 | 363 | val nesw_resize : t 364 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-nesw-resize} 365 | nesw-resize} *) 366 | 367 | val nwse_resize : t 368 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-nwse-resize} 369 | nwse-resize} *) 370 | 371 | val col_resize : t 372 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-col-resize} 373 | col-resize} *) 374 | 375 | val row_resize : t 376 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-row-resize} 377 | row-resize} *) 378 | 379 | val all_scroll : t 380 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-all-scroll} 381 | all-scroll} *) 382 | 383 | (** {1:zooming_cursors Zooming cursors} *) 384 | 385 | val zoom_in : t 386 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-zoom-in} 387 | zoom-in} *) 388 | 389 | val zoom_out : t 390 | (** {{:https://www.w3.org/TR/css-ui-3/#valdef-cursor-zoom-out} 391 | zoom-out} *) 392 | end 393 | end 394 | 395 | (** Monotonic time. *) 396 | module Time : sig 397 | 398 | (** {1 Time span} *) 399 | 400 | type span = float 401 | (** The type for time spans, in seconds. FIXME move to ms. *) 402 | 403 | (** {1 Passing time} *) 404 | 405 | val elapsed : unit -> span 406 | (** [elapsed ()] is the number of seconds elapsed since the 407 | beginning of the program. *) 408 | 409 | (** {1 Tick events} *) 410 | 411 | val tick : span -> span event 412 | (** [tick span] is an event that occurs once in [span] seconds with 413 | the value [span - span'] where [span'] is the actual delay 414 | performed by the system. 415 | 416 | {b Note.} Since the system may introduce delays you cannot 417 | assume that two different calls to {!tick} will necessarily 418 | yield two non-simultaneous events. *) 419 | 420 | val delay : span -> (unit -> unit) -> unit 421 | (** [delay span f] calls [f] after [span] seconds. *) 422 | 423 | (** {1 Counters} *) 424 | 425 | type counter 426 | (** The type for time counters. *) 427 | 428 | val counter : unit -> counter 429 | (** [counter ()] is a counter counting time from call time on. *) 430 | 431 | val counter_value : counter -> span 432 | (** [counter_value c] is the current counter value in seconds. *) 433 | 434 | (** {1 Pretty printing time} *) 435 | 436 | val to_jstr : [`S | `Ms | `Mus] -> span -> Jstr.t 437 | end 438 | 439 | (** Human factors. *) 440 | module Human : sig 441 | 442 | (** {1 System latency feelings} 443 | 444 | These values are from 445 | {{:http://www.nngroup.com/articles/response-times-3-important-limits/} 446 | here}. *) 447 | 448 | val noticed : Time.span 449 | (** [noticed] is [0.1]s, the time span after which the user will 450 | notice a delay and feel that the system is not reacting 451 | instantaneously. *) 452 | 453 | val interrupted : Time.span 454 | (** [interrupted] is [1.]s, the time span after which the user will 455 | feel interrupted and feedback from the system is needed. *) 456 | 457 | val left : Time.span 458 | (** [left] is [10.]s, the time span after which the user will 459 | switch to another task and feedback indicating when the system 460 | expects to respond is needed. *) 461 | 462 | val feel : unit -> [ `Interacting | `Interrupted | `Left ] signal 463 | (** [feel ()] is a signal that varies according to user latency 464 | constants: 465 | {ul 466 | {- \[[user_feel ()]\]{_t} [= `Interacting] if 467 | [t < User.interrupted].} 468 | {- \[[user_feel ()]\]{_t} [= `Interrupted] if 469 | [t < User.left].} 470 | {- \[[user_feel ()]\]{_t} [= `Left] if [t >= User.left].}} *) 471 | 472 | (** {1 Touch target and finger sizes} 473 | 474 | These values are from 475 | {{:https://docs.microsoft.com/en-us/windows/win32/uxguide/inter-touch#control-sizes-and-touch-targeting}here}. *) 476 | 477 | val touch_target_size : float 478 | (** [touch_target_size] is [9.]mm, the recommended touch target size in 479 | millimiters. *) 480 | 481 | val touch_target_size_min : float 482 | (** [touch_size_min] is [7.]mm, the minimal touch target size in 483 | millimeters. *) 484 | 485 | val touch_target_pad : float 486 | (** [touch_target_pad] is [2.]mm, the minimum padding size in 487 | millimeters between two touch targets. *) 488 | 489 | val average_finger_width : float 490 | (** [average_finger_width] is [11.]mm, the average {e adult} finger width. *) 491 | end 492 | 493 | (** Graphical user interaction. 494 | 495 | {b Warning.} This will definitively break in the future. 496 | 497 | Note based GUI toolkit. 498 | 499 | {%html: %} 501 | 502 | {b XXX.} 503 | {ul 504 | {- A common interface seems to emerge. Can we get rid of the 505 | different types and unify the elements under a single type ?} 506 | {- Provide action refinement. This could be as an optional 507 | argument but it's likely you want to do it after. So 508 | as *.with_action functions seem better.} 509 | {- Layout is still painful}} *) 510 | module Ui : sig 511 | 512 | (** Element groups. 513 | 514 | Groups allow to gather and layout GUI elements and summarize 515 | their actions. See the {{!Group.style}styling information}. *) 516 | module Group : sig 517 | 518 | (** {1:group Groups} *) 519 | 520 | type dir = [ `H | `V ] 521 | (** The type for specifiy the layout direction. *) 522 | 523 | type align = [ `Start | `End | `Center | `Justify | `Distribute | `Stretch ] 524 | (** The type for specifying alignements. [`Stretch] is dodgy. *) 525 | 526 | type 'a t 527 | (** The type for groups which summarize actions of type ['a]. *) 528 | 529 | val v : 530 | ?class':Jstr.t -> ?enabled:bool signal -> ?action:'a event -> 531 | ?xdir_align:align -> ?dir_align:align -> dir:dir -> El.t list signal -> 532 | 'a t 533 | (** [v ~class' ~enabled ~action ~dir_align ~xdir_align ~dir cs] 534 | layouts elements [cs] in a container. Arguments are as follows: 535 | {ul 536 | {- [dir] is the layout direction for elements} 537 | {- [dir_align] is the alignment between elements in the layout 538 | direction. Defaults to [`Start].} 539 | {- [xdir_align] is the alignement between elements in the direction 540 | perpendicular to the layout direction. Defaults to [`Start].} 541 | {- [action] can be used by the client to summarize the user interaction 542 | performed by the underlying elements. Defaults to {!Note.E.never}} 543 | {- [enabled] visually indicates if the group can be 544 | interacted with. Defaults to {!Note.S.Bool.true'}} 545 | {- [class'] is added to the underlying element's classes.}} *) 546 | 547 | val dir : 'a t -> dir 548 | (** [dir g] is [g]'s children layout direction. *) 549 | 550 | val dir_align : 'a t -> align 551 | (** [dir_align g] is [g]'s children alignement along the layout direction. *) 552 | 553 | val xdir_align : 'a t -> align 554 | (** [xdir_align g] is [g]'s children alignement in the parti the direction. *) 555 | 556 | val action : 'a t -> 'a event 557 | (** [action g] occurs whenever an action occurs in the group (see {!v}). *) 558 | 559 | val enabled : 'a t -> bool signal 560 | (** [enabled g] is [true] iff [g] is enabled. *) 561 | 562 | val el : 'a t -> El.t 563 | (** [el b] is [b]'s DOM element. *) 564 | 565 | (** {1:tr Transforming UI elements} *) 566 | 567 | val with_action : 'b event -> 'a t -> 'b t 568 | (** [with_action action g] uses [g] for [g]'s action. *) 569 | 570 | val hide_action : 'b t -> 'a t 571 | (** [hide_action g] is [with_action E.never g]. *) 572 | 573 | (** {1:style Styling} 574 | 575 | The element returned by {!el} makes use of the following CSS 576 | classes: 577 | {ul 578 | {- [ui-group] always.} 579 | {- [ui-dir-{h,v}] according to {!val-dir}.} 580 | {- [ui-dir-align-{start,end,center,justify,distribute,stretch}] according 581 | to {!val-dir_align}} 582 | {- [ui-xdir-align-{start,end,center,justify,distribute,stretch}] according 583 | to {!val-xdir_align}} 584 | {- [ui-disabled] whenever {!enabled} is [false].}} *) 585 | end 586 | 587 | (** Labels. 588 | 589 | Labels are for displaying short units of textual content. See 590 | the {{!style}styling information}. *) 591 | module Label : sig 592 | 593 | (** {1:labels Labels} *) 594 | 595 | type t 596 | (** The type for labels. *) 597 | 598 | val v : 599 | ?class':Jstr.t -> ?enabled:bool signal -> ?tip:Jstr.t signal -> 600 | El.t list signal -> t 601 | (** [v ~class' ~enabled ~tip label] is a label with: 602 | {ul 603 | {- [label] the label's contents.} 604 | {- [enabled] indicates if the label should look as such. Defaults to 605 | {!Note.S.Bool.true'}} 606 | {- [tip] is a tooltip for the label.} 607 | {- [class'] is added to the element's classes.}} *) 608 | 609 | val enabled : t -> bool signal 610 | (** [enabled l] is a signal that is [true] iff the label is enabled. *) 611 | 612 | val el : t -> El.t 613 | (** [el l] is [l]'s DOM element. *) 614 | 615 | (** {1:style Styling} 616 | 617 | The element returned by {!el} makes use of the following CSS 618 | classes: 619 | {ul 620 | {- [ui-label] always.} 621 | {- [ui-disabled] whenever {!enabled} is [false].}} *) 622 | end 623 | 624 | (** Buttons. 625 | 626 | See the {{!Button.style}styling information}. *) 627 | module Button : sig 628 | 629 | (** {1:buttons Buttons} *) 630 | 631 | type 'a t 632 | (** The type for buttons whose action occurs with type ['a]. *) 633 | 634 | val v : 635 | ?class':Jstr.t -> ?active:bool signal -> ?enabled:bool signal -> 636 | ?tip:Jstr.t signal -> El.t list signal -> 'a -> 'a t 637 | (** [v ~class' ~active ~enabled ~tip label action] is a button with: 638 | {ul 639 | {- [label] the button's label.} 640 | {- [action] the value reported when the button is actuated.} 641 | {- [tip] a tooltip for the button.} 642 | {- [enabled] indicates if the button can 643 | be interacted with. Defaults to [S.Bool.true'].} 644 | {- [active] indicates that the button is 645 | being interacted with programmatically (e.g. via a 646 | shortcut)} 647 | {- [class'] is added to the underlying element's classes}} *) 648 | 649 | val action : 'a t -> 'a event 650 | (** [action b] is an event that occurs when the button is actuated. *) 651 | 652 | val enabled : 'a t -> bool signal 653 | (** [enabled b] is a signal that is [true] iff the button is enabled. *) 654 | 655 | val active : 'a t -> bool signal 656 | (** [active b] is a signal that is [true] iff the button is 657 | being interacted with. {b FIXME.} For now this doesn't change on 658 | mouse activation. *) 659 | 660 | val el : 'a t -> El.t 661 | (** [el b] is [b]'s DOM element. *) 662 | 663 | (** {1:special Special buttons} *) 664 | 665 | val file_selector : 666 | ?class':Jstr.t -> ?active:bool signal -> ?enabled:bool signal -> 667 | ?tip:Jstr.t signal -> ?exts:string list -> El.t list signal -> 668 | File.t t 669 | (** [file_selector ~exts cs] is a button which, whenever clicked, 670 | allows to select a file on the host's file system. [exts] is the 671 | caseless list of file extensions (including the dot) that 672 | can be selected; all file can be selected if this is the empty 673 | list (default). 674 | 675 | The resulting {{!el}element} as an additional [ui-file-selector] 676 | class. See {!style}. *) 677 | 678 | val files_selector : 679 | ?class':Jstr.t -> ?active:bool signal -> ?enabled:bool signal -> 680 | ?tip:Jstr.t signal -> ?exts:string list -> El.t list signal -> 681 | File.t list t 682 | (** [files_selector] is like {!file_selector} but allows multiple 683 | files to be selected. *) 684 | 685 | (** {1:style Styling} 686 | 687 | The element returned by {!el} makes use of the following CSS 688 | classes: 689 | {ul 690 | {- [ui-button] always.} 691 | {- [ui-file-selector] always iff created via {!file_selector} 692 | or {!files_selector}} 693 | {- [ui-active] whenever {!active} is [true].} 694 | {- [ui-disabled] whenever {!enabled} is [false].}} *) 695 | end 696 | 697 | (** String editors. 698 | 699 | String editors are for editing short strings. See the 700 | {{!Jstr_editor.style}styling information}. *) 701 | module Jstr_editor : sig 702 | 703 | (** {1:str String editors} *) 704 | 705 | type t 706 | (** The type for string editors. *) 707 | 708 | val v : 709 | ?class':Jstr.t -> ?enabled:bool signal -> ?on:'a event -> 710 | ?length:int signal -> Jstr.t signal -> t 711 | (** [v ~class' ~enabled ~on ~size s] is an editor for a string: 712 | {ul 713 | {- [s] is the string value to edit.} 714 | {- [length] is the length of the editor in number of characters 715 | (defaults to [S.const 20]).} 716 | {- [on] can be used to put the string editor on focus and in 717 | editing mode.} 718 | {- [enabled] indicates if the editor can be interacted with 719 | defaults to {!Note.S.Bool.true'}.} 720 | {- [class'] is added to the underlying element's classes.}} *) 721 | 722 | val action : t -> Jstr.t event 723 | (** [action e] occurs with a new string when an edition was validated. *) 724 | 725 | val enabled : t -> bool signal 726 | (** [enabled e] is [true] iff the editor is enabled. *) 727 | 728 | val editing : t -> bool signal 729 | (** [editing e] is [true] whenever the string is being edited. *) 730 | 731 | val el : t -> El.t 732 | (** [el b] is [b]'s DOM element. *) 733 | 734 | (** {1:style Styling} 735 | 736 | The element returned by {!el} makes use of the following CSS 737 | classes: 738 | {ul 739 | {- [ui-str-editor] always.} 740 | {- [ui-editing] whenever {!editing} is [true].} 741 | {- [ui-disabled] whenever {!enabled} is [false].}} *) 742 | end 743 | 744 | (** Value selectors 745 | 746 | Value selector allow to select a value among a finite number 747 | of choices. *) 748 | module Value_selector : sig 749 | 750 | (** Menu selector 751 | 752 | The value is selected in a list of elements 753 | via a drop down menu. See the {{!Menu.style}styling information}. *) 754 | module Menu : sig 755 | 756 | (** {1:selector Selectors} *) 757 | 758 | type 'a t 759 | (** The type for menu selector of values of type ['a]. *) 760 | 761 | val v : 762 | ?class':Jstr.t -> ?enabled:bool signal -> ('a -> Jstr.t) -> 763 | 'a list signal -> 'a signal -> 'a t 764 | (** [v ~class' ~enabled label choices sel] is a menu for 765 | selecting a value. [S.eq sel] is used to test values 766 | for equality in the list of [choices]. 767 | {ul 768 | {- [label] is used to label the values to select} 769 | {- [choices] are the values among which to select} 770 | {- [sel] is the value shown as selected it must be included in 771 | [choices]} 772 | {- [enabled] indicates if the selector can be 773 | interacted with. Defaults to {!Note.S.Bool.true'}} 774 | {- [class'] is added to the underlying element's classes.}} *) 775 | 776 | val action : 'a t -> 'a event 777 | (** [action s] occurs whenever a new value is selected. *) 778 | 779 | val enabled : 'a t -> bool signal 780 | (** [enabled s] is [true] iff the selector is enabled. *) 781 | 782 | val el : 'a t -> El.t 783 | (** [el s] is [s]'s DOM element. *) 784 | 785 | (** {1:style Styling} 786 | 787 | The element returned by {!el} makes use of the following CSS 788 | classes: 789 | {ul 790 | {- [ui-menu-selector] always.} 791 | {- [ui-disabled] whenever {!enabled} is [false].}} *) 792 | end 793 | 794 | (** Button selectors. 795 | 796 | The value is selected by clicking in a list of buttons. 797 | See the {{!Button.style}styling information}. *) 798 | module Button : sig 799 | 800 | (** {1:selector Selector} *) 801 | 802 | val v : 803 | ?class':Jstr.t -> ?enabled:bool signal -> 804 | ?button_class:('a -> Jstr.t) -> ?button_tip:('a -> Jstr.t signal) -> 805 | ?xdir_align:Group.align -> ?dir_align:Group.align -> dir:Group.dir -> 806 | ('a -> El.t list signal) -> 'a list signal -> 'a option signal -> 807 | 'a Group.t 808 | (** [v ~class' ~enaled ~eq label choices sel] is list of buttons for 809 | selecting a value. [S.eq sel] is used to test values 810 | for equality in the list of [choices]. 811 | {ul 812 | {- [label] is used to label the choice buttons.} 813 | {- [choices] are the values among which to select} 814 | {- [sel] is the value shown as selected, if any. It must be 815 | included in [choices]} 816 | {- [button_class] is a class for choice buttons.} 817 | {- [enabled] indicates if the selector can be 818 | interacted with. Defaults to {!Note.S.Bool.true'}} 819 | {- [class'] is added to the underlying element's classes.}} 820 | 821 | The {!Group.action} of the result occurs whenever a new 822 | selection occurs. *) 823 | 824 | (** {1:style Styling} 825 | 826 | The returned group and buttons makes use of the following CSS 827 | classes (the {{!Group.style}group styling} also applies): 828 | {ul 829 | {- [ui-button-selector] always on the group} 830 | {- [ui-selected] on the button currently selected} 831 | {- [ui-disabled] on the group and buttons whenever 832 | [enabled] is [false].}} *) 833 | end 834 | end 835 | 836 | (** Floating point value selector. 837 | 838 | The value is selected by a slider. 839 | See the {{!Float_selector.style}styling information}. *) 840 | module Float_selector : sig 841 | 842 | (** {1:selector Selector} *) 843 | 844 | type t 845 | val v : 846 | ?class':Jstr.t -> 847 | ?enabled:bool signal -> ?min:float signal -> ?max:float signal -> 848 | ?step:float option signal -> float signal -> t 849 | 850 | val action : t -> float event 851 | (** [action b] is an event that occurs when a new float is selected. *) 852 | 853 | val enabled : t -> bool signal 854 | (** [enabled b] is a signal that is [true] iff the selector is enabled. *) 855 | 856 | val el : t -> El.t 857 | 858 | (** {1:style Styling} *) 859 | end 860 | end 861 | -------------------------------------------------------------------------------- /src/brr/note_brr_legacy.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | 7 | open Brr 8 | open Brr_io 9 | open Note 10 | open Note_brr 11 | 12 | (* Unsafe encoding of OCaml values according to 13 | 14 | https://github.com/ocsigen/js_of_ocaml/blob/master/lib/js_of_ocaml/json.ml 15 | 16 | Get rid of this. *) 17 | 18 | let json = Jv.get Jv.global "JSON" 19 | 20 | external string_of_jsbytes : Jv.t -> Jv.t = "caml_string_of_jsbytes" 21 | external string_to_jsbytes : Jv.t -> Jv.t = "caml_jsbytes_of_string" 22 | external int64_lo_mi_hi : int -> int -> int -> Jv.t 23 | = "caml_int64_create_lo_mi_hi" 24 | 25 | let int64_to_jv v = 26 | Jv.of_jv_array Jv.[| of_int 255; get v "lo"; get v "mi"; get v "hi" |] 27 | 28 | let int64_of_jv v = 29 | int64_lo_mi_hi 30 | (Jv.to_int (Jv.Jarray.get v 1)) (Jv.to_int (Jv.Jarray.get v 2)) 31 | (Jv.to_int (Jv.Jarray.get v 3)) 32 | 33 | let encode_ocaml_value v = 34 | let string = Jv.get (Jv.repr "") "constructor" in 35 | let int64 = Jv.get (Jv.repr 1L) "constructor" in 36 | let replacer _key v = 37 | if Jv.instanceof v ~cons:string then string_to_jsbytes v else 38 | if Jv.instanceof v ~cons:int64 then int64_to_jv v else 39 | v 40 | in 41 | Jv.to_jstr (Jv.call json "stringify" Jv.[| repr v; repr replacer |]) 42 | 43 | let decode_unsafe_ocaml_value s = 44 | let jsarray = Jv.get (Jv.repr (Jv.Jarray.create 0)) "constructor" in 45 | let reviver _key v = 46 | (* XXX this will also revive Jstr.t values as OCaml strings. 47 | replacer should tag ocaml strings, it does not for now. 48 | We should get rid of this anyways. *) 49 | if Jstr.equal (Jv.typeof v) (Jstr.v "string") 50 | then string_of_jsbytes v else 51 | if Jv.instanceof v ~cons:jsarray && Jv.Jarray.length v == 4 && 52 | Jv.to_int (Jv.Jarray.get v 0) = 255 53 | then (int64_of_jv v) 54 | else v 55 | in 56 | Obj.magic (Jv.call json "parse" Jv.[| of_jstr s; repr reviver |]) 57 | 58 | module Store = struct 59 | 60 | type scope = [ `Session | `Persist ] 61 | 62 | let scope_store = function 63 | | `Session -> Storage.session G.window 64 | | `Persist -> Storage.local G.window 65 | 66 | type 'a key = Jstr.t 67 | 68 | let key_prefix = Jstr.v "k" 69 | let key = 70 | let id = ref (-1) in 71 | fun ?ns () -> 72 | id := !id + 1; 73 | let id = Jstr.of_int !id in 74 | match ns with 75 | | None -> Jstr.(key_prefix + id) 76 | | Some ns -> Jstr.(ns + v "-" + key_prefix + id) 77 | 78 | let version = key ~ns:(Jstr.v "brr") () 79 | 80 | let mem ?(scope = `Persist) k = 81 | Storage.get_item (scope_store scope) k <> None 82 | 83 | let add ?(scope = `Persist) k v = 84 | (Storage.set_item (scope_store scope) k (encode_ocaml_value v)) 85 | |> Console.log_if_error ~use:() 86 | 87 | let rem ?(scope = `Persist) k = Storage.remove_item (scope_store scope) k 88 | let find ?(scope = `Persist) k = 89 | match Storage.get_item (scope_store scope) k with 90 | | None -> None 91 | | Some v -> Some (decode_unsafe_ocaml_value v) 92 | 93 | let get ?(scope = `Persist) ?absent k = 94 | let absent () = match absent with 95 | | None -> invalid_arg "key unbound" 96 | | Some v -> v 97 | in 98 | match Storage.get_item (scope_store scope) k with 99 | | None -> absent () 100 | | Some v -> decode_unsafe_ocaml_value v 101 | 102 | let clear ?(scope = `Persist) () = Storage.clear (scope_store scope) 103 | let force_version ?(scope = `Persist) v = 104 | match find ~scope version with 105 | | None -> add ~scope version v 106 | | Some sv -> 107 | if v <> sv then (clear ~scope (); add ~scope version v) 108 | 109 | let storage = Ev.Type.void (Jstr.v "storage") 110 | let ev = 111 | (* protect web workers *) 112 | if Jv.is_none (Window.to_jv G.window) then E.never else 113 | (Evr.on_target storage (fun _ -> ()) (Window.as_target G.window)) 114 | end 115 | -------------------------------------------------------------------------------- /src/brr/note_brr_legacy.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Legacy functionality. 7 | 8 | Needed for transitional reasons. Will disappear when 9 | a suitable replacement is provided. Do not use. *) 10 | 11 | open Note 12 | open Brr 13 | 14 | (** Persistent storage. 15 | 16 | Persisent key-value store implemented over 17 | {{:http://www.w3.org/TR/webstorage/}webstorage}. Safe if no one 18 | tampers with the storage outside of the program. 19 | 20 | {b XXX.} 21 | {ul 22 | {- This still relies on the jsoo representation, add safer keys with type 23 | indexed codecs.} 24 | {- Provide something sensitive for storage events}} *) 25 | module Store : sig 26 | 27 | (** {1 Storage scope} *) 28 | 29 | type scope = [ `Session | `Persist ] 30 | (** The storage scope. *) 31 | 32 | (** {1 Keys} *) 33 | 34 | type 'a key 35 | (** The type for keys whose lookup value is 'a *) 36 | 37 | val key : ?ns:Jstr.t -> unit -> 'a key 38 | (** [key ~ns ()] is a new storage key in namespace [ns]. If [ns] 39 | is unspecified, the key lives in a global namespace. 40 | 41 | {b Warning.} Reordering invocations of {!val-key} in the same 42 | namespace will most of the time corrupt existing storage. This 43 | means that all {!val-key} calls should always be performed at 44 | initialization time. {!Store.force_version} can be used to 45 | easily version your store and aleviate this problem. *) 46 | 47 | (** {1 Storage} 48 | 49 | In the functions below [scope] defaults to [`Persist]. *) 50 | 51 | val mem : ?scope:scope -> 'a key -> bool 52 | (** [mem k] is [true] iff [k] has a mapping. *) 53 | 54 | val add : ?scope:scope -> 'a key -> 'a -> unit 55 | (** [add k v] maps [k] to [v]. *) 56 | 57 | val rem : ?scope:scope -> 'a key -> unit 58 | (** [rem k] unbinds [k]. *) 59 | 60 | val find : ?scope:scope -> 'a key -> 'a option 61 | (** [find k] is [k]'s mapping in [m], if any. *) 62 | 63 | val get : ?scope:scope -> ?absent:'a -> 'a key -> 'a 64 | (** [get k] is [k]'s mapping. If [absent] is provided and [m] has 65 | not binding for [k], [absent] is returned. 66 | 67 | @raise Invalid_argument if [k] is not bound and [absent] 68 | is unspecified or if [scope] is not {!support}ed. *) 69 | 70 | val clear : ?scope:scope -> unit -> unit 71 | (** [clear ()], clears all mapping. *) 72 | 73 | val ev : unit event 74 | (** [ev] fires on storage changes. FIXME provide something 75 | sensitive, e.g. key watching. *) 76 | 77 | (** {1 Versioning} *) 78 | 79 | val force_version : ?scope:scope -> string -> unit 80 | (** [force_version v] checks that the version of the store is [v]. If 81 | it's not it {!clear}s the store and sets the version to [v]. *) 82 | end 83 | -------------------------------------------------------------------------------- /src/note.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | module rec Src : sig (* Sources where data is pushed *) 7 | type t = V : _ typed -> t 8 | and 'a typed 9 | val compare : t -> t -> int 10 | val id : t -> int 11 | val cell : 'a typed -> 'a C.t 12 | val untyped : 'a typed -> t 13 | val logrs : t -> Logr.t list 14 | val add_logr : Logr.t -> t -> unit 15 | val rem_logr : Logr.t -> t -> unit 16 | val reset_stamp : t -> unit 17 | val find_active_step : Step.t -> Srcs.t -> Step.t 18 | val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a typed 19 | end = struct 20 | type t = V : _ typed -> t 21 | and 'a typed = 22 | { id : int; (* unique id for the source *) 23 | cell : 'a C.t; (* Cell holding the source's value *) 24 | mutable logrs : Logr.t list (* loggers that depend on the source *); 25 | self : t; (* self, untyped. *) } 26 | 27 | let id (V s) = s.id 28 | let cell s = s.cell 29 | let untyped s = s.self 30 | let compare (V s) (V t) = (Stdlib.compare : int -> int -> int) s.id t.id 31 | let logrs (V s) = s.logrs 32 | let add_logr logr (V s) = s.logrs <- logr :: s.logrs 33 | let rem_logr logr (V s) = 34 | let rec rem logr acc = function 35 | | [] -> acc 36 | | v :: vs when v == logr -> List.rev_append vs acc 37 | | v :: vs -> rem logr (v :: acc) vs 38 | in 39 | s.logrs <- rem logr [] s.logrs 40 | 41 | let reset_stamp (V s) = C.set_stamp s.cell Step.nil 42 | 43 | exception Step of Step.t 44 | let find_active_step step ss = 45 | if step != Step.nil then step else 46 | let find_not_nil (V s) = 47 | let step = C.stamp s.cell in 48 | if step != Step.nil then raise_notrace (Step step) 49 | in 50 | try Srcs.iter find_not_nil ss; Step.nil with Step s -> s 51 | 52 | let uid = let id = ref 0 in fun () -> incr id; !id 53 | let create ?eq v = 54 | let update _ _ = () in 55 | let cell = C.create ?eq ~step:Step.nil ~srcs:Srcs.empty v ~update in 56 | let rec src = { id = uid (); cell; logrs = []; self = V src } in 57 | C.set_srcs cell (Srcs.singleton src.self); 58 | C.set_srcs_changed cell false; 59 | src 60 | end 61 | 62 | and Srcs : Set.S with type elt = Src.t = Set.Make (Src) 63 | and C : sig (* Cells *) 64 | type 'a t 65 | type untyped = C : 'a t -> untyped 66 | val create : 67 | ?eq:('a -> 'a -> bool) -> step:Step.t -> srcs:Srcs.t -> 'a -> 68 | update:(Step.t -> 'a t -> unit) -> 'a t 69 | 70 | val const : ?eq:('a -> 'a -> bool) -> 'a -> 'a t 71 | val eq : 'a t -> ('a -> 'a -> bool) 72 | val set_eq : 'a t -> ('a -> 'a -> bool) -> unit 73 | val with_eq : ('a -> 'a -> bool) -> 'a t -> 'a t 74 | val stamp : 'a t -> Step.t 75 | val set_stamp : 'a t -> Step.t -> unit 76 | val srcs : 'a t -> Srcs.t 77 | val srcs_changed : 'a t -> bool 78 | val set_srcs : 'a t -> Srcs.t -> unit 79 | val set_srcs_changed : 'a t -> bool -> unit 80 | val value : 'a t -> 'a 81 | val value_changed : 'a t -> bool 82 | val set_value : 'a t -> 'a -> unit 83 | val update : Step.t -> 'a t -> unit 84 | val set_update : 'a t -> (Step.t -> 'a t -> unit) -> unit 85 | val src_update : Step.t -> 'a t -> 'a -> bool 86 | val up_to_date_value : 'a t -> 'a 87 | 88 | val create_instant : 89 | step:Step.t -> srcs:Srcs.t -> 'a option -> 90 | update:(Step.t -> 'a option t -> unit) -> 'a option t 91 | 92 | val reset_instant : 'a option t -> unit 93 | val set_instant : Step.t -> 'a option t -> 'a option -> unit 94 | 95 | val delay : 'a -> 'a t Lazy.t -> 'a t 96 | val fix : ?eq:('a -> 'a -> bool) -> 'a -> ('a t -> 'a t * 'b) -> 'b 97 | val defer : 'a -> 'a t -> 'a t 98 | val dump_src_ids : Format.formatter -> 'a t -> unit 99 | end = struct 100 | type 'a t = 101 | { mutable eq : 'a -> 'a -> bool; (* testing for cell value equality *) 102 | mutable stamp : Step.t; (* last step in which the cell updated *) 103 | mutable srcs : Srcs.t; (* sources the cell depends on *) 104 | mutable srcs_changed : bool; (* [true] if [srcs] changed *) 105 | mutable value : 'a; (* cell value *) 106 | mutable value_changed : bool; (* [true] if [value] changed *) 107 | mutable update : Step.t -> 'a t -> unit; }(* updates [value] and [srcs] *) 108 | 109 | type untyped = C : 'a t -> untyped 110 | 111 | let create ?(eq = ( = )) ~step ~srcs value ~update = 112 | { eq; stamp = step; srcs; srcs_changed = true; value; value_changed = true; 113 | update } 114 | 115 | let const ?(eq = ( = )) v = 116 | { eq; stamp = Step.nil; srcs = Srcs.empty; srcs_changed = false; 117 | value = v; value_changed = false; update = (fun _ _ -> ()) } 118 | 119 | let eq c = c.eq 120 | let set_eq c eq = c.eq <- eq 121 | let with_eq eq c = { c with eq } 122 | let stamp c = c.stamp 123 | let set_stamp c stamp = c.stamp <- stamp 124 | let srcs_changed c = c.srcs_changed 125 | let set_srcs_changed c bool = c.srcs_changed <- bool 126 | let srcs c = c.srcs 127 | let set_srcs c srcs = c.srcs_changed <- true; c.srcs <- srcs 128 | let value c = c.value 129 | let value_changed c = c.value_changed 130 | let set_value c v = 131 | if c.eq v c.value then () else (c.value_changed <- true; c.value <- v) 132 | 133 | let update step c = 134 | if step != Step.nil && c.stamp != step then begin 135 | c.stamp <- step; c.srcs_changed <- false; c.value_changed <- false; 136 | (* XXX would be nice to avoid constructing the set *) 137 | if Srcs.(is_empty (inter c.srcs (Step.srcs step))) 138 | then () (* no need to go there, nothing can update *) 139 | else 140 | c.update step c 141 | end 142 | 143 | let set_update c u = c.update <- u 144 | let src_update step c v = 145 | c.value_changed <- false; 146 | if c.eq v c.value 147 | then false 148 | else (c.stamp <- step; c.value_changed <- true; c.value <- v; true) 149 | 150 | let up_to_date_value c = 151 | let step = Src.find_active_step Step.nil c.srcs in 152 | update step c; c.value 153 | 154 | let reset_instant c = c.value_changed <- false; c.value <- None 155 | let set_instant step c = function 156 | | None -> () 157 | | Some _ as v -> 158 | c.value_changed <- true; c.value <- v; 159 | Step.add_cleanup step (fun () -> reset_instant c) 160 | 161 | let create_instant ~step ~srcs value ~update = 162 | let value_changed = match value with None -> false | Some _ -> true in 163 | let c = 164 | { eq = ( = ); stamp = step; srcs; srcs_changed = true; value; 165 | value_changed; update } 166 | in 167 | if value_changed && step <> Step.nil 168 | then Step.add_cleanup step (fun () -> reset_instant c); 169 | c 170 | 171 | let delay i z = failwith "TOOD" 172 | let fix ?eq i cf = 173 | let src = Src.create ?eq i in 174 | let src = Src.V src and d = Src.cell src in 175 | let c, r = cf d in 176 | let c_update = c.update in 177 | let c_update step self = 178 | c_update step self; 179 | if c.value_changed then (Step.add_delayed step src); 180 | in 181 | let d_update step self = 182 | if step == Step.delayed then set_value self (value c) else () 183 | in 184 | c.update <- c_update; 185 | d.update <- d_update; 186 | let step = Src.find_active_step Step.nil (C.srcs c) in 187 | let () = update step c in 188 | if step == Step.nil then Step.execute_delayed (Srcs.singleton src); 189 | r 190 | 191 | let defer init c = 192 | (** XXX do we really need a source for that. *) 193 | let src = Src.create ~eq:c.eq init in 194 | let src = Src.V src and d = Src.cell src in 195 | let update step self = 196 | if step == Step.delayed 197 | then set_value self (value c) 198 | else begin 199 | C.(update step c); 200 | if C.srcs_changed c then C.set_srcs d (C.srcs c); 201 | if C.value_changed c then Step.add_delayed step src 202 | end 203 | in 204 | d.update <- update; 205 | let step = Src.find_active_step Step.nil (srcs c) in 206 | let () = update step c in 207 | let () = update step d in 208 | if step == Step.nil then Step.execute_delayed (Srcs.singleton src); 209 | d 210 | 211 | let dump_src_ids ppf c = 212 | Format.fprintf ppf "@[{%a}@]" 213 | Format.(pp_print_list ~pp_sep:pp_print_space pp_print_int) 214 | (List.map (fun s -> Src.id s) (Srcs.elements c.srcs)) 215 | end 216 | 217 | and Logr : sig 218 | type 'a obs 219 | val const : 'a -> 'a obs 220 | val obs_cell : 'a C.t -> 'a obs 221 | val app : ('a -> 'b) obs -> 'a obs -> 'b obs 222 | val ( $ ) : ('a -> 'b) obs -> 'a obs -> 'b obs 223 | type t 224 | val create : ?now:bool -> unit obs -> t 225 | val for_cell : ?now:bool -> 'a C.t -> ('a -> unit) -> t 226 | val force : t -> unit 227 | val destroy : t -> unit 228 | val update : Step.t -> t -> unit 229 | val hold : t -> unit 230 | val may_hold : t option -> unit 231 | val unhold_all : unit -> unit 232 | end = struct 233 | type 'a obs = C.untyped list * (unit -> 'a) 234 | let const v = [], fun () -> v 235 | let obs_cell c = [C.C c], fun () -> C.value c 236 | let app (fcs, f) (vcs, v) = List.rev_append fcs vcs, fun () -> (f ()) (v ()) 237 | let ( $ ) = app 238 | 239 | type t = 240 | { mutable stamp : Step.t; 241 | mutable srcs : Srcs.t; (* sources we are registered with *) 242 | cells : C.untyped list; (* cells we are observing *) 243 | log : unit -> unit (* logger action *) } 244 | 245 | let update_srcs l = 246 | let cells_srcs l = 247 | let add_cell acc (C.C c) = Srcs.union acc (C.srcs c) in 248 | List.fold_left add_cell Srcs.empty l.cells 249 | in 250 | let new_srcs = cells_srcs l in 251 | let rems = Srcs.diff l.srcs new_srcs in 252 | let adds = Srcs.diff new_srcs l.srcs in 253 | Srcs.iter (Src.rem_logr l) rems; 254 | Srcs.iter (Src.add_logr l) adds; 255 | l.srcs <- new_srcs 256 | 257 | let update step l = 258 | if step != Step.nil && step != l.stamp then begin 259 | l.stamp <- step; 260 | let rec loop step srcs_changed value_changed = function 261 | | [] -> 262 | if srcs_changed then update_srcs l; 263 | if value_changed then l.log () 264 | | (C.C c) :: cs -> 265 | C.update step c; 266 | loop step 267 | (srcs_changed || C.srcs_changed c) 268 | (value_changed || C.value_changed c) cs 269 | in 270 | loop step false false l.cells 271 | end 272 | 273 | let force l = 274 | let step = Src.find_active_step Step.nil l.srcs in 275 | update step l; 276 | l.log () 277 | 278 | let create ?(now = true) (cells, log) = 279 | let l = { stamp = Step.nil; srcs = Srcs.empty; cells; log } in 280 | update_srcs l; 281 | if now then force l; 282 | l 283 | 284 | let for_cell ?now c log = create ?now ([C.C c], fun () -> log (C.value c)) 285 | let destroy l = Srcs.iter (Src.rem_logr l) l.srcs 286 | let held : t list ref = ref [] 287 | let hold l = held := l :: !held 288 | let may_hold = function None -> () | Some l -> hold l 289 | let unhold_all () = List.iter destroy !held; held := [] 290 | end 291 | 292 | and Step : sig 293 | type t 294 | val create : unit -> t 295 | val nil : t 296 | val delayed : t 297 | val srcs : t -> Srcs.t 298 | val add_src : t -> Src.t -> unit 299 | val add_delayed : t -> Src.t -> unit 300 | val add_cleanup : t -> (unit -> unit) -> unit 301 | val execute : t -> unit 302 | val execute_delayed : Srcs.t -> unit 303 | end = struct 304 | type t = 305 | { mutable srcs : Srcs.t; (* sources part of the update step *) 306 | mutable delayed : Srcs.t; (* sources for delayed cells *) 307 | mutable cleanup : (unit -> unit) list (* for reseting events to None *) } 308 | 309 | let _create srcs = { srcs; delayed = Srcs.empty; cleanup = [] } 310 | let create () = _create Srcs.empty 311 | let nil = create () 312 | let delayed = create () 313 | let srcs step = step.srcs 314 | let add_src step src = step.srcs <- Srcs.add src step.srcs 315 | let add_delayed step src = step.delayed <- Srcs.add src step.delayed 316 | let add_cleanup step clean = step.cleanup <- clean :: step.cleanup 317 | let cleanup step = List.iter (fun f -> f ()) step.cleanup; step.cleanup <- [] 318 | let already_executed () = invalid_arg "step already executed" 319 | 320 | let rec execute_delayed srcs = 321 | let update_delayed_src ds (Src.V s) = 322 | let c = Src.cell s in 323 | C.update delayed c; 324 | C.set_stamp c ds; 325 | in 326 | let ds = _create srcs in 327 | delayed.srcs <- srcs; 328 | Srcs.iter (update_delayed_src ds) srcs; 329 | execute ds 330 | 331 | and execute step = 332 | let update_src_logs src = List.iter (Logr.update step) (Src.logrs src) in 333 | Srcs.iter update_src_logs step.srcs; 334 | Srcs.iter Src.reset_stamp step.srcs; 335 | cleanup step; 336 | add_cleanup step already_executed; (* error further executes *) 337 | match Srcs.is_empty step.delayed with 338 | | true -> () 339 | | false -> execute_delayed step.delayed 340 | end 341 | 342 | (* High-level interface *) 343 | 344 | type 'a signal = 'a C.t 345 | type 'a event = 'a option C.t 346 | 347 | (* Signal and event definition always have the same structure. 348 | 349 | let combinator ... = 350 | let update step self = 351 | C.update step ... 352 | if C.srcs_changed ... then C.set_srcs self ... 353 | if C.value_changed ... then C.set_{instant,value} self ... 354 | in 355 | let srcs = ... 356 | let step = Src.find_active_step Step.nil srcs in 357 | let () = C.update step ... in 358 | let srcs = ... 359 | let init = 360 | C.create .... 361 | 362 | In [update], update dependencies. If dependencies sources changed 363 | update the cell's sources, if dependencies values changed update 364 | the cell's value. 365 | 366 | To create the cell. Get the dependency sources. Find the update 367 | step going on (will be Step.nil if there is none). Update the 368 | dependencies with the step. Get the sources again (they may have changed) 369 | and the needed values to create the cell. 370 | 371 | XXX it would be nice to see if we can simply invoke [update] for 372 | init, possibly with a special Step.init step on Step.nil. *) 373 | 374 | module E = struct 375 | type 'a t = 'a event 376 | type 'a send = ?step:Step.t -> 'a -> unit 377 | 378 | let obs = Logr.obs_cell 379 | let log ?now e f = 380 | let wrap = function None -> () | Some v -> f v in 381 | Some (Logr.for_cell ?now e wrap) 382 | 383 | let create () = 384 | let src = Src.create None in 385 | let send ?step v = 386 | let step, exec = match step with 387 | | None -> Step.create (), true 388 | | Some step -> step, false 389 | in 390 | C.set_stamp (Src.cell src) step; 391 | C.set_instant step (Src.cell src) (Some v); 392 | Step.add_src step (Src.untyped src); 393 | if exec then Step.execute step 394 | in 395 | (Src.cell src), send 396 | 397 | let value = C.up_to_date_value 398 | let never = (* XXX *) Obj.magic @@ C.const None 399 | let bind e f = 400 | let step = Src.find_active_step Step.nil (C.srcs e) in 401 | let () = C.update step e in 402 | let current = match C.value e with None -> never | Some curr -> f curr in 403 | let current = ref current in 404 | let update step self = 405 | C.update step e; 406 | match C.value e with 407 | | None -> 408 | C.update step !current; 409 | if C.(srcs_changed e || srcs_changed !current) then 410 | C.set_srcs self (Srcs.union (C.srcs e) (C.srcs !current)); 411 | C.set_instant step self (C.value !current) 412 | | Some curr -> 413 | current := f curr; 414 | C.update step !current; 415 | C.set_srcs self (Srcs.union (C.srcs e) (C.srcs !current)); 416 | C.set_instant step self (C.value !current) 417 | in 418 | let step = Src.find_active_step step (C.srcs !current) in 419 | let () = C.update step !current in 420 | let srcs = Srcs.union (C.srcs e) (C.srcs !current) in 421 | let init = C.value !current in 422 | C.create_instant ~step ~srcs init ~update 423 | 424 | let join ee = bind ee (fun e -> e) 425 | let swap es = 426 | let step = Src.find_active_step Step.nil (C.srcs es) in 427 | let () = C.update step es in 428 | let current = ref (C.value es) in 429 | let update step self = 430 | C.update step es; 431 | begin match C.value_changed es with 432 | | false -> 433 | C.update step !current; 434 | if C.(srcs_changed es || srcs_changed !current) 435 | then C.set_srcs self (Srcs.union (C.srcs es) (C.srcs !current)) 436 | | true -> 437 | current := C.value es; 438 | C.update step !current; 439 | C.set_srcs self (Srcs.union (C.srcs es) (C.srcs !current)); 440 | end; 441 | C.set_instant step self (C.value !current) 442 | in 443 | let step = Src.find_active_step step (C.srcs !current) in 444 | let () = C.update step !current in 445 | let srcs = Srcs.union (C.srcs es) (C.srcs !current) in 446 | let init = C.value !current in 447 | C.create_instant ~step ~srcs init ~update 448 | 449 | let map f e = 450 | let map f = function None -> None | Some v -> Some (f v) in 451 | let update step self = 452 | C.update step e; 453 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 454 | C.set_instant step self (map f (C.value e)) 455 | in 456 | let step = Src.find_active_step Step.nil (C.srcs e) in 457 | let () = C.update step e in 458 | C.create_instant ~step ~srcs:(C.srcs e) (map f (C.value e)) ~update 459 | 460 | let stamp e v = 461 | let stamp = function None -> None | Some _ -> Some v in 462 | let update step self = 463 | C.update step e; 464 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 465 | C.set_instant step self (stamp (C.value e)) 466 | in 467 | let step = Src.find_active_step Step.nil (C.srcs e) in 468 | let () = C.update step e in 469 | let init = stamp (C.value e) in 470 | C.create_instant ~step ~srcs:(C.srcs e) init ~update 471 | 472 | let filter f e = 473 | let filter f = function 474 | | None -> None 475 | | Some v as occ when f v -> occ 476 | | Some _ -> None 477 | in 478 | let update step self = 479 | C.update step e; 480 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 481 | C.set_instant step self (filter f (C.value e)) 482 | in 483 | let step = Src.find_active_step Step.nil (C.srcs e) in 484 | let () = C.update step e in 485 | let init = filter f (C.value e) in 486 | C.create_instant ~step ~srcs:(C.srcs e) init ~update 487 | 488 | let filter_map f e = 489 | let filter_map f = function None -> None | Some v -> f v in 490 | let update step self = 491 | C.update step e; 492 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 493 | C.set_instant step self (filter_map f (C.value e)) 494 | in 495 | let step = Src.find_active_step Step.nil (C.srcs e) in 496 | let () = C.update step e in 497 | let init = filter_map f (C.value e) in 498 | C.create_instant ~step ~srcs:(C.srcs e) init ~update 499 | 500 | let select es = 501 | let add_srcs acc e = Srcs.union acc (C.srcs e) in 502 | let or_srcs_changed acc e = acc || C.srcs_changed e in 503 | let update step self = 504 | List.iter (C.update step) es; 505 | let srcs_changed = List.fold_left or_srcs_changed false es in 506 | if srcs_changed 507 | then C.set_srcs self (List.fold_left add_srcs Srcs.empty es); 508 | let v = match List.find (fun e -> C.value e <> None) es with 509 | | exception Not_found -> None | e -> C.value e 510 | in 511 | C.set_instant step self v 512 | in 513 | let find_step step e = Src.find_active_step step (C.srcs e) in 514 | let step = List.fold_left find_step Step.nil es in 515 | let () = List.iter (C.update step) es in 516 | let init = match List.find (fun e -> C.value e <> None) es with 517 | | exception Not_found -> None | e -> C.value e 518 | in 519 | let srcs = List.fold_left add_srcs Srcs.empty es in 520 | C.create_instant ~step ~srcs init ~update 521 | 522 | let accum acc e = 523 | let acc = ref acc in 524 | let accum = function None -> None | Some f -> acc := f !acc; Some !acc in 525 | let update step self = 526 | C.update step e; 527 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 528 | C.set_instant step self (accum (C.value e)) 529 | in 530 | let step = Src.find_active_step Step.nil (C.srcs e) in 531 | let () = C.update step e in 532 | let init = accum (C.value e) in 533 | C.create_instant ~step ~srcs:(C.srcs e) init ~update 534 | 535 | let until ?(limit = false) ~next e = 536 | let nop step self = () in 537 | let update step self = 538 | C.(update step next; update step e); 539 | match C.value next with 540 | | None -> 541 | if C.(srcs_changed next || srcs_changed e) 542 | then C.set_srcs self (Srcs.union (C.srcs next) (C.srcs e)); 543 | C.set_instant step self (C.value e) 544 | | Some _ -> 545 | C.set_srcs self Srcs.empty; 546 | C.set_update self nop; 547 | C.set_instant step self (if limit then C.value e else None) 548 | in 549 | let step = Src.find_active_step Step.nil (C.srcs next) in 550 | let step = Src.find_active_step step (C.srcs e) in 551 | let () = C.(update step next; update step e) in 552 | match C.value next with 553 | | None -> 554 | let srcs = Srcs.union (C.srcs next) (C.srcs e) in 555 | C.create_instant ~step ~srcs (C.value e) ~update 556 | | Some _ -> 557 | let init = if limit then C.value e else None in 558 | C.create_instant ~step ~srcs:Srcs.empty init ~update:nop 559 | 560 | let follow e ~on = 561 | (* FIXME rewrite combinators with this style. 562 | FIXME determine why we don't simply call update for init in general *) 563 | let deps_srcs e on = Srcs.union (C.srcs e) (C.srcs on) in 564 | let deps_srcs_changed e on = C.(srcs_changed e || srcs_changed on) in 565 | let update_deps step e on = C.(update step e; update step on) in 566 | let follow e on = match e with Some _ as o when on -> o | _ -> None in 567 | let update step self = 568 | update_deps step e on; 569 | if deps_srcs_changed e on then C.set_srcs self (deps_srcs e on); 570 | C.set_instant step self (follow (C.value e) (C.value on)) 571 | in 572 | let step = Src.find_active_step Step.nil (C.srcs e) in 573 | let step = Src.find_active_step step (C.srcs on) in 574 | let () = update_deps step e on in 575 | let init = follow (C.value e) (C.value on) in 576 | C.create_instant ~step ~srcs:(deps_srcs e on) init ~update 577 | 578 | let defer e = C.defer None e 579 | let fix ef = C.fix None ef 580 | 581 | module Option = struct 582 | let on_some e = filter_map (fun x -> x) e 583 | let some e = map (fun v -> Some v) e 584 | let value e ~default = 585 | let update step self = 586 | C.update step e; 587 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 588 | let occ = match C.value e with 589 | | None -> None 590 | | Some (Some _ as v) -> v 591 | | Some None -> C.update step default; Some (C.value default) 592 | in 593 | C.set_instant step self occ 594 | in 595 | let step = Src.find_active_step Step.nil (C.srcs e) in 596 | let () = C.update step e; C.update step default in 597 | let init = match C.value e with 598 | | None -> None 599 | | Some (Some _ as v) -> v 600 | | Some None -> Some (C.value default) 601 | in 602 | C.create_instant ~step ~srcs:(C.srcs e) init ~update 603 | 604 | let get e = 605 | map (function Some v -> v | None -> invalid_arg "option is None") e 606 | 607 | let bind e f = map (function None -> None | Some v -> f v) e 608 | let join e = map (function Some (Some _ as o) -> o | _ -> None) e 609 | let is_none e = map (function None -> true | Some _ -> false) e 610 | let is_some e = map (function None -> false | Some _ -> true) e 611 | let map f e = map (function None -> None | Some v -> Some (f v)) e 612 | end 613 | 614 | module Pair = struct 615 | let fst e = map fst e 616 | let snd e = map snd e 617 | let v e0 e1 = 618 | let update step self = 619 | C.(update step e0; update step e1); 620 | if C.(srcs_changed e0 || srcs_changed e1) 621 | then C.set_srcs self (Srcs.union (C.srcs e0) (C.srcs e1)); 622 | let occ = match C.value e0, C.value e1 with 623 | | Some v0, Some v1 -> Some (v0, v1) 624 | | _ -> None 625 | in 626 | C.set_instant step self occ 627 | in 628 | let step = Src.find_active_step Step.nil (C.srcs e0) in 629 | let step = Src.find_active_step step (C.srcs e1) in 630 | let srcs = Srcs.union (C.srcs e0) (C.srcs e1) in 631 | let init = match C.value e0, C.value e1 with 632 | | Some v0, Some v1 -> Some (v0, v1) 633 | | _ -> None 634 | in 635 | C.create_instant ~step ~srcs init ~update 636 | end 637 | 638 | let dump_src_ids = C.dump_src_ids 639 | end 640 | 641 | module S = struct 642 | type 'a t = 'a signal 643 | type 'a set = ?step:Step.t -> 'a -> unit 644 | 645 | let log = Logr.for_cell 646 | let obs = Logr.obs_cell 647 | let eq = C.eq 648 | let with_eq = C.with_eq 649 | let create ?eq v = 650 | let src = Src.create ?eq v in 651 | let set ?step v = 652 | let step, exec = match step with 653 | | None -> Step.create (), true 654 | | Some step -> step, false 655 | in 656 | let cell = Src.cell src in 657 | if C.src_update step cell v 658 | then Step.add_src step (Src.untyped src); 659 | if exec then Step.execute step 660 | in 661 | Src.cell src, set 662 | 663 | let value = C.up_to_date_value 664 | let rough_value = C.value 665 | let const = C.const 666 | let bind v f = 667 | let step = Src.find_active_step Step.nil (C.srcs v) in 668 | let () = C.update step v in 669 | let current = ref (f (C.value v)) in 670 | let update step self = 671 | C.update step v; 672 | match C.value_changed v with 673 | | false -> 674 | C.update step !current; 675 | if C.(srcs_changed v || srcs_changed !current) then 676 | C.set_srcs self (Srcs.union (C.srcs v) (C.srcs !current)); 677 | if C.value_changed !current then C.set_value self (C.value !current) 678 | | true -> 679 | current := f (C.value v); 680 | C.update step !current; 681 | C.set_eq self (C.eq !current); 682 | C.set_srcs self (Srcs.union (C.srcs v) (C.srcs !current)); 683 | C.set_value self (C.value !current) 684 | in 685 | let step = Src.find_active_step step (C.srcs !current) in 686 | let () = C.update step !current in 687 | let srcs = Srcs.union (C.srcs v) (C.srcs !current) in 688 | let init = C.value !current in 689 | C.create ~eq:(C.eq !current) ~step ~srcs init ~update 690 | 691 | let hold ?eq i e = 692 | let update step self = 693 | C.update step e; 694 | if C.(srcs_changed e) then C.set_srcs self (C.srcs e); 695 | match C.value e with 696 | | None -> () 697 | | Some v -> C.set_value self v 698 | in 699 | let step = Src.find_active_step Step.nil (C.srcs e) in 700 | let () = C.update step e in 701 | let init = match C.value e with None -> i | Some v -> v in 702 | C.create ?eq ~step ~srcs:(C.srcs e) init ~update 703 | 704 | let join ss = bind ss (fun s -> s) 705 | let swap s se = join (hold ~eq:( == ) s se) 706 | let changes s = 707 | let update step self = 708 | C.update step s; 709 | if C.srcs_changed s then C.set_srcs self (C.srcs s); 710 | if C.value_changed s then C.set_instant step self (Some (C.value s)) 711 | in 712 | let step = Src.find_active_step Step.nil (C.srcs s) in 713 | let () = C.update step s in 714 | (* NB: 0 - dt doesn't exist so this is always None *) 715 | C.create_instant ~step ~srcs:(C.srcs s) None ~update 716 | 717 | let sample s ~on f = 718 | let update step self = 719 | C.(update step on; update step s); 720 | if C.(srcs_changed on || srcs_changed s) 721 | then C.set_srcs self (Srcs.union (C.srcs s) (C.srcs on)); 722 | match C.value on with 723 | | None -> () 724 | | Some v -> C.set_instant step self (Some (f (C.value s) v)) 725 | in 726 | let step = Src.find_active_step Step.nil (C.srcs s) in 727 | let step = Src.find_active_step step (C.srcs on) in 728 | let () = C.(update step on; update step s) in 729 | let srcs = Srcs.union (C.srcs s) (C.srcs on) in 730 | let init = match C.value on with 731 | | None -> None 732 | | Some v -> Some (f (C.value s) v) 733 | in 734 | C.create_instant ~step ~srcs init ~update 735 | 736 | let sample_filter s ~on f = E.Option.on_some (sample s ~on f) 737 | let snapshot s ~on = sample s ~on (fun v _ -> v) 738 | 739 | let map ?eq f v = 740 | let update step self = 741 | C.update step v; 742 | if C.srcs_changed v then C.set_srcs self (C.srcs v); 743 | if C.value_changed v then C.set_value self (f (C.value v)) 744 | in 745 | let step = Src.find_active_step Step.nil (C.srcs v) in 746 | let () = C.update step v in 747 | C.create ?eq ~step ~srcs:(C.srcs v) (f (C.value v)) ~update 748 | 749 | let app ?eq f v = 750 | let update step self = 751 | C.(update step f; update step v); 752 | if C.(srcs_changed f || srcs_changed v) then 753 | C.set_srcs self (Srcs.union (C.srcs f) (C.srcs v)); 754 | if C.(value_changed f || value_changed v) then 755 | C.set_value self ((C.value f) (C.value v)) 756 | in 757 | let step = Src.find_active_step Step.nil (C.srcs f) in 758 | let step = Src.find_active_step step (C.srcs v) in 759 | let () = C.update step f; C.update step v in 760 | let srcs = Srcs.union (C.srcs f) (C.srcs v) in 761 | let init = (C.value f) (C.value v) in 762 | C.create ?eq ~step ~srcs init ~update 763 | 764 | let accum ?eq i e = hold ?eq i (E.accum i e) 765 | let until ?(limit = false) ?init ~next s = 766 | let nop step self = () in 767 | let update step self = 768 | C.(update step next; update step s); 769 | match C.value next with 770 | | None -> 771 | if C.(srcs_changed next || srcs_changed s) 772 | then C.set_srcs self (Srcs.union (C.srcs next) (C.srcs s)); 773 | C.set_value self (C.value s) 774 | | Some _ -> 775 | C.set_srcs self Srcs.empty; 776 | C.set_update self nop; 777 | if limit then C.set_value self (C.value s) else () 778 | in 779 | let step = Src.find_active_step Step.nil (C.srcs next) in 780 | let step = Src.find_active_step step (C.srcs s) in 781 | let () = C.(update step next; update step s) in 782 | match C.value next with 783 | | None -> 784 | let srcs = Srcs.union (C.srcs next) (C.srcs s) in 785 | C.create ~eq:(eq s) ~step ~srcs (C.value s) ~update 786 | | Some _ -> 787 | let init = match init with None -> C.value s | Some i -> i in 788 | C.create ~eq:(eq s) ~step ~srcs:Srcs.empty init ~update:nop 789 | 790 | let follow ?init s ~on = 791 | let deps_srcs s on = Srcs.union (C.srcs s) (C.srcs on) in 792 | let deps_srcs_changed s on = C.(srcs_changed s || srcs_changed on) in 793 | let update_deps step s on = C.(update step s; update step on) in 794 | let update step self = 795 | update_deps step s on; 796 | if deps_srcs_changed s on then C.set_srcs self (deps_srcs s on); 797 | if C.value on then C.set_value self (C.value s) 798 | in 799 | let step = Src.find_active_step Step.nil (C.srcs s) in 800 | let step = Src.find_active_step step (C.srcs on) in 801 | let () = update_deps step s on in 802 | let init = match init with None -> (C.value s) | Some i -> i in 803 | C.create ~eq:(eq s) ~step ~srcs:(deps_srcs s on) init ~update 804 | 805 | let delay = C.delay 806 | let defer ?init s = 807 | let init = match init with 808 | | Some init -> init 809 | | None -> 810 | let step = Src.find_active_step Step.nil (C.srcs s) in 811 | let () = C.update step s in 812 | C.value s 813 | in 814 | C.defer init s 815 | 816 | let fix = C.fix 817 | let l1 ?eq f x = map ?eq f x 818 | let l2 ?eq f x y = 819 | let update step self = 820 | C.(update step x; update step y); 821 | if C.(srcs_changed x || srcs_changed y) 822 | then C.set_srcs self (Srcs.union (C.srcs x) (C.srcs y)); 823 | if C.(value_changed x || value_changed y) 824 | then C.set_value self (f (C.value x) (C.value y)) 825 | in 826 | let step = Src.find_active_step Step.nil (C.srcs x) in 827 | let step = Src.find_active_step step (C.srcs y) in 828 | let () = C.(update step x; update step y) in 829 | let srcs = Srcs.union (C.srcs x) (C.srcs y) in 830 | let init = f (C.value x) (C.value y) in 831 | C.create ?eq ~step ~srcs init ~update 832 | 833 | let l3 ?eq f x y z = 834 | let srcs_union x y z = 835 | Srcs.union (C.srcs x) (Srcs.union (C.srcs y) (C.srcs z)) 836 | in 837 | let update step self = 838 | C.(update step x; update step y; update step z); 839 | if C.(srcs_changed x || srcs_changed y || srcs_changed z) 840 | then C.set_srcs self (srcs_union x y z); 841 | if C.(value_changed x || value_changed y || value_changed z) 842 | then C.set_value self (f (C.value x) (C.value y) (C.value z)) 843 | in 844 | let step = Src.find_active_step Step.nil (C.srcs x) in 845 | let step = Src.find_active_step step (C.srcs y) in 846 | let step = Src.find_active_step step (C.srcs z) in 847 | let () = C.(update step x; update step y; update step z) in 848 | let srcs = srcs_union x y z in 849 | let init = f (C.value x) (C.value y) (C.value z) in 850 | C.create ?eq ~step ~srcs init ~update 851 | 852 | module Bool = struct 853 | let eq : bool -> bool -> bool = ( = ) 854 | let false' = const false 855 | let true' = const true 856 | let not s = map ~eq not s 857 | let ( && ) = l2 ( && ) 858 | let ( || ) = l2 ( || ) 859 | let edge s = changes s 860 | let edge_detect edge s = 861 | let update step self = 862 | C.update step s; 863 | if C.srcs_changed s then C.set_srcs self (C.srcs s); 864 | if Stdlib.( && ) (C.value_changed s) (C.value s = edge) 865 | then C.set_instant step self (Some ()) 866 | in 867 | let step = Src.find_active_step Step.nil (C.srcs s) in 868 | let () = C.update step s in 869 | C.create_instant ~step ~srcs:(C.srcs s) None ~update 870 | 871 | let rise s = edge_detect true s 872 | let fall s = edge_detect false s 873 | let flip ~init e = 874 | let update step self = 875 | C.update step e; 876 | if C.srcs_changed e then C.set_srcs self (C.srcs e); 877 | match C.value e with 878 | | None -> () 879 | | Some _ -> C.set_value self (Stdlib.not (C.value self)) 880 | in 881 | let step = Src.find_active_step Step.nil (C.srcs e) in 882 | let () = C.update step e in 883 | let init = match C.value e with 884 | | Some _ -> Stdlib.not init 885 | | None -> init 886 | in 887 | C.create ~eq ~step ~srcs:(C.srcs e) init ~update 888 | end 889 | 890 | module Option = struct 891 | let _eq eq = fun v0 v1 -> match v0, v1 with 892 | | Some v0, Some v1 -> eq v0 v1 893 | | None, None -> true 894 | | _, _ -> false 895 | 896 | let none = (* XXX *) Obj.magic @@ (const None) 897 | let some s = map ~eq:(_eq (eq s)) (fun v -> Some v) s 898 | 899 | let hold_value i s = 900 | let update step self = 901 | C.update step s; 902 | if (C.srcs_changed s) then C.set_srcs self (C.srcs s); 903 | match C.value s with None -> () | Some v -> C.set_value self v 904 | in 905 | let eq v v' = C.eq s (Some v) (Some v') in 906 | let step = Src.find_active_step Step.nil (C.srcs s) in 907 | let () = C.update step s in 908 | let init = match C.value s with None -> i | Some v -> v in 909 | C.create ~eq ~step ~srcs:(C.srcs s) init ~update 910 | 911 | let value s ~default = 912 | let update step self = 913 | C.update step default; C.update step s; 914 | if C.(srcs_changed default || C.srcs_changed s) 915 | then C.set_srcs self (Srcs.union (C.srcs default) (C.srcs s)); 916 | if (C.value_changed default || C.value_changed s) 917 | then match C.value s with 918 | | None -> C.set_value self (C.value default) 919 | | Some v -> C.set_value self v 920 | in 921 | let step = Src.find_active_step Step.nil (C.srcs default) in 922 | let step = Src.find_active_step step (C.srcs s) in 923 | let () = C.(update step default; update step s) in 924 | let init = match C.value s with None -> C.value default | Some v -> v in 925 | let srcs = Srcs.union (C.srcs default) (C.srcs s) in 926 | C.create ~eq:(eq default) ~step ~srcs init ~update 927 | 928 | let get ?eq s = 929 | map ?eq (function Some v -> v | None -> invalid_arg "option is None") s 930 | 931 | let bind ?eq s f = map ?eq (function None -> None | Some v -> f v) s 932 | let join ?eq s = map ?eq (function Some (Some _ as o) -> o | _ -> None) s 933 | let is_none s = map ~eq:Bool.eq (function None -> true | Some _ -> false) s 934 | let is_some s = map ~eq:Bool.eq (function None -> false | Some _ -> true) s 935 | let map ?eq f s = map ?eq (function None -> None | Some v -> Some (f v)) s 936 | let eq = _eq 937 | end 938 | 939 | module Pair = struct 940 | let fst ?eq s = map ?eq fst s 941 | let snd ?eq s = map ?eq snd s 942 | let v s0 s1 = l2 (fun x y -> (x, y)) s0 s1 943 | end 944 | 945 | let dump_src_ids = C.dump_src_ids 946 | end 947 | -------------------------------------------------------------------------------- /src/note.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Declarative events and signals for OCaml. *) 7 | 8 | 9 | (** {1 Note} *) 10 | 11 | (** Update steps. 12 | 13 | Update steps allow to schedule {e simultaneous} primitive event occurrence 14 | and signal changes. *) 15 | module Step : sig 16 | 17 | (** {1:steps Steps} *) 18 | 19 | type t 20 | (** The type for update steps. *) 21 | 22 | val create : unit -> t 23 | (** [create ()] is a new update step. *) 24 | 25 | val execute : t -> unit 26 | (** [execute step] executes the update step [step]. 27 | 28 | @raise Invalid_argument if [step] was already executed. *) 29 | end 30 | 31 | (** Event and signal changes loggers. 32 | 33 | Loggers are the output interface of the reactive system. They 34 | allow external entities to observe event occurrences and signal 35 | changes. *) 36 | module Logr : sig 37 | 38 | (** {1:obs Observations} *) 39 | 40 | type 'a obs 41 | (** The type for observing changes of type ['a]. *) 42 | 43 | val const : 'a -> 'a obs 44 | (** [const v] never changes and always observes [v]. *) 45 | 46 | val app : ('a -> 'b) obs -> 'a obs -> 'b obs 47 | (** [app f v] is the observation that result from applying the 48 | changes of [f] to the ones of [v]. *) 49 | 50 | val ( $ ) : ('a -> 'b) obs -> 'a obs -> 'b obs 51 | (** [f $ v] is [app f v]. *) 52 | 53 | (** {1:loggers Loggers} *) 54 | 55 | type t 56 | (** The type for loggers. *) 57 | 58 | val create : ?now:bool -> unit obs -> t 59 | (** [create ~now o] is a logger that observes changes to [o]. If 60 | [now] is [true] (default) logs at least one observation before 61 | the call returns. *) 62 | 63 | val force : t -> unit 64 | (** [force l] observes [l] even if nothing changed. *) 65 | 66 | val destroy : t -> unit 67 | (** [destroy l] destroys log [l] this ensure that [l]'s does not 68 | observe any change again. The underlying observed events or 69 | signals also stop updating, unless they are observed by another 70 | logger. *) 71 | 72 | val hold : t -> unit 73 | (** [hold l] holds logger [l] to ensure it does not get garbage 74 | collected. *) 75 | 76 | val may_hold : t option -> unit 77 | (** [may_hold l] holds logger [Some l] to ensure it does not get 78 | garbage collected. Does nothing on [None]. *) 79 | 80 | val unhold_all : unit -> unit 81 | (** [unhold_all ()] {{!destroy}destroys} and unholds all loggers held 82 | via {!hold}. *) 83 | end 84 | 85 | type 'a signal 86 | (** The type for signals of type 'a *) 87 | 88 | type 'a event 89 | (** The type for events of type 'a *) 90 | 91 | (** Events. 92 | 93 | An event is a value with discrete occurrences over time. 94 | Consult the {{!page-semantics.events}semantics and notations} of 95 | events. *) 96 | module E : sig 97 | 98 | (** {1:ev Events} *) 99 | 100 | type 'a t = 'a event 101 | (** The type for events with occurrences of type ['a]. *) 102 | 103 | type 'a send = ?step:Step.t -> 'a -> unit 104 | (** The type for functions sending event occurrences of type ['a]. 105 | See {!create}. *) 106 | 107 | val obs : 'a t -> 'a option Logr.obs 108 | (** [obs e] is an observation for [e]'s occurrences. *) 109 | 110 | val log : ?now:bool -> 'a event -> ('a -> unit) -> Logr.t option 111 | (** [log ?now e f] is [Some (Logr.(create ?now (const f $ obs e)))] 112 | if [e] is not {!never} and [None] otherwise. *) 113 | 114 | val create : unit -> 'a event * 'a send 115 | (** [create ()] is a primitive event [e] and a [send] function. 116 | The function [send] is such that: 117 | {ul 118 | {- [send v] generates an occurrence [v] of [e] at the time it is 119 | called .} 120 | {- [send ~step v] generates an occurrence [v] of [e] at the time 121 | [step]. The function should not be called again before [step] 122 | is {{!Step.execute}executed}.}} 123 | {b Warning.} [send] must not be used in the definition of signals 124 | or events. *) 125 | 126 | val value : 'a event -> 'a option 127 | (** [value e] is the value of event [e] at call time. If this is [None] 128 | the event has no occurrence, if this is [Some v], the event occurs 129 | with [v]. *) 130 | 131 | val never : 'a event 132 | (** [never] is a never occuring event, \[[never]\]{_t} [= None]. *) 133 | 134 | val bind : 'a event -> ('a -> 'b event) -> 'b event 135 | (** [bind e f] is the event that results from applying [f] to 136 | the last event of [e]: 137 | {ul 138 | {- \[[bind e f]\]{_ t} [=] \[[f v]\]{_t} if \[[e]\]{_≤t} [= Some v].} 139 | {- \[[bind e f]\]{_ t} [=] [never]{_t} if \[[e]\]{_≤t} [= None].}} *) 140 | 141 | val join : 'a event event -> 'a event 142 | (** [join ee] is [bind ee (fun e -> e)]. *) 143 | 144 | val swap : 'a event signal -> 'a event 145 | (** [swap es] is the current event of [es], 146 | \[[swap es]\]{_t} [=] \[\[[es]\]{_t}\]{_t}. *) 147 | 148 | val map : ('a -> 'b) -> 'a event -> 'b event 149 | (** [map f e] applies [f] to [e]'s occurrences. 150 | {ul 151 | {- \[[map f e]\]{_t} [= Some (f v)] if \[[e]\]{_t} [= Some v].} 152 | {- \[[map f e]\]{_t} [= None] otherwise.}} *) 153 | 154 | val stamp : 'b event -> 'a -> 'a event 155 | (** [stamp e v] is [map e (fun _ -> v)] *) 156 | 157 | val filter : ('a -> bool) -> 'a event -> 'a event 158 | (** [filter p e] are the occurrences of [e] that satisfy [p]. 159 | {ul 160 | {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and 161 | [p v = true]} 162 | {- \[[filter p e]\]{_t} [= None] otherwise.}} *) 163 | 164 | val filter_map : ('a -> 'b option) -> 'a event -> 'b event 165 | (** [filter_map fm e] are [e]'s occurrences filtered and mapped by [fm]. 166 | {ul 167 | {- \[[filter_map fm e]\]{_t} [= Some v] if [fm] \[[e]\]{_t} [= Some v]} 168 | {- \[[filter_map fm e]\]{_t} [= None] otherwise.}} *) 169 | 170 | val select : 'a event list -> 'a event 171 | (** [select el] is the occurrences of every event in [el]. If more 172 | than one event occurs simlutanously, the leftmost is taken 173 | and the other are lost: 174 | {ul 175 | {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} 176 | [<> None) el]\]{_t}.} 177 | {- \[[select el]\]{_ t} [= None] otherwise.}} *) 178 | 179 | val accum : 'a -> ('a -> 'a) event -> 'a event 180 | (** [accum i e] accumulates a value, starting with [i], using [e]'s 181 | functional occurrences. 182 | {ul 183 | {- \[[accum i e]\]{_t} [= Some (f i)] if \[[e]\]{_t} [= Some f] 184 | and \[[e]\]{_ next:'a event -> 'b event -> 'b event 191 | (** [until ~limit ~next e] is [e]'s occurrences until [next] 192 | occurs. At that point if [e] occurs simultaneously the occurrence is 193 | discarded ([limit] is [false], default) or kept ([limit] is [true]) 194 | and after this the event never occurs again. 195 | {ul 196 | {- \[[until ~limit ~next e]\]{_t} [=] \[[e]\]{_t} 197 | if \[[next]\]{_≤t} [= None]} 198 | {- \[[until ~limit:false ~next e]\]{_t} [= None] 199 | if \[[next]\]{_t} [= Some _] and \[[next]\]{_ on:bool signal -> 'a event 205 | (** [follow e ~on] is [e]'s occurrences whenever [on] is [true]. 206 | {ul 207 | {- \[[follow e ~on]\]{_t} [=] \[[e]\]{_t} if \[[on]\]{_t} [= true]} 208 | {- \[[follow e ~on]\]{_t} [= None] if \[[on]\]{_t} [= false]}} *) 209 | 210 | val defer : 'a event -> 'a event 211 | (** [defer s] is [s] delayed by an infinitesimal amount of time. 212 | At creation time [init] is used (defaults to [S.value s]). 213 | {ul 214 | {- \[[defer e]\]{_ t} [=] [None] for t = 0. } 215 | {- \[[defer e]\]{_ t} [=] \[[e]\]{_t-dt} otherwise.}} *) 216 | 217 | val fix : ('a event -> 'a event * 'b) -> 'b 218 | (** [fix ef] allows to refer to the value an event had an 219 | infinitesimal amount of time before. 220 | 221 | In [fix ef], [ef] is called with an event [e] that represents 222 | the event returned by [ef] delayed by an infinitesimal amount of 223 | time. If [e', r = ef e] then [r] is returned by [fix] and [e] 224 | is such that : 225 | {ul 226 | {- \[[e]\]{_ t} [=] [None] if t = 0 } 227 | {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} 228 | 229 | {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. 230 | an event given to a fixing function). *) 231 | 232 | (** {1:stdlib Stdlib types support} *) 233 | 234 | (** Option events *) 235 | module Option : sig 236 | 237 | val on_some : 'a option event -> 'a event 238 | (** [on_some e] is [e] when [Some _] occurs: 239 | {ul 240 | {- \[[on_some e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some (Some v)]} 241 | {- \[[on_some e]\]{_t} [= None] otherwise.}} *) 242 | 243 | (** {1:lift Lifted {!Stdlib.Option} module} *) 244 | 245 | val some : 'a event -> 'a option event 246 | (** [some e] is [map (fun v -> Some v) e]. *) 247 | 248 | val value : 'a option event -> default:'a signal -> 'a event 249 | (** [value e default] is [default] when [e] occurs with [None]: 250 | {ul 251 | {- \[[value e ~default]\]{_t} [= None] if \[[e]\]{_t} [= None]} 252 | {- \[[value e ~default]\]{_t} [= Some v] 253 | if \[[e]\]{_t} [= Some (Some v)]} 254 | {- \[[value e ~default]\]{_t} [=] \[[default]\]{_t} if \[[e]\]{_t} 255 | [= Some None]}} *) 256 | 257 | val get : 'a option event -> 'a event 258 | (** [get e] is [map get e]. *) 259 | 260 | val bind : 'a option event -> ('a -> 'b option) -> 'b option event 261 | (** [bind e f] is [map (fun v -> Option.bind v f) e]. *) 262 | 263 | val join : 'a option option event -> 'a option event 264 | (** [join e] is [map Option.join e]. *) 265 | 266 | val map : ('a -> 'b) -> 'a option event -> 'b option event 267 | (** [map f e] is [map Option.map e]. *) 268 | 269 | val is_none : 'a option event -> bool event 270 | (** [is_none e] is [map is_none e]. *) 271 | 272 | val is_some : 'a option event -> bool event 273 | (** [is_some e] is [map is_some e]. *) 274 | end 275 | 276 | (** Pair events. *) 277 | module Pair : sig 278 | val fst : ('a * 'b) event -> 'a event 279 | (** [fst e] is [map fst e]. *) 280 | 281 | val snd : ('a * 'b) event -> 'b event 282 | (** [snd e] is [map snd e]. *) 283 | 284 | val v : 'a event -> 'b event -> ('a * 'b) event 285 | (** [v e0 e1] pair simultaneous occurrences of [e0] and [e1]: 286 | {ul 287 | {- \[[v e0 e1]\]{_t} [= Some (v0, v1)] if \[[e0]\]{_t} [= Some v0] 288 | and \[[e1]\]{_t} [= Some v1]} 289 | {- \[[v e0 e1]\]{_t} [= None] otherwise.}} *) 290 | end 291 | 292 | (**/**) 293 | val dump_src_ids : Format.formatter -> 'a event -> unit 294 | (**/**) 295 | end 296 | 297 | (** Signals. 298 | 299 | A signal is a value that varies continuously over time. Consult 300 | the {!page-semantics.signals}semantics and notations} of signals. *) 301 | module S : sig 302 | 303 | (** {1:sig Signals} *) 304 | 305 | type 'a t = 'a signal 306 | (** The type for signals of type ['a]. *) 307 | 308 | type 'a set = ?step:Step.t -> 'a -> unit 309 | (** The type for functions setting signal values of type ['a]. 310 | See {!create}.*) 311 | 312 | val obs : 'a t -> 'a Logr.obs 313 | (** [obs s] is an observation for [s]. *) 314 | 315 | val log : ?now:bool -> 'a signal -> ('a -> unit) -> Logr.t 316 | (** [log ?now s f] is [Logr.(create ~now (const f $ obs s))]. *) 317 | 318 | val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a signal * 'a set 319 | (** [create v] is a primitive signal set to the value [v] and a 320 | [set] function. The function [set] is such that: 321 | {ul 322 | {- [set v] sets the signal's value to [v] at the time it is called.} 323 | {- [set ~step v] sets the signal value to [v] at the time it is called 324 | and schedules an update at time [step].}} 325 | 326 | {b Warning.} [set] must not be used in the definition of signals 327 | or events. *) 328 | 329 | val eq : 'a signal -> 'a -> 'a -> bool 330 | (** [eq s] is [s]'s equality function. *) 331 | 332 | val with_eq : ('a -> 'a -> bool) -> 'a signal -> 'a signal 333 | (** [with_eq eq s] is [s] with equality function [eq]. *) 334 | 335 | val value : 'a signal -> 'a 336 | (** [value s] is the current value of [s], \[[s]\]{_t} *) 337 | 338 | val rough_value : 'a signal -> 'a 339 | (** [rough_value s] is the current value of [s], but in contrast to 340 | {!value} it might not be exactly \[[s]\]{_t}. *) 341 | 342 | val const : ?eq:('a -> 'a -> bool) -> 'a -> 'a signal 343 | (** [const v] is always [v], \[[const v]\]{_t} [= v]. *) 344 | 345 | val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a event -> 'a signal 346 | (** [hold i e] has the value of [e]'s last occurrence or the 347 | value of [i] provides the signal value at creation time if 348 | there's no event at that time. 349 | {ul 350 | {- \[[hold i e]\]{_t} [= i] if \[[e]\]{_≤t} [= None]} 351 | {- \[[hold i e]\]{_t} [= v] if \[[e]\]{_≤t} [= Some v]}} *) 352 | 353 | val bind : 'a signal -> ('a -> 'b signal) -> 'b signal 354 | (** [bind s f] is the signal that results from applying [f] to 355 | [s], \[[bind s f]\]{_ t} [=] \[f\[[s]\]{_t}\]{_t}. *) 356 | 357 | val join : 'a signal signal -> 'a signal 358 | (** [join ss] is [bind ss (fun s -> s)]. *) 359 | 360 | val swap : 'a signal -> 'a signal event -> 'a signal 361 | (** [swap s se] is [join (hold ~eq:( == ) s se)] that is the values of 362 | [s] followed by values of the last signal that occurred on [se]. *) 363 | 364 | val changes : 'a signal -> 'a event 365 | (** [changes s] occurs with the value of [s] whenever it changes. 366 | {ul 367 | {- \[[changes s]\]{_t} [= Some v] 368 | if \[[s]\]{_t} [= v] and \[[s]\]{_t-dt} [= v'] and [eq v v' = false].} 369 | {- \[[changes s]\]{_t} [= None] otherwise.}} 370 | 371 | {b Warning.} By definition no event occurs if [s] changes at 372 | creation time ([0 - dt] is undefined). *) 373 | 374 | val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a signal -> 'b signal 375 | (** [map f s] is [s] transformed by [f], 376 | \[[map f s]\]{_t} = [f] \[[s]\]{_t}. *) 377 | 378 | val app : 379 | ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> 'b signal 380 | (** [app sf s] holds the value of [sf] applied to the value of [s], 381 | \[[app sf s]\]{_t} [=] \[[sf]\]{_t} \[[s]\]{_t}. *) 382 | 383 | val sample : 'b signal -> on:'a event -> ('b -> 'a -> 'c) -> 'c event 384 | (** [sample s ~on f] samples [s] at [e]'s occurrences. 385 | {ul 386 | {- \[[sample s ~on f]\]{_t} [= Some (f sv ev)] if \[[on]\]{_t} [= Some ev] 387 | and \[[s]\]{_t} [= sv].} 388 | {- \[[sample s ~on f]\]{_t} [= None] otherwise.}} *) 389 | 390 | val sample_filter : 391 | 'b signal -> on:'a event -> ('b -> 'a -> 'c option) -> 'c event 392 | (** [sample_filter s on f] is [E.Option.on_some (sample s ~on f)]. *) 393 | 394 | val snapshot : 'b signal -> on:'a event -> 'b event 395 | (** [snapshot ~on s] is [sample (fun v _ -> v) ~on s]. 396 | 397 | {b TODO.} Candidate for deletion. *) 398 | 399 | (* 400 | val active : on:bool signal -> 'a signal -> 'a signal 401 | (** [active ~on s] is has the value of [s] at creation 402 | time and then mirrors [s] whenever [on] is [true]. 403 | When [on] is false holds the last value [s] had when [on] 404 | was true. 405 | {ul 406 | {- \[[active ~on s]\]{_0} [=] \[[s]\]{_0}} 407 | {- \[[active ~on s]\]{_t} [=] \[[s]\]{_t} if \[[on]\]{_t} [= true]} 408 | {- \[[active ~on s]\]{_t} [=] \[[s]\]{_t'} if \[[on]\]{_t} [= false] 409 | where t' is the greatest 0 < t' < t with \[[on]\]{_t'} [= true].}} *) 410 | *) 411 | 412 | val accum : ?eq:('a -> 'a -> bool) -> 'a -> ('a -> 'a) event -> 'a signal 413 | (** [accum i e] is [hold i (E.accum i e)]. *) 414 | 415 | val until : ?limit:bool -> ?init:'b -> next:'a event -> 'b signal -> 'b signal 416 | (** [until ~limit ~init ~next s] is [s] until [next] occurs, after 417 | which the value [s] had just before ([limit] is [false], default) 418 | or whenever [next] occurs ([limit] is [true]) is kept forever. 419 | {ul 420 | {- \[[until ~limit ~init ~next s]\]{_t} [=] \[[s]\]{_t} 421 | if \[[next]\]{_≤t} [= None]} 422 | {- \[[until ~limit ~init ~next s]\]{_t} 423 | [= init] if \[[next]\]{_0} [= Some _]} 424 | {- \[[until ~limit:false ~init ~next s]\]{_t} [=] \[[s]\]{_t'- dt} 425 | if \[[next]\]{_t'} [= Some _] and \[[next]\]{_ 'a signal -> on:bool signal -> 'a signal 431 | (** [follow ~init s ~on] is [s] whenever [on] is [true] and the last 432 | value of [s] when [on] was [true] if [on] is [false]. If [on] is 433 | [false] at creation time [init] is used (defaults to [S.value 434 | s]). 435 | {ul 436 | {- \[[follow ~init s ~on]\]{_0} [=] \[[s]\]{_0} 437 | if \[[on]\]{_0} [= true]} 438 | {- \[[follow ~init s ~on]\]{_0} [=] \[[init]\]{_0} 439 | if \[[on]\]{_0} [= false]} 440 | {- \[[follow ~init s ~on]\]{_t} [=] \[[s]\]{_t} 441 | if \[[on]\]{_t} [= true]} 442 | {- \[[follow ~init s ~on]\]{_t} [=] \[[follow ~init s ~on]\]{_t'} 443 | if \[[on]\]{_t} [= false] where t' is the 444 | greatest t' < t with \[[on]\]{_t'} [= true] or [0] if there 445 | is no such time.}} *) 446 | 447 | val defer : ?init:'a -> 'a signal -> 'a signal 448 | (** [defer s] is [s] delayed by an infinitesimal amount of time. 449 | At creation time [init] is used (defaults to [S.value s]). 450 | {ul 451 | {- \[[defer s]\]{_ t} [=] [init] for t = 0. } 452 | {- \[[defer s]\]{_ t} [=] \[[s]\]{_t-dt} otherwise.}} *) 453 | 454 | val delay : 'a -> 'a signal Lazy.t -> 'a signal 455 | (** [delay i (lazy s)] is the value [s] had an infinitesimal amount 456 | of time before: 457 | {ul 458 | {- \[[delay i (lazy s)]\]{_ t} [=] [i] for t = 0. } 459 | {- \[[delay i (lazy s)]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} *) 460 | 461 | val fix : ?eq:('a -> 'a -> bool) -> 'a -> ('a signal -> 'a signal * 'b) -> 'b 462 | (** In [fix sf], [sf] is called with a signal [s] that represents 463 | 464 | the signal returned by [sf] delayed by an infinitesimal amount 465 | time. If [s', r = sf s] then [r] is returned by [fix] and [s] 466 | is such that : 467 | {ul 468 | {- \[[s]\]{_ t} [=] [i] for t = 0. } 469 | {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} *) 470 | 471 | (** {1:lifting Lifting} 472 | Lifting combinators. For a given [n] the semantics is : 473 | \[[ln f a1] ... [an]\]{_t} = f \[[a1]\]{_t} ... \[[an]\]{_t} *) 474 | 475 | val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a signal -> 'b signal 476 | val l2 : 477 | ?eq:('c -> 'c -> bool) -> ('a -> 'b -> 'c) -> 'a signal -> 'b signal -> 478 | 'c signal 479 | val l3 : 480 | ?eq:('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd) -> 'a signal -> 481 | 'b signal -> 'c signal -> 'd signal 482 | 483 | (** {1:stdlib Stdlib types support} *) 484 | 485 | (** Boolean signals *) 486 | module Bool : sig 487 | 488 | val false' : bool signal 489 | (** [false'] is [const false]. *) 490 | 491 | val true' : bool signal 492 | (** [true'] is [const true]. *) 493 | 494 | val not : bool signal -> bool signal 495 | (** [not s] is [map not s]. *) 496 | 497 | val ( && ) : bool signal -> bool signal -> bool signal 498 | (** [s0 && s1] is [l2 ( && ) s1 s2]. *) 499 | 500 | val ( || ) : bool signal -> bool signal -> bool signal 501 | (** [s0 || s1] is [l2 ( || ) s1 s2]. *) 502 | 503 | val edge : bool signal -> bool event 504 | (** [edge s] is [changes s]. *) 505 | 506 | val rise : bool signal -> unit event 507 | (** [rise s] is 508 | [E.filter_map (function true -> Some b | false -> None) (edge s)]. *) 509 | 510 | val fall : bool signal -> unit event 511 | (** [fall s] is 512 | [E.filter_map (function true -> None | None -> Some b) (edge s)] *) 513 | 514 | val flip : init:bool -> 'a event -> bool signal 515 | (** [flip ~init e] is a signal whose boolean value flips each time 516 | [e] occurs. [init] provides the signal value at creation time. 517 | {ul 518 | {- \[[flip b e]\]{_0} [= not b] if \[[e]\]{_0} [= Some _]} 519 | {- \[[flip b e]\]{_t} [=] init if \[[e]\]{_≤t} [= None]} 520 | {- \[[flip b e]\]{_t} [=] [not] \[[flip b e]\]{_t-dt} 521 | if \[[e]\]{_t} [= Some _]}} *) 522 | end 523 | 524 | (** Option signals *) 525 | module Option : sig 526 | 527 | val eq : ('a -> 'a -> bool) -> ('a option -> 'a option -> bool) 528 | (** [eq f] derives an equality function on options using [f] for 529 | testing [Some _]. *) 530 | 531 | val hold_value : 'a -> 'a option signal -> 'a signal 532 | (** [hold_value i s] is the last [Some _] value of [s] or 533 | [i] if there was no such value: 534 | {ul 535 | {- \[[hold_some i s]\]{_t} [= i] if \[[s]\]{_ 'a option signal 545 | (** [some s] is [map (fun v -> Some v) s] and uses [s]'s equality 546 | function to derive the obvious one on options. *) 547 | 548 | val value : 'a option signal -> default:'a signal -> 'a signal 549 | (** [value s ~default] is [default] when [s] is [None]: 550 | {ul 551 | {- \[[value s ~default]\]{_t} [= v] if \[[s]\]{_t} [= Some v]} 552 | {- \[[value s ~default]\]{_t} [=] 553 | \[[default]\]{_t} if \[[s]\]{_t} [= None]}} 554 | [default]'s equality function is used for the resulting signal. *) 555 | 556 | val get : ?eq:('a -> 'a -> bool) -> 'a option signal -> 'a signal 557 | (** [get s] is [map ~eq Option.get s]. *) 558 | 559 | val bind : 560 | ?eq:('b option -> 'b option -> bool) -> 'a option signal -> 561 | ('a -> 'b option) -> 'b option signal 562 | (** [bind ~eq s f] is [map ~eq (fun v -> Option.bind v f) s]. *) 563 | 564 | val join : 565 | ?eq:('a option -> 'a option -> bool) -> 'a option option signal -> 566 | 'a option signal 567 | (** [join ~eq oos] is [map ~eq Option.join oos]. *) 568 | 569 | val map : 570 | ?eq:('b option -> 'b option -> bool) -> ('a -> 'b) -> 571 | 'a option signal -> 'b option signal 572 | (** [map ~eq f s] is [map ~eq Option.map s]. *) 573 | 574 | val is_none : 'a option signal -> bool signal 575 | (** [is_none s] is [map Option.is_none s]. *) 576 | 577 | val is_some : 'a option signal -> bool signal 578 | (** [is_some s] is [map Option.is_some s]. *) 579 | end 580 | 581 | (** Pair signals. *) 582 | module Pair : sig 583 | 584 | val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) signal -> 'a signal 585 | (** [fst ?eq s] is [map ?eq fst s]. *) 586 | 587 | val snd : ?eq:('b -> 'b -> bool) -> ('a * 'b) signal -> 'b signal 588 | (** [snd ?eq e] is [map ?eq snd e]. *) 589 | 590 | val v : 'a signal -> 'b signal -> ('a * 'b) signal 591 | (** [v s0 s1] is [l2 (fun x y -> (x, y) s0 s1]. *) 592 | end 593 | 594 | (**/**) 595 | val dump_src_ids : Format.formatter -> 'a signal -> unit 596 | (**/**) 597 | end 598 | -------------------------------------------------------------------------------- /src/note.mllib: -------------------------------------------------------------------------------- 1 | Note 2 | -------------------------------------------------------------------------------- /test/clock.ml: -------------------------------------------------------------------------------- 1 | (* This code is in the public domain. 2 | Prints a clock with the current local time in the terminal. *) 3 | 4 | let pr_time t = 5 | let tm = Unix.localtime t in 6 | Printf.printf "\x1B[8D%02d:%02d:%02d%!" 7 | tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 8 | 9 | open Note;; 10 | 11 | let seconds, run = 12 | let e, send = E.create () in 13 | let run () = while true do send (Unix.gettimeofday ()); Unix.sleep 1 done in 14 | e, run 15 | 16 | let log = E.log seconds pr_time 17 | let () = run () 18 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Tests for note's combinators. 7 | Compile with -g to get a precise backtrace to the error. 8 | 9 | Note that the testing mechanism itself (cf. occs and vals) needs a correct 10 | implementation; particulary w.r.t. updates with side effects. *) 11 | 12 | open Note 13 | 14 | let strf = Printf.sprintf 15 | let log f = Format.printf (f ^^ "@.") 16 | let tr id v = Printf.printf "%s: %d\n%!" id v; v 17 | 18 | let log_fail pp_val v v' rest = 19 | log "@[@[%a@] <> @[%a@] (assert) remaining: @[%a@]@]" 20 | pp_val v pp_val v' 21 | Format.(pp_print_list ~pp_sep:pp_print_space pp_val) rest 22 | 23 | let log_fail_empty pp_val v = log "%a but no change expected" pp_val v 24 | 25 | (* Tests the event e goes trough occs *) 26 | let occs pp_val ?(eq = ( = )) e occs = 27 | let occs = ref occs in 28 | let assert_occ o = match !occs with 29 | | o' :: occs' when eq o o' -> occs := occs' 30 | | o' :: occs' -> log_fail pp_val o o' occs'; assert false 31 | | [] -> log_fail_empty pp_val o; assert false 32 | in 33 | E.log e assert_occ, occs 34 | 35 | let int_occs = occs Format.pp_print_int 36 | let bool_occs = occs Format.pp_print_bool 37 | let unit_occs = occs (fun ppf () -> Format.fprintf ppf "()") 38 | 39 | (* Tests the signal s goes through vals *) 40 | let vals pp_val ?(eq = ( = )) s vals = 41 | let vals = ref vals in 42 | let assert_val v = match !vals with 43 | | v' :: vals' when eq v v' -> vals := vals' 44 | | v' :: vals' -> log_fail pp_val v v' vals'; assert false 45 | | [] -> log "%a, but empty asserts" pp_val v; assert false 46 | in 47 | Some (S.log s assert_val), vals 48 | 49 | let int_vals = vals Format.pp_print_int 50 | let bool_vals = vals Format.pp_print_bool 51 | 52 | (* To initialize asserts of dynamic creations. *) 53 | let assert_e_stub () = ref (None, ref []) 54 | let assert_s_stub v = ref (None, ref []) 55 | 56 | (* Tests that we went through all vals or occs *) 57 | let empty (_, r) = assert (!r = []) 58 | 59 | let test_basic_event () = 60 | log "Basic event"; 61 | let x, send_x = E.create () in 62 | let occs = [1;2;2;3;3;3] in 63 | let assert_x = int_occs x occs in 64 | List.iter send_x occs; 65 | List.iter empty [assert_x]; 66 | () 67 | 68 | let test_e_map () = 69 | log "E.map"; 70 | let x, send_x = E.create () in 71 | let occs = [1;2;2;3;3;3] in 72 | let twice = ( * ) 2 in 73 | let y = E.map twice x in 74 | let assert_twice = int_occs y (List.map twice occs) in 75 | List.iter send_x occs; 76 | List.iter empty [assert_twice]; 77 | () 78 | 79 | let test_e_swap () = 80 | log "E.swap"; 81 | let x, send_x = E.create () in 82 | let y, send_y = E.create () in 83 | let s, set_x = S.create 0 in 84 | let es = s |> S.map ~eq:( == ) @@ function 85 | | 0 -> E.map (fun x -> x) x 86 | | 1 -> y 87 | | _ -> assert false 88 | in 89 | let e = E.swap es in 90 | let assert_e = int_occs e [2;3;3;4;5;6] in 91 | send_x 2; send_y 5; 92 | set_x 1; send_x 2; send_y 3; send_y 3; 93 | set_x 0; send_y 5; send_x 4; send_x 5; send_x 6; 94 | List.iter empty [assert_e]; 95 | () 96 | 97 | let test_basic_signal () = 98 | log "Basic signal"; 99 | let x, set_x = S.create 1 in 100 | let assert_x = int_vals x [1;2;3;2;3] in 101 | List.iter set_x [2;2;3;2;3;3]; 102 | List.iter empty [assert_x]; 103 | () 104 | 105 | let test_s_hold () = 106 | log "S.hold"; 107 | let x, send_x = E.create () in 108 | let s = S.hold 1 x in 109 | let assert_x = int_occs x [2;2;3;2;3;3]; in 110 | let assert_s = int_vals s [1;2;3;2;3] in 111 | List.iter send_x [2;2;3;2;3;3]; 112 | List.iter empty [assert_x; assert_s]; 113 | () 114 | 115 | let test_s_map () = 116 | log "S.map"; 117 | let x, set_x = S.create 1 in 118 | let twice = S.map (fun x -> 2 * x) x in 119 | let assert_twice = int_vals twice [2;4;6;4;6] in 120 | List.iter set_x [2;2;2;3;2;3;3]; 121 | List.iter empty [assert_twice]; 122 | () 123 | 124 | let test_s_bind () = 125 | log "S.bind"; 126 | let flip, set_flip = S.create true in 127 | let s0, set_s0 = S.create 0 in 128 | let s1, set_s1 = S.create 1 in 129 | let switch = function true -> s0 | false -> s1 in 130 | let b = S.bind flip switch in 131 | let assert_b = int_vals b [0;1;3;2;3] in 132 | set_flip true; set_flip false; 133 | set_s0 2; set_s1 3; 134 | set_flip true; 135 | set_s1 2; 136 | set_flip false; 137 | set_s1 3; 138 | List.iter empty [assert_b]; 139 | () 140 | 141 | let high_s s = 142 | let id s = S.map (fun v -> v) s in (id (id (id (id (id (id (id (id s)))))))) 143 | 144 | let test_s_changes () = 145 | log "S.changes"; 146 | let e, send_e = E.create () in 147 | let s = S.hold 1 e in 148 | let c = S.changes s in 149 | let assert_dc = assert_e_stub () in 150 | let assert_dhc = assert_e_stub () in 151 | let dyn () = 152 | let dc = S.changes s in 153 | let dhc = S.changes (high_s s) in 154 | assert_dc := int_occs dc [4]; 155 | assert_dhc := int_occs dhc [4] 156 | in 157 | let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in 158 | let log_dyn = S.log create_dyn (fun _ -> ()) in 159 | let assert_c = int_occs c [3; 4] in 160 | List.iter send_e [1; 1; 3; 3; 4; 4]; 161 | List.iter empty [assert_c; !assert_dc; !assert_dhc]; 162 | Logr.destroy log_dyn; 163 | () 164 | 165 | let test_s_init_dyn () = 166 | (* Tests init when created in a step. *) 167 | log "S dynamic creation initialization"; 168 | let s0, set_s0 = S.create 0 in 169 | let s1, set_s1 = S.create 1 in 170 | let m0 = S.map (fun x -> x + 1) s0 in 171 | let m1 = S.map (fun x -> x + 1) s1 in 172 | let dyn0 = function _ -> S.map (fun x -> x + 1) m1 (* !! *) in 173 | let dyn1 = function _ -> S.map (fun x -> x + 1) m0 (* !! *) in 174 | let d0 = S.bind s0 dyn0 in 175 | let d1 = S.bind s1 dyn1 in 176 | let assert_d0 = int_vals d0 [3;8] in 177 | let assert_d1 = int_vals d1 [2;7] in 178 | let step = Step.create () in 179 | set_s0 ~step 5; 180 | set_s1 ~step 6; 181 | Step.execute step; 182 | List.iter empty [assert_d0; assert_d1]; 183 | () 184 | 185 | let test_s_bind_dyn () = (* dyn bind from react test suite *) 186 | log "S.bind dynamic"; 187 | let s1, set_s1 = S.create true in 188 | let s2, set_s2 = S.create 1 in 189 | let bind1 = function 190 | | true -> 191 | let bind2 = function 192 | | true -> s2 193 | | false -> S.const 2 194 | in 195 | S.bind s1 bind2 196 | | false -> S.const 2 197 | in 198 | let s = S.bind s1 bind1 in 199 | let assert_bind = int_vals s [1; 2; 1] in 200 | set_s1 true; 201 | set_s1 false; 202 | set_s1 true; 203 | List.iter empty [assert_bind]; 204 | () 205 | 206 | let test_s_bool () = 207 | log "S.Bool"; 208 | let s, set_s = S.create 0 in 209 | let a_zedge = bool_occs (S.Bool.(edge false')) [] in 210 | let a_zrise = unit_occs (S.Bool.(rise false')) [] in 211 | let a_zfall = unit_occs (S.Bool.(fall false')) [] in 212 | let a_flip_never = bool_vals (S.Bool.flip ~init:false E.never) [false] in 213 | let flip = S.Bool.flip ~init:true (S.changes s) in 214 | let a_flip = bool_vals flip [true; false; true] in 215 | let a_flip_edge = bool_occs (S.Bool.edge flip) [false; true] in 216 | let a_flip_rise = unit_occs (S.Bool.rise flip) [()] in 217 | let a_flip_fall = unit_occs (S.Bool.fall flip) [()] in 218 | let dyn_flip = S.bind s (fun _ -> S.Bool.flip ~init:true (S.changes s)) in 219 | let a_dyn_flip = bool_vals dyn_flip [true] in 220 | let changes = S.changes s in 221 | let dyn_flip' = S.bind s (fun _ -> S.Bool.flip ~init:true changes) in 222 | let a_dyn_flip' = bool_vals dyn_flip' [true; false] in 223 | List.iter set_s [1;2;2]; 224 | List.iter empty [a_flip_never; a_flip; a_dyn_flip; a_dyn_flip'; a_zedge; 225 | a_flip_edge; ]; 226 | List.iter empty [a_zrise; a_zfall; a_flip_rise; a_flip_fall ]; 227 | () 228 | 229 | (* 230 | let test_s_delay () = 231 | log "Test delay"; 232 | let int_list_vals = 233 | vals Format.(pp_print_list 234 | ~pp_sep:pp_print_space Format.pp_print_int) 235 | in 236 | let history s = 237 | let push v = function 238 | | [] -> [v] 239 | | v' :: _ as l when S.eq s v v' -> l 240 | | l -> v :: l 241 | in 242 | let rec h = lazy (S.l2 push s (S.delay [] h)) in 243 | Lazy.force h 244 | in 245 | let s, set_s = S.create 0 in 246 | let h = history s in 247 | let assert_h = int_list_vals h [[]; [1]; [1;2]] in 248 | List.iter set_s [1;1;2;2]; 249 | List.iter empty [assert_h]; 250 | () 251 | *) 252 | 253 | let test_s_fix () = 254 | log "S.fix"; 255 | let pp_comma ppf () = Format.fprintf ppf ",@ " in 256 | let pp_int_list = Format.(pp_print_list ~pp_sep:pp_comma pp_print_int)in 257 | let int_list_vals = vals pp_int_list in 258 | let history s = 259 | let push v = function 260 | | [] -> [v] 261 | | v' :: _ as l when S.eq s v v' -> l 262 | | l -> v :: l 263 | in 264 | S.fix [] (fun h -> let h' = S.l2 push s h in h', (h, h')) 265 | in 266 | let s, set_s = S.create 0 in 267 | let h_dt, h = history s in 268 | let incd = S.map (fun l -> List.map (( + ) 1) l) h_dt in 269 | let assert_h = int_list_vals h [[0]; [1;0]; [2;1;0]; [3;2;1;0]] in 270 | let assert_incd = int_list_vals incd [[1]; [2;1]; [3;2;1]; [4;3;2;1]] in 271 | List.iter set_s [1;1;2;2;3]; 272 | List.iter empty [assert_h; assert_incd]; 273 | () 274 | 275 | let test_s_fix_2 () = 276 | log "S.fix"; 277 | let pairs s = 278 | let def v = 279 | let t = S.map (fun v -> v * 2) v in 280 | let v = S.map (fun v -> v) v in 281 | let v' = S.l2 (fun _ v -> if v mod 2 = 0 then v else v + 1) v s in 282 | v', (t, v') 283 | in 284 | S.fix 0 def 285 | in 286 | let s, set_s = S.create 0 in 287 | let t, p = pairs s in 288 | let assert_t = int_vals t [0; 4; 8] in 289 | let assert_p = int_vals p [0; 2; 4] in 290 | List.iter set_s [1;1;2;2;3]; 291 | List.iter empty [assert_t; assert_p;]; 292 | () 293 | 294 | let test_observation () = 295 | log "Test observation"; 296 | let test ~now = 297 | let obs = [(Some 1, 1); (None, 2)] in 298 | let obs = if now then (None, 0) :: obs else obs in 299 | let obs = ref obs in 300 | let assert_obs e s = 301 | if (e, s) <> List.hd !obs then assert false; 302 | obs := List.tl !obs 303 | in 304 | let s, set_s = S.create 0 in 305 | let e = E.filter (( = ) 1) (S.changes s) in 306 | let log = Logr.(create ~now (const assert_obs $ E.obs e $ S.obs s)) in 307 | List.iter set_s [1;2;2]; 308 | assert (!obs = []); 309 | Sys.opaque_identity @@ ignore (log) (* Avoid gc. *) 310 | in 311 | test ~now:true; 312 | test ~now:false; 313 | () 314 | 315 | let test_signals () = 316 | test_basic_event (); 317 | test_e_map (); 318 | test_e_swap (); 319 | test_basic_signal (); 320 | test_s_hold (); 321 | test_s_map (); 322 | test_s_bind (); 323 | test_s_changes (); 324 | test_s_init_dyn (); 325 | test_s_bind_dyn (); 326 | test_s_bool (); 327 | test_s_fix (); 328 | test_s_fix_2 (); 329 | test_observation (); 330 | () 331 | 332 | let main () = 333 | test_signals (); 334 | print_endline "All tests succeeded." 335 | 336 | let () = main () 337 | -------------------------------------------------------------------------------- /test/test_key.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open Note 8 | open Note_brr 9 | open Note_brr_kit 10 | 11 | let key_state id is_down = 12 | let kbd = El.kbd [El.txt (Jstr.v id)] in 13 | Elr.def_class (Jstr.v "down") is_down kbd; 14 | kbd 15 | 16 | let key_dir down up = 17 | let show_dir = El.span [] in 18 | let show d _ = [El.txt' (match d with `Up -> "↑" | `Down -> "↓")] in 19 | let dir = E.select [ E.map (show `Down) down; E.map (show `Up) up ] in 20 | Elr.set_children show_dir ~on:dir; 21 | show_dir 22 | 23 | let key_id ev = 24 | let kbd = El.kbd [El.txt' "  "] in 25 | let id e = [El.txt (Key.to_jstr e)] in 26 | Elr.set_children kbd ~on:(E.map id ev); 27 | kbd 28 | 29 | let key_viz evs = El.div [ 30 | El.p [ key_id (E.select [Key.any_down evs; Key.any_up evs ]); 31 | key_dir (Key.any_down evs) (Key.any_up evs) ]; 32 | El.p [ key_state "Any" (Key.any_holds evs) ]; 33 | El.p [ key_state "Shift" (Key.shift evs); 34 | key_state "L" (Key.holds evs (`Shift `Left)); 35 | key_state "R" (Key.holds evs (`Shift `Right)) ]; 36 | El.p [ key_state "Ctrl" (Key.ctrl evs); 37 | key_state "L" (Key.holds evs (`Ctrl `Left)); 38 | key_state "R" (Key.holds evs (`Ctrl `Right)) ]; 39 | El.p [ key_state "Alt" (Key.alt evs); 40 | key_state "L" (Key.holds evs (`Alt `Left)); 41 | key_state "R" (Key.holds evs (`Alt `Right)) ]; 42 | El.p [ key_state "Meta" (Key.meta evs); 43 | key_state "L" (Key.holds evs (`Meta `Left)); 44 | key_state "R" (Key.holds evs (`Meta `Right)) ]; 45 | El.p [ key_state "Spacebar" (Key.holds evs `Spacebar); 46 | key_dir (Key.down evs `Spacebar) (Key.up evs `Spacebar)]; 47 | ] 48 | 49 | let main () = 50 | let h1 = El.h1 [El.txt' "Keyboard test"] in 51 | let info = El.p [El.txt' "Hit your keyboard."] in 52 | let body = Document.body G.document in 53 | El.set_children body [h1; info; key_viz (Key.on_el body)] 54 | 55 | let () = main () 56 | -------------------------------------------------------------------------------- /test/test_leak.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open Note 8 | open Note_brr 9 | 10 | (* This tests that nodes removed from the HTML DOM destroy their log. If 11 | they didn't they would never be garbage collected. *) 12 | 13 | let count, run_count = 14 | let v = ref 0 in 15 | let count, send_count = E.create () in 16 | let rec run_count () = 17 | incr v; send_count !v; ignore (G.set_timeout ~ms:0 run_count) 18 | in 19 | count, run_count 20 | 21 | let count_value count = 22 | (* Voluntarily silly. *) 23 | let p = El.p [] in 24 | let count_txt c = [El.txt Jstr.(v "Steps: " + of_int c)] in 25 | let count = S.hold [] (E.map count_txt count) in 26 | Elr.def_children p count; 27 | p 28 | 29 | let count_value_nest count = 30 | let p = El.p [] in 31 | let count_txt c = [El.txt Jstr.(v "Steps (nest): " + of_int c)] in 32 | let count = S.hold [] (E.map count_txt count) in 33 | Elr.def_children p count; 34 | El.div [p] 35 | 36 | let steps () = 37 | let steps = El.div [] in 38 | let children = 39 | let counts c = [count_value count; count_value_nest count] in 40 | S.hold [] (E.map counts count) 41 | in 42 | Elr.def_children steps children; 43 | steps 44 | 45 | let main () = 46 | let h1 = El.h1 [El.txt' "No leaks!"] in 47 | let i = "Memory usage must be bounded and the counters must not slow down." in 48 | let info = El.p [El.txt' i ] in 49 | El.set_children (Document.body G.document) [h1; info; steps ()]; 50 | run_count () 51 | 52 | let () = main () 53 | -------------------------------------------------------------------------------- /test/test_mouse.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open Note 8 | open Note_brr 9 | open Note_brr_kit 10 | 11 | let show_pos (x, y) = 12 | let coord x = Jstr.of_float ~frac:4 x in 13 | [El.txt Jstr.(coord x + sp + coord y)] 14 | 15 | let active id bool = 16 | let kbd = El.kbd (* semantic abuse *) [El.txt (Jstr.v id)] in 17 | Elr.def_class (Jstr.v "down") bool kbd; 18 | kbd 19 | 20 | let pos pos = 21 | let view = El.code [] in 22 | Elr.def_children view (S.map show_pos pos); view 23 | 24 | let ev_pos pos = 25 | let view = El.code [] in 26 | Elr.set_children view ~on:(E.map show_pos pos); view 27 | 28 | let dir down up = 29 | let show_dir = El.span [] in 30 | let show d _ = [El.txt' (match d with `Up -> "↑" | `Down -> "↓")] in 31 | let dir = E.select [ E.map (show `Down) down; E.map (show `Up) up ] in 32 | Elr.set_children show_dir ~on:dir; 33 | show_dir 34 | 35 | let button_viz evs name is_down down up = 36 | El.p [ active name (is_down evs); dir (down evs) (up evs); El.txt' "  "; 37 | ev_pos (E.select [down evs; up evs])] 38 | 39 | let mouse_viz evs = El.div [ 40 | El.p [ active "Inside" (Mouse.mem evs); 41 | pos (Mouse.pos evs); El.txt' "    Δ "; 42 | ev_pos (Mouse.dpos evs); ]; 43 | button_viz evs "Left" Mouse.left Mouse.left_down Mouse.left_up; 44 | button_viz evs "Mid" Mouse.mid Mouse.mid_down Mouse.mid_up; 45 | button_viz evs "Right" Mouse.mid Mouse.right_down Mouse.right_up; ] 46 | 47 | let area () = 48 | let area = El.div [] in 49 | El.set_inline_style El.Style.width (Jstr.v "75%") area; 50 | El.set_inline_style El.Style.height (Jstr.v "15rem") area; 51 | El.set_inline_style (Jstr.v "border") (Jstr.v "solid 1px black") area; 52 | area 53 | 54 | let main () = 55 | let h1 = El.h1 [El.txt' "Mouse test"] in 56 | let info = El.txt' "Mouse and click in the area.  " in 57 | let area = area () in 58 | let m = Mouse.on_el ~propagate:true Mouse.pt area in 59 | let destroy = El.button [El.txt' "Destroy events"] in 60 | let destroy_click = Evr.on_el Ev.click Evr.unit destroy in 61 | let children = [h1; El.p [info; destroy]; area; mouse_viz m] in 62 | El.set_children (Document.body G.document) children; 63 | Logr.may_hold (E.log destroy_click (fun () -> Mouse.destroy m)) 64 | 65 | let () = main () 66 | -------------------------------------------------------------------------------- /test/test_mutobs.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | 8 | (* Testing the way we use mutation observers internally in Brr_note *) 9 | 10 | let log op in_html_dom node = 11 | if not (El.is_el node) then Console.(log [str "Not an element"]) else 12 | let star = Jv.of_string "*" in 13 | let descendents n = Jv.call (El.to_jv n) "querySelectorAll" [| star |] in 14 | Console.(group [str "[%s] id:%s in_html_dom: %s"; 15 | (Jstr.v op); (El.prop El.Prop.id node); in_html_dom]); 16 | Console.(log [(descendents node)]); 17 | Console.group_end (); 18 | () 19 | 20 | let () = 21 | (* Moral equivalent of what we do in Brr_note.Elr. 22 | Observe DOM additionals and removals *) 23 | let obs records _obs = 24 | let in_html_dom n = 25 | Jv.call (El.to_jv n) "getRootNode" [||] == Document.to_jv @@ G.document 26 | in 27 | for i = 0 to (Jv.Int.get records "length") - 1 do 28 | let r = Jv.Jarray.get records i in 29 | let adds = Jv.get r "addedNodes" in 30 | for i = 0 to (Jv.Int.get adds "length") - 1 do 31 | let n = El.of_jv @@ Jv.call adds "item" [|Jv.of_int i|] in 32 | log "add" (in_html_dom n) n 33 | done; 34 | let rems = Jv.get r "removedNodes" in 35 | for i = 0 to (Jv.Int.get rems "length") - 1 do 36 | let n = El.of_jv @@ Jv.call rems "item" [|Jv.of_int i|] in 37 | log "rem" (in_html_dom n) n 38 | done 39 | done 40 | in 41 | let mutation_observer = Jv.get Jv.global "MutationObserver" in 42 | let obs = Jv.new' mutation_observer [| Jv.callback ~arity:2 obs |] in 43 | let opts = Jv.obj [| "childList", Jv.true'; "subtree", Jv.true' |] in 44 | let root = El.to_jv (Document.root G.document) in 45 | ignore @@ Jv.call obs "observe" [| root; opts |] 46 | 47 | let el_id eid cs = El.div ~at:At.[id (Jstr.v eid)] cs 48 | let d0 = el_id "d0" [el_id "i0" [el_id "i00" []]; el_id "i1" [];] 49 | let d1 = el_id "d1" [] 50 | 51 | let main () = 52 | let async f = ignore (G.set_timeout f ~ms:0) in 53 | let body = Document.body G.document in 54 | async (fun () -> El.set_children body [d0]); 55 | async (fun () -> El.set_children body [d1]); 56 | async (fun () -> El.set_children d1 [el_id "i2" []]); 57 | async (fun () -> El.set_children body [d0]); 58 | async (fun () -> El.set_children body [d1];); 59 | () 60 | 61 | let () = main () 62 | -------------------------------------------------------------------------------- /test/todomvc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 7 | 8 | 391 | Brr TodoMVC 392 | 393 | 394 | 395 |
396 | 400 | 401 | 402 | -------------------------------------------------------------------------------- /test/todomvc.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 The note programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* The implementation respects the framework given at 7 | http://todomvc.com/. Notably the CSS file and markup 8 | structure. Some things could be implemented differently, organized 9 | in a more natural, modular and generic manner by lifting this 10 | restriction. 11 | 12 | The UX was also kept as defined by the backbone.js reference 13 | implementation -- but it's not always good. Here are a few things 14 | that could be improved: 15 | 16 | 1. The footer should not be placed at the bottom of the todo list. 17 | First this means you have to scroll if you have many 18 | todos. Second it moves away from your pointer when you click on 19 | a filter which is very annoying when you want to quickly switch 20 | between filters. 21 | 22 | 2. Operating on the data when filters are active is a bit 23 | confusing. For example adding a new todo when the filter is 24 | "Completed" should disable the filter otherwise the user has the 25 | feeling no new item is being added. Toggling completeness is 26 | equally confusing (though a bit of animation could do here). 27 | 28 | 3. The "toggle all" button look and behaviour is a bit confusing. *) 29 | 30 | open Brr 31 | open Brr_io 32 | open Note 33 | open Note_brr 34 | open Note_brr_kit 35 | 36 | (* Model *) 37 | 38 | module Todo : sig 39 | type t 40 | val v : Jstr.t -> t 41 | val task : t -> Jstr.t 42 | val done' : t -> bool 43 | val with_task : Jstr.t -> t -> t 44 | val with_done : bool -> t -> t 45 | val to_json : t -> Json.t 46 | val of_json : Json.t -> t 47 | end = struct 48 | type t = { task : Jstr.t; done' : bool } 49 | let v task = { task; done' = false } 50 | let task t = t.task 51 | let done' t = t.done' 52 | let with_task task t = { t with task } 53 | let with_done done' t = { t with done' } 54 | let to_json t = Jv.(obj [|"task", of_jstr t.task; "done", of_bool t.done' |]) 55 | let of_json j = { task = Jv.Jstr.get j "task"; done' = Jv.Bool.get j "done" } 56 | end 57 | 58 | module Todos : sig 59 | type t 60 | val empty : t 61 | val is_empty : t -> bool 62 | val to_list : t -> Todo.t list 63 | val count : t -> int 64 | val add : Todo.t -> t -> t 65 | val rem : Todo.t -> t -> t 66 | val replace : Todo.t -> by:Todo.t -> t -> t 67 | val map : (Todo.t -> Todo.t) -> t -> t 68 | val fold : (Todo.t -> 'a -> 'a) -> t -> 'a -> 'a 69 | val filter : (Todo.t -> bool) -> t -> t 70 | val for_all : (Todo.t -> bool) -> t -> bool 71 | val exists : (Todo.t -> bool) -> t -> bool 72 | val to_json : t -> Json.t 73 | val of_json : Json.t -> t 74 | end = struct 75 | type t = Todo.t list 76 | let empty = [] 77 | let is_empty ts = ts = empty 78 | let to_list ts = ts 79 | let count ts = List.length ts 80 | let update upd t ts = 81 | let upd t acc = match upd t with None -> acc | Some v -> (v :: acc) in 82 | let rec loop acc = function 83 | | [] -> List.rev acc 84 | | t' :: ts when t == t' -> List.rev_append (upd t acc) ts 85 | | t' :: ts -> loop (t' :: acc) ts 86 | in 87 | loop [] ts 88 | 89 | let add t ts = t :: ts 90 | let rem = update (fun _ -> None) 91 | let replace t ~by = update (fun _ -> Some by) t 92 | let map f ts = List.(rev @@ rev_map f ts) 93 | let fold f ts acc = List.fold_left (fun acc t -> f t acc) acc ts 94 | let filter sat = List.filter sat 95 | let for_all sat = List.for_all sat 96 | let exists sat = List.exists sat 97 | let to_json ts = Jv.of_list Todo.to_json ts 98 | let of_json j = Jv.to_list Todo.of_json j 99 | end 100 | 101 | (* Model actions *) 102 | 103 | type add_action = [ `Add_todo of Jstr.t ] 104 | type bulk_action = [ `All_done of bool | `Rem_done ] 105 | type edit_action = 106 | [ `Set_task of Jstr.t * Todo.t 107 | | `Set_done of bool * Todo.t 108 | | `Rem_todo of Todo.t ] 109 | 110 | type action = [ add_action | bulk_action | edit_action ] 111 | 112 | let do_action : action -> Todos.t -> Todos.t = function 113 | | `Add_todo task -> Todos.add (Todo.v task) 114 | | `Set_task (task, todo) -> Todos.replace todo ~by:(Todo.with_task task todo) 115 | | `Set_done (d, todo) -> Todos.replace todo ~by:(Todo.with_done d todo) 116 | | `Rem_todo todo -> Todos.rem todo 117 | | `All_done d -> Todos.map (Todo.with_done d) 118 | | `Rem_done -> Todos.filter (fun t -> not (Todo.done' t)) 119 | 120 | (* Persisting FIXME make that versioned (like the old Brr_note_legacy.Store) 121 | and easier. *) 122 | 123 | let state_key = Jstr.v "brr-todomvc-state" 124 | let save_state ts = 125 | let s = Storage.local G.window in 126 | (Storage.set_item s state_key (Json.encode (Todos.to_json ts))) 127 | |> Console.log_if_error ~use:() 128 | 129 | let load_state () = 130 | let s = Storage.local G.window in 131 | match Storage.get_item s state_key with 132 | | None -> Todos.empty 133 | | Some j -> 134 | (Result.map Todos.of_json (Json.decode j)) 135 | |> Console.log_if_error ~use:Todos.empty 136 | 137 | (* Rendering & interaction *) 138 | 139 | let el_def_display : El.t -> bool signal -> unit = 140 | (* Would maybe be better to do this via CSS classes *) 141 | let none = Jstr.v "none" and show = Jstr.empty in 142 | let bool_to_display = function true -> show | false -> none in 143 | fun el bool -> 144 | Elr.def_inline_style El.Style.display (S.map bool_to_display bool) el 145 | 146 | let add_todo : unit -> [> add_action] event * El.t = 147 | fun () -> 148 | let p = Jstr.v "What needs to be done ?" in 149 | let typ = At.type' (Jstr.v "text") in 150 | let at = At.[typ; class' (Jstr.v "new-todo"); autofocus; placeholder p] in 151 | let i = El.input ~at () in 152 | let keydown = Ev.keydown in 153 | let return = E.filter (Key.equal `Return) (Evr.on_el keydown Key.of_ev i) in 154 | let input = E.map (fun _ -> Jstr.trim @@ El.prop El.Prop.value i) return in 155 | let add_todo = input |> E.filter_map @@ fun v -> match Jstr.is_empty v with 156 | | true -> None 157 | | false -> Some (`Add_todo v) 158 | in 159 | let clear = E.stamp add_todo Jstr.empty in 160 | let () = Elr.set_prop El.Prop.value i ~on:clear in 161 | add_todo, i 162 | 163 | let toggle_all : set:bool signal -> [> bulk_action ] event * El.t = 164 | fun ~set -> 165 | let tid = Jstr.v "toggle-all" in 166 | let typ = At.type' (Jstr.v "checkbox") in 167 | let i = El.input ~at:At.[typ; class' tid; id tid] () in 168 | let () = Elr.def_prop El.Prop.checked set i in 169 | let click = Evr.on_el Ev.click Evr.unit i in 170 | let toggle = 171 | E.map (fun _ -> `All_done (El.prop El.Prop.checked i)) click 172 | in 173 | let label = [El.txt (Jstr.v "Mark all as complete")] in 174 | let label = El.label ~at:At.[for' tid] label in 175 | toggle, El.div [i; label] 176 | 177 | let items_left : count:int signal -> El.t = 178 | fun ~count -> 179 | let count_msg = function 180 | | 0 -> Jstr.v "0 items left" 181 | | 1 -> Jstr.v "1 item left" 182 | | n -> Jstr.(of_int n + v " items left") 183 | in 184 | let span = El.span ~at:At.[class' (Jstr.v "todo-count")] [] in 185 | let msg = S.map (fun c -> [El.txt (count_msg c)]) count in 186 | let () = Elr.def_children span msg in 187 | span 188 | 189 | type filter = [ `All | `Todo | `Done ] 190 | let filters : unit -> filter signal * El.t = 191 | fun () -> 192 | let fragment _ = Uri.fragment (Window.location G.window) in 193 | let hashchange = 194 | Evr.on_target Ev.hashchange fragment (Window.as_target G.window) 195 | in 196 | let parse_frag frag = match Jstr.to_string frag with 197 | | "/active" -> `Todo | "/completed" -> `Done | v -> `All 198 | in 199 | let init_filter = parse_frag (fragment ()) in 200 | let filter_li frag name = 201 | let a = El.(a ~at:At.[href Jstr.(v "#" + frag)] [El.txt (Jstr.v name)]) in 202 | let sel = parse_frag frag = init_filter in 203 | let selected = S.hold sel (E.map (Jstr.equal frag) hashchange) in 204 | let () = Elr.def_class (Jstr.v "selected") selected a in 205 | El.li [a] 206 | in 207 | let all = filter_li (Jstr.v "/") "All" in 208 | let todo = filter_li (Jstr.v "/active") "Active" in 209 | let done' = filter_li (Jstr.v "/completed") "Completed" in 210 | let filter = S.hold init_filter (E.map parse_frag hashchange) in 211 | filter, El.ul ~at:At.[class' (Jstr.v "filters")] [all; todo; done'] 212 | 213 | let string_editor : 214 | Jstr.t -> on:'a event -> bool event * Jstr.t event * El.t = 215 | fun s ~on -> 216 | let ed = El.input ~at:At.[class' (Jstr.v "edit"); value s] () in 217 | let keys = Evr.on_el Ev.keydown Key.of_ev ed in 218 | let edited = E.filter (Key.equal `Return) keys in 219 | let undo = E.filter (Key.equal `Escape) keys in 220 | let start_edit = E.stamp on true in 221 | let stop_edit = E.stamp (E.select [edited; undo]) false in 222 | let editing = E.select [start_edit; stop_edit] in 223 | let str = E.map (fun _ -> El.prop El.Prop.value ed) edited in 224 | let () = Elr.set_prop El.Prop.value ~on:(E.map (fun _ -> s) undo) ed in 225 | let () = Elr.set_has_focus ~on:start_edit ed in 226 | let () = Elr.call (fun _ e -> El.select_text e) ~on:start_edit ed in 227 | editing, str, ed 228 | 229 | let bool_editor : bool -> bool event * El.t = 230 | fun b -> 231 | let at = At.[type' (Jstr.v "checkbox"); class' (Jstr.v "toggle")] in 232 | let at = At.(if' b checked) :: at in 233 | let el = El.input ~at () in 234 | let click = Evr.on_el Ev.click Evr.unit el in 235 | let toggle = E.map (fun () -> El.prop El.Prop.checked el) click in 236 | toggle, el 237 | 238 | let todo_item : Todo.t -> [> edit_action ] event * El.t = 239 | fun todo -> 240 | let done' = Todo.done' todo in 241 | let task = Todo.task todo in 242 | let set_done, done_editor = bool_editor done' in 243 | let set_done = E.map (fun d -> `Set_done (d, todo)) set_done in 244 | let rem_but = El.button ~at:At.[class' (Jstr.v "destroy")] [] in 245 | let rem = Evr.on_el Ev.click (Evr.stamp (`Rem_todo todo)) rem_but in 246 | let label = El.label [El.txt task] in 247 | let editing, edited, ed = 248 | string_editor task ~on:(Evr.on_el Ev.dblclick Evr.unit label) 249 | in 250 | let edit = edited |> E.filter_map @@ fun v -> 251 | let v = Jstr.trim v in 252 | if Jstr.is_empty v then Some (`Rem_todo todo) else 253 | if not (Jstr.equal v task) then Some (`Set_task (v, todo)) else None 254 | in 255 | let div_at = At.[class' (Jstr.v "view")] in 256 | let div = El.div ~at:div_at [done_editor; label; rem_but] in 257 | let li_at = At.[if' done' (class' (Jstr.v "completed"))] in 258 | let li = El.li ~at:li_at [div; ed] in 259 | let () = Elr.set_class (Jstr.v "editing") ~on:editing li in 260 | E.select [edit; rem; set_done], li 261 | 262 | let todo_list : 263 | Todos.t signal -> filter:filter signal -> [> edit_action ] event * El.t = 264 | fun ts ~filter -> 265 | let add filter t (es, is as acc) = match filter with 266 | | `Todo when Todo.done' t -> acc 267 | | `Done when not (Todo.done' t) -> acc 268 | | _ -> let e, i = todo_item t in (e :: es, i :: is) 269 | in 270 | let add_todos ts filter = Todos.fold (add filter) ts ([], []) in 271 | let items = S.l2 ~eq:( == ) add_todos ts filter in 272 | let act = E.swap @@ S.map ~eq:( == ) (fun (evs, _) -> E.select evs) items in 273 | let items = S.map snd items in 274 | let ul = El.ul ~at:At.[class' (Jstr.v "todo-list")] [] in 275 | let () = Elr.def_children ul items in 276 | act, ul 277 | 278 | let header () = 279 | let add, field = add_todo () in 280 | let at = At.[class' (Jstr.v "header")] in 281 | add, El.header ~at [El.h1 [El.txt (Jstr.v "todos")]; field] 282 | 283 | let footer ~todos = 284 | let is_todo t = not (Todo.done' t) in 285 | let has_done = S.map (Todos.exists Todo.done') todos in 286 | let todo_left ts = List.(length @@ filter is_todo (Todos.to_list ts)) in 287 | let left_el = items_left ~count:(S.map todo_left todos) in 288 | let filter, fs_el = filters () in 289 | let rem_done, rem_el = 290 | let at = At.[class' (Jstr.v "clear-completed")] in 291 | let b = El.button ~at [El.txt (Jstr.v "Clear completed")] in 292 | let () = el_def_display b has_done in 293 | let rem_done = Evr.on_el Ev.click (Evr.stamp `Rem_done) b in 294 | rem_done, b 295 | in 296 | let at = At.[class' (Jstr.v "footer")] in 297 | let ft = El.footer ~at [left_el;fs_el;rem_el] in 298 | let display ts = not @@ Todos.is_empty ts in 299 | let () = el_def_display ft (S.map display todos) in 300 | filter, rem_done, ft 301 | 302 | let main ~add_todo ~rem_done ~todos ~filter = 303 | let toggle_set = todos |> S.map @@ fun ts -> 304 | Todos.(not (is_empty ts) && for_all Todo.done' ts) 305 | in 306 | let toggle_all, toggle_el = toggle_all ~set:toggle_set in 307 | let edit, items = todo_list todos ~filter in 308 | let at = At.[class' (Jstr.v "main")] in 309 | let sec = El.section ~at [toggle_el; items] in 310 | let display ts = not @@ Todos.is_empty ts in 311 | let () = el_def_display sec (S.map display todos) in 312 | E.select [add_todo; rem_done; edit; toggle_all], sec 313 | 314 | let ui : todos:Todos.t -> (Todos.t signal * El.t list) = 315 | fun ~todos -> 316 | let def todos = 317 | let add_todo, header = header () in 318 | let filter, rem_done, footer = footer ~todos in 319 | let action, main = main ~add_todo ~rem_done ~todos ~filter in 320 | let do_action = E.map do_action action in 321 | let todos' = S.accum (S.value todos) do_action in 322 | todos', (todos', [header; main; footer]) 323 | in 324 | S.fix todos def 325 | 326 | let main () = 327 | let id = Jstr.v "app" in 328 | match Document.find_el_by_id G.document id with 329 | | None -> Console.(error [str "No element with id '%s' found"; id]) 330 | | Some el -> 331 | let todos, children = ui ~todos:(load_state ()) in 332 | Logr.(hold @@ S.log todos save_state); 333 | El.set_children el children 334 | 335 | let () = main () 336 | --------------------------------------------------------------------------------