├── .gitignore ├── .merlin ├── B0.ml ├── BRZO ├── CHANGES.md ├── LICENSE.md ├── README.md ├── TODO.md ├── _tags ├── doc └── index.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── react.ml ├── react.mli ├── react.mllib ├── react_top.ml ├── react_top.mllib └── react_top_init.ml └── test ├── breakout.ml ├── clock.ml ├── js_hisig_test.html ├── js_hisig_test.ml ├── js_test.html ├── js_test.ml └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *.install -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit 2 | S src 3 | S test 4 | B _b0/** -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | 3 | (* OCaml library names *) 4 | 5 | let react = B0_ocaml.libname "react" 6 | let react_top = B0_ocaml.libname "react.top" 7 | 8 | let unix = B0_ocaml.libname "unix" 9 | let compiler_libs_toplevel = B0_ocaml.libname "compiler-libs.toplevel" 10 | 11 | (* Libraries *) 12 | 13 | let react_lib = 14 | let srcs = Fpath.[ `File (v "src/react.mli"); `File (v "src/react.ml") ] in 15 | let requires = [] in 16 | B0_ocaml.lib react ~doc:"The react library" ~srcs ~requires 17 | 18 | let react_top_lib = 19 | let srcs = Fpath.[ `File (v "src/react_top.ml") ] in 20 | let requires = [compiler_libs_toplevel] in 21 | let doc = "The react toplevel support library" in 22 | B0_ocaml.lib react_top ~doc ~srcs ~requires 23 | 24 | (* Tests *) 25 | 26 | let test_exe ?(requires = []) src ~doc = 27 | let src = Fpath.v src in 28 | let srcs = Fpath.[`File src] in 29 | let meta = B0_meta.(empty |> tag test) in 30 | let requires = react :: requires in 31 | B0_ocaml.exe (Fpath.basename ~strip_ext:true src) ~srcs ~doc ~meta ~requires 32 | 33 | let test = test_exe "test/test.ml" ~doc:"Test suite" 34 | let clock = 35 | test_exe "test/clock.ml" ~doc:"Reactive clock example" ~requires:[unix] 36 | 37 | let breakout = 38 | test_exe "test/breakout.ml" ~doc:"Breakout game example" ~requires:[unix] 39 | 40 | (* Packs *) 41 | 42 | let default = 43 | let meta = 44 | B0_meta.empty 45 | |> B0_meta.(add authors) ["The react programmers"] 46 | |> B0_meta.(add maintainers) 47 | ["Daniel Bünzli "] 48 | |> B0_meta.(add homepage) "https://erratique.ch/software/react" 49 | |> B0_meta.(add online_doc) "https://erratique.ch/software/react/doc/" 50 | |> B0_meta.(add licenses) ["ISC"] 51 | |> B0_meta.(add repo) "git+https://erratique.ch/repos/react.git" 52 | |> B0_meta.(add issues) "https://github.com/dbuenzli/react/issues" 53 | |> B0_meta.(add description_tags) 54 | ["reactive"; "declarative"; "signal"; "event"; "frp"; "org:erratique"] 55 | |> B0_meta.tag B0_opam.tag 56 | |> B0_meta.add B0_opam.depends 57 | [ "ocaml", {|>= "4.08.0"|}; 58 | "ocamlfind", {|build|}; 59 | "ocamlbuild", {|build|}; 60 | "topkg", {|build & >= "1.0.3"|}; 61 | ] 62 | |> B0_meta.add B0_opam.build 63 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]]|} 64 | in 65 | B0_pack.make "default" ~doc:"react package" ~meta ~locked:true @@ 66 | B0_unit.list () 67 | -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg) -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v1.2.2 2022-01-09 La Forclaz (VS) 2 | --------------------------------- 3 | 4 | - Require OCaml 4.08. 5 | - Handle deprecation of `Pervasives` (and thus support OCaml 5.00) 6 | 7 | v1.2.1 2017-03-16 La Forclaz (VS) 8 | --------------------------------- 9 | 10 | - Allow signals to be created and `S.stop`ped instantaneously (#18) 11 | Previously this could lead to failed assertions in updates (e.g. 12 | `S.bind` trying to switch to an uninitialized signal). Thanks 13 | to Arthur Wendling for the report. 14 | - Fix implementation of `S.Bool.flip`, its initial value on creation 15 | could be wrong in dynamic creation (#17). Thanks to Arthur Wendling 16 | for the report. 17 | - Fix bug in `S.Option.value` with `` `Always`` on `S.const None` (#19). 18 | Thanks to Arthur Wendling for the report. 19 | - Safe-string support. 20 | - Build depend on topkg. 21 | - Relicense from BSD3 to ISC 22 | 23 | v1.2.0 2014-08-24 Cambridge (UK) 24 | -------------------------------- 25 | 26 | - Fix bug in dynamic creation of `S.{diff,changes}` (#8). 27 | - Fix bug in dynamic creation of `S.switch` (#7). 28 | - Add support for toplevel: automatically `open React` on `#require "react"`. 29 | - Add `S.Bool.{flip,edge,fall,rise}`. 30 | 31 | v1.1.0 2014-04-27 La Forclaz (VS) 32 | --------------------------------- 33 | 34 | - Fix `S.switch` rank's initialisation. 35 | - Add `E.l{1,2,3,4,5,6}`, lifting combinators on events. 36 | - Add `E.Option.{some,value}`. 37 | - Add `S.{Float,Int}.{zero,one,minus_one}`. 38 | - Add `S.Bool.{zero,one}`. 39 | - Add `S.Option.{none,some,value}`. 40 | - Add `{S,E}.on` equivalent to `{S,E}.when_`. 41 | - Deprecate `{S,E}.when_` (syntax error prone). 42 | 43 | v1.0.1 2014-04-21 La Forclaz (VS) 44 | --------------------------------- 45 | 46 | - Fix `S.bind`. 47 | - Use package builder topkg for distribution. 48 | 49 | v1.0.0 2014-04-02 La Forclaz (VS) 50 | --------------------------------- 51 | 52 | - OPAM friendly workflow and drop OASIS support. 53 | - Add `S.bind`. 54 | 55 | The following changes are incompatible. 56 | 57 | - Add support for update steps, see the `React.Step` module. Allows to 58 | specify simultaneous primitive signal updates and event occurences. 59 | The functions returned by `{S,E}.create` now have an optional 60 | `?step` argument; if unused the previous semantics is preserved. 61 | - Add support for strong stops, can be used on platforms where weak 62 | arrays are not to prevent leaks. The function `{E,S}.stop` now have 63 | an optional `?strong` argument; if unused the previous semantics is 64 | preserved. 65 | - Change signature of `S.switch`. Any existing call `S.switch ~eq s es` can 66 | be replaced by `S.(switch ~eq (hold ~eq:( == ) s es))`. 67 | 68 | 69 | v0.9.4 2012-08-05 Lausanne 70 | -------------------------- 71 | 72 | - OASIS 0.3.0 support. 73 | 74 | 75 | v0.9.3 2012-03-17 La Forclaz (VS) 76 | --------------------------------- 77 | 78 | - OASIS support. 79 | 80 | 81 | v0.9.2 2010-04-25 Lausanne 82 | -------------------------- 83 | 84 | - Fix a bug in weak heap implementation (thanks to Jake Donham for reporting 85 | and a discussion about the fix). 86 | 87 | 88 | v0.9.1 2010-04-15 Paris 89 | ----------------------- 90 | 91 | - Added `E.retain` and `S.retain`. 92 | - A few `List.map` where replaced by `List.rev_map`. 93 | - Fixes to `breakout.ml` to make it work on vte based terminals. 94 | 95 | 96 | v0.9.0 2009-01-19 Lausanne 97 | -------------------------- 98 | 99 | - First release. 100 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 The react 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 | React — Declarative events and signals for OCaml 2 | ================================================ 3 | Release %%VERSION%% 4 | 5 | React is an OCaml module for functional reactive programming (FRP). It 6 | provides support to program with time varying values : declarative 7 | events and signals. React doesn't define any primitive event or 8 | signal, it lets the client chooses the concrete timeline. 9 | 10 | React is made of a single, independent, module and distributed under 11 | the ISC license. 12 | 13 | Homepage: 14 | 15 | # Installation 16 | 17 | React can be installed with `opam`: 18 | 19 | opam install react 20 | 21 | If you don't use `opam` consult the [`opam`](opam) file for build 22 | instructions. 23 | 24 | # Documentation 25 | 26 | The documentation and API reference is automatically generated by from 27 | the source interfaces. It can be consulted [online][doc] or via `odig 28 | doc react`. 29 | 30 | [doc]: http://erratique.ch/software/react/doc/ 31 | 32 | 33 | # Sample programs 34 | 35 | If you installed React with `opam` sample programs are located in 36 | the directory `opam var react:doc`. 37 | 38 | In the distribution sample programs are located in the `test` 39 | directory of the distribution. They can be built with: 40 | 41 | ocamlbuild -use-ocamlfind test/tests.otarget 42 | 43 | The resulting binaries are in `_build/test`. 44 | 45 | - `test.native` tests the library, nothing should fail. 46 | - `clock.native` is a command line program using ANSI escape sequences 47 | and the Unix module to print the current local time. 48 | - `breakout.native` is a command line program using ANSI escape sequences 49 | and the Unix module to implement a simple breakout game. 50 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # Exceptions 2 | 3 | * Make steps resistant to exceptions ? There's more than one solution here 4 | one is to discard the step and unschedule all nodes. Another would be 5 | to catch them an trap them like in Fut. 6 | 7 | 8 | # New event combinators 9 | 10 | * E.merge but only on simultanous occs ? 11 | * E.Bool.flip 12 | 13 | # Signal init. 14 | 15 | Instead of having bare values why not always have signals ? 16 | This would undermine the temptation of using S.value. 17 | 18 | # Stopped nodes 19 | 20 | Stopped nodes could be detected and considered as constant by 21 | smart constructors. 22 | 23 | # Multisample 24 | 25 | Current combinators are not good for sampling multiple signals, 26 | which is generally useful in conjunction with accum. TODO 27 | maybe not in fact see list selector. Just compute the as a signal. 28 | But maybe not always natural ? 29 | 30 | # Recursive defs 31 | 32 | Investigate the case when dynamics can replace signals with constants 33 | one which could make a direct dep on the delay noded (and hence 34 | raise). Doesn't seem possible but I suspect I saw this once. 35 | 36 | # New signal combinators. 37 | 38 | To avoid uses of S.value we need better ways to access a 39 | signal's current value and inject it in an efficient 40 | way in the graph. 41 | 42 | ```ocaml 43 | S.freeze : 'a signal -> 'a signal 44 | (** [freeze s]_{t} = [s]_{t'} where t' is freeze's creation time. *) 45 | ``` 46 | 47 | See if we can return a const and if what happens when used with 48 | bind and/or provide an alternative S.bind for bootstraping. 49 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | 3 | <_b0> : -traverse 4 | : include 5 | : package(compiler-libs.toplevel) 6 | 7 | : include 8 | : use_unix 9 | : use_unix 10 | : package(js_of_ocaml), package(js_of_ocaml-ppx) -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 React {%html: %%VERSION%%%}} 2 | 3 | React is an OCaml module for functional reactive programming (FRP). It 4 | provides support to program with time varying values : declarative 5 | events and signals. React doesn't define any primitive event or 6 | signal, it lets the client chooses the concrete timeline. 7 | 8 | {!modules: React } 9 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "react" 3 | synopsis: "Declarative events and signals for OCaml" 4 | description: """\ 5 | Release %%VERSION%% 6 | 7 | React is an OCaml module for functional reactive programming (FRP). It 8 | provides support to program with time varying values : declarative 9 | events and signals. React doesn't define any primitive event or 10 | signal, it lets the client chooses the concrete timeline. 11 | 12 | React is made of a single, independent, module and distributed under 13 | the ISC license. 14 | 15 | Homepage: """ 16 | maintainer: "Daniel Bünzli " 17 | authors: "The react programmers" 18 | license: "ISC" 19 | tags: ["reactive" "declarative" "signal" "event" "frp" "org:erratique"] 20 | homepage: "https://erratique.ch/software/react" 21 | doc: "https://erratique.ch/software/react/doc/" 22 | bug-reports: "https://github.com/dbuenzli/react/issues" 23 | depends: [ 24 | "ocaml" {>= "4.08.0"} 25 | "ocamlfind" {build} 26 | "ocamlbuild" {build} 27 | "topkg" {build & >= "1.0.3"} 28 | ] 29 | build: ["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"] 30 | dev-repo: "git+https://erratique.ch/repos/react.git" 31 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | version = "%%VERSION_NUM%%" 2 | description = "Declarative events and signals for OCaml" 3 | requires = "" 4 | archive(byte) = "react.cma" 5 | archive(native) = "react.cmxa" 6 | plugin(byte) = "react.cma" 7 | plugin(native) = "react.cmxs" 8 | 9 | package "top" ( 10 | version = "%%VERSION_NUM%%" 11 | description = "React toplevel support" 12 | requires = "react" 13 | archive(byte) = "react_top.cma" 14 | archive(native) = "react_top.cmxa" 15 | plugin(byte) = "react_top.cma" 16 | plugin(native) = "react_top.cmxs" 17 | exists_if = "react_top.cma" 18 | ) 19 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let jsoo_test ~cond test = 7 | Pkg.flatten 8 | [ Pkg.test ~run:false ~cond ~auto:false (test ^ ".js"); 9 | Pkg.test ~run:false ~cond ~auto:false (test ^ ".html"); ] 10 | 11 | let () = 12 | Pkg.describe "react" @@ fun c -> 13 | Ok [ Pkg.mllib "src/react.mllib"; 14 | Pkg.mllib ~api:[] "src/react_top.mllib"; 15 | Pkg.lib "src/react_top_init.ml"; 16 | Pkg.test ~run:false "test/breakout"; 17 | Pkg.test ~run:false "test/clock"; 18 | Pkg.test "test/test"; 19 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 20 | (* jsoo_test ~cond:jsoo "test/js_hisig_test"; 21 | jsoo_test ~cond:jsoo "test/js_test"; *) 22 | ] 23 | -------------------------------------------------------------------------------- /src/react.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2009 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let err_max_rank = "maximal rank exceeded" 7 | let err_sig_undef = "signal value undefined yet" 8 | let err_fix = "trying to fix a delayed value" 9 | let err_retain_never = "E.never cannot retain a closure" 10 | let err_retain_cst_sig = "constant signals cannot retain a closure" 11 | let err_step_executed = "step already executed" 12 | let err_event_scheduled = "event already scheduled on a step" 13 | let err_signal_scheduled = "signal already scheduled on a step" 14 | 15 | module Wa = struct 16 | type 'a t = { mutable arr : 'a Weak.t; mutable len : int } 17 | (* The type for resizeable weak arrays. 18 | 19 | For now the arrays only grow. We could try to compact and 20 | downsize the array in scan_add if a threshold of empty slots is 21 | exceeded. *) 22 | 23 | let create size = { arr = Weak.create size; len = 0 } 24 | let length a = a.len 25 | let is_empty a = 26 | try 27 | for i = 0 to a.len - 1 do 28 | if Weak.check a.arr i then raise Exit; 29 | done; 30 | true 31 | with Exit -> false 32 | 33 | let clear a = a.arr <- Weak.create 0; a.len <- 0 34 | let get a i = Weak.get a.arr i 35 | let set a i = Weak.set a.arr i 36 | let swap a i i' = 37 | let v = Weak.get a.arr i' in 38 | Weak.blit a.arr i a.arr i' 1; (* blit prevents i from becoming live. *) 39 | Weak.set a.arr i v 40 | 41 | let grow a = 42 | let arr' = Weak.create (2 * (a.len + 1)) in 43 | Weak.blit a.arr 0 arr' 0 a.len; 44 | a.arr <- arr' 45 | 46 | let add a v = (* adds v at the end of a. *) 47 | if a.len = Weak.length a.arr then grow a; 48 | Weak.set a.arr a.len (Some v); 49 | a.len <- a.len + 1 50 | 51 | let scan_add a v = (* adds v to a, tries to find an empty slot, O(a.len). *) 52 | try 53 | for i = 0 to a.len - 1 do 54 | match Weak.get a.arr i with 55 | | None -> Weak.set a.arr i (Some v); raise Exit | Some _ -> () 56 | done; 57 | add a v 58 | with Exit -> () 59 | 60 | let rem_last a = let l = a.len - 1 in (a.len <- l; Weak.set a.arr l None) 61 | let rem a v = (* removes v from a, uses physical equality, O(a.len). *) 62 | try 63 | for i = 0 to a.len - 1 do 64 | match Weak.get a.arr i with 65 | | Some v' when v == v' -> Weak.set a.arr i None; raise Exit 66 | | _ -> () 67 | done 68 | with Exit -> () 69 | 70 | let iter f a = 71 | for i = 0 to a.len - 1 do 72 | match Weak.get a.arr i with Some v -> f v | None -> () 73 | done 74 | 75 | let fold f acc a = 76 | let acc = ref acc in 77 | for i = 0 to a.len - 1 do 78 | match Weak.get a.arr i with Some v -> acc := f !acc v | None -> () 79 | done; 80 | !acc 81 | end 82 | 83 | type node = 84 | { mutable rank : int; (* its rank (height) in the dataflow graph. *) 85 | mutable stamp : step; (* last step in which it was scheduled. *) 86 | mutable retain : unit -> unit; (* retained by the node, NEVER invoked. *) 87 | mutable producers : unit -> node list; (* nodes on which it depends. *) 88 | mutable update : step -> unit; (* update closure. *) 89 | deps : node Wa.t } (* weak references to dependent nodes. *) 90 | (* The type for nodes. 91 | 92 | Each event and (non-constant) signal has an associated node. The 93 | fields producers and update keep, in their closure environment, 94 | references to mutables (see later) on which the node depends. 95 | Defining their contents via a let rec allows the environment to be 96 | shared by the two closures. 97 | 98 | There are special nodes to represent infinitesimally delayed nodes 99 | (needed for recursive definitions). These nodes all have a rank of 100 | Node.delayed_rank and depend only on the node they delay. Since 101 | they have the highest rank possible they are updated only at the 102 | end of the step and treated specially at that point (see 103 | Step.execute). *) 104 | 105 | and step = 106 | { mutable over : bool; (* true when the step is over. *) 107 | mutable heap : heap; (* min-heap of nodes sorted by rank. *) 108 | mutable eops : (unit -> unit) list; (* end of step operations. *) 109 | mutable cops : (unit -> unit) list } (* cleanup step operations. *) 110 | (* The type for update steps. 111 | 112 | Note for historical reasons we use the variable names [c] and [c'] 113 | in the code for representing update steps. 114 | 115 | There are four successive phases in the execution of a step c (see 116 | Step.execute). 117 | 118 | 1. Nodes are updated in topological order until c.heap is empty or 119 | we reach a delayed node. 120 | 121 | 2. End of step operations are executed. This may add new 122 | dependencies (see S.diff and S.changes) and clear the occurence 123 | of delayed events from a previous step (but used in this 124 | step). 125 | 126 | 3. If there are delayed nodes in c.heap, we create a new step 127 | c'. Each delayed node is updated and its dependents are put in 128 | c'.heap. For delayed events, an end of step operation is added 129 | in c' to clear the occurence at step 2 of c'. Delayed nodes are 130 | updated in any order as a delayed node updating in a step 131 | cannot depend on a delayed node updating in the same step. 132 | 133 | 4. Cleanup operations are executed. This clears the event occurences of 134 | non-delayed event that occured in c. 135 | 136 | After this, if a step c' was created in 3. the step gets executed. *) 137 | 138 | and heap = node Wa.t 139 | (* The type for heaps. 140 | 141 | Weak min-heaps of nodes sorted according to their rank. Classic 142 | imperative implementation with a twist to accomodate the fact 143 | that nodes may disappear. 144 | 145 | The heap property we maintain is that for any node its descendents 146 | (vs. children) are either of no smaller rank or they are None. None 147 | nodes need to be treated specially in percolate up and down. The 148 | reason is that it blocks information about the rank of their 149 | descendents. In percolate down the solution is to systematically 150 | swap with None children. So do we in percolate up, however, in 151 | that case we may violate the property if we swap with a None node 152 | and stop right after (either because we got the root or we found a 153 | parent of smaller rank), the property can however be reestablished 154 | by percolating down from that point. *) 155 | 156 | type 'a emut = 157 | { ev : 'a option ref; (* during steps, holds a potential occurence. *) 158 | enode : node; } (* associated node. *) 159 | 160 | type 'a event = Never | Emut of 'a emut 161 | (* The type for events. 162 | 163 | An event is either the never occuring event Never or a mutable 164 | Emut. A mutable m has some value in m.v iff a step is being 165 | executed and m has an occurence in the step. m's dependents are 166 | scheduled for update iff m has a value in m.v. 167 | 168 | Mutables that occur in a step are set back to None when the step 169 | terminates with an cleanup step operation (see eupdate and 170 | Step.execute). To avoid a weak reference on m in the cleanup 171 | operation, the field m.v is a field on a reference instead of a 172 | mutable field. 173 | 174 | A new node n can be made dependent on a an event mutable m during a 175 | step. But when n is added to m's dependents, m may already have 176 | updated and scheduled its dependents. In that case n also need to 177 | be scheduled (see E.add_dep). If m only occurs later in the step, 178 | the n will be scheduled as usual with the others. *) 179 | 180 | type 'a smut = 181 | { mutable sv : 'a option; (* signal value (None only temporary). *) 182 | eq : 'a -> 'a -> bool; (* to detect signal value changes. *) 183 | snode : node } (* associated node. *) 184 | 185 | type 'a signal = Const of 'a | Smut of 'a smut 186 | (* The type for signals. 187 | 188 | A signal is either a constant signal Const or a mutable Smut. A 189 | mutable m has a value in m.v iff m.v initialized. m's dependents 190 | are scheduled for update iff m is initialized and m.v changed 191 | according to m.eq in the step. 192 | 193 | Signal initialization occurs as follows. If we have an init. value 194 | we set the signal's value to this value and then : 195 | 196 | 1. If the creation occurs outside a step, the signal's update 197 | function is invoked with Step.nil. This may overwrite the 198 | init. value, but no dependent will see this change as there 199 | cannot be any at that time. 200 | 201 | 2. If the creation occurs inside a step, the signal is scheduled 202 | for update. Here again this may overwrite the init. value. If 203 | the new value is equal to the init. value this will not schedule 204 | the signals' dependents. However this is not a problem since 205 | dependents are either new signals and will be scheduled via the 206 | init. process or a new dependency added by S.switch in which 207 | case this dependent is also be scheduled. 208 | 209 | Note that in both cases if we had no init. value, the call to the 210 | update function must unconditionaly write a concrete value for the 211 | signal. 212 | 213 | To find out whether the creation occurs in a step we walk back the 214 | signal's producers recursively looking for a node stamp with an 215 | unfinished step (see Step.find_unfinished). This is not in favor 216 | of static signal creation but this is the price we have to pay for 217 | not having global data structures. 218 | 219 | A new node n can be made dependent on a signal mutable m during a 220 | step. In contrast to events (see above) nothing special has to be 221 | done. Here's the rationale : 222 | 223 | 1. If n is the node of a new event then either the event cannot 224 | happen in the same step and thus the depency addition occurs at 225 | the end of the step (S.diff, S.changes) or the event cares only 226 | about having an up to date value if some other event occurs 227 | (S.sample, E.on) in the same step and the rank of n ensures 228 | this. 229 | 230 | 2. If n is the node of a new signal then n cares only about having 231 | m's up to date values whenever n will initialize and the rank of 232 | n ensures this. *) 233 | 234 | module H = struct 235 | let size = Wa.length 236 | let els h = Wa.fold (fun acc e -> e :: acc) [] h (* no particular order. *) 237 | let compare_down h i i' = match Wa.get h i, Wa.get h i' with 238 | | Some n, Some n' -> compare n.rank n'.rank 239 | | Some _, None -> 1 (* None is smaller than anything. *) 240 | | None, Some _ -> -1 (* None is smaller than anything. *) 241 | | None, None -> 0 242 | 243 | let rec down h i = 244 | let last = size h - 1 in 245 | let start = 2 * i in 246 | let l = start + 1 in (* left child index. *) 247 | let r = start + 2 in (* right child index. *) 248 | if l > last then () (* no child, stop *) else 249 | let child = (* index of smallest child. *) 250 | if r > last then l else (if compare_down h l r < 0 then l else r) 251 | in 252 | if compare_down h i child > 0 then (Wa.swap h i child; down h child) 253 | 254 | let up h i = 255 | let rec aux h i last_none = 256 | if i = 0 then (if last_none then down h 0) else 257 | let p = (i - 1) / 2 in (* parent index. *) 258 | match Wa.get h i, Wa.get h p with 259 | | Some n, Some n' -> 260 | if compare n.rank n'.rank < 0 then (Wa.swap h i p; aux h p false) else 261 | (if last_none then down h i) 262 | | Some _, None -> 263 | Wa.swap h i p; aux h p true 264 | | None, _ -> () 265 | in 266 | aux h i false 267 | 268 | let rebuild h = for i = (size h - 2) / 2 downto 0 do down h i done 269 | let add h n = Wa.add h n; up h (size h - 1) 270 | let rec take h = 271 | let s = size h in 272 | if s = 0 then None else 273 | let v = Wa.get h 0 in 274 | begin 275 | if s > 1 276 | then (Wa.set h 0 (Wa.get h (s - 1)); Wa.rem_last h; down h 0) 277 | else Wa.rem_last h 278 | end; 279 | match v with None -> take h | v -> v 280 | end 281 | 282 | let delayed_rank = max_int 283 | 284 | module Step = struct (* Update steps. *) 285 | type t = step 286 | let nil = { over = true; heap = Wa.create 0; eops = []; cops = []} 287 | 288 | let create () = 289 | let h = Wa.create 11 in 290 | { over = false; heap = h; eops = []; cops = []} 291 | 292 | let add c n = if n.stamp == c then () else (n.stamp <- c; H.add c.heap n) 293 | let add_deps c n = Wa.iter (add c) n.deps 294 | let add_eop c op = c.eops <- op :: c.eops 295 | let add_cop c op = c.cops <- op :: c.cops 296 | let allow_reschedule n = n.stamp <- nil 297 | let rebuild c = H.rebuild c.heap 298 | 299 | let rec execute c = 300 | let eops c = List.iter (fun op -> op ()) c.eops; c.eops <- [] in 301 | let cops c = List.iter (fun op -> op ()) c.cops; c.cops <- [] in 302 | let finish c = c.over <- true; c.heap <- Wa.create 0 in 303 | let rec update c = match H.take c.heap with 304 | | Some n when n.rank <> delayed_rank -> n.update c; update c 305 | | Some n -> 306 | let c' = create () in 307 | eops c; List.iter (fun n -> n.update c') (n :: H.els c.heap); cops c; 308 | finish c; 309 | execute c' 310 | | None -> eops c; cops c; finish c 311 | in 312 | update c 313 | 314 | let execute c = if c.over then invalid_arg err_step_executed else execute c 315 | 316 | 317 | let find_unfinished nl = (* find unfinished step in recursive producers. *) 318 | let rec aux next = function (* zig-zag breadth-first search. *) 319 | | [] -> if next = [] then nil else aux [] next 320 | | [] :: todo -> aux next todo 321 | | nl :: todo -> find next todo nl 322 | and find next todo = function 323 | | [] -> aux next todo 324 | | n :: nl -> 325 | if not n.stamp.over then n.stamp else 326 | find (n.producers () :: next) todo nl 327 | in 328 | aux [] [ nl ] 329 | end 330 | 331 | module Node = struct 332 | let delayed_rank = delayed_rank 333 | let min_rank = min_int 334 | let max_rank = delayed_rank - 1 335 | 336 | let nop _ = () 337 | let no_producers () = [] 338 | let create r = 339 | { rank = r; stamp = Step.nil; update = nop; retain = nop; 340 | producers = no_producers; deps = Wa.create 0 } 341 | 342 | let rem_dep n n' = Wa.rem n.deps n' 343 | let add_dep n n' = Wa.scan_add n.deps n' 344 | let has_dep n = not (Wa.is_empty n.deps) 345 | let deps n = Wa.fold (fun acc d -> d :: acc) [] n.deps 346 | 347 | let bind n p u = n.producers <- p; n.update <- u 348 | let stop ?(strong = false) n = 349 | if not strong then begin 350 | n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; 351 | end else begin 352 | let rec loop next to_rem = function 353 | | [] -> 354 | begin match next with 355 | | (to_rem, prods) :: next -> loop next to_rem prods 356 | | [] -> () 357 | end 358 | | n :: todo -> 359 | rem_dep n to_rem; (* N.B. rem_dep could be combined with has_dep *) 360 | if n.rank = min_rank (* is a primitive *) || has_dep n 361 | then loop next to_rem todo else 362 | begin 363 | let prods = n.producers () in 364 | n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; 365 | loop ((n, prods) :: next) to_rem todo 366 | end 367 | in 368 | let producers = n.producers () in 369 | n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; 370 | loop [] n producers 371 | end 372 | 373 | let set_rank n r = n.rank <- r 374 | let rmin = create min_rank 375 | let rmax n n' = if n.rank > n'.rank then n else n' 376 | let rsucc n = 377 | if n.rank = delayed_rank then min_rank else 378 | if n.rank < max_rank then n.rank + 1 else invalid_arg err_max_rank 379 | 380 | let rsucc2 n n' = 381 | let r = rsucc n in 382 | let r' = rsucc n' in 383 | if r > r' then r else r' 384 | 385 | (* Rank updates currently only increases ranks. If this is problematic 386 | udpate ranks orthodoxly by taking the succ of the max of n.producers. 387 | Note that rank update stops at delayed nodes (otherwise we would 388 | loop and blow the ranks). *) 389 | let update_rank n r = (* returns true iff n's rank increased. *) 390 | let rec aux = function 391 | | [] -> () 392 | | n :: todo -> 393 | let update todo d = 394 | if n.rank < d.rank || n.rank = delayed_rank then todo else 395 | (d.rank <- rsucc n; d :: todo) 396 | in 397 | aux (Wa.fold update todo n.deps) 398 | in 399 | if r > n.rank then (n.rank <- r; aux [ n ]; true) else false 400 | end 401 | 402 | (* Shortcuts *) 403 | 404 | let rsucc = Node.rsucc 405 | let rsucc2 = Node.rsucc2 406 | let rmax = Node.rmax 407 | 408 | (* Event value, creation and update *) 409 | 410 | let eval m = match !(m.ev) with Some v -> v | None -> assert false 411 | let emut rank = { ev = ref None; enode = Node.create rank } 412 | let event m p u = Node.bind m.enode p u; Emut m 413 | let eupdate v m c = 414 | let clear v () = v := None in 415 | m.ev := Some v; 416 | Step.add_cop c (clear m.ev); 417 | Step.add_deps c m.enode 418 | 419 | (* Signal value, creation and update *) 420 | 421 | let sval m = match m.sv with Some v -> v | None -> assert false 422 | let smut rank eq = { sv = None; eq = eq; snode = Node.create rank } 423 | let signal ?i m p u = 424 | Node.bind m.snode p u; 425 | begin match i with Some _ as v -> m.sv <- v | None -> () end; 426 | begin match Step.find_unfinished (m.snode.producers ()) with 427 | | c when c == Step.nil -> m.snode.update Step.nil 428 | | c -> Step.add c m.snode 429 | end; 430 | Smut m 431 | 432 | let supdate v m c = match m.sv with 433 | | Some v' when (m.eq v v') -> () 434 | | Some _ -> m.sv <- Some v; if c != Step.nil then Step.add_deps c m.snode 435 | | None -> m.sv <- Some v (* init. without init value. *) 436 | 437 | module E = struct 438 | type 'a t = 'a event 439 | 440 | let add_dep m n = 441 | Node.add_dep m.enode n; 442 | if !(m.ev) <> None then Step.add m.enode.stamp n 443 | 444 | let send m ?step v = match step with (* sends an event occurence. *) 445 | | Some c -> 446 | if c.over then invalid_arg err_step_executed else 447 | if not m.enode.stamp.over then invalid_arg err_event_scheduled else 448 | m.enode.stamp <- c; 449 | eupdate v m c 450 | | None -> 451 | let c = Step.create () in 452 | m.enode.stamp <- c; 453 | eupdate v m c; 454 | Step.execute c 455 | 456 | (* Basics *) 457 | 458 | let never = Never 459 | let create () = 460 | let m = emut Node.min_rank in 461 | Emut m, send m 462 | 463 | let retain e c = match e with 464 | | Never -> invalid_arg err_retain_never 465 | | Emut m -> let c' = m.enode.retain in (m.enode.retain <- c); (`R c') 466 | 467 | let stop ?strong = function Never -> () | Emut m -> Node.stop ?strong m.enode 468 | let equal e e' = match e, e' with 469 | | Never, Never -> true 470 | | Never, _ | _, Never -> false 471 | | Emut m, Emut m' -> m == m' 472 | 473 | let trace ?(iff = Const true) t e = match iff with 474 | | Const false -> e 475 | | Const true -> 476 | begin match e with 477 | | Never -> e 478 | | Emut m -> 479 | let m' = emut (rsucc m.enode) in 480 | let rec p () = [ m.enode ] 481 | and u c = let v = eval m in t v; eupdate v m' c in 482 | add_dep m m'.enode; 483 | event m' p u 484 | end 485 | | Smut mc -> 486 | match e with 487 | | Never -> Never 488 | | Emut m -> 489 | let m' = emut (rsucc2 mc.snode m.enode) in 490 | let rec p () = [mc.snode; m.enode] 491 | and u c = match !(m.ev) with 492 | | None -> () (* mc updated. *) 493 | | Some v -> if (sval mc) then t v; eupdate v m' c 494 | in 495 | Node.add_dep mc.snode m'.enode; 496 | add_dep m m'.enode; 497 | event m' p u 498 | 499 | (* Transforming and filtering *) 500 | 501 | let once = function 502 | | Never -> Never 503 | | Emut m -> 504 | let m' = emut (rsucc m.enode) in 505 | let rec p () = [ m.enode ] 506 | and u c = 507 | Node.rem_dep m.enode m'.enode; 508 | eupdate (eval m) m' c; 509 | Node.stop m'.enode 510 | in 511 | add_dep m m'.enode; 512 | event m' p u 513 | 514 | let drop_once = function 515 | | Never -> Never 516 | | Emut m -> 517 | let m' = emut (rsucc m.enode) in 518 | let rec p () = [ m.enode ] 519 | and u c = (* first update. *) 520 | let u' c = eupdate (eval m) m' c in (* subsequent updates. *) 521 | Node.bind m'.enode p u' 522 | in 523 | add_dep m m'.enode; 524 | event m' p u 525 | 526 | let app ef = function 527 | | Never -> Never 528 | | Emut m -> 529 | match ef with 530 | | Never -> Never 531 | | Emut mf -> 532 | let m' = emut (rsucc2 m.enode mf.enode) in 533 | let rec p () = [ m.enode; mf.enode ] 534 | and u c = match !(mf.ev), !(m.ev) with 535 | | None, _ | _, None -> () 536 | | Some f, Some v -> eupdate (f v) m' c 537 | in 538 | add_dep m m'.enode; 539 | add_dep mf m'.enode; 540 | event m' p u 541 | 542 | let map f = function 543 | | Never -> Never 544 | | Emut m -> 545 | let m' = emut (rsucc m.enode) in 546 | let rec p () = [ m.enode ] 547 | and u c = eupdate (f (eval m)) m' c in 548 | add_dep m m'.enode; 549 | event m' p u 550 | 551 | let stamp e v = match e with 552 | | Never -> Never 553 | | Emut m -> 554 | let m' = emut (rsucc m.enode) in 555 | let rec p () = [ m.enode ] 556 | and u c = eupdate v m' c in 557 | add_dep m m'.enode; 558 | event m' p u 559 | 560 | let filter pred = function 561 | | Never -> Never 562 | | Emut m -> 563 | let m' = emut (rsucc m.enode) in 564 | let rec p () = [ m.enode ] 565 | and u c = let v = eval m in if pred v then eupdate v m' c else () in 566 | add_dep m m'.enode; 567 | event m' p u 568 | 569 | let fmap fm = function 570 | | Never -> Never 571 | | Emut m -> 572 | let m' = emut (rsucc m.enode) in 573 | let rec p () = [ m.enode ] 574 | and u c = match fm (eval m) with Some v -> eupdate v m' c | None -> () 575 | in 576 | add_dep m m'.enode; 577 | event m' p u 578 | 579 | let diff d = function 580 | | Never -> Never 581 | | Emut m -> 582 | let m' = emut (rsucc m.enode) in 583 | let last = ref None in 584 | let rec p () = [ m.enode ] 585 | and u c = 586 | let v = eval m in 587 | match !last with 588 | | None -> last := Some v 589 | | Some v' -> last := Some v; eupdate (d v v') m' c 590 | in 591 | add_dep m m'.enode; 592 | event m' p u 593 | 594 | let changes ?(eq = ( = )) = function 595 | | Never -> Never 596 | | Emut m -> 597 | let m' = emut (rsucc m.enode) in 598 | let last = ref None in 599 | let rec p () = [ m.enode ] 600 | and u c = 601 | let v = eval m in 602 | match !last with 603 | | None -> last := Some v; eupdate v m' c 604 | | Some v' -> last := Some v; if eq v v' then () else eupdate v m' c 605 | in 606 | add_dep m m'.enode; 607 | event m' p u 608 | 609 | let on c = function 610 | | Never -> Never 611 | | Emut m as e -> 612 | match c with 613 | | Const true -> e 614 | | Const false -> Never 615 | | Smut mc -> 616 | let m' = emut (rsucc2 m.enode mc.snode) in 617 | let rec p () = [ m.enode; mc.snode ] 618 | and u c = match !(m.ev) with 619 | | None -> () (* mc updated. *) 620 | | Some _ -> if (sval mc) then eupdate (eval m) m' c else () 621 | in 622 | add_dep m m'.enode; 623 | Node.add_dep mc.snode m'.enode; 624 | event m' p u 625 | 626 | let when_ = on 627 | 628 | let dismiss c = function 629 | | Never -> Never 630 | | Emut m as e -> 631 | match c with 632 | | Never -> e 633 | | Emut mc -> 634 | let m' = emut (rsucc2 mc.enode m.enode) in 635 | let rec p () = [ mc.enode; m.enode ] 636 | and u c = match !(mc.ev) with 637 | | Some _ -> () 638 | | None -> eupdate (eval m) m' c 639 | in 640 | add_dep mc m'.enode; 641 | add_dep m m'.enode; 642 | event m' p u 643 | 644 | let until c = function 645 | | Never -> Never 646 | | Emut m as e -> 647 | match c with 648 | | Never -> e 649 | | Emut mc -> 650 | let m' = emut (rsucc2 m.enode mc.enode) in 651 | let rec p () = [ m.enode; mc.enode] in 652 | let u c = match !(mc.ev) with 653 | | None -> eupdate (eval m) m' c 654 | | Some _ -> 655 | Node.rem_dep m.enode m'.enode; 656 | Node.rem_dep mc.enode m'.enode; 657 | Node.stop m'.enode 658 | in 659 | add_dep m m'.enode; 660 | add_dep mc m'.enode; 661 | event m' p u 662 | 663 | (* Accumulating *) 664 | 665 | let accum ef i = match ef with 666 | | Never -> Never 667 | | Emut m -> 668 | let m' = emut (rsucc m.enode) in 669 | let acc = ref i in 670 | let rec p () = [ m.enode ] 671 | and u c = acc := (eval m) !acc; eupdate !acc m' c in 672 | add_dep m m'.enode; 673 | event m' p u 674 | 675 | let fold f i = function 676 | | Never -> Never 677 | | Emut m -> 678 | let m' = emut (rsucc m.enode) in 679 | let acc = ref i in 680 | let rec p () = [ m.enode ] 681 | and u c = acc := f !acc (eval m); eupdate !acc m' c in 682 | add_dep m m'.enode; 683 | event m' p u 684 | 685 | (* Combining *) 686 | 687 | let occurs m = !(m.ev) <> None 688 | let find_muts_and_next_rank el = 689 | let rec aux acc max = function 690 | | [] -> List.rev acc, rsucc max 691 | | (Emut m) :: l -> aux (m :: acc) (rmax max m.enode) l 692 | | Never :: l -> aux acc max l 693 | in 694 | aux [] Node.rmin el 695 | 696 | let select el = 697 | let emuts, r = find_muts_and_next_rank el in 698 | let m' = emut r in 699 | let rec p () = List.rev_map (fun m -> m.enode) emuts 700 | and u c = try eupdate (eval (List.find occurs emuts)) m' c with 701 | | Not_found -> assert false 702 | in 703 | List.iter (fun m -> add_dep m m'.enode) emuts; 704 | event m' p u 705 | 706 | let merge f a el = 707 | let rec fold f acc = function 708 | | m :: l when occurs m -> fold f (f acc (eval m)) l 709 | | m :: l -> fold f acc l 710 | | [] -> acc 711 | in 712 | let emuts, r = find_muts_and_next_rank el in 713 | let m' = emut r in 714 | let rec p () = List.rev_map (fun m -> m.enode) emuts 715 | and u c = eupdate (fold f a emuts) m' c in 716 | List.iter (fun m -> add_dep m m'.enode) emuts; 717 | event m' p u 718 | 719 | let switch e = function 720 | | Never -> e 721 | | Emut ms -> 722 | let r = match e with 723 | | Emut m -> rsucc2 m.enode ms.enode | Never -> rsucc ms.enode 724 | in 725 | let m' = emut r in 726 | let src = ref e in (* current event source. *) 727 | let rec p () = match !src with 728 | | Emut m -> [ m.enode; ms.enode ] | Never -> [ ms.enode ] 729 | and u c = match !(ms.ev) with 730 | | None -> (match !src with (* only src occurs. *) 731 | | Emut m -> eupdate (eval m) m' c | Never -> assert false) 732 | | Some e -> 733 | begin match !src with 734 | | Emut m -> Node.rem_dep m.enode m'.enode | Never -> () 735 | end; 736 | src := e; 737 | match e with 738 | | Never -> ignore (Node.update_rank m'.enode (rsucc ms.enode)) 739 | | Emut m -> 740 | Node.add_dep m.enode m'.enode; 741 | if Node.update_rank m'.enode (rsucc2 m.enode ms.enode) then 742 | begin 743 | (* Rank increased because of m. Thus m may stil 744 | update and we may be rescheduled. If it happens 745 | we'll be in the other branch without any harm 746 | but some redundant computation. *) 747 | Step.allow_reschedule m'.enode; 748 | Step.rebuild c; 749 | end 750 | else 751 | (* No rank increase, m already updated if needed. *) 752 | (match !(m.ev) with Some v -> eupdate v m' c | None -> ()) 753 | in 754 | (match e with Emut m -> add_dep m m'.enode | Never -> ()); 755 | add_dep ms m'.enode; 756 | event m' p u 757 | 758 | let fix f = 759 | let m = emut Node.delayed_rank in 760 | let e = event m (fun () -> []) (fun _ -> assert false) in 761 | match f e with 762 | | Never, r -> r 763 | | Emut m', r -> 764 | if m'.enode.rank = Node.delayed_rank then invalid_arg err_fix; 765 | let rec p () = [ (* avoid cyclic dep. *) ] 766 | and u c = (* N.B. c is the next step. *) 767 | let clear v () = v := None in 768 | m.ev := Some (eval m'); 769 | Step.add_eop c (clear m.ev); (* vs. add_cop for regular events. *) 770 | Step.add_deps c m.enode 771 | in 772 | Node.bind m.enode p u; 773 | add_dep m' m.enode; 774 | r 775 | 776 | (* Lifting *) 777 | 778 | let l1 = map 779 | let l2 f e0 e1 = match e0, e1 with 780 | | Never, _ -> Never 781 | | _, Never -> Never 782 | | Emut m0, Emut m1 -> 783 | let r = rsucc2 m0.enode m1.enode in 784 | let m' = emut r in 785 | let rec p () = [ m0.enode; m1.enode ] in 786 | let u c = match !(m0.ev), !(m1.ev) with 787 | | None, _ 788 | | _, None -> () 789 | | Some v0, Some v1 -> eupdate (f v0 v1) m' c 790 | in 791 | add_dep m0 m'.enode; 792 | add_dep m1 m'.enode; 793 | event m' p u 794 | 795 | let l3 f e0 e1 e2 = match e0, e1, e2 with 796 | | Never, _, _ -> Never 797 | | _, Never, _ -> Never 798 | | _, _, Never -> Never 799 | | Emut m0, Emut m1, Emut m2 -> 800 | let r = rsucc (rmax (rmax m0.enode m1.enode) m2.enode) in 801 | let m' = emut r in 802 | let rec p () = [ m0.enode; m1.enode; m2.enode ] in 803 | let u c = match !(m0.ev), !(m1.ev), !(m2.ev) with 804 | | None, _, _ 805 | | _, None, _ 806 | | _, _, None -> () 807 | | Some v0, Some v1, Some v2 -> eupdate (f v0 v1 v2) m' c 808 | in 809 | add_dep m0 m'.enode; 810 | add_dep m1 m'.enode; 811 | add_dep m2 m'.enode; 812 | event m' p u 813 | 814 | 815 | let l4 f e0 e1 e2 e3 = match e0, e1, e2, e3 with 816 | | Never, _, _, _ -> Never 817 | | _, Never, _, _ -> Never 818 | | _, _, Never, _ -> Never 819 | | _, _, _, Never -> Never 820 | | Emut m0, Emut m1, Emut m2, Emut m3 -> 821 | let r = rsucc (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) in 822 | let m' = emut r in 823 | let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode ] in 824 | let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev) with 825 | | None, _, _, _ 826 | | _, None, _, _ 827 | | _, _, None, _ 828 | | _, _, _, None -> () 829 | | Some v0, Some v1, Some v2, Some v3 -> eupdate (f v0 v1 v2 v3) m' c 830 | in 831 | add_dep m0 m'.enode; 832 | add_dep m1 m'.enode; 833 | add_dep m2 m'.enode; 834 | add_dep m3 m'.enode; 835 | event m' p u 836 | 837 | let l5 f e0 e1 e2 e3 e4 = match e0, e1, e2, e3, e4 with 838 | | Never, _, _, _, _ -> Never 839 | | _, Never, _, _, _ -> Never 840 | | _, _, Never, _, _ -> Never 841 | | _, _, _, Never, _ -> Never 842 | | _, _, _, _, Never -> Never 843 | | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4 -> 844 | let r = 845 | rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) 846 | m4.enode) 847 | in 848 | let m' = emut r in 849 | let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode ] in 850 | let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev) with 851 | | None, _, _, _, _ 852 | | _, None, _, _, _ 853 | | _, _, None, _, _ 854 | | _, _, _, None, _ 855 | | _, _, _, _, None -> () 856 | | Some v0, Some v1, Some v2, Some v3, Some v4 -> 857 | eupdate (f v0 v1 v2 v3 v4) m' c 858 | in 859 | add_dep m0 m'.enode; 860 | add_dep m1 m'.enode; 861 | add_dep m2 m'.enode; 862 | add_dep m3 m'.enode; 863 | add_dep m4 m'.enode; 864 | event m' p u 865 | 866 | let l6 f e0 e1 e2 e3 e4 e5 = match e0, e1, e2, e3, e4, e5 with 867 | | Never, _, _, _, _, _ -> Never 868 | | _, Never, _, _, _, _ -> Never 869 | | _, _, Never, _, _, _ -> Never 870 | | _, _, _, Never, _, _ -> Never 871 | | _, _, _, _, Never, _ -> Never 872 | | _, _, _, _, _, Never -> Never 873 | | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4, Emut m5 -> 874 | let r = 875 | rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) 876 | (rmax m4.enode m5.enode)) 877 | in 878 | let m' = emut r in 879 | let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode; 880 | m5.enode; ] in 881 | let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev), 882 | !(m5.ev) with 883 | | None, _, _, _, _, _ 884 | | _, None, _, _, _, _ 885 | | _, _, None, _, _, _ 886 | | _, _, _, None, _, _ 887 | | _, _, _, _, None, _ 888 | | _, _, _, _, _, None -> () 889 | | Some v0, Some v1, Some v2, Some v3, Some v4, Some v5 -> 890 | eupdate (f v0 v1 v2 v3 v4 v5) m' c 891 | in 892 | add_dep m0 m'.enode; 893 | add_dep m1 m'.enode; 894 | add_dep m2 m'.enode; 895 | add_dep m3 m'.enode; 896 | add_dep m4 m'.enode; 897 | add_dep m5 m'.enode; 898 | event m' p u 899 | 900 | (* Stdlib support *) 901 | 902 | module Option = struct 903 | let some e = map (fun v -> Some v) e 904 | let value ?default e = match default with 905 | | None -> fmap (fun v -> v) e 906 | | Some (Const dv) -> map (function None -> dv | Some v -> v) e 907 | | Some (Smut ms) -> 908 | match e with 909 | | Never -> Never 910 | | Emut m -> 911 | let m' = emut (rsucc2 m.enode ms.snode) in 912 | let rec p () = [ m.enode; ms.snode ] 913 | and u c = match !(m.ev) with 914 | | None -> () (* ms updated. *) 915 | | Some None -> eupdate (sval ms) m' c 916 | | Some Some v -> eupdate v m' c 917 | in 918 | add_dep m m'.enode; 919 | Node.add_dep ms.snode m'.enode; 920 | event m' p u 921 | end 922 | end 923 | 924 | module S = struct 925 | type 'a t = 'a signal 926 | 927 | let set_sval v m c = m.sv <- Some v; Step.add_deps c m.snode 928 | let set m ?step v = (* starts an update step. *) 929 | if m.eq (sval m) v then () else 930 | match step with 931 | | Some c -> 932 | if c.over then invalid_arg err_step_executed else 933 | if not m.snode.stamp.over then invalid_arg err_signal_scheduled else 934 | m.snode.stamp <- c; 935 | m.sv <- Some v; 936 | Step.add_deps c m.snode 937 | | None -> 938 | let c = Step.create () in 939 | m.snode.stamp <- c; 940 | m.sv <- Some v; 941 | Step.add_deps c m.snode; 942 | Step.execute c 943 | 944 | let end_of_step_add_dep ?(post_add_op = fun () -> ()) ~stop_if_stopped m m' = 945 | (* In some combinators, when the semantics of event m' is such 946 | that it should not occur in the (potential) step it is created, 947 | we add the dependency [m'] to signal [m] only via an end of 948 | step operation to avoid being scheduled in the step. *) 949 | match Step.find_unfinished (m.snode.producers ()) with 950 | | c when c == Step.nil -> 951 | Node.add_dep m.snode m'.enode; 952 | post_add_op (); 953 | | c -> 954 | let add_dep () = 955 | if m.snode.update == Node.nop then 956 | (* m stopped in step *) 957 | (if stop_if_stopped then Node.stop m'.enode) 958 | else 959 | begin 960 | ignore (Node.update_rank m'.enode (rsucc m.snode)); 961 | Node.add_dep m.snode m'.enode; 962 | post_add_op (); 963 | end 964 | in 965 | Step.add_eop c add_dep 966 | 967 | (* Basics *) 968 | 969 | let const v = Const v 970 | let create ?(eq = ( = )) v = 971 | let m = smut Node.min_rank eq in 972 | m.sv <- Some v; 973 | Smut m, set m 974 | 975 | let retain s c = match s with 976 | | Const _ -> invalid_arg err_retain_cst_sig 977 | | Smut m -> let c' = m.snode.retain in m.snode.retain <- c; (`R c') 978 | 979 | let eq_fun = function Const _ -> None | Smut m -> Some m.eq 980 | 981 | let value = function 982 | | Const v | Smut { sv = Some v } -> v 983 | | Smut { sv = None } -> failwith err_sig_undef 984 | 985 | let stop ?strong = function 986 | | Const _ -> () 987 | | Smut m -> 988 | match m.sv with 989 | | Some _ -> Node.stop ?strong m.snode 990 | | None -> 991 | (* The signal was dynamically created and didn't update yet. Add the 992 | stop as an end of step operation. *) 993 | match Step.find_unfinished (m.snode.producers ()) with 994 | | c when c == Step.nil -> assert false 995 | | c -> 996 | let stop () = Node.stop ?strong m.snode in 997 | Step.add_eop c stop 998 | 999 | let equal ?(eq = ( = )) s s' = match s, s' with 1000 | | Const v, Const v' -> eq v v' 1001 | | Const _, _ | _, Const _ -> false 1002 | | Smut m, Smut m' -> m == m' 1003 | 1004 | let trace ?(iff = const true) t s = match iff with 1005 | | Const false -> s 1006 | | Const true -> 1007 | begin match s with 1008 | | Const v -> t v; s 1009 | | Smut m -> 1010 | let m' = smut (rsucc m.snode) m.eq in 1011 | let rec p () = [ m.snode ] in 1012 | let u c = let v = sval m in t v; supdate v m' c in 1013 | Node.add_dep m.snode m'.snode; 1014 | signal m' p u 1015 | end 1016 | | Smut mc -> 1017 | match s with 1018 | | Const v -> 1019 | let m' = smut (rsucc mc.snode) ( = ) (* we don't care about eq *) in 1020 | let rec p () = [ mc.snode ] 1021 | and u c = 1022 | if (sval mc) then t v; 1023 | Node.rem_dep mc.snode m'.snode; 1024 | Node.stop m'.snode; 1025 | in 1026 | Node.add_dep mc.snode m'.snode; 1027 | signal ~i:v m' p u 1028 | | Smut m -> 1029 | let m' = smut (rsucc2 mc.snode m.snode) m.eq in 1030 | let rec p () = [ mc.snode; m.snode ] 1031 | and u c = 1032 | let v = sval m in 1033 | match m'.sv with 1034 | | Some v' when m'.eq v v' -> () (* mc updated. *) 1035 | | _ -> if (sval mc) then t v; supdate v m' c (* init or diff. *) 1036 | in 1037 | Node.add_dep mc.snode m'.snode; 1038 | Node.add_dep m.snode m'.snode; 1039 | signal m' p u 1040 | 1041 | (* From events *) 1042 | 1043 | let hold ?(eq = ( = )) i = function 1044 | | Never -> Const i 1045 | | Emut m -> 1046 | let m' = smut (rsucc m.enode) eq in 1047 | let rec p () = [ m.enode ] 1048 | and u c = match !(m.ev) with 1049 | | None -> () (* init. only. *) 1050 | | Some v -> supdate v m' c 1051 | in 1052 | E.add_dep m m'.snode; 1053 | signal ~i m' p u 1054 | 1055 | (* Filtering and transforming *) 1056 | 1057 | let map ?(eq = ( = )) f = function 1058 | | Const v -> Const (f v) 1059 | | Smut m -> 1060 | let m' = smut (rsucc m.snode) eq in 1061 | let rec p () = [ m.snode ] 1062 | and u c = supdate (f (sval m)) m' c in 1063 | Node.add_dep m.snode m'.snode; 1064 | signal m' p u 1065 | 1066 | let app ?(eq = ( = )) sf sv = match sf, sv with 1067 | | Smut mf, Smut mv -> 1068 | let m' = smut (rsucc2 mf.snode mv.snode) eq in 1069 | let rec p () = [ mf.snode; mv.snode ] 1070 | and u c = supdate ((sval mf) (sval mv)) m' c in 1071 | Node.add_dep mf.snode m'.snode; 1072 | Node.add_dep mv.snode m'.snode; 1073 | signal m' p u 1074 | | Const f, Const v -> Const (f v) 1075 | | Const f, sv -> map ~eq f sv 1076 | | Smut mf, Const v -> 1077 | let m' = smut (rsucc mf.snode) eq in 1078 | let rec p () = [ mf.snode ] 1079 | and u c = supdate ((sval mf) v) m' c in 1080 | Node.add_dep mf.snode m'.snode; 1081 | signal m' p u 1082 | 1083 | let filter ?(eq = ( = )) pred i = function 1084 | | Const v as s -> if pred v then s else Const i 1085 | | Smut m -> 1086 | let m' = smut (rsucc m.snode) eq in 1087 | let rec p () = [ m.snode ] 1088 | and u c = let v = sval m in if pred v then supdate v m' c else () in 1089 | Node.add_dep m.snode m'.snode; 1090 | signal ~i m' p u 1091 | 1092 | let fmap ?(eq = ( = )) fm i = function 1093 | | Const v -> (match fm v with Some v' -> Const v' | None -> Const i) 1094 | | Smut m -> 1095 | let m' = smut (rsucc m.snode) eq in 1096 | let rec p () = [ m.snode ] 1097 | and u c = match fm (sval m) with Some v -> supdate v m' c | None -> () 1098 | in 1099 | Node.add_dep m.snode m'.snode; 1100 | signal ~i m' p u 1101 | 1102 | let diff d = function 1103 | | Const _ -> Never 1104 | | Smut m -> 1105 | let m' = emut (rsucc m.snode) in 1106 | let last = ref None in 1107 | let rec p () = [ m.snode ] 1108 | and u c = 1109 | let v = sval m in 1110 | match !last with 1111 | | Some v' -> last := Some v; eupdate (d v v') m' c 1112 | | None -> assert false 1113 | in 1114 | let post_add_op () = last := Some (sval m) in 1115 | end_of_step_add_dep ~post_add_op ~stop_if_stopped:true m m'; 1116 | event m' p u 1117 | 1118 | let changes = function 1119 | | Const _ -> Never 1120 | | Smut m -> 1121 | let m' = emut (rsucc m.snode) in 1122 | let rec p () = [ m.snode ] 1123 | and u c = eupdate (sval m) m' c in 1124 | end_of_step_add_dep ~stop_if_stopped:true m m'; 1125 | event m' p u 1126 | 1127 | let sample f e = function 1128 | | Const v -> E.map (fun ev -> f ev v) e 1129 | | Smut ms -> 1130 | match e with 1131 | | Never -> Never 1132 | | Emut me -> 1133 | let m' = emut (rsucc2 me.enode ms.snode) in 1134 | let rec p () = [ me.enode; ms.snode ] 1135 | and u c = match !(me.ev) with 1136 | | None -> () (* ms updated *) 1137 | | Some v -> eupdate (f v (sval ms)) m' c 1138 | in 1139 | E.add_dep me m'.enode; 1140 | Node.add_dep ms.snode m'.enode; 1141 | event m' p u 1142 | 1143 | let on ?(eq = ( = )) c i s = match c with 1144 | | Const true -> s 1145 | | Const false -> Const i 1146 | | Smut mc -> 1147 | match s with 1148 | | Const v -> 1149 | let m' = smut (rsucc mc.snode) eq in 1150 | let rec p () = [ mc.snode ] 1151 | and u c = if (sval mc) then supdate v m' c else () in 1152 | Node.add_dep mc.snode m'.snode; 1153 | signal ~i m' p u 1154 | | Smut ms -> 1155 | let m' = smut (rsucc2 mc.snode ms.snode) eq in 1156 | let rec p () = [ mc.snode; ms.snode ] 1157 | and u c = if (sval mc) then supdate (sval ms) m' c else () in 1158 | Node.add_dep mc.snode m'.snode; 1159 | Node.add_dep ms.snode m'.snode; 1160 | signal ~i m' p u 1161 | 1162 | let when_ = on 1163 | 1164 | let dismiss ?(eq = ( = )) c i s = match c with 1165 | | Never -> s 1166 | | Emut mc -> 1167 | match s with 1168 | | Const v -> 1169 | let m' = smut (rsucc mc.enode) eq in 1170 | let rec p () = [ mc.enode ] 1171 | and u c = match !(mc.ev) with 1172 | | Some _ -> () | None -> supdate v m' c 1173 | in 1174 | Node.add_dep mc.enode m'.snode; 1175 | signal ~i m' p u 1176 | | Smut ms -> 1177 | let m' = smut (rsucc2 mc.enode ms.snode) eq in 1178 | let rec p () = [ mc.enode; ms.snode ] 1179 | and u c = match !(mc.ev) with 1180 | | Some _ -> () | None -> supdate (sval ms) m' c 1181 | in 1182 | Node.add_dep mc.enode m'.snode; 1183 | Node.add_dep ms.snode m'.snode; 1184 | signal ~i m' p u 1185 | 1186 | (* Accumulating *) 1187 | 1188 | let accum ?(eq = ( = )) ef i = match ef with 1189 | | Never -> Const i 1190 | | Emut m -> 1191 | let m' = smut (rsucc m.enode) eq in 1192 | let rec p () = [ m.enode ] 1193 | and u c = match !(m.ev) with 1194 | | None -> () (* init only. *) 1195 | | Some v -> supdate (v (sval m')) m' c 1196 | in 1197 | E.add_dep m m'.snode; 1198 | signal ~i m' p u 1199 | 1200 | let fold ?(eq = ( = )) f i = function 1201 | | Never -> Const i 1202 | | Emut m -> 1203 | let m' = smut (rsucc m.enode) eq in 1204 | let rec p () = [ m.enode ] 1205 | and u c = match !(m.ev) with 1206 | | None -> () (* init only. *) 1207 | | Some v -> supdate (f (sval m') v) m' c in 1208 | E.add_dep m m'.snode; 1209 | signal ~i m' p u 1210 | 1211 | (* Combining *) 1212 | 1213 | let merge ?(eq = ( = )) f a sl = 1214 | let rmax' acc = function Const _ -> acc | Smut m -> rmax acc m.snode in 1215 | let nodes acc = function Const _ -> acc | Smut m -> m.snode :: acc in 1216 | let merger f a = function Const v -> f a v | Smut m -> f a (sval m) in 1217 | let m' = smut (rsucc (List.fold_left rmax' Node.rmin sl)) eq in 1218 | let rec p () = List.fold_left nodes [] sl 1219 | and u c = supdate (List.fold_left (merger f) a sl) m' c in 1220 | let dep = function Const _ -> ()| Smut m -> Node.add_dep m.snode m'.snode in 1221 | List.iter dep sl; 1222 | signal m' p u 1223 | 1224 | let switch ?(eq = ( = )) = function 1225 | | Const s -> s 1226 | | Smut mss -> 1227 | let dummy = smut Node.min_rank eq in 1228 | let src = ref (Smut dummy) in (* dummy is overwritten by sig. init *) 1229 | let m' = smut (rsucc mss.snode) eq in 1230 | let rec p () = match !src with 1231 | | Smut m -> [ mss.snode; m.snode] | Const _ -> [ mss.snode ] 1232 | and u c = 1233 | if (sval mss) == !src then (* ss didn't change, !src did *) 1234 | begin match !src with 1235 | | Smut m -> supdate (sval m) m' c 1236 | | Const _ -> () (* init only. *) 1237 | end 1238 | else (* ss changed *) 1239 | begin 1240 | begin match !src with 1241 | | Smut m -> Node.rem_dep m.snode m'.snode 1242 | | Const _ -> () 1243 | end; 1244 | let new_src = sval mss in 1245 | src := new_src; 1246 | match new_src with 1247 | | Const v -> 1248 | ignore (Node.update_rank m'.snode (rsucc mss.snode)); 1249 | supdate v m' c 1250 | | Smut m -> 1251 | Node.add_dep m.snode m'.snode; 1252 | if c == Step.nil then 1253 | begin 1254 | ignore (Node.update_rank m'.snode 1255 | (rsucc2 m.snode mss.snode)); 1256 | (* Check if the init src is in a step. *) 1257 | match Step.find_unfinished [m.snode] with 1258 | | c when c == Step.nil -> supdate (sval m) m' c 1259 | | c -> Step.add c m'.snode 1260 | end 1261 | else 1262 | if Node.update_rank m'.snode (rsucc2 m.snode mss.snode) then 1263 | begin 1264 | (* Rank increased because of m. Thus m may still 1265 | update and we need to reschedule. Next time we 1266 | will be in the other branch. *) 1267 | Step.allow_reschedule m'.snode; 1268 | Step.rebuild c; 1269 | Step.add c m'.snode 1270 | end 1271 | else 1272 | (* No rank increase. m already updated if needed, no need 1273 | to reschedule and rebuild the queue. *) 1274 | supdate (sval m) m' c 1275 | end 1276 | in 1277 | Node.add_dep mss.snode m'.snode; 1278 | (* We add a dep to dummy to avoid a long scan of Wa.rem when we remove 1279 | the dep in the [u] function during static init. *) 1280 | Node.add_dep dummy.snode m'.snode; 1281 | signal m' p u 1282 | 1283 | let bind ?eq s sf = switch ?eq (map ~eq:( == ) sf s) 1284 | 1285 | let fix ?(eq = ( = )) i f = 1286 | let update_delayed n p u nl = 1287 | Node.bind n p u; 1288 | match Step.find_unfinished nl with 1289 | | c when c == Step.nil -> 1290 | (* no pertinent occuring step, create a step for update. *) 1291 | let c = Step.create () in 1292 | n.update c; 1293 | Step.execute c 1294 | | c -> Step.add c n 1295 | in 1296 | let m = smut Node.delayed_rank eq in 1297 | let s = signal ~i m (fun () -> []) (fun _ -> ()) in 1298 | match f s with 1299 | | Const v, r -> 1300 | let rec p () = [] 1301 | and u c = supdate v m c in 1302 | update_delayed m.snode p u (Node.deps m.snode); 1303 | r 1304 | | Smut m', r -> 1305 | if m'.snode.rank = Node.delayed_rank then invalid_arg err_fix; 1306 | let rec p () = [ (* avoid cyclic dep. *) ] 1307 | and u c = supdate (sval m') m c in (* N.B. c is the next step. *) 1308 | Node.add_dep m'.snode m.snode; 1309 | update_delayed m.snode p u (m'.snode :: Node.deps m.snode); 1310 | r 1311 | 1312 | (* Lifting *) 1313 | 1314 | let l1 = map 1315 | let l2 ?(eq = ( = )) f s s' = match s, s' with 1316 | | Smut m0, Smut m1 -> 1317 | let m' = smut (rsucc2 m0.snode m1.snode) eq in 1318 | let rec p () = [ m0.snode; m1.snode ] 1319 | and u c = supdate (f (sval m0) (sval m1)) m' c in 1320 | Node.add_dep m0.snode m'.snode; 1321 | Node.add_dep m1.snode m'.snode; 1322 | signal m' p u 1323 | | Const v, Const v' -> Const (f v v') 1324 | | Const v, Smut m -> 1325 | let m' = smut (rsucc m.snode) eq in 1326 | let rec p () = [ m.snode ] 1327 | and u c = supdate (f v (sval m)) m' c in 1328 | Node.add_dep m.snode m'.snode; 1329 | signal m' p u 1330 | | Smut m, Const v -> 1331 | let m' = smut (rsucc m.snode) eq in 1332 | let rec p () = [ m.snode ] 1333 | and u c = supdate (f (sval m) v) m' c in 1334 | Node.add_dep m.snode m'.snode; 1335 | signal m' p u 1336 | 1337 | let l3 ?(eq = ( = )) f s0 s1 s2 = match s0, s1, s2 with 1338 | | Smut m0, Smut m1, Smut m2 -> 1339 | let r = rsucc (rmax (rmax m0.snode m1.snode) m2.snode) in 1340 | let m' = smut r eq in 1341 | let rec p () = [ m0.snode; m1.snode; m2.snode ] 1342 | and u c = supdate (f (sval m0) (sval m1) (sval m2)) m' c in 1343 | Node.add_dep m0.snode m'.snode; 1344 | Node.add_dep m1.snode m'.snode; 1345 | Node.add_dep m2.snode m'.snode; 1346 | signal m' p u 1347 | | Const v0, Const v1, Const v2 -> Const (f v0 v1 v2) 1348 | | s0, s1, s2 -> app ~eq (l2 ~eq:( == ) f s0 s1) s2 1349 | 1350 | let l4 ?(eq = ( = )) f s0 s1 s2 s3 = match s0, s1, s2, s3 with 1351 | | Smut m0, Smut m1, Smut m2, Smut m3 -> 1352 | let r = rsucc (rmax (rmax m0.snode m1.snode) (rmax m2.snode m3.snode)) in 1353 | let m' = smut r eq in 1354 | let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode ] 1355 | and u c = supdate (f (sval m0) (sval m1) (sval m2) (sval m3)) m' c in 1356 | Node.add_dep m0.snode m'.snode; 1357 | Node.add_dep m1.snode m'.snode; 1358 | Node.add_dep m2.snode m'.snode; 1359 | Node.add_dep m3.snode m'.snode; 1360 | signal m' p u 1361 | | Const v0, Const v1, Const v2, Const v3 -> Const (f v0 v1 v2 v3) 1362 | | s0, s1, s2, s3 -> app ~eq (l3 ~eq:( == ) f s0 s1 s2) s3 1363 | 1364 | let l5 ?(eq = ( = )) f s0 s1 s2 s3 s4 = match s0, s1, s2, s3, s4 with 1365 | | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4 -> 1366 | let m = rmax in 1367 | let r = rsucc (m (m m0.snode m1.snode) 1368 | (m m2.snode (m m3.snode m4.snode))) 1369 | in 1370 | let m' = smut r eq in 1371 | let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode ] 1372 | and u c = 1373 | let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) in 1374 | supdate v m' c 1375 | in 1376 | Node.add_dep m0.snode m'.snode; 1377 | Node.add_dep m1.snode m'.snode; 1378 | Node.add_dep m2.snode m'.snode; 1379 | Node.add_dep m3.snode m'.snode; 1380 | Node.add_dep m4.snode m'.snode; 1381 | signal m' p u 1382 | | Const v0, Const v1, Const v2, Const v3, Const v4 -> Const (f v0 v1 v2 v3 v4) 1383 | | s0, s1, s2, s3, s4 -> app ~eq (l4 ~eq:( == ) f s0 s1 s2 s3) s4 1384 | 1385 | let l6 ?(eq = ( = )) f s0 s1 s2 s3 s4 s5 = match s0, s1, s2, s3, s4, s5 with 1386 | | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4, Smut m5 -> 1387 | let m = rmax in 1388 | let m = m (m m0.snode (m m1.snode m2.snode)) 1389 | (m m3.snode (m m4.snode m5.snode)) 1390 | in 1391 | let m' = smut (rsucc m) eq in 1392 | let rec p () = 1393 | [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode; m5.snode ] 1394 | and u c = 1395 | let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) (sval m5) in 1396 | supdate v m' c 1397 | in 1398 | Node.add_dep m0.snode m'.snode; 1399 | Node.add_dep m1.snode m'.snode; 1400 | Node.add_dep m2.snode m'.snode; 1401 | Node.add_dep m3.snode m'.snode; 1402 | Node.add_dep m4.snode m'.snode; 1403 | Node.add_dep m5.snode m'.snode; 1404 | signal m' p u 1405 | | Const v0, Const v1, Const v2, Const v3, Const v4, Const v5-> 1406 | Const (f v0 v1 v2 v3 v4 v5) 1407 | | s0, s1, s2, s3, s4, s5 -> app ~eq (l5 ~eq:( == ) f s0 s1 s2 s3 s4) s5 1408 | 1409 | module Bool = struct 1410 | let stdlib_not = not 1411 | let one = Const true 1412 | let zero = Const false 1413 | let eq : bool -> bool -> bool = ( = ) 1414 | let not s = l1 ~eq stdlib_not s 1415 | let ( && ) s s' = l2 ~eq ( && ) s s' 1416 | let ( || ) s s' = l2 ~eq ( || ) s s' 1417 | 1418 | let edge s = changes s 1419 | let edge_detect edge = function 1420 | | Const _ -> Never 1421 | | Smut m -> 1422 | let m' = emut (rsucc m.snode) in 1423 | let rec p () = [ m.snode ] 1424 | and u c = if (sval m) = edge then eupdate () m' c in 1425 | end_of_step_add_dep ~stop_if_stopped:true m m'; 1426 | event m' p u 1427 | 1428 | let rise s = edge_detect true s 1429 | let fall s = edge_detect false s 1430 | let flip b = function 1431 | | Never -> Const b 1432 | | Emut m -> 1433 | let m' = smut (rsucc m.enode) ( = ) in 1434 | let rec p () = [ m.enode ] 1435 | and u c = match !(m.ev) with 1436 | | None -> () 1437 | | Some _ -> supdate (stdlib_not (sval m')) m' c 1438 | in 1439 | E.add_dep m m'.snode; 1440 | signal ~i:b m' p u 1441 | end 1442 | 1443 | module Int = struct 1444 | let zero = Const 0 1445 | let one = Const 1 1446 | let minus_one = Const (-1) 1447 | let eq : int -> int -> bool = ( = ) 1448 | let ( ~- ) s = l1 ~eq ( ~- ) s 1449 | let succ s = l1 ~eq succ s 1450 | let pred s = l1 ~eq pred s 1451 | let ( + ) s s' = l2 ~eq ( + ) s s' 1452 | let ( - ) s s' = l2 ~eq ( - ) s s' 1453 | let ( * ) s s' = l2 ~eq ( * ) s s' 1454 | let ( mod ) s s' = l2 ~eq ( mod ) s s' 1455 | let abs s = l1 ~eq abs s 1456 | let max_int = const max_int 1457 | let min_int = const min_int 1458 | let ( land ) s s' = l2 ~eq ( land ) s s' 1459 | let ( lor ) s s' = l2 ~eq ( lor ) s s' 1460 | let ( lxor ) s s' = l2 ~eq ( lxor ) s s' 1461 | let lnot s = l1 ~eq lnot s 1462 | let ( lsl ) s s' = l2 ~eq ( lsl ) s s' 1463 | let ( lsr ) s s' = l2 ~eq ( lsr ) s s' 1464 | let ( asr ) s s' = l2 ~eq ( asr ) s s' 1465 | end 1466 | 1467 | module Float = struct 1468 | let zero = Const 0. 1469 | let one = Const 1. 1470 | let minus_one = Const (-1.) 1471 | let eq : float -> float -> bool = ( = ) 1472 | let ( ~-. ) s = l1 ~eq ( ~-. ) s 1473 | let ( +. ) s s' = l2 ~eq ( +. ) s s' 1474 | let ( -. ) s s' = l2 ~eq ( -. ) s s' 1475 | let ( *. ) s s' = l2 ~eq ( *. ) s s' 1476 | let ( /. ) s s' = l2 ~eq ( /. ) s s' 1477 | let ( ** ) s s' = l2 ~eq ( ** ) s s' 1478 | let sqrt s = l1 ~eq sqrt s 1479 | let exp s = l1 ~eq exp s 1480 | let log s = l1 ~eq log s 1481 | let log10 s = l1 ~eq log10 s 1482 | let cos s = l1 ~eq cos s 1483 | let sin s = l1 ~eq sin s 1484 | let tan s = l1 ~eq tan s 1485 | let acos s = l1 ~eq acos s 1486 | let asin s = l1 ~eq asin s 1487 | let atan s = l1 ~eq atan s 1488 | let atan2 s s' = l2 ~eq atan2 s s' 1489 | let cosh s = l1 ~eq cosh s 1490 | let sinh s = l1 ~eq sinh s 1491 | let tanh s = l1 ~eq tanh s 1492 | let ceil s = l1 ~eq ceil s 1493 | let floor s = l1 ~eq floor s 1494 | let abs_float s = l1 ~eq abs_float s 1495 | let mod_float s s' = l2 ~eq mod_float s s' 1496 | let frexp s = l1 ~eq:( = ) frexp s 1497 | let ldexp s s' = l2 ~eq ldexp s s' 1498 | let modf s = l1 ~eq:( = ) modf s 1499 | let float s = l1 ~eq float s 1500 | let float_of_int s = l1 ~eq float_of_int s 1501 | let truncate s = l1 ~eq:Int.eq truncate s 1502 | let int_of_float s = l1 ~eq:Int.eq int_of_float s 1503 | let infinity = const infinity 1504 | let neg_infinity = const neg_infinity 1505 | let nan = const nan 1506 | let max_float = const max_float 1507 | let min_float = const min_float 1508 | let epsilon_float = const epsilon_float 1509 | let classify_float s = l1 ~eq:( = ) classify_float s 1510 | end 1511 | 1512 | module Pair = struct 1513 | let pair ?eq s s' = l2 ?eq (fun x y -> x, y) s s' 1514 | let fst ?eq s = l1 ?eq fst s 1515 | let snd ?eq s = l1 ?eq snd s 1516 | end 1517 | 1518 | module Option = struct 1519 | let none = Const None 1520 | let some s = 1521 | let eq = match eq_fun s with 1522 | | None -> None 1523 | | Some eq -> 1524 | let eq v v' = match v, v' with 1525 | | Some v, Some v' -> eq v v' 1526 | | _ -> assert false 1527 | in 1528 | Some eq 1529 | in 1530 | map ?eq (fun v -> Some v) s 1531 | 1532 | let value ?(eq = ( = )) ~default s = match s with 1533 | | Const (Some v) -> Const v 1534 | | Const None -> 1535 | begin match default with 1536 | | `Always d -> d 1537 | | `Init d -> 1538 | begin match d with 1539 | | Const d -> Const d 1540 | | Smut md -> 1541 | match Step.find_unfinished [md.snode] with 1542 | | c when c == Step.nil -> Const (sval md) 1543 | | c -> 1544 | let m' = smut (rsucc md.snode) eq in 1545 | let rec p () = [ md.snode ] 1546 | and u c = 1547 | Node.rem_dep md.snode m'.snode; 1548 | supdate (sval md) m' c; 1549 | Node.stop m'.snode 1550 | in 1551 | Node.add_dep md.snode m'.snode; 1552 | signal m' p u 1553 | end 1554 | end 1555 | | Smut m -> 1556 | match default with 1557 | | `Init (Const d) -> fmap ~eq (fun v -> v) d s 1558 | | `Always (Const d) -> map ~eq (function None -> d | Some v -> v) s 1559 | | `Init (Smut md) -> 1560 | begin match Step.find_unfinished [md.snode] with 1561 | | c when c == Step.nil -> 1562 | let m' = smut (rsucc m.snode) eq in 1563 | let rec p () = [ m.snode ] 1564 | and u c = match sval m with 1565 | | Some v -> supdate v m' c | None -> () 1566 | in 1567 | Node.add_dep m.snode m'.snode; 1568 | signal ~i:(sval md) m' p u 1569 | | c -> 1570 | let m' = smut (rsucc2 m.snode md.snode) eq in 1571 | let rec p () = [ m.snode ] in (* subsequent updates *) 1572 | let u c = match sval m with 1573 | | Some v -> supdate v m' c | None -> () 1574 | in 1575 | let rec p_first () = [ m.snode; md.snode ] in (* first update *) 1576 | let u_first c = 1577 | Node.rem_dep md.snode m'.snode; 1578 | begin match sval m with 1579 | | None -> supdate (sval md) m' c 1580 | | Some v -> supdate v m' c 1581 | end; 1582 | Node.bind m'.snode p u 1583 | in 1584 | Node.add_dep m.snode m'.snode; 1585 | Node.add_dep md.snode m'.snode; 1586 | signal m' p_first u_first 1587 | end 1588 | | `Always (Smut md) -> 1589 | let m' = smut (rsucc2 m.snode md.snode) eq in 1590 | let rec p () = [ m.snode; md.snode ] in 1591 | let u c = match sval m with 1592 | | Some v -> supdate v m' c 1593 | | None -> supdate (sval md) m' c 1594 | in 1595 | Node.add_dep m.snode m'.snode; 1596 | Node.add_dep md.snode m'.snode; 1597 | signal m' p u 1598 | end 1599 | 1600 | module Compare = struct 1601 | let eq = Bool.eq 1602 | let ( = ) s s' = l2 ~eq ( = ) s s' 1603 | let ( <> ) s s' = l2 ~eq ( <> ) s s' 1604 | let ( < ) s s' = l2 ~eq ( < ) s s' 1605 | let ( > ) s s' = l2 ~eq ( > ) s s' 1606 | let ( <= ) s s' = l2 ~eq ( <= ) s s' 1607 | let ( >= ) s s' = l2 ~eq ( >= ) s s' 1608 | let compare s s' = l2 ~eq:Int.eq compare s s' 1609 | let ( == ) s s' = l2 ~eq ( == ) s s' 1610 | let ( != ) s s' = l2 ~eq ( != ) s s' 1611 | end 1612 | 1613 | (* Combinator specialization *) 1614 | 1615 | module type EqType = sig 1616 | type 'a t 1617 | val equal : 'a t -> 'a t -> bool 1618 | end 1619 | 1620 | module type S = sig 1621 | type 'a v 1622 | val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) 1623 | val equal : 'a v signal -> 'a v signal -> bool 1624 | val hold : 'a v -> 'a v event -> 'a v signal 1625 | val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal 1626 | val map : ('a -> 'b v) -> 'a signal -> 'b v signal 1627 | val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal 1628 | val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal 1629 | val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal 1630 | val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal 1631 | val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal 1632 | val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal 1633 | val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal 1634 | val switch : 'a v signal signal -> 'a v signal 1635 | val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal 1636 | val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b 1637 | val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) 1638 | val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) 1639 | val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 'c signal 1640 | -> 'd v signal) 1641 | val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> 1642 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) 1643 | val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> 1644 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 1645 | 'f v signal) 1646 | val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> 1647 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 1648 | 'f signal -> 'g v signal) 1649 | end 1650 | 1651 | module Make (Eq : EqType) = struct 1652 | type 'a v = 'a Eq.t 1653 | let eq = Eq.equal 1654 | let create v = create ~eq v 1655 | let equal s s' = equal ~eq s s' 1656 | let hold v e = hold ~eq v e 1657 | let app sf sv = app ~eq sf sv 1658 | let map f s = map ~eq f s 1659 | let filter pred i = filter ~eq pred i 1660 | let fmap fm i = fmap ~eq fm i 1661 | let when_ c i s = when_ ~eq c i s 1662 | let dismiss c s = dismiss ~eq c s 1663 | let accum ef i = accum ~eq ef i 1664 | let fold f i = fold ~eq f i 1665 | let merge f a sl = merge ~eq f a sl 1666 | let switch s = switch ~eq s 1667 | let bind s sf = bind ~eq s sf 1668 | let fix f = fix ~eq f 1669 | let l1 = map 1670 | let l2 f s s' = l2 ~eq f s s' 1671 | let l3 f s0 s1 s2 = l3 ~eq f s0 s1 s2 1672 | let l4 f s0 s1 s2 s3 = l4 ~eq f s0 s1 s2 s3 1673 | let l5 f s0 s1 s2 s3 s4 = l5 ~eq f s0 s1 s2 s3 s4 1674 | let l6 f s0 s1 s2 s3 s4 s5 = l6 ~eq f s0 s1 s2 s3 s4 s5 1675 | end 1676 | 1677 | module Special = struct 1678 | module Sb = Make (struct type 'a t = bool let equal = Bool.eq end) 1679 | module Si = Make (struct type 'a t = int let equal = Int.eq end) 1680 | module Sf = Make (struct type 'a t = float let equal = Float.eq end) 1681 | end 1682 | end 1683 | 1684 | (*--------------------------------------------------------------------------- 1685 | Copyright (c) 2009 The react programmers 1686 | 1687 | Permission to use, copy, modify, and/or distribute this software for any 1688 | purpose with or without fee is hereby granted, provided that the above 1689 | copyright notice and this permission notice appear in all copies. 1690 | 1691 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1692 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1693 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1694 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1695 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1696 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1697 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1698 | ---------------------------------------------------------------------------*) 1699 | -------------------------------------------------------------------------------- /src/react.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2009 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Declarative events and signals. 7 | 8 | React is a module for functional reactive programming (frp). It 9 | provides support to program with time varying values : declarative 10 | {{!E}events} and {{!S}signals}. React 11 | doesn't define any primitive event or signal, this lets the client 12 | choose the concrete timeline. 13 | 14 | Consult the {{!sem}semantics}, the {{!basics}basics} and 15 | {{!ex}examples}. Open the module to use it, this defines only two 16 | types and modules in your scope. *) 17 | 18 | (** {1:interface Interface} *) 19 | 20 | type 'a event 21 | (** The type for events of type ['a]. *) 22 | 23 | type 'a signal 24 | (** The type for signals of type ['a]. *) 25 | 26 | type step 27 | (** The type for update steps. *) 28 | 29 | (** Event combinators. 30 | 31 | Consult their {{!evsem}semantics.} *) 32 | module E : sig 33 | (** {1:prim Primitive and basics} *) 34 | 35 | type 'a t = 'a event 36 | (** The type for events with occurrences of type ['a]. *) 37 | 38 | val never : 'a event 39 | (** A never occuring event. For all t, \[[never]\]{_t} [= None]. *) 40 | 41 | val create : unit -> 'a event * (?step:step -> 'a -> unit) 42 | (** [create ()] is a primitive event [e] and a [send] function. The 43 | function [send] is such that: 44 | {ul 45 | {- [send v] generates an occurrence [v] of [e] at the time it is called 46 | and triggers an {{!steps}update step}.} 47 | {- [send ~step v] generates an occurence [v] of [e] on the step [step] 48 | when [step] is {{!Step.execute}executed}.} 49 | {- [send ~step v] raises [Invalid_argument] if it was previously 50 | called with a step and this step has not executed yet or if 51 | the given [step] was already executed.}} 52 | 53 | {b Warning.} [send] must not be executed inside an update step. *) 54 | 55 | val retain : 'a event -> (unit -> unit) -> [ `R of (unit -> unit) ] 56 | (** [retain e c] keeps a reference to the closure [c] in [e] and 57 | returns the previously retained value. [c] will {e never} be 58 | invoked. 59 | 60 | {b Raises.} [Invalid_argument] on {!E.never}. *) 61 | 62 | val stop : ?strong:bool -> 'a event -> unit 63 | (** [stop e] stops [e] from occuring. It conceptually becomes 64 | {!never} and cannot be restarted. Allows to 65 | disable {{!sideeffects}effectful} events. 66 | 67 | The [strong] argument should only be used on platforms 68 | where weak arrays have a strong semantics (i.e. JavaScript). 69 | See {{!strongstop}details}. 70 | 71 | {b Note.} If executed in an {{!steps}update step} 72 | the event may still occur in the step. *) 73 | 74 | val equal : 'a event -> 'a event -> bool 75 | (** [equal e e'] is [true] iff [e] and [e'] are equal. If both events are 76 | different from {!never}, physical equality is used. *) 77 | 78 | val trace : ?iff:bool signal -> ('a -> unit) -> 'a event -> 'a event 79 | (** [trace iff tr e] is [e] except [tr] is invoked with e's 80 | occurence when [iff] is [true] (defaults to [S.const true]). 81 | For all t where \[[e]\]{_t} [= Some v] and \[[iff]\]{_t} = 82 | [true], [tr] is invoked with [v]. *) 83 | 84 | (** {1:transf Transforming and filtering} *) 85 | 86 | val once : 'a event -> 'a event 87 | (** [once e] is [e] with only its next occurence. 88 | {ul 89 | {- \[[once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and 90 | \[[e]\]{_ 'a event 94 | (** [drop_once e] is [e] without its next occurrence. 95 | {ul 96 | {- \[[drop_once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and 97 | \[[e]\]{_ 'b) event -> 'a event -> 'b event 101 | (** [app ef e] occurs when both [ef] and [e] occur 102 | {{!simultaneity}simultaneously}. 103 | The value is [ef]'s occurence applied to [e]'s one. 104 | {ul 105 | {- \[[app ef e]\]{_t} [= Some v'] if \[[ef]\]{_t} [= Some f] and 106 | \[[e]\]{_t} [= Some v] and [f v = v'].} 107 | {- \[[app ef e]\]{_t} [= None] otherwise.}} *) 108 | 109 | val map : ('a -> 'b) -> 'a event -> 'b event 110 | (** [map f e] applies [f] to [e]'s occurrences. 111 | {ul 112 | {- \[[map f e]\]{_t} [= Some (f v)] if \[[e]\]{_t} [= Some v].} 113 | {- \[[map f e]\]{_t} [= None] otherwise.}} *) 114 | 115 | val stamp : 'b event -> 'a -> 'a event 116 | (** [stamp e v] is [map (fun _ -> v) e]. *) 117 | 118 | val filter : ('a -> bool) -> 'a event -> 'a event 119 | (** [filter p e] are [e]'s occurrences that satisfy [p]. 120 | {ul 121 | {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and 122 | [p v = true]} 123 | {- \[[filter p e]\]{_t} [= None] otherwise.}} *) 124 | 125 | val fmap : ('a -> 'b option) -> 'a event -> 'b event 126 | (** [fmap fm e] are [e]'s occurrences filtered and mapped by [fm]. 127 | {ul 128 | {- \[[fmap fm e]\]{_t} [= Some v] if [fm] \[[e]\]{_t} [= Some v]} 129 | {- \[[fmap fm e]\]{_t} [= None] otherwise.}} *) 130 | 131 | val diff : ('a -> 'a -> 'b) -> 'a event -> 'b event 132 | (** [diff f e] occurs whenever [e] occurs except on the next occurence. 133 | Occurences are [f v v'] where [v] is [e]'s current 134 | occurrence and [v'] the previous one. 135 | {ul 136 | {- \[[diff f e]\]{_t} [= Some r] if \[[e]\]{_t} [= Some v], 137 | \[[e]\]{_ 'a -> bool) -> 'a event -> 'a event 141 | (** [changes eq e] is [e]'s occurrences with occurences equal to 142 | the previous one dropped. Equality is tested with [eq] (defaults to 143 | structural equality). 144 | {ul 145 | {- \[[changes eq e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] 146 | and either \[[e]\]{_ 'a event -> 'a event 151 | (** [on c e] is the occurrences of [e] when [c] is [true]. 152 | {ul 153 | {- \[[on c e]\]{_t} [= Some v] 154 | if \[[c]\]{_t} [= true] and \[[e]\]{_t} [= Some v].} 155 | {- \[[on c e]\]{_t} [= None] otherwise.}} *) 156 | 157 | val when_ : bool signal -> 'a event -> 'a event 158 | (** @deprecated Use {!on}. *) 159 | 160 | val dismiss : 'b event -> 'a event -> 'a event 161 | (** [dismiss c e] is the occurences of [e] except the ones when [c] occurs. 162 | {ul 163 | {- \[[dimiss c e]\]{_t} [= Some v] 164 | if \[[c]\]{_t} [= None] and \[[e]\]{_t} [= Some v].} 165 | {- \[[dimiss c e]\]{_t} [= None] otherwise.}} *) 166 | 167 | val until : 'a event -> 'b event -> 'b event 168 | (** [until c e] is [e]'s occurences until [c] occurs. 169 | {ul 170 | {- \[[until c e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and 171 | \[[c]\]{_<=t} [= None]} 172 | {- \[[until c e]\]{_t} [= None] otherwise.}} *) 173 | 174 | (** {1:accum Accumulating} *) 175 | 176 | val accum : ('a -> 'a) event -> 'a -> 'a event 177 | (** [accum ef i] accumulates a value, starting with [i], using [e]'s 178 | functional occurrences. 179 | {ul 180 | {- \[[accum ef i]\]{_t} [= Some (f i)] if \[[ef]\]{_t} [= Some f] 181 | and \[[ef]\]{_ 'b -> 'a) -> 'a -> 'b event -> 'a event 188 | (** [fold f i e] accumulates [e]'s occurrences with [f] starting with [i]. 189 | {ul 190 | {- \[[fold f i e]\]{_t} [= Some (f i v)] if 191 | \[[e]\]{_t} [= Some v] and \[[e]\]{_ 'a event 199 | (** [select el] is the occurrences of every event in [el]. 200 | If more than one event occurs {{!simultaneity}simultaneously} 201 | the leftmost is taken and the others are lost. 202 | {ul 203 | {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} 204 | [<> None) el]\]{_t}.} 205 | {- \[[select el]\]{_ t} [= None] otherwise.}} *) 206 | 207 | val merge : ('a -> 'b -> 'a) -> 'a -> 'b event list -> 'a event 208 | (** [merge f a el] merges the {{!simultaneity}simultaneous} 209 | occurrences of every event in [el] using [f] and the accumulator [a]. 210 | 211 | \[[merge f a el]\]{_ t} 212 | [= List.fold_left f a (List.filter (fun o -> o <> None) 213 | (List.map] \[\]{_t}[ el))]. *) 214 | 215 | val switch : 'a event -> 'a event event -> 'a event 216 | (** [switch e ee] is [e]'s occurrences until there is an 217 | occurrence [e'] on [ee], the occurrences of [e'] are then used 218 | until there is a new occurrence on [ee], etc.. 219 | {ul 220 | {- \[[switch e ee]\]{_ t} [=] \[[e]\]{_t} if \[[ee]\]{_<=t} [= None].} 221 | {- \[[switch e ee]\]{_ t} [=] \[[e']\]{_t} if \[[ee]\]{_<=t} 222 | [= Some e'].}} *) 223 | 224 | val fix : ('a event -> 'a event * 'b) -> 'b 225 | (** [fix ef] allows to refer to the value an event had an 226 | infinitesimal amount of time before. 227 | 228 | In [fix ef], [ef] is called with an event [e] that represents 229 | the event returned by [ef] delayed by an infinitesimal amount of 230 | time. If [e', r = ef e] then [r] is returned by [fix] and [e] 231 | is such that : 232 | {ul 233 | {- \[[e]\]{_ t} [=] [None] if t = 0 } 234 | {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} 235 | 236 | {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. 237 | an event given to a fixing function). *) 238 | 239 | (** {1 Lifting} 240 | 241 | Lifting combinators. For a given [n] the semantics is: 242 | {ul 243 | {- \[[ln f e1 ... en]\]{_t} [= Some (f v1 ... vn)] if for all 244 | i : \[[ei]\]{_t} [= Some vi].} 245 | {- \[[ln f e1 ... en]\]{_t} [= None] otherwise.}} *) 246 | 247 | val l1 : ('a -> 'b) -> 'a event -> 'b event 248 | val l2 : ('a -> 'b -> 'c) -> 'a event -> 'b event -> 'c event 249 | val l3 : ('a -> 'b -> 'c -> 'd) -> 'a event -> 'b event -> 'c event -> 250 | 'd event 251 | val l4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a event -> 'b event -> 'c event -> 252 | 'd event -> 'e event 253 | val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a event -> 'b event -> 254 | 'c event -> 'd event -> 'e event -> 'f event 255 | val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a event -> 'b event -> 256 | 'c event -> 'd event -> 'e event -> 'f event -> 'g event 257 | 258 | (** {1:stdlib_support Stdlib support} *) 259 | 260 | (** Events with option occurences. *) 261 | module Option : sig 262 | val some : 'a event -> 'a option event 263 | (** [some e] is [map (fun v -> Some v) e]. *) 264 | 265 | val value : ?default:'a signal -> 'a option event -> 'a event 266 | (** [value default e] either silences [None] occurences if [default] is 267 | unspecified or replaces them by the value of [default] at the occurence 268 | time. 269 | {ul 270 | {- \[[value ~default e]\]{_t}[ = v] if \[[e]\]{_t} [= Some (Some v)].} 271 | {- \[[value ?default:None e]\]{_t}[ = None] if \[[e]\]{_t} = [None].} 272 | {- \[[value ?default:(Some s) e]\]{_t}[ = v] 273 | if \[[e]\]{_t} = [None] and \[[s]\]{_t} [= v].}} *) 274 | end 275 | end 276 | 277 | (** Signal combinators. 278 | 279 | Consult their {{!sigsem}semantics.} *) 280 | module S : sig 281 | (** {1:prim Primitive and basics} *) 282 | 283 | type 'a t = 'a signal 284 | (** The type for signals of type ['a]. *) 285 | 286 | val const : 'a -> 'a signal 287 | (** [const v] is always [v], \[[const v]\]{_t} [= v]. *) 288 | 289 | val create : ?eq:('a -> 'a -> bool) -> 'a -> 290 | 'a signal * (?step:step -> 'a -> unit) 291 | (** [create i] is a primitive signal [s] set to [i] and a 292 | [set] function. The function [set] is such that: 293 | {ul 294 | {- [set v] sets the signal's value to [v] at the time it is called and 295 | triggers an {{!steps}update step}.} 296 | {- [set ~step v] sets the signal's value to [v] at the time it is 297 | called and updates it dependencies when [step] is 298 | {{!Step.execute}executed}} 299 | {- [set ~step v] raises [Invalid_argument] if it was previously 300 | called with a step and this step has not executed yet or if 301 | the given [step] was already executed.}} 302 | {b Warning.} [set] must not be executed inside an update step. *) 303 | 304 | val value : 'a signal -> 'a 305 | (** [value s] is [s]'s current value. 306 | 307 | {b Warning.} If executed in an {{!steps}update 308 | step} may return a non up-to-date value or raise [Failure] if 309 | the signal is not yet initialized. *) 310 | 311 | val retain : 'a signal -> (unit -> unit) -> [ `R of (unit -> unit) ] 312 | (** [retain s c] keeps a reference to the closure [c] in [s] and 313 | returns the previously retained value. [c] will {e never} be 314 | invoked. 315 | 316 | {b Raises.} [Invalid_argument] on constant signals. *) 317 | 318 | (**/**) 319 | val eq_fun : 'a signal -> ('a -> 'a -> bool) option 320 | (**/**) 321 | 322 | val stop : ?strong:bool -> 'a signal -> unit 323 | (** [stop s], stops updating [s]. It conceptually becomes {!const} 324 | with the signal's last value and cannot be restarted. Allows to 325 | disable {{!sideeffects}effectful} signals. 326 | 327 | The [strong] argument should only be used on platforms 328 | where weak arrays have a strong semantics (i.e. JavaScript). 329 | See {{!strongstop}details}. 330 | 331 | {b Note.} If executed in an update step the signal may 332 | still update in the step. *) 333 | 334 | val equal : ?eq:('a -> 'a -> bool) -> 'a signal -> 'a signal -> bool 335 | (** [equal s s'] is [true] iff [s] and [s'] are equal. If both 336 | signals are {!const}ant [eq] is used between their value 337 | (defauts to structural equality). If both signals are not 338 | {!const}ant, physical equality is used.*) 339 | 340 | val trace : ?iff:bool t -> ('a -> unit) -> 'a signal -> 'a signal 341 | (** [trace iff tr s] is [s] except [tr] is invoked with [s]'s 342 | current value and on [s] changes when [iff] is [true] (defaults 343 | to [S.const true]). For all t where \[[s]\]{_t} [= v] and (t = 0 344 | or (\[[s]\]{_t-dt}[= v'] and [eq v v' = false])) and 345 | \[[iff]\]{_t} = [true], [tr] is invoked with [v]. *) 346 | 347 | (** {1 From events} *) 348 | 349 | val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a event -> 'a signal 350 | (** [hold i e] has the value of [e]'s last occurrence or [i] if there 351 | wasn't any. 352 | {ul 353 | {- \[[hold i e]\]{_t} [= i] if \[[e]\]{_<=t} [= None]} 354 | {- \[[hold i e]\]{_t} [= v] if \[[e]\]{_<=t} [= Some v]}} *) 355 | 356 | (** {1:tr Transforming and filtering} *) 357 | 358 | val app : ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> 359 | 'b signal 360 | (** [app sf s] holds the value of [sf] applied 361 | to the value of [s], \[[app sf s]\]{_t} 362 | [=] \[[sf]\]{_t} \[[s]\]{_t}. *) 363 | 364 | val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a signal -> 'b signal 365 | (** [map f s] is [s] transformed by [f], \[[map f s]\]{_t} = [f] \[[s]\]{_t}. 366 | *) 367 | 368 | val filter : ?eq:('a -> 'a -> bool) -> ('a -> bool) -> 'a -> 'a signal -> 369 | 'a signal 370 | (** [filter f i s] is [s]'s values that satisfy [p]. If a value does not 371 | satisfy [p] it holds the last value that was satisfied or [i] if 372 | there is none. 373 | {ul 374 | {- \[[filter p s]\]{_t} [=] \[[s]\]{_t} if [p] \[[s]\]{_t}[ = true].} 375 | {- \[[filter p s]\]{_t} [=] \[[s]\]{_t'} if [p] \[[s]\]{_t}[ = false] 376 | and t' is the greatest t' < t with [p] \[[s]\]{_t'}[ = true].} 377 | {- \[[filter p e]\]{_t} [= i] otherwise.}} *) 378 | 379 | val fmap : ?eq:('b -> 'b -> bool) -> ('a -> 'b option) -> 'b -> 'a signal -> 380 | 'b signal 381 | (** [fmap fm i s] is [s] filtered and mapped by [fm]. 382 | {ul 383 | {- \[[fmap fm i s]\]{_t} [=] v if [fm] \[[s]\]{_t}[ = Some v].} 384 | {- \[[fmap fm i s]\]{_t} [=] \[[fmap fm i s]\]{_t'} if [fm] 385 | \[[s]\]{_t} [= None] and t' is the greatest t' < t with [fm] 386 | \[[s]\]{_t'} [<> None].} 387 | {- \[[fmap fm i s]\]{_t} [= i] otherwise.}} *) 388 | 389 | val diff : ('a -> 'a -> 'b) -> 'a signal -> 'b event 390 | (** [diff f s] is an event with occurrences whenever [s] changes from 391 | [v'] to [v] and [eq v v'] is [false] ([eq] is the signal's equality 392 | function). The value of the occurrence is [f v v']. 393 | {ul 394 | {- \[[diff f s]\]{_t} [= Some d] 395 | if \[[s]\]{_t} [= v] and \[[s]\]{_t-dt} [= v'] and [eq v v' = false] 396 | and [f v v' = d].} 397 | {- \[[diff f s]\]{_t} [= None] otherwise.}} *) 398 | 399 | val changes : 'a signal -> 'a event 400 | (** [changes s] is [diff (fun v _ -> v) s]. *) 401 | 402 | val sample : ('b -> 'a -> 'c) -> 'b event -> 'a signal -> 'c event 403 | (** [sample f e s] samples [s] at [e]'s occurrences. 404 | {ul 405 | {- \[[sample f e s]\]{_t} [= Some (f ev sv)] if \[[e]\]{_t} [= Some ev] 406 | and \[[s]\]{_t} [= sv].} 407 | {- \[[sample e s]\]{_t} [= None] otherwise.}} *) 408 | 409 | val on : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> 410 | 'a signal 411 | (** [on c i s] is the signal [s] whenever [c] is [true]. 412 | When [c] is [false] it holds the last value [s] had when 413 | [c] was the last time [true] or [i] if it never was. 414 | {ul 415 | {- \[[on c i s]\]{_t} [=] \[[s]\]{_t} if \[[c]\]{_t} [= true]} 416 | {- \[[on c i s]\]{_t} [=] \[[s]\]{_t'} if \[[c]\]{_t} [= false] 417 | where t' is the greatest t' < t with \[[c]\]{_t'} [= true].} 418 | {- \[[on c i s]\]{_t} [=] [i] otherwise.}} *) 419 | 420 | val when_ : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> 421 | 'a signal 422 | (** @deprecated Use {!on}. *) 423 | 424 | val dismiss : ?eq:('a -> 'a -> bool) -> 'b event -> 'a -> 'a signal -> 425 | 'a signal 426 | (** [dismiss c i s] is the signal [s] except changes when [c] occurs 427 | are ignored. If [c] occurs initially [i] is used. 428 | {ul 429 | {- \[[dismiss c i s]\]{_t} [=] \[[s]\]{_t'} 430 | where t' is the greatest t' <= t with \[[c]\]{_t'} [= None] and 431 | \[[s]\]{_t'-dt} [<>] \[[s]\]{_t'}} 432 | {- \[[dismiss_ c i s]\]{_0} [=] [v] where [v = i] if 433 | \[[c]\]{_0} [= Some _] and [v =] \[[s]\]{_0} otherwise.}} *) 434 | 435 | (** {1:acc Accumulating} *) 436 | 437 | val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) event -> 'a -> 'a signal 438 | (** [accum e i] is [S.hold i (]{!E.val-accum}[ e i)]. *) 439 | 440 | val fold : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b event -> 441 | 'a signal 442 | (** [fold f i e] is [S.hold i (]{!E.fold}[ f i e)]. *) 443 | 444 | (** {1:combine Combining} *) 445 | 446 | val merge : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 447 | 'b signal list -> 'a signal 448 | (** [merge f a sl] merges the value of every signal in [sl] 449 | using [f] and the accumulator [a]. 450 | 451 | \[[merge f a sl]\]{_ t} 452 | [= List.fold_left f a (List.map] \[\]{_t}[ sl)]. *) 453 | 454 | val switch : ?eq:('a -> 'a -> bool) -> 'a signal signal -> 'a signal 455 | (** [switch ss] is the inner signal of [ss]. 456 | {ul 457 | {- \[[switch ss]\]{_ t} [=] \[\[[ss]\]{_t}\]{_t}.}} *) 458 | 459 | val bind : ?eq:('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 460 | 'b signal 461 | (** [bind s sf] is [switch (map ~eq:( == ) sf s)]. *) 462 | 463 | val fix : ?eq:('a -> 'a -> bool) -> 'a -> ('a signal -> 'a signal * 'b) -> 'b 464 | (** [fix i sf] allow to refer to the value a signal had an 465 | infinitesimal amount of time before. 466 | 467 | In [fix sf], [sf] is called with a signal [s] that represents 468 | the signal returned by [sf] delayed by an infinitesimal amount 469 | time. If [s', r = sf s] then [r] is returned by [fix] and [s] 470 | is such that : 471 | {ul 472 | {- \[[s]\]{_ t} [=] [i] for t = 0. } 473 | {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} 474 | 475 | [eq] is the equality used by [s]. 476 | 477 | {b Raises.} [Invalid_argument] if [s'] is directly a delayed signal (i.e. 478 | a signal given to a fixing function). 479 | 480 | {b Note.} Regarding values depending on the result [r] of 481 | [s', r = sf s] the following two cases need to be distinguished : 482 | {ul 483 | {- After [sf s] is applied, [s'] does not depend on 484 | a value that is in a step and [s] has no dependents in a step (e.g 485 | in the simple case where [fix] is applied outside a step). 486 | 487 | In that case if the initial value of [s'] differs from [i], 488 | [s] and its dependents need to be updated and a special 489 | update step will be triggered for this. Values 490 | depending on the result [r] will be created only after this 491 | special update step has finished (e.g. they won't see 492 | the [i] of [s] if [r = s]).} 493 | {- Otherwise, values depending on [r] will be created in the same 494 | step as [s] and [s'] (e.g. they will see the [i] of [s] if [r = s]).}} 495 | *) 496 | 497 | (** {1:lifting Lifting} 498 | 499 | Lifting combinators. For a given [n] the semantics is : 500 | 501 | \[[ln f a1] ... [an]\]{_t} = f \[[a1]\]{_t} ... \[[an]\]{_t} *) 502 | 503 | val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> ('a signal -> 'b signal) 504 | val l2 : ?eq:('c -> 'c -> bool) -> 505 | ('a -> 'b -> 'c) -> ('a signal -> 'b signal -> 'c signal) 506 | val l3 : ?eq:('d -> 'd -> bool) -> 507 | ('a -> 'b -> 'c -> 'd) -> ('a signal -> 'b signal -> 'c signal -> 'd signal) 508 | val l4 : ?eq:('e -> 'e -> bool) -> 509 | ('a -> 'b -> 'c -> 'd -> 'e) -> 510 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) 511 | val l5 : ?eq:('f -> 'f -> bool) -> 512 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 513 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 514 | 'f signal) 515 | val l6 : ?eq:('g -> 'g -> bool) -> 516 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 517 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 518 | 'f signal -> 'g signal) 519 | 520 | (** The following modules lift some of [Stdlib] functions and 521 | operators. *) 522 | 523 | module Bool : sig 524 | val zero : bool signal 525 | val one : bool signal 526 | val not : bool signal -> bool signal 527 | val ( && ) : bool signal -> bool signal -> bool signal 528 | val ( || ) : bool signal -> bool signal -> bool signal 529 | 530 | val edge : bool signal -> bool event 531 | (** [edge s] is [changes s]. *) 532 | 533 | val rise : bool signal -> unit event 534 | (** [rise s] is [E.fmap (fun b -> if b then Some () else None) (edge s)].*) 535 | 536 | val fall : bool signal -> unit event 537 | (** [fall s] is [E.fmap (fun b -> if b then None else Some ()) (edge s)].*) 538 | 539 | val flip : bool -> 'a event -> bool signal 540 | (** [flip b e] is a signal whose boolean value flips each time 541 | [e] occurs. [b] is the initial signal value. 542 | {ul 543 | {- \[[flip b e]\]{_0} [= not b] if \[[e]\]{_0} [= Some _]} 544 | {- \[[flip b e]\]{_t} [= b] if \[[e]\]{_<=t} [= None]} 545 | {- \[[flip b e]\]{_t} [=] [not] \[[flip b e]\]{_t-dt} 546 | if \[[e]\]{_t} [= Some _]}} 547 | *) 548 | end 549 | 550 | module Int : sig 551 | val zero : int signal 552 | val one : int signal 553 | val minus_one : int signal 554 | val ( ~- ) : int signal -> int signal 555 | val succ : int signal -> int signal 556 | val pred : int signal -> int signal 557 | val ( + ) : int signal -> int signal -> int signal 558 | val ( - ) : int signal -> int signal -> int signal 559 | val ( * ) : int signal -> int signal -> int signal 560 | val ( mod ) : int signal -> int signal -> int signal 561 | val abs : int signal -> int signal 562 | val max_int : int signal 563 | val min_int : int signal 564 | val ( land ) : int signal -> int signal -> int signal 565 | val ( lor ) : int signal -> int signal -> int signal 566 | val ( lxor ) : int signal -> int signal -> int signal 567 | val lnot : int signal -> int signal 568 | val ( lsl ) : int signal -> int signal -> int signal 569 | val ( lsr ) : int signal -> int signal -> int signal 570 | val ( asr ) : int signal -> int signal -> int signal 571 | end 572 | 573 | module Float : sig 574 | val zero : float signal 575 | val one : float signal 576 | val minus_one : float signal 577 | val ( ~-. ) : float signal -> float signal 578 | val ( +. ) : float signal -> float signal -> float signal 579 | val ( -. ) : float signal -> float signal -> float signal 580 | val ( *. ) : float signal -> float signal -> float signal 581 | val ( /. ) : float signal -> float signal -> float signal 582 | val ( ** ) : float signal -> float signal -> float signal 583 | val sqrt : float signal -> float signal 584 | val exp : float signal -> float signal 585 | val log : float signal -> float signal 586 | val log10 : float signal -> float signal 587 | val cos : float signal -> float signal 588 | val sin : float signal -> float signal 589 | val tan : float signal -> float signal 590 | val acos : float signal -> float signal 591 | val asin : float signal -> float signal 592 | val atan : float signal -> float signal 593 | val atan2 : float signal -> float signal -> float signal 594 | val cosh : float signal -> float signal 595 | val sinh : float signal -> float signal 596 | val tanh : float signal -> float signal 597 | val ceil : float signal -> float signal 598 | val floor : float signal -> float signal 599 | val abs_float : float signal -> float signal 600 | val mod_float : float signal -> float signal -> float signal 601 | val frexp : float signal -> (float * int) signal 602 | val ldexp : float signal -> int signal -> float signal 603 | val modf : float signal -> (float * float) signal 604 | val float : int signal -> float signal 605 | val float_of_int : int signal -> float signal 606 | val truncate : float signal -> int signal 607 | val int_of_float : float signal -> int signal 608 | val infinity : float signal 609 | val neg_infinity : float signal 610 | val nan : float signal 611 | val max_float : float signal 612 | val min_float : float signal 613 | val epsilon_float : float signal 614 | val classify_float : float signal -> fpclass signal 615 | end 616 | 617 | module Pair : sig 618 | val pair : ?eq:(('a * 'b) -> ('a * 'b) -> bool)-> 619 | 'a signal -> 'b signal -> ('a * 'b) signal 620 | val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) signal -> 'a signal 621 | val snd : ?eq:('a -> 'a -> bool) -> ('b * 'a) signal -> 'a signal 622 | end 623 | 624 | module Option : sig 625 | val none : 'a option signal 626 | (** [none] is [S.const None]. *) 627 | 628 | val some : 'a signal -> 'a option signal 629 | (** [some s] is [S.map ~eq (fun v -> Some v) None], where [eq] uses 630 | [s]'s equality function to test the [Some v]'s equalities. *) 631 | 632 | val value : ?eq:('a -> 'a -> bool) -> 633 | default:[`Init of 'a signal | `Always of 'a signal ] -> 634 | 'a option signal -> 'a signal 635 | (** [value default s] is [s] with only its [Some v] values. 636 | Whenever [s] is [None], if [default] is [`Always dv] then 637 | the current value of [dv] is used instead. If [default] 638 | is [`Init dv] the current value of [dv] is only used 639 | if there's no value at creation time, otherwise the last 640 | [Some v] value of [s] is used. 641 | {ul 642 | {- \[[value ~default s]\]{_t} [= v] if \[[s]\]{_t} [= Some v]} 643 | {- \[[value ~default:(`Always d) s]\]{_t} [=] \[[d]\]{_t} 644 | if \[[s]\]{_t} [= None]} 645 | {- \[[value ~default:(`Init d) s]\]{_0} [=] \[[d]\]{_0} 646 | if \[[s]\]{_0} [= None]} 647 | {- \[[value ~default:(`Init d) s]\]{_t} [=] 648 | \[[value ~default:(`Init d) s]\]{_t'} 649 | if \[[s]\]{_t} [= None] and t' is the greatest t' < t 650 | with \[[s]\]{_t'} [<> None] or 0 if there is no such [t'].}} *) 651 | end 652 | 653 | module Compare : sig 654 | val ( = ) : 'a signal -> 'a signal -> bool signal 655 | val ( <> ) : 'a signal -> 'a signal -> bool signal 656 | val ( < ) : 'a signal -> 'a signal -> bool signal 657 | val ( > ) : 'a signal -> 'a signal -> bool signal 658 | val ( <= ) : 'a signal -> 'a signal -> bool signal 659 | val ( >= ) : 'a signal -> 'a signal -> bool signal 660 | val compare : 'a signal -> 'a signal -> int signal 661 | val ( == ) : 'a signal -> 'a signal -> bool signal 662 | val ( != ) : 'a signal -> 'a signal -> bool signal 663 | end 664 | 665 | (** {1:special Combinator specialization} 666 | 667 | Given an equality function [equal] and a type [t], the functor 668 | {!Make} automatically applies the [eq] parameter of the combinators. 669 | The outcome is combinators whose {e results} are signals with 670 | values in [t]. 671 | 672 | Basic types are already specialized in the module {!Special}, open 673 | this module to use them. *) 674 | 675 | (** Input signature of {!Make} *) 676 | module type EqType = sig 677 | type 'a t 678 | val equal : 'a t -> 'a t -> bool 679 | end 680 | 681 | (** Output signature of {!Make} *) 682 | module type S = sig 683 | type 'a v 684 | val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) 685 | val equal : 'a v signal -> 'a v signal -> bool 686 | val hold : 'a v -> 'a v event -> 'a v signal 687 | val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal 688 | val map : ('a -> 'b v) -> 'a signal -> 'b v signal 689 | val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal 690 | val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal 691 | val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal 692 | val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal 693 | val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal 694 | val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal 695 | val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal 696 | val switch : 'a v signal signal -> 'a v signal 697 | val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal 698 | val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b 699 | val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) 700 | val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) 701 | val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 702 | 'c signal -> 'd v signal) 703 | val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> 704 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) 705 | val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> 706 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 707 | 'f v signal) 708 | val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> 709 | ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 710 | 'f signal -> 'g v signal) 711 | end 712 | 713 | (** Functor specializing the combinators for the given signal value type *) 714 | module Make (Eq : EqType) : S with type 'a v = 'a Eq.t 715 | 716 | 717 | (** Specialization for booleans, integers and floats. 718 | 719 | Open this module to use it. *) 720 | module Special : sig 721 | 722 | (** Specialization for booleans. *) 723 | module Sb : S with type 'a v = bool 724 | 725 | (** Specialization for integers. *) 726 | module Si : S with type 'a v = int 727 | 728 | (** Specialization for floats. *) 729 | module Sf : S with type 'a v = float 730 | end 731 | end 732 | 733 | (** Update steps. 734 | 735 | Update functions returned by {!S.create} and {!E.create} 736 | implicitely create and execute update steps when used without 737 | specifying their [step] argument. 738 | 739 | Using explicit {!step} values with these functions gives more control on 740 | the time when the update step is perfomed and allows to perform 741 | simultaneous {{!primitives}primitive} signal updates and event 742 | occurences. See also the documentation about {{!steps}update steps} and 743 | {{!simultaneity}simultaneous events}. *) 744 | module Step : sig 745 | 746 | (** {1 Steps} *) 747 | 748 | type t = step 749 | (** The type for update steps. *) 750 | 751 | val create : unit -> step 752 | (** [create ()] is a new update step. *) 753 | 754 | val execute : step -> unit 755 | (** [execute step] executes the update step. 756 | 757 | @raise Invalid_argument if [step] was already executed. *) 758 | end 759 | 760 | (** {1:sem Semantics} 761 | 762 | The following notations are used to give precise meaning to the 763 | combinators. It is important to note that in these semantic 764 | descriptions the origin of time t = 0 is {e always} fixed at 765 | the time at which the combinator creates the event or the signal and 766 | the semantics of the dependents is evaluated relative to this timeline. 767 | 768 | We use dt to denote an infinitesimal amount of time. 769 | {2:evsem Events} 770 | 771 | An event is a value with discrete occurrences over time. 772 | 773 | The semantic function \[\] [: 'a event -> time -> 'a option] gives 774 | meaning to an event [e] by mapping it to a function of time 775 | \[[e]\] returning [Some v] whenever the event occurs with value 776 | [v] and [None] otherwise. We write \[[e]\]{_t} the evaluation of 777 | this {e semantic} function at time t. 778 | 779 | As a shortcut notation we also define \[\]{_ 'a option] 780 | (resp. \[\]{_<=t}) to denote the last occurrence, if any, of an 781 | event before (resp. before or at) [t]. More precisely : 782 | {ul 783 | {- \[[e]\]{_ None].} 786 | {- \[[e]\]{_ time -> 'a] gives 795 | meaning to a signal [s] by mapping it to a function of time 796 | \[[s]\] that returns its value at a given time. We write \[[s]\]{_t} 797 | the evaluation of this {e semantic} function at time t. 798 | {3:sigeq Equality} 799 | 800 | Most signal combinators have an optional [eq] parameter that 801 | defaults to structural equality. [eq] specifies the equality 802 | function used to detect changes in the value of the resulting 803 | signal. This function is needed for the efficient update of 804 | signals and to deal correctly with signals that perform 805 | {{!sideeffects}side effects}. 806 | 807 | Given an equality function on a type the combinators can be automatically 808 | {{!S.special}specialized} via a functor. 809 | 810 | {3:sigcont Continuity} 811 | 812 | Ultimately signal updates depend on 813 | {{!primitives}primitives} updates. Thus a signal can 814 | only approximate a real continuous signal. The accuracy of the 815 | approximation depends on the variation rate of the real signal and 816 | the primitive's update frequency. 817 | 818 | {1:basics Basics} 819 | 820 | {2:primitives Primitive events and signals} 821 | 822 | React doesn't define primitive events and signals, they must be 823 | created and updated by the client. 824 | 825 | Primitive events are created with {!E.create}. This function 826 | returns a new event and an update function that generates an 827 | occurrence for the event at the time it is called. The following 828 | code creates a primitive integer event [x] and generates three 829 | occurrences with value [1], [2], [3]. Those occurrences are printed 830 | on stdout by the effectful event [pr_x]. 831 | {[open React;; 832 | 833 | let x, send_x = E.create () 834 | let pr_x = E.map print_int x 835 | let () = List.iter send_x [1; 2; 3]]} 836 | Primitive signals are created with {!S.create}. This function 837 | returns a new signal and an update function that sets the signal's value 838 | at the time it is called. The following code creates an 839 | integer signal [x] initially set to [1] and updates it three time with 840 | values [2], [2], [3]. The signal's values are printed on stdout by the 841 | effectful signal [pr_x]. Note that only updates that change 842 | the signal's value are printed, hence the program prints [123], not [1223]. 843 | See the discussion on 844 | {{!sideeffects}side effects} for more details. 845 | 846 | {[open React;; 847 | 848 | let x, set_x = S.create 1 849 | let pr_x = S.map print_int x 850 | let () = List.iter set_x [2; 2; 3]]} 851 | The {{!clock}clock} example shows how a realtime time 852 | flow can be defined. 853 | 854 | {2:steps Update steps} 855 | 856 | The {!E.create} and {!S.create} functions return update functions 857 | used to generate primitive event occurences and set the value of 858 | primitive signals. Upon invocation as in the preceding section 859 | these functions immediatly create and invoke an update step. 860 | The {e update step} automatically updates events and signals that 861 | transitively depend on the updated primitive. The dependents of a 862 | signal are updated iff the signal's value changed according to its 863 | {{!sigeq}equality function}. 864 | 865 | The update functions have an optional [step] argument. If they are 866 | given a concrete [step] value created with {!Step.create}, then it 867 | updates the event or signal but doesn't update its dependencies. It 868 | will only do so whenever [step] is executed with 869 | {!Step.execute}. This allows to make primitive event occurences and 870 | signal changes simultaneous. See next section for an example. 871 | 872 | {2:simultaneity Simultaneous events} 873 | 874 | {{!steps}Update steps} are made under a 875 | {{:http://dx.doi.org/10.1016/0167-6423(92)90005-V}synchrony hypothesis} : 876 | the update step takes no time, it is instantenous. Two event occurrences 877 | are {e simultaneous} if they occur in the same update step. 878 | 879 | In the code below [w], [x] and [y] will always have simultaneous 880 | occurrences. They {e may} have simulatenous occurences with [z] 881 | if [send_w] and [send_z] are used with the same update step. 882 | 883 | {[let w, send_w = E.create () 884 | let x = E.map succ w 885 | let y = E.map succ x 886 | let z, send_z = E.create () 887 | 888 | let () = 889 | let () = send_w 3 (* w x y occur simultaneously, z doesn't occur *) in 890 | let step = Step.create () in 891 | send_w ~step 3; 892 | send_z ~step 4; 893 | Step.execute step (* w x z y occur simultaneously *) 894 | ]} 895 | 896 | {2:update The update step and thread safety} 897 | 898 | {{!primitives}Primitives} are the only mean to drive the reactive 899 | system and they are entirely under the control of the client. When 900 | the client invokes a primitive's update function without the 901 | [step] argument or when it invokes {!Step.execute} on a [step] 902 | value, React performs an update step. 903 | 904 | To ensure correctness in the presence of threads, update steps 905 | must be executed in a critical section. Let uset([p]) be the set 906 | of events and signals that need to be updated whenever the 907 | primitive [p] is updated. Updating two primitives [p] and [p'] 908 | concurrently is only allowed if uset([p]) and uset([p']) are 909 | disjoint. Otherwise the updates must be properly serialized. 910 | 911 | Below, concurrent, updates to [x] and [y] must be serialized (or 912 | performed on the same step if it makes sense semantically), but z 913 | can be updated concurently to both [x] and [y]. 914 | 915 | {[open React;; 916 | 917 | let x, set_x = S.create 0 918 | let y, send_y = E.create () 919 | let z, set_z = S.create 0 920 | let max_xy = S.l2 (fun x y -> if x > y then x else y) x (S.hold 0 y) 921 | let succ_z = S.map succ z]} 922 | 923 | {2:sideeffects Side effects} 924 | 925 | Effectful events and signals perform their side effect 926 | exactly {e once} in each {{!steps}update step} in which there 927 | is an update of at least one of the event or signal it depends on. 928 | 929 | Remember that a signal updates in a step iff its 930 | {{!sigeq}equality function} determined that the signal 931 | value changed. Signal initialization is unconditionally considered as 932 | an update. 933 | 934 | It is important to keep references on effectful events and 935 | signals. Otherwise they may be reclaimed by the garbage collector. 936 | The following program prints only a [1]. 937 | {[let x, set_x = S.create 1 938 | let () = ignore (S.map print_int x) 939 | let () = Gc.full_major (); List.iter set_x [2; 2; 3]]} 940 | {2:lifting Lifting} 941 | 942 | Lifting transforms a regular function to make it act on signals. 943 | The combinators 944 | {!S.const} and {!S.app} allow to lift functions of arbitrary arity n, 945 | but this involves the inefficient creation of n-1 intermediary 946 | closure signals. The fixed arity {{!S.lifting}lifting 947 | functions} are more efficient. For example : 948 | {[let f x y = x mod y 949 | let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y (* inefficient *) 950 | let fl' x y = S.l2 f x y (* efficient *) 951 | ]} 952 | Besides, some of [Stdlib]'s functions and operators are 953 | already lifted and availables in submodules of {!S}. They can be 954 | be opened in specific scopes. For example if you are dealing with 955 | float signals you can open {!S.Float}. 956 | {[open React 957 | open React.S.Float 958 | 959 | let f t = sqrt t *. sin t (* f is defined on float signals *) 960 | ... 961 | open Stdlib (* back to Stdlib floats *) 962 | ]} 963 | If you are using OCaml 3.12 or later you can also use the [let open] 964 | construct 965 | {[let open React.S.Float in 966 | let f t = sqrt t *. sin t in (* f is defined on float signals *) 967 | ... 968 | ]} 969 | 970 | {2:recursion Mutual and self reference} 971 | 972 | Mutual and self reference among time varying values occurs naturally 973 | in programs. However a mutually recursive definition of two signals 974 | in which both need the value of the other at time t to define 975 | their value at time t has no least fixed point. To break this 976 | tight loop one signal must depend on the value the other had at time 977 | t-dt where dt is an infinitesimal delay. 978 | 979 | The fixed point combinators {!E.fix} and {!S.fix} allow to refer to 980 | the value an event or signal had an infinitesimal amount of time 981 | before. These fixed point combinators act on a function [f] that takes 982 | as argument the infinitesimally delayed event or signal that [f] 983 | itself returns. 984 | 985 | In the example below [history s] returns a signal whose value 986 | is the history of [s] as a list. 987 | {[let history ?(eq = ( = )) s = 988 | let push v = function 989 | | [] -> [ v ] 990 | | v' :: _ as l when eq v v' -> l 991 | | l -> v :: l 992 | in 993 | let define h = 994 | let h' = S.l2 push s h in 995 | h', h' 996 | in 997 | S.fix [] define]} 998 | When a program has infinitesimally delayed values a 999 | {{!primitives}primitive} may trigger more than one update 1000 | step. For example if a signal [s] is infinitesimally delayed, then 1001 | its update in a step [c] will trigger a new step [c'] at the end 1002 | of the step in which the delayed signal of [s] will have the value 1003 | [s] had in [c]. This means that the recursion occuring between a 1004 | signal (or event) and its infinitesimally delayed counterpart must 1005 | be well-founded otherwise this may trigger an infinite number 1006 | of update steps, like in the following examples. 1007 | {[let start, send_start = E.create () 1008 | let diverge = 1009 | let define e = 1010 | let e' = E.select [e; start] in 1011 | e', e' 1012 | in 1013 | E.fix define 1014 | 1015 | let () = send_start () (* diverges *) 1016 | 1017 | let diverge = (* diverges *) 1018 | let define s = 1019 | let s' = S.Int.succ s in 1020 | s', s' 1021 | in 1022 | S.fix 0 define]} 1023 | For technical reasons, delayed events and signals (those given to 1024 | fixing functions) are not allowed to directly depend on each 1025 | other. Fixed point combinators will raise [Invalid_argument] if 1026 | such dependencies are created. This limitation can be 1027 | circumvented by mapping these values with the identity. 1028 | 1029 | {2:strongstop Strong stops} 1030 | 1031 | Strong stops should only be used on platforms where weak arrays have 1032 | a strong semantics (i.e. JavaScript). You can safely ignore that 1033 | section and the [strong] argument of {!E.stop} and {!S.stop} 1034 | if that's not the case. 1035 | 1036 | Whenever {!E.stop} and {!S.stop} is called with [~strong:true] on a 1037 | reactive value [v], it is first stopped and then it walks over the 1038 | list [prods] of events and signals that it depends on and 1039 | unregisters itself from these ones as a dependent (something that is 1040 | normally automatically done when [v] is garbage collected since 1041 | dependents are stored in a weak array). Then for each element of 1042 | [prod] that has no dependents anymore and is not a primitive it 1043 | stops them aswell and recursively. 1044 | 1045 | A stop call with [~strong:true] is more involved. But it allows to 1046 | prevent memory leaks when used judiciously on the leaves of the 1047 | reactive system that are no longer used. 1048 | 1049 | {b Warning.} It should be noted that if direct references are kept 1050 | on an intermediate event or signal of the reactive system it may 1051 | suddenly stop updating if all its dependents were strongly stopped. In 1052 | the example below, [e1] will {e never} occur: 1053 | {[let e, e_send = E.create () 1054 | let e1 = E.map (fun x -> x + 1) e (* never occurs *) 1055 | let () = 1056 | let e2 = E.map (fun x -> x + 1) e1 in 1057 | E.stop ~strong:true e2 1058 | ]} 1059 | This can be side stepped by making an artificial dependency to keep 1060 | the reference: 1061 | {[let e, e_send = E.create () 1062 | let e1 = E.map (fun x -> x + 1) e (* may still occur *) 1063 | let e1_ref = E.map (fun x -> x) e1 1064 | let () = 1065 | let e2 = E.map (fun x -> x + 1) e1 in 1066 | E.stop ~strong:true e2 1067 | ]} 1068 | 1069 | {1:ex Examples} 1070 | 1071 | {2:clock Clock} 1072 | 1073 | The following program defines a primitive event [seconds] holding 1074 | the UNIX time and occuring on every second. An effectful event 1075 | converts these occurences to local time and prints them on stdout 1076 | along with an 1077 | {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm}ANSI 1078 | escape sequence} to control the cursor position. 1079 | {[let pr_time t = 1080 | let tm = Unix.localtime t in 1081 | Printf.printf "\x1B[8D%02d:%02d:%02d%!" 1082 | tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 1083 | 1084 | open React;; 1085 | 1086 | let seconds, run = 1087 | let e, send = E.create () in 1088 | let run () = 1089 | while true do send (Unix.gettimeofday ()); Unix.sleep 1 done 1090 | in 1091 | e, run 1092 | 1093 | let printer = E.map pr_time seconds 1094 | 1095 | let () = run ()]} 1096 | *) 1097 | 1098 | (*--------------------------------------------------------------------------- 1099 | Copyright (c) 2009 The react programmers 1100 | 1101 | Permission to use, copy, modify, and/or distribute this software for any 1102 | purpose with or without fee is hereby granted, provided that the above 1103 | copyright notice and this permission notice appear in all copies. 1104 | 1105 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1106 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1107 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1108 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1109 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1110 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1111 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1112 | ---------------------------------------------------------------------------*) 1113 | -------------------------------------------------------------------------------- /src/react.mllib: -------------------------------------------------------------------------------- 1 | React 2 | -------------------------------------------------------------------------------- /src/react_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let () = ignore (Toploop.use_file Format.err_formatter "react_top_init.ml") 7 | 8 | (*--------------------------------------------------------------------------- 9 | Copyright (c) 2014 The react programmers 10 | 11 | Permission to use, copy, modify, and/or distribute this software for any 12 | purpose with or without fee is hereby granted, provided that the above 13 | copyright notice and this permission notice appear in all copies. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 16 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 17 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 18 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 19 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 20 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 21 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 22 | ---------------------------------------------------------------------------*) 23 | -------------------------------------------------------------------------------- /src/react_top.mllib: -------------------------------------------------------------------------------- 1 | React_top -------------------------------------------------------------------------------- /src/react_top_init.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open React 7 | ;; 8 | 9 | 10 | 11 | (*--------------------------------------------------------------------------- 12 | Copyright (c) 2014 The react programmers 13 | 14 | Permission to use, copy, modify, and/or distribute this software for any 15 | purpose with or without fee is hereby granted, provided that the above 16 | copyright notice and this permission notice appear in all copies. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 19 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 20 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 21 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 22 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 23 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 24 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 25 | ---------------------------------------------------------------------------*) 26 | -------------------------------------------------------------------------------- /test/breakout.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2009 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Breakout clone. *) 7 | 8 | open React 9 | 10 | module Log : sig (* Logs values, signals and events to stderr. *) 11 | val init : unit -> unit 12 | val value : (Format.formatter -> 'a -> unit) -> string -> 'a -> unit 13 | val e : (Format.formatter -> 'a -> unit) -> string -> 'a event -> 'a event 14 | val s : (Format.formatter -> 'a -> unit) -> string -> 'a signal -> 'a signal 15 | end = struct 16 | let init () = 17 | let t = Unix.gettimeofday () in 18 | let tm = Unix.localtime t in 19 | Format.eprintf 20 | "\x1B[2J\x1B[H\x1B[7m@[>> %04d-%02d-%02d %02d:%02d:%02d <<@]\x1B[0m@." 21 | (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday 22 | tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 23 | 24 | let value pp name v = Format.eprintf "@[%s =@ %a@]@." name pp v 25 | let e pp name e = E.trace (value pp name) e 26 | let s pp name s = S.trace (value pp name) s 27 | end 28 | 29 | module V2 : sig (* Vectors. *) 30 | type t 31 | val v : float -> float -> t 32 | val o : t 33 | val ex : t 34 | val ey : t 35 | val x : t -> float 36 | val y : t -> float 37 | val add : t -> t -> t 38 | val sub : t -> t -> t 39 | val neg : t -> t 40 | val smul : float -> t -> t 41 | val dot : t -> t -> float 42 | val to_ints : t -> int * int 43 | val print : Format.formatter -> t -> unit 44 | end = struct 45 | type t = { x : float; y : float } 46 | let v x y = { x = x; y = y } 47 | let o = v 0. 0. 48 | let ex = v 1. 0. 49 | let ey = v 0. 1. 50 | let x p = p.x 51 | let y p = p.y 52 | let add p p' = v (p.x +. p'.x) (p.y +. p'.y) 53 | let sub p p' = v (p.x -. p'.x) (p.y -. p'.y) 54 | let neg p = v (-. p.x) (-. p.y) 55 | let smul s p = v (s *. p.x) (s *. p.y) 56 | let dot p p' = p.x *. p'.x +. p.y *. p'.y 57 | let to_ints p = (truncate p.x, truncate p.y) 58 | let print pp p = Format.fprintf pp "(%F,%F)" p.x p.y 59 | end 60 | 61 | module Rect : sig (* Rectangles. *) 62 | type t 63 | val create : V2.t -> V2.t -> t (* lower left corner and extents. *) 64 | val empty : t 65 | val o : t -> V2.t 66 | val size : t -> V2.t 67 | val xmin : t -> float 68 | val xmax : t -> float 69 | val ymin : t -> float 70 | val ymax : t -> float 71 | val print : Format.formatter -> t -> unit 72 | end = struct 73 | type t = V2.t * V2.t 74 | let create o size = o, size 75 | let empty = V2.o, V2.o 76 | let o (o, s) = o 77 | let size (_, s) = s 78 | let xmin (o, _) = V2.x o 79 | let xmax (o, s) = V2.x o +. V2.x s 80 | let ymin (o, _) = V2.y o 81 | let ymax (o, s) = V2.y o +. V2.y s 82 | let print pp (o, s) = Format.fprintf pp "%a %a" V2.print o V2.print s 83 | end 84 | 85 | module Draw : sig (* Draw with ANSI escape sequences. *) 86 | val frame : Rect.t 87 | val init : unit -> unit 88 | val clear : unit -> unit 89 | val flush : unit -> unit 90 | val text : ?center:bool -> ?color:int -> V2.t -> string -> unit 91 | val rect : ?color:int -> Rect.t -> unit 92 | val beep : unit -> unit 93 | end = struct 94 | let pr = Printf.printf 95 | let frame = Rect.create (V2.v 1. 1.) (V2.v 80. 24.) 96 | let clear () = pr "\x1B[47m\x1B[2J" 97 | let flush () = pr "%!" 98 | let reset () = clear (); pr "\x1Bc"; flush () 99 | let init () = 100 | pr "\x1B[H\x1B[7l\x1B[?25l"; clear (); flush (); 101 | at_exit (reset) 102 | 103 | let text ?(center = true) ?(color = 30) pos str = 104 | let x, y = V2.to_ints pos in 105 | let x = if center then x - (String.length str) / 2 else x in 106 | pr ("\x1B[%d;%df\x1B[47;%dm%s") y x color str 107 | 108 | let rect ?(color = 40) r = 109 | let (x, y) = V2.to_ints (Rect.o r) in 110 | let (w, h) = V2.to_ints (Rect.size r) in 111 | pr "\x1B[%dm" color; 112 | for y' = y to y + h - 1 do 113 | pr "\x1B[%d;%df" y' x; for i = 1 to w do pr " " done 114 | done 115 | 116 | let beep () = pr "\x07%!" 117 | end 118 | 119 | module Input : sig (* Keyboard and time events. *) 120 | val init : unit -> unit 121 | val time : float event (* time event. *) 122 | val key : char event (* keyboard event. *) 123 | val gather : unit -> unit 124 | end = struct 125 | let init () = (* suppress input echo and buffering. *) 126 | let reset tattr () = Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH tattr in 127 | let attr = Unix.tcgetattr Unix.stdin in 128 | let attr' = { attr with Unix.c_echo = false; c_icanon = false } in 129 | let quit _ = exit 0 in 130 | at_exit (reset attr); 131 | Unix.tcsetattr Unix.stdin Unix.TCSANOW attr'; 132 | Sys.set_signal Sys.sigquit (Sys.Signal_handle quit); 133 | Sys.set_signal Sys.sigint (Sys.Signal_handle quit); 134 | Sys.set_signal Sys.sigfpe (Sys.Signal_handle quit) 135 | 136 | let time, send_time = E.create () 137 | let key, send_key = E.create () 138 | let gather () = (* updates primitive events. *) 139 | let c = Bytes.create 1 in 140 | let i = Unix.stdin in 141 | let input_char i = ignore (Unix.read i c 0 1); Bytes.get c 0 in 142 | let dt = 0.1 in 143 | while true do 144 | if Unix.select [i] [] [] dt = ([i], [], []) then send_key (input_char i); 145 | send_time (Unix.gettimeofday ()); 146 | done 147 | end 148 | 149 | module Game : sig (* Game simulation and logic. *) 150 | type t 151 | val create : Rect.t -> float event -> [`Left | `Right ] event -> t 152 | val walls : t -> Rect.t 153 | val ball : t -> Rect.t signal 154 | val paddle : t -> Rect.t signal 155 | val bricks : t -> Rect.t list signal 156 | val brick_count : t -> int signal 157 | val collisions : t -> unit event 158 | val outcome : t -> [> `Game_over of int ] event 159 | end = struct 160 | type t = 161 | { walls : Rect.t; 162 | ball : Rect.t signal; 163 | paddle : Rect.t signal; 164 | bricks : Rect.t list signal; 165 | brick_count : int signal; 166 | collisions : unit event } 167 | 168 | (* Collisions *) 169 | 170 | let ctime c r d n = Some (n, (r -. c) /. d) 171 | let cmin c r d n = if r <= c && d < 0. then ctime c r d n else None 172 | let cmax c r d n = if r >= c && d > 0. then ctime c r d n else None 173 | let cinter cmin cmax rmin rmax d n = match d with 174 | | d when d < 0. -> 175 | if rmax -. d < cmin then None else (* moving apart. *) 176 | if rmin -. d >= cmax then 177 | if rmin <= cmax then ctime cmax rmin d n else None 178 | else Some (V2.o, 0.) (* initially overlapping. *) 179 | | d when d > 0. -> 180 | if rmin -. d > cmax then None else (* moving apart. *) 181 | if rmax -. d <= cmin then 182 | if rmax >= cmin then ctime cmin rmax d (V2.neg n) else None 183 | else Some (V2.o, 0.) (* initially overlapping. *) 184 | | _ (* d = 0. *) -> 185 | if cmax < rmin || rmax < cmin then None else Some (V2.o, 0.) 186 | 187 | let crect c r d = (* r last moved by d relatively to c. *) 188 | let inter min max c r d n = cinter (min c) (max c) (min r) (max r) d n in 189 | match inter Rect.xmin Rect.xmax c r (V2.x d) V2.ex with 190 | | None -> None 191 | | Some (_, t as x) -> 192 | match inter Rect.ymin Rect.ymax c r (V2.y d) V2.ey with 193 | | None -> None 194 | | Some (_, t' as y) -> 195 | let _, t as c = if t > t' then x else y in 196 | if t = 0. then None else Some c 197 | 198 | (* Game objects *) 199 | 200 | let moving_rect pos size = S.map (fun pos -> Rect.create pos size) pos 201 | 202 | let ball walls dt collisions = 203 | let size = V2.v 2. 1. in 204 | let x0 = 0.5 *. (Rect.xmax walls -. V2.x size) in 205 | let p0 = V2.v x0 (0.5 *. Rect.ymax walls) in 206 | let v0 = 207 | let sign = if Random.bool () then -1. else 1. in 208 | let angle = (sign *. (10. +. Random.float 60.) *. 3.14) /. 180. in 209 | let speed = 18. +. Random.float 2. in 210 | V2.v (speed *. sin angle) (speed *. cos angle) 211 | in 212 | let v = 213 | let bounce (n, _) v = V2.sub v (V2.smul (2. *. V2.dot n v) n) in 214 | S.accum (E.map bounce collisions) v0 215 | in 216 | let dp = S.sample (fun dt v -> V2.smul dt v) dt v in 217 | let p = 218 | let pos p0 = S.fold V2.add p0 dp in 219 | let adjust (_, pc) = pos pc in (* visually sufficient. *) 220 | S.switch (S.hold ~eq:( == ) (pos p0) (E.map adjust collisions)) 221 | in 222 | moving_rect p size, dp 223 | 224 | let walls walls (ball, dp) = 225 | let left = Rect.xmin walls in 226 | let right = Rect.xmax walls in 227 | let top = Rect.ymin walls in 228 | let collisions = 229 | let collide dp ball = 230 | let c = match cmin left (Rect.xmin ball) (V2.x dp) V2.ex with 231 | | Some _ as c -> c 232 | | None -> 233 | match cmax right (Rect.xmax ball) (V2.x dp) (V2.neg V2.ex) with 234 | | Some _ as c -> c 235 | | None -> cmin top (Rect.ymin ball) (V2.y dp) V2.ey 236 | in 237 | match c with 238 | | None -> None 239 | | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) 240 | in 241 | E.fmap (fun x -> x) (S.sample collide dp ball) 242 | in 243 | walls, collisions 244 | 245 | let paddle walls moves (ball, dp) = 246 | let speed = 4. in 247 | let size = V2.v 9. 1. in 248 | let xmin = Rect.xmin walls in 249 | let xmax = Rect.xmax walls -. (V2.x size) in 250 | let p0 = V2.v (0.5 *. xmax) (Rect.ymax walls -. 2.) in 251 | let control p = function 252 | | `Left -> 253 | let x' = V2.x p -. speed in 254 | if x' < xmin then V2.v xmin (V2.y p) else V2.v x' (V2.y p) 255 | | `Right -> 256 | let x' = V2.x p +. speed in 257 | if x' > xmax then V2.v xmax (V2.y p) else V2.v x' (V2.y p) 258 | in 259 | let paddle = moving_rect (S.fold control p0 moves) size in 260 | let collisions = 261 | let collide dp (ball, paddle) = match crect paddle ball dp with 262 | | None -> None 263 | | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) 264 | in 265 | E.fmap (fun x -> x) (S.sample collide dp (S.Pair.pair ball paddle)) 266 | in 267 | paddle, collisions 268 | 269 | let bricks walls (ball, dp) = 270 | let bricks0 = 271 | let size = Rect.size walls in 272 | let w = V2.x size in 273 | let h = (V2.y size) /. 4. in (* use 1/4 for bricks. *) 274 | let bw, bh = (w /. 8.), h /. 3. in 275 | let x_count = truncate (w /. bw) in 276 | let y_count = truncate (h /. bh) in 277 | let acc = ref [] in 278 | for x = 0 to x_count - 1 do 279 | for y = 0 to y_count - 1 do 280 | let x = Rect.xmin walls +. (float x) *. bw in 281 | let y = Rect.ymin walls +. 2. *. bh +. (float y) *. bh in 282 | acc := Rect.create (V2.v x y) (V2.v bw bh) :: !acc 283 | done 284 | done; 285 | !acc 286 | in 287 | let define bricks = 288 | let cresult = 289 | let collide dp (ball, bricks) = 290 | let rec aux c acc bricks ball dp = match bricks with 291 | | [] -> c, List.rev acc 292 | | b :: bricks' -> match crect b ball dp with 293 | | None -> aux c (b :: acc) bricks' ball dp 294 | | c -> aux c acc bricks' ball dp 295 | in 296 | match aux None [] bricks ball dp with 297 | | None, bl -> None, bl 298 | | Some (n, t), bl -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)),bl 299 | in 300 | S.sample collide dp (S.Pair.pair ball bricks) 301 | in 302 | let collisions = E.fmap (fun (c, _) -> c) cresult in 303 | let bricks_e = E.map (fun (_, bl) -> fun _ -> bl) cresult in 304 | let bricks' = S.accum bricks_e bricks0 in 305 | bricks', (bricks', collisions) 306 | in 307 | S.fix bricks0 define 308 | 309 | (* Game data structure, links game objects *) 310 | 311 | let create w dt moves = 312 | let define collisions = 313 | let ball = ball w dt collisions in 314 | let walls, wcollisions = walls w ball in 315 | let paddle, pcollisions = paddle w moves ball in 316 | let bricks, bcollisions = bricks w ball in 317 | let collisions' = E.select [pcollisions; wcollisions; bcollisions] in 318 | let g = 319 | { walls = walls; 320 | ball = S.dismiss collisions' Rect.empty (fst ball); 321 | paddle = paddle; 322 | bricks = bricks; 323 | brick_count = S.map List.length bricks; 324 | collisions = E.stamp collisions' () } 325 | in 326 | collisions', g 327 | in 328 | E.fix define 329 | 330 | let walls g = g.walls 331 | let ball g = g.ball 332 | let paddle g = g.paddle 333 | let bricks g = g.bricks 334 | let brick_count g = g.brick_count 335 | let collisions g = g.collisions 336 | let outcome g = (* game outcome logic. *) 337 | let no_bricks = S.map (fun l -> l = 0) g.brick_count in 338 | let miss = S.map (fun b -> Rect.ymax b >= Rect.ymax g.walls) g.ball in 339 | let game_over = S.changes (S.Bool.( || ) no_bricks miss) in 340 | S.sample (fun _ l -> `Game_over l) game_over g.brick_count 341 | end 342 | 343 | module Render = struct 344 | let str = Printf.sprintf 345 | let str_bricks count = if count = 1 then "1 brick" else str "%d bricks" count 346 | 347 | let intro title_color = (* draws the splash screen. *) 348 | let x = 0.5 *. Rect.xmax Draw.frame in 349 | let y = 0.5 *. Rect.ymax Draw.frame in 350 | Draw.clear (); 351 | Draw.text ~color:title_color (V2.v x (y -. 2.)) "BREAKOUT"; 352 | Draw.text ~color:30 (V2.v x y) 353 | "Hit 'a' and 'd' to move the paddle, 'q' to quit"; 354 | Draw.text ~color:31 (V2.v x (y +. 2.)) "Hit spacebar to start the game"; 355 | Draw.flush () 356 | 357 | let game_init m = (* draws game init message. *) 358 | let x = 0.5 *. Rect.xmax Draw.frame in 359 | let y = 0.5 *. Rect.ymax Draw.frame in 360 | Draw.text ~color:31 (V2.v x (y +. 2.)) m; 361 | Draw.flush () 362 | 363 | let game ball paddle bricks bcount = (* draws the game state. *) 364 | let bl = V2.v (Rect.xmin Draw.frame) (Rect.ymax Draw.frame -. 1.) in 365 | Draw.clear (); 366 | List.iter (Draw.rect ~color:40) bricks; 367 | Draw.rect ~color:44 paddle; 368 | Draw.rect ~color:41 ball; 369 | Draw.text ~center:false ~color:30 bl (str "%s left" (str_bricks bcount)); 370 | Draw.flush () 371 | 372 | let game_over outcome = (* draws the game over screen. *) 373 | let x = 0.5 *. Rect.xmax Draw.frame in 374 | let y = 0.5 *. Rect.ymax Draw.frame in 375 | let outcome_msg = 376 | if outcome = 0 then "Congratulations, no bricks left" else 377 | str "%s left, you can do better" (str_bricks outcome) 378 | in 379 | Draw.text ~color:34 (V2.v x (y +. 2.)) "GAME OVER"; 380 | Draw.text ~color:30 (V2.v x (y +. 4.)) outcome_msg; 381 | Draw.text ~color:31 (V2.v x (y +. 6.)) "Hit spacebar to start again"; 382 | Draw.flush () 383 | end 384 | 385 | module Ui : sig 386 | val init : unit -> unit event 387 | end = struct 388 | let key k = E.fmap (fun c -> if c = k then Some () else None) Input.key 389 | let quit () = E.once (E.stamp (key 'q') `Quit) 390 | let new_game () = E.once (E.stamp (key ' ') `Game) 391 | 392 | let wait_until ?stop e = match stop with 393 | | Some s -> E.map (fun v -> s (); v) (E.once e) 394 | | None -> E.once e 395 | 396 | let intro () = 397 | let color_swap = E.stamp Input.time (fun c -> if c = 31 then 34 else 31) in 398 | let output = S.l1 Render.intro (S.accum color_swap 34) in 399 | let stop () = S.stop output in 400 | wait_until (E.select [quit (); new_game ()]) ~stop 401 | 402 | let game () = 403 | let run = S.hold false (E.once (E.stamp (key ' ') true)) in 404 | let moves = 405 | let move = function 'a' -> Some `Left | 'd' -> Some `Right | _ -> None in 406 | E.on run (E.fmap move Input.key) 407 | in 408 | let dt = E.on run (E.diff ( -. ) Input.time) in 409 | let g = Game.create Draw.frame dt moves in 410 | let outcome = Game.outcome g in 411 | let sound = E.map Draw.beep (Game.collisions g) in 412 | let output = S.l4 Render.game (Game.ball g) (Game.paddle g) (Game.bricks g) 413 | (Game.brick_count g) 414 | in 415 | let stop () = E.stop sound; S.stop output in 416 | Render.game_init "Hit spacebar to start the game"; 417 | wait_until (E.select [quit (); outcome]) ~stop 418 | 419 | let game_over outcome = 420 | Render.game_over outcome; 421 | wait_until (E.select [quit (); new_game ()]) 422 | 423 | let init () = 424 | let define ui = 425 | let display ui = 426 | Gc.full_major (); (* cleanup game objects. *) 427 | match ui with 428 | | `Intro -> intro () 429 | | `Game -> game () 430 | | `Game_over outcome -> game_over outcome 431 | | `Quit -> exit 0 432 | in 433 | let ui' = E.switch (display `Intro) (E.map display ui) in 434 | ui', ui' 435 | in 436 | E.stamp (E.fix define) () 437 | end 438 | 439 | let main () = 440 | Random.self_init (); 441 | Log.init (); 442 | Draw.init (); 443 | Input.init (); 444 | let ui = Ui.init () in 445 | Input.gather (); 446 | ui 447 | 448 | let ui = main () (* keep a ref. to avoid g.c. *) 449 | 450 | (*---------------------------------------------------------------------------- 451 | Copyright (c) 2009 The react programmers 452 | 453 | Permission to use, copy, modify, and/or distribute this software for any 454 | purpose with or without fee is hereby granted, provided that the above 455 | copyright notice and this permission notice appear in all copies. 456 | 457 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 458 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 459 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 460 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 461 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 462 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 463 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 464 | ---------------------------------------------------------------------------*) 465 | -------------------------------------------------------------------------------- /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 React;; 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 printer = E.map pr_time seconds 17 | 18 | let () = run () 19 | -------------------------------------------------------------------------------- /test/js_hisig_test.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 10 | 11 | 14 | React higher order signals 15 | 16 | 17 | 18 |

Tab memory usage should be bounded and the step counter below 19 | should not slow down.

20 |

Steps: 0

21 | 22 | 23 | -------------------------------------------------------------------------------- /test/js_hisig_test.ml: -------------------------------------------------------------------------------- 1 | (* Test for ~strong stop, how to gc a higher-order signal *) 2 | 3 | open React 4 | 5 | let strong = true 6 | 7 | (* Artificially increase memory usage *) 8 | let high_e e = 9 | let id e = E.map (fun v -> v) e in 10 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 11 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 12 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 13 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 14 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 15 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 16 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 17 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 18 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 19 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 20 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 21 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 22 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 23 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 24 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 25 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 26 | e 27 | 28 | let counter_ui = 29 | let none () = assert false in 30 | let el = Dom_html.window ##. document ## (getElementById (Js.string "count")) in 31 | Js.Opt.get el none 32 | 33 | let count = ref 0 34 | let set_counter_ui v = 35 | counter_ui ##. innerHTML := Js.string (string_of_int v) 36 | 37 | let tick, send_tick = E.create () 38 | let ss = 39 | S.hold ~eq:( == ) 40 | (S.const 0) 41 | (E.map (fun v -> S.hold v (high_e tick)) tick) 42 | 43 | let gc_ss = S.diff (fun _ old -> S.stop ~strong:true old) ss 44 | 45 | let s = S.map (fun v -> set_counter_ui v) (S.switch ss) 46 | 47 | let rec loop () = 48 | incr count; 49 | send_tick !count; 50 | ignore (Dom_html.window ## (setTimeout (Js.wrap_callback loop) (1.))) 51 | 52 | 53 | let main _ = loop (); Js._false 54 | 55 | let () = Dom_html.window ##. onload := Dom_html.handler main 56 | -------------------------------------------------------------------------------- /test/js_test.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 10 | 11 | 14 | React strong stops 15 | 16 | 17 | 18 |

Tab memory usage should be bounded and the step counter below 19 | should not slow down.

20 |

Steps: 0

21 | 22 | 23 | -------------------------------------------------------------------------------- /test/js_test.ml: -------------------------------------------------------------------------------- 1 | (* Test for ~strong stop *) 2 | 3 | open React 4 | 5 | let strong = true 6 | 7 | (* Artificially increase memory usage *) 8 | let high_e e = 9 | let id e = E.map (fun v -> v) e in 10 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 11 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 12 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 13 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 14 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 15 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 16 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 17 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 18 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 19 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 20 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 21 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 22 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 23 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 24 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 25 | id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ 26 | e 27 | 28 | let counter_ui = 29 | let none () = assert false in 30 | let el = Dom_html.window ##. document ## (getElementById (Js.string "count")) in 31 | Js.Opt.get el none 32 | 33 | let count = ref 0 34 | let incr_counter () = 35 | incr count; 36 | counter_ui ##. innerHTML := Js.string (string_of_int !count) 37 | 38 | let tick, send_tick = E.create () 39 | 40 | let rec loop () = 41 | let ev = E.map (fun () -> incr_counter ()) (high_e tick) in 42 | send_tick (); 43 | E.stop ~strong ev; 44 | ignore (Dom_html.window ## (setTimeout (Js.wrap_callback loop) (1.))) 45 | 46 | 47 | let main _ = loop (); Js._false 48 | 49 | let () = Dom_html.window ##. onload := Dom_html.handler main 50 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2009 The react programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Tests for react'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 React;; 13 | 14 | let pp_list ppv pp l = 15 | Format.fprintf pp "@[["; 16 | List.iter (fun v -> Format.fprintf pp "%a;@ " ppv v) l; 17 | Format.fprintf pp "]@]" 18 | 19 | let pr_value pp name v = Format.printf "@[%s =@ %a@]@." name pp v 20 | let e_pr ?iff pp name e = E.trace ?iff (pr_value pp name) e 21 | let s_pr ?iff pp name s = S.trace ?iff (pr_value pp name) s 22 | 23 | (* Tests the event e has occurences occs. *) 24 | let occs ?(eq = ( = )) e occs = 25 | let occs = ref occs in 26 | let assert_occ o = match !occs with 27 | | o' :: occs' when eq o' o -> occs := occs' 28 | | _ -> assert false 29 | in 30 | E.map assert_occ e, occs 31 | 32 | (* Tests the signal s goes through vals. *) 33 | let vals ?(eq = ( = )) s vals = 34 | let vals = ref vals in 35 | let assert_val v = match !vals with 36 | | v' :: vals' when eq v' v -> vals := vals' 37 | | _ -> assert false 38 | in 39 | S.map assert_val s, vals 40 | 41 | (* Tests that we went through all vals or occs *) 42 | let empty (_, r) = assert (!r = []) 43 | 44 | (* To initialize asserts of dynamic creations. *) 45 | let assert_e_stub () = ref (occs E.never []) 46 | let assert_s_stub v = ref (vals (S.const v) [v]) 47 | 48 | (* To keep references for the g.c. (warning also stops the given nodes) *) 49 | let keep_eref e = E.stop e 50 | let keep_sref s = S.stop s 51 | 52 | (* To artificially raise the rank of events and signals *) 53 | let high_e e = 54 | let id e = E.map (fun v -> v) e in (id (id (id (id (id (id (id (id e)))))))) 55 | 56 | let high_s s = 57 | let id s = S.map (fun v -> v) s in (id (id (id (id (id (id (id (id s)))))))) 58 | 59 | (* Event tests *) 60 | 61 | let test_no_leak () = 62 | let x, send_x = E.create () in 63 | let count = ref 0 in 64 | let w = 65 | let w = Weak.create 1 in 66 | let e = E.map (fun x -> incr count) x in 67 | Weak.set w 0 (Some e); 68 | w 69 | in 70 | List.iter send_x [0; 1; 2]; 71 | Gc.full_major (); 72 | List.iter send_x [3; 4; 5]; 73 | (match Weak.get w 0 with None -> () | Some _ -> assert false); 74 | if !count > 3 then assert false else () 75 | 76 | let test_once_drop_once () = 77 | let w, send_w = E.create () in 78 | let x = E.once w in 79 | let y = E.drop_once w in 80 | let assert_x = occs x [0] in 81 | let assert_y = occs y [1; 2; 3] in 82 | let assert_dx = assert_e_stub () in 83 | let assert_dy = assert_e_stub () in 84 | let dyn () = 85 | let dx = E.once w in 86 | let dy = E.drop_once w in 87 | assert_dx := occs dx [1]; 88 | assert_dy := occs dy [2; 3] 89 | in 90 | let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in 91 | Gc.full_major (); 92 | List.iter send_w [0; 1; 2; 3]; 93 | List.iter empty [assert_x; assert_y; !assert_dx; !assert_dy]; 94 | keep_eref create_dyn 95 | 96 | let test_app () = 97 | let f x y = x + y in 98 | let w, send_w = E.create () in 99 | let x = E.map (fun w -> f w) w in 100 | let y = E.drop_once w in 101 | let z = E.app x y in 102 | let assert_z = occs z [ 2; 4; 6 ] in 103 | let assert_dz = assert_e_stub () in 104 | let dyn () = 105 | let dx = E.drop_once (E.map (fun w -> f w) w) in 106 | let dz = E.app dx y in 107 | assert_dz := occs dz [ 4; 6 ]; 108 | in 109 | let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in 110 | Gc.full_major (); 111 | List.iter send_w [0; 1; 2; 3]; 112 | List.iter empty [assert_z; !assert_dz]; 113 | keep_eref create_dyn 114 | 115 | let test_map_stamp_filter_fmap () = 116 | let v, send_v = E.create () in 117 | let w = E.map (fun s -> "z:" ^ s) v in 118 | let x = E.stamp v "bla" in 119 | let y = E.filter (fun s -> String.length s = 5) v in 120 | let z = E.fmap (fun s -> if s = "blu" then Some "hip" else None) v in 121 | let assert_w = occs w ["z:didap"; "z:dip"; "z:didop"; "z:blu"] in 122 | let assert_x = occs x ["bla"; "bla"; "bla"; "bla"] in 123 | let assert_y = occs y ["didap"; "didop"] in 124 | let assert_z = occs z ["hip"] in 125 | let assert_dw = assert_e_stub () in 126 | let assert_dx = assert_e_stub () in 127 | let assert_dy = assert_e_stub () in 128 | let assert_dz = assert_e_stub () in 129 | let dyn () = 130 | let dw = E.map (fun s -> String.length s) v in 131 | let dx = E.stamp v 4 in 132 | let dy = E.filter (fun s -> String.length s = 5) v in 133 | let dz = E.fmap (fun s -> if s = "didap" then Some "ha" else None) v in 134 | let _ = E.map (fun _ -> assert false) (E.fmap (fun _ -> None) x) in 135 | assert_dw := occs dw [5; 3; 5; 3]; 136 | assert_dx := occs dx [4; 4; 4; 4]; 137 | assert_dy := occs dy ["didap"; "didop"]; 138 | assert_dz := occs dz ["ha"]; 139 | in 140 | let create_dyn = E.map (fun v -> if v = "didap" then dyn ()) v in 141 | Gc.full_major (); 142 | List.iter send_v ["didap"; "dip"; "didop"; "blu"]; 143 | List.iter empty [assert_w; assert_x; assert_y; assert_z]; 144 | List.iter empty [!assert_dw; !assert_dx]; 145 | List.iter empty [!assert_dy; !assert_dz]; 146 | keep_eref create_dyn 147 | 148 | let test_diff_changes () = 149 | let x, send_x = E.create () in 150 | let y = E.diff ( - ) x in 151 | let z = E.changes x in 152 | let assert_y = occs y [ 0; 1; 1; 0] in 153 | let assert_z = occs z [ 1; 2; 3] in 154 | let assert_dy = assert_e_stub () in 155 | let assert_dz = assert_e_stub () in 156 | let dyn () = 157 | let dy = E.diff ( - ) x in 158 | let dz = E.changes z in 159 | assert_dy := occs dy [1; 0]; 160 | assert_dz := occs dz [2; 3]; 161 | in 162 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in 163 | Gc.full_major (); 164 | List.iter send_x [1; 1; 2; 3; 3]; 165 | List.iter empty [assert_y; assert_z; !assert_dy; !assert_dz]; 166 | keep_eref create_dyn 167 | 168 | let test_dismiss () = 169 | let x, send_x = E.create () in 170 | let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in 171 | let z = E.dismiss y x in 172 | let assert_z = occs z [1; 3; 5] in 173 | let assert_dz = assert_e_stub () in 174 | let dyn () = 175 | let dz = E.dismiss y x in 176 | assert_dz := occs dz [3; 5]; 177 | in 178 | let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in 179 | Gc.full_major (); 180 | List.iter send_x [0; 1; 2; 3; 4; 5]; 181 | List.iter empty [assert_z; !assert_dz]; 182 | keep_eref create_dyn 183 | 184 | let test_on () = 185 | let e, send_e = E.create () in 186 | let s = S.hold 0 e in 187 | let c = S.map (fun x -> x mod 2 = 0) s in 188 | let w = E.on c e in 189 | let ovals = [2; 4; 4; 6; 4] in 190 | let assert_w = occs w ovals in 191 | let assert_dw = assert_e_stub () in 192 | let assert_dhw = assert_e_stub () in 193 | let dyn () = 194 | let dw = E.on c e in 195 | let dhw = E.on (high_s c) (high_e e) in 196 | assert_dw := occs dw ovals; 197 | assert_dhw := occs dhw ovals 198 | in 199 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) e in 200 | Gc.full_major (); 201 | List.iter send_e [ 1; 3; 1; 2; 4; 4; 6; 1; 3; 4 ]; 202 | List.iter empty [assert_w; !assert_dw; !assert_dhw ]; 203 | keep_eref create_dyn 204 | 205 | let test_until () = 206 | let x, send_x = E.create () in 207 | let stop = E.filter (fun v -> v = 3) x in 208 | let e = E.until stop x in 209 | let assert_e = occs e [1; 2] in 210 | let assert_de = assert_e_stub () in 211 | let assert_de' = assert_e_stub () in 212 | let dyn () = 213 | let de = E.until stop x in 214 | let de' = E.until (E.filter (fun v -> v = 5) x) x in 215 | assert_de := occs de []; 216 | assert_de' := occs de' [3; 4] 217 | in 218 | let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in 219 | Gc.full_major (); 220 | List.iter send_x [1; 2; 3; 4; 5]; 221 | List.iter empty [assert_e; !assert_de; !assert_de']; 222 | keep_eref create_dyn 223 | 224 | let test_accum () = 225 | let f, send_f = E.create () in 226 | let a = E.accum f 0 in 227 | let assert_a = occs a [2; -1; -2] in 228 | let assert_da = assert_e_stub () in 229 | let dyn () = 230 | let da = E.accum f 0 in 231 | assert_da := occs da [1; 2]; 232 | in 233 | let create_dyn = 234 | let count = ref 0 in 235 | E.map (fun _ -> incr count; if !count = 2 then dyn ()) f 236 | in 237 | Gc.full_major (); 238 | List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; 239 | List.iter empty [assert_a; !assert_da]; 240 | keep_eref create_dyn 241 | 242 | let test_fold () = 243 | let x, send_x = E.create () in 244 | let c = E.fold ( + ) 0 x in 245 | let assert_c = occs c [1; 3; 6; 10] in 246 | let assert_dc = assert_e_stub () in 247 | let dyn () = 248 | let dc = E.fold ( + ) 0 x in 249 | assert_dc := occs dc [2; 5; 9]; 250 | in 251 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in 252 | Gc.full_major (); 253 | List.iter send_x [1; 2; 3; 4]; 254 | List.iter empty [assert_c; !assert_dc]; 255 | keep_eref create_dyn 256 | 257 | let test_select () = 258 | let w, send_w = E.create () in 259 | let x, send_x = E.create () in 260 | let y = E.map succ w in 261 | let z = E.map succ y in 262 | let tw = E.map (fun v -> `Int v) w in 263 | let tx = E.map (fun v -> `Bool v) x in 264 | let t = E.select [tw; tx] in 265 | let sy = E.select [y; z] in (* always y. *) 266 | let sz = E.select [z; y] in (* always z. *) 267 | let assert_t = occs t [ `Int 0; `Bool false; `Int 1; `Int 2; `Int 3 ] in 268 | let assert_sy = occs sy [1; 2; 3; 4] in 269 | let assert_sz = occs sz [2; 3; 4; 5] in 270 | let assert_d = assert_e_stub () in 271 | let dyn () = 272 | let d = E.select [y; w; z] in 273 | assert_d := occs d [3; 4] 274 | in 275 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) w in 276 | Gc.full_major (); 277 | send_w 0; send_x false; List.iter send_w [1; 2; 3;]; 278 | empty assert_t; List.iter empty [assert_sy; assert_sz; !assert_d]; 279 | keep_eref create_dyn 280 | 281 | let test_merge () = 282 | let w, send_w = E.create () in 283 | let x, send_x = E.create () in 284 | let y = E.map succ w in 285 | let z = E.merge (fun acc v -> v :: acc) [] [w; x; y] in 286 | let assert_z = occs z [[2; 1]; [4]; [3; 2]] in 287 | let assert_dz = assert_e_stub () in 288 | let dyn () = 289 | let dz = E.merge (fun acc v -> v :: acc) [] [y; x; w] in 290 | assert_dz := occs dz [[4]; [2; 3]] 291 | in 292 | let create_dyn = E.map (fun v -> if v = 4 then dyn ()) x in 293 | Gc.full_major (); 294 | send_w 1; send_x 4; send_w 2; 295 | List.iter empty [assert_z; !assert_dz]; 296 | keep_eref create_dyn 297 | 298 | let test_switch () = 299 | let x, send_x = E.create () in 300 | let switch e = 301 | E.fmap (fun v -> if v mod 3 = 0 then Some (E.map (( * ) v) e) else None) x 302 | in 303 | let s = E.switch x (switch x) in 304 | let hs = E.switch x (switch (high_e x)) in 305 | let assert_s = occs s [1; 2; 9; 12; 15; 36; 42; 48; 81] in 306 | let assert_hs = occs hs [1; 2; 9; 12; 15; 36; 42; 48; 81] in 307 | let assert_ds = assert_e_stub () in 308 | let assert_dhs = assert_e_stub () in 309 | let dyn () = 310 | let ds = E.switch x (switch x) in 311 | let dhs = E.switch x (switch (high_e x)) in 312 | assert_ds := occs ds [9; 12; 15; 36; 42; 48; 81]; 313 | assert_ds := occs dhs [9; 12; 15; 36; 42; 48; 81] 314 | in 315 | let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in 316 | Gc.full_major (); 317 | List.iter send_x [1; 2; 3; 4; 5; 6; 7; 8; 9]; 318 | List.iter empty [assert_s; assert_hs; !assert_ds; !assert_dhs]; 319 | keep_eref create_dyn 320 | 321 | let test_fix () = 322 | let x, send_x = E.create () in 323 | let c1 () = E.stamp x `C2 in 324 | let c2 () = E.stamp x `C1 in 325 | let loop result = 326 | let switch = function `C1 -> c1 () | `C2 -> c2 () in 327 | let switcher = E.switch (c1 ()) (E.map switch result) in 328 | switcher, switcher 329 | in 330 | let l = E.fix loop in 331 | let assert_l = occs l [`C2; `C1; `C2] in 332 | let assert_dl = assert_e_stub () in 333 | let dyn () = 334 | let dl = E.fix loop in 335 | assert_dl := occs dl [`C2; `C1]; 336 | in 337 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in 338 | Gc.full_major (); 339 | List.iter send_x [1; 2; 3]; 340 | List.iter empty [assert_l; !assert_dl]; 341 | keep_eref create_dyn 342 | 343 | let test_lifts () = 344 | let x1, send_x1 = E.create () in 345 | let x2, send_x2 = E.create () in 346 | let x3, send_x3 = E.create () in 347 | let x4, send_x4 = E.create () in 348 | let x5, send_x5 = E.create () in 349 | let x6, send_x6 = E.create () in 350 | let f1 a = 1 + a in 351 | let f2 a0 a1 = a0 + a1 in 352 | let f3 a0 a1 a2 = a0 + a1 + a2 in 353 | let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in 354 | let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in 355 | let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in 356 | let v1 = E.l1 f1 x1 in 357 | let v2 = E.l2 f2 x1 x2 in 358 | let v3 = E.l3 f3 x1 x2 x3 in 359 | let v4 = E.l4 f4 x1 x2 x3 x4 in 360 | let v5 = E.l5 f5 x1 x2 x3 x4 x5 in 361 | let v6 = E.l6 f6 x1 x2 x3 x4 x5 x6 in 362 | let a_v1 = occs v1 [2; 2; 2; 2; 2; 2;] in 363 | let a_v2 = occs v2 [ 3; 3; 3; 3; 3;] in 364 | let a_v3 = occs v3 [ 6; 6; 6; 6;] in 365 | let a_v4 = occs v4 [ 10;10;10;] in 366 | let a_v5 = occs v5 [ 15;15;] in 367 | let a_v6 = occs v6 [ 21;] in 368 | let with_step f = 369 | let s = Step.create () in 370 | f s; Step.execute s 371 | in 372 | let s1 s = send_x1 ~step:s 1 in 373 | let s2 s = s1 s; send_x2 ~step:s 2 in 374 | let s3 s = s2 s; send_x3 ~step:s 3 in 375 | let s4 s = s3 s; send_x4 ~step:s 4 in 376 | let s5 s = s4 s; send_x5 ~step:s 5 in 377 | let s6 s = s5 s; send_x6 ~step:s 6 in 378 | with_step s1; with_step s2; with_step s3; 379 | with_step s4; with_step s5; with_step s6; 380 | List.iter empty [ a_v1; a_v2; a_v3; a_v4; a_v5; a_v6;]; 381 | () 382 | 383 | let test_option () = 384 | let x, send_x = E.create () in 385 | let s, set_s = S.create 4 in 386 | let some = E.Option.some (S.changes s) in 387 | let e0 = E.Option.value x in 388 | let e1 = E.Option.value ~default:(S.const 2) x in 389 | let e2 = E.Option.value ~default:s x in 390 | let assert_some = occs some [ Some 42;] in 391 | let assert_e0 = occs e0 [1; 5; ] in 392 | let assert_e1 = occs e1 [1; 2; 5; 2] in 393 | let assert_e2 = occs e2 [1; 4; 5; 42] in 394 | send_x (Some 1); send_x None; set_s 42; 395 | send_x (Some 5); send_x None; 396 | empty assert_some; 397 | List.iter empty [ assert_e0; assert_e1; assert_e2]; 398 | () 399 | 400 | let test_events () = 401 | test_no_leak (); 402 | test_once_drop_once (); 403 | test_app (); 404 | test_map_stamp_filter_fmap (); 405 | test_diff_changes (); 406 | test_on (); 407 | test_dismiss (); 408 | test_until (); 409 | test_accum (); 410 | test_fold (); 411 | test_select (); 412 | test_merge (); 413 | test_switch (); 414 | test_fix (); 415 | test_lifts (); 416 | test_option (); 417 | () 418 | 419 | (* Signal tests *) 420 | 421 | let test_no_leak () = 422 | let x, set_x = S.create 0 in 423 | let count = ref 0 in 424 | let w = 425 | let w = Weak.create 1 in 426 | let e = S.map (fun x -> incr count) x in 427 | Weak.set w 0 (Some e); 428 | w 429 | in 430 | List.iter set_x [ 0; 1; 2]; 431 | Gc.full_major (); 432 | List.iter set_x [ 3; 4; 5]; 433 | (match Weak.get w 0 with None -> () | Some _ -> assert false); 434 | if !count > 3 then assert false else () 435 | 436 | let test_hold () = 437 | let e, send_e = E.create () in 438 | let e', send_e' = E.create () in 439 | let he = high_e e in 440 | let s = S.hold 1 e in 441 | let assert_s = vals s [1; 2; 3; 4] in 442 | let assert_ds = assert_s_stub 0 in 443 | let assert_dhs = assert_s_stub 0 in 444 | let assert_ds' = assert_s_stub 0 in 445 | let dyn () = 446 | let ds = S.hold 42 e in (* init value unused. *) 447 | let dhs = S.hold 44 he in (* init value unused. *) 448 | let ds' = S.hold 128 e' in (* init value used. *) 449 | assert_ds := vals ds [3; 4]; 450 | assert_dhs := vals dhs [3; 4]; 451 | assert_ds' := vals ds' [128; 2; 4] 452 | in 453 | let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in 454 | Gc.full_major (); 455 | List.iter send_e [ 1; 1; 1; 1; 2; 2; 2; 3; 3; 3]; 456 | List.iter send_e' [2; 4]; 457 | List.iter send_e [4; 4; 4]; 458 | List.iter empty [assert_s; !assert_ds; !assert_dhs; !assert_ds']; 459 | keep_sref create_dyn 460 | 461 | let test_app () = 462 | let f x y = x + y in 463 | let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y in 464 | let x, set_x = S.create 0 in 465 | let y, set_y = S.create 0 in 466 | let z = fl x y in 467 | let assert_z = vals z [ 0; 1; 3; 4 ] in 468 | let assert_dz = assert_s_stub 0 in 469 | let assert_dhz = assert_s_stub 0 in 470 | let dyn () = 471 | let dz = fl x y in 472 | let dhz = fl (high_s x) (high_s y) in 473 | assert_dz := vals dz [3; 4]; 474 | assert_dhz := vals dhz [3; 4]; 475 | in 476 | let create_dyn = S.map (fun v -> if v = 2 then dyn ()) y in 477 | Gc.full_major (); 478 | set_x 1; set_y 2; set_x 1; set_y 3; 479 | List.iter empty [assert_z; !assert_dz; !assert_dhz]; 480 | keep_sref create_dyn 481 | 482 | let test_map_filter_fmap () = 483 | let even x = x mod 2 = 0 in 484 | let odd x = x mod 2 <> 0 in 485 | let meven x = if even x then Some (x * 2) else None in 486 | let modd x = if odd x then Some (x * 2) else None in 487 | let double x = 2 * x in 488 | let x, set_x = S.create 1 in 489 | let x2 = S.map double x in 490 | let fe = S.filter even 56 x in 491 | let fo = S.filter odd 56 x in 492 | let fme = S.fmap meven 7 x in 493 | let fmo = S.fmap modd 7 x in 494 | let assert_x2 = vals x2 [ 2; 4; 6; 8; 10] in 495 | let assert_fe = vals fe [ 56; 2; 4;] in 496 | let assert_fo = vals fo [ 1; 3; 5] in 497 | let assert_fme = vals fme [ 7; 4; 8;] in 498 | let assert_fmo = vals fmo [ 2; 6; 10;] in 499 | let assert_dx2 = assert_s_stub 0 in 500 | let assert_dhx2 = assert_s_stub 0 in 501 | let assert_dfe = assert_s_stub 0 in 502 | let assert_dhfe = assert_s_stub 0 in 503 | let assert_dfo = assert_s_stub 0 in 504 | let assert_dhfo = assert_s_stub 0 in 505 | let assert_dfme = assert_s_stub 0 in 506 | let assert_dhfme = assert_s_stub 0 in 507 | let assert_dfmo = assert_s_stub 0 in 508 | let assert_dhfmo = assert_s_stub 0 in 509 | let dyn () = 510 | let dx2 = S.map double x in 511 | let dhx2 = S.map double (high_s x) in 512 | let dfe = S.filter even 56 x in 513 | let dhfe = S.filter even 56 (high_s x) in 514 | let dfo = S.filter odd 56 x in 515 | let dhfo = S.filter odd 56 (high_s x) in 516 | let dfme = S.fmap meven 7 x in 517 | let dhfme = S.fmap meven 7 (high_s x) in 518 | let dfmo = S.fmap modd 7 x in 519 | let dhfmo = S.fmap modd 7 (high_s x) in 520 | assert_dx2 := vals dx2 [6; 8; 10]; 521 | assert_dhx2 := vals dhx2 [6; 8; 10]; 522 | assert_dfe := vals dfe [56; 4]; 523 | assert_dhfe := vals dhfe [56; 4]; 524 | assert_dfo := vals dfo [3; 5]; 525 | assert_dhfo := vals dhfo [3; 5]; 526 | assert_dfme := vals dfme [7; 8;]; 527 | assert_dhfme := vals dhfme [7; 8;]; 528 | assert_dfmo := vals dfmo [6; 10]; 529 | assert_dhfmo := vals dhfmo [6; 10]; 530 | () 531 | in 532 | let create_dyn = S.map (fun v -> if v = 3 then dyn ()) x in 533 | Gc.full_major (); 534 | List.iter set_x [ 1; 2; 3; 4; 4; 5; 5]; 535 | List.iter empty [assert_x2; assert_fe; assert_fo; assert_fme; 536 | assert_fmo; !assert_dx2; !assert_dhx2; !assert_dfe; 537 | !assert_dhfe; !assert_dfo ; !assert_dhfo; !assert_dfme ; 538 | !assert_dhfme ; !assert_dfmo ; !assert_dhfmo ]; 539 | keep_sref create_dyn 540 | 541 | 542 | let test_diff_changes () = 543 | let e, send_e = E.create () in 544 | let s = S.hold 1 e in 545 | let d = S.diff (fun x y -> x - y) s in 546 | let c = S.changes s in 547 | let assert_dd = assert_e_stub () in 548 | let assert_dhd = assert_e_stub () in 549 | let assert_dc = assert_e_stub () in 550 | let assert_dhc = assert_e_stub () in 551 | let dyn () = 552 | let dd = S.diff (fun x y -> x - y) s in 553 | let dhd = S.diff (fun x y -> x - y) (high_s s) in 554 | let dc = S.changes s in 555 | let dhc = S.changes (high_s s) in 556 | assert_dd := occs dd [1]; 557 | assert_dhd := occs dhd [1]; 558 | assert_dc := occs dc [4]; 559 | assert_dhc := occs dhc [4] 560 | in 561 | let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in 562 | let assert_d = occs d [2; 1] in 563 | let assert_c = occs c [3; 4] in 564 | Gc.full_major (); 565 | List.iter send_e [1; 1; 3; 3; 4; 4]; 566 | List.iter empty [assert_d; assert_c; !assert_dd; !assert_dhd; !assert_dc; 567 | !assert_dhc]; 568 | keep_sref create_dyn 569 | 570 | let test_sample () = 571 | let pair v v' = v, v' in 572 | let e, send_e = E.create () in 573 | let sampler () = E.filter (fun x -> x mod 2 = 0) e in 574 | let s = S.hold 0 e in 575 | let sam = S.sample pair (sampler ()) s in 576 | let ovals = [ (2, 2); (2, 2); (4, 4); (4, 4)] in 577 | let assert_sam = occs sam ovals in 578 | let assert_dsam = assert_e_stub () in 579 | let assert_dhsam = assert_e_stub () in 580 | let dyn () = 581 | let dsam = S.sample pair (sampler ()) s in 582 | let dhsam = S.sample pair (high_e (sampler ())) (high_s s) in 583 | assert_dsam := occs dsam ovals; 584 | assert_dhsam := occs dhsam ovals 585 | in 586 | let create_dyn = S.map (fun v -> if v = 2 then dyn ()) s in 587 | Gc.full_major (); 588 | List.iter send_e [1; 1; 2; 2; 3; 3; 4; 4]; 589 | List.iter empty [assert_sam; !assert_dsam; !assert_dhsam]; 590 | keep_sref create_dyn 591 | 592 | let test_on () = 593 | let s, set_s = S.create 0 in 594 | let ce = S.map (fun x -> x mod 2 = 0) s in 595 | let co = S.map (fun x -> x mod 2 <> 0) s in 596 | let se = S.on ce 42 s in 597 | let so = S.on co 56 s in 598 | let assert_se = vals se [ 0; 2; 4; 6; 4 ] in 599 | let assert_so = vals so [ 56; 1; 3; 1; 3 ] in 600 | let assert_dse = assert_s_stub 0 in 601 | let assert_dhse = assert_s_stub 0 in 602 | let assert_dso = assert_s_stub 0 in 603 | let assert_dhso = assert_s_stub 0 in 604 | let dyn () = 605 | let dse = S.on ce 42 s in 606 | let dhse = S.on ce 42 (high_s s) in 607 | let dso = S.on co 56 s in 608 | let dhso = S.on co 56 (high_s s) in 609 | assert_dse := vals dse [6; 4]; 610 | assert_dhse := vals dhse [6; 4]; 611 | assert_dso := vals dso [56; 1; 3]; 612 | assert_dhso := vals dhso [56; 1; 3 ] 613 | in 614 | let create_dyn = S.map (fun v -> if v = 6 then dyn ()) s in 615 | Gc.full_major (); 616 | List.iter set_s [ 1; 3; 1; 2; 4; 4; 6; 1; 3; 4 ]; 617 | List.iter empty [assert_se; assert_so; !assert_dse; !assert_dhse; 618 | !assert_dso; !assert_dhso]; 619 | keep_sref create_dyn 620 | 621 | let test_dismiss () = 622 | let x, send_x = E.create () in 623 | let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in 624 | let z = S.dismiss y 4 (S.hold 44 x) in 625 | let assert_z = vals z [44; 1; 3; 5] in 626 | let assert_dz = assert_s_stub 0 in 627 | let dyn () = 628 | let dz = S.dismiss y 4 (S.hold 44 x) in 629 | assert_dz := vals dz [4; 3; 5]; 630 | in 631 | let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in 632 | Gc.full_major (); 633 | List.iter send_x [0; 1; 2; 3; 4; 5]; 634 | List.iter empty [assert_z; !assert_dz]; 635 | keep_eref create_dyn 636 | 637 | let test_accum () = 638 | let f, send_f = E.create () in 639 | let a = S.accum f 0 in 640 | let assert_a = vals a [ 0; 2; -1; -2] in 641 | let assert_da = assert_s_stub 0 in 642 | let assert_dha = assert_s_stub 0 in 643 | let dyn () = 644 | let da = S.accum f 3 in 645 | let dha = S.accum (high_e f) 3 in 646 | assert_da := vals da [-2; -4]; 647 | assert_dha := vals dha [-2; -4] 648 | in 649 | let create_dyn = 650 | let count = ref 0 in 651 | E.map (fun _ -> incr count; if !count = 2 then dyn()) f 652 | in 653 | Gc.full_major (); 654 | List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; 655 | List.iter empty [assert_a; !assert_da; !assert_dha]; 656 | keep_eref create_dyn 657 | 658 | let test_fold () = 659 | let x, send_x = E.create () in 660 | let c = S.fold ( + ) 0 x in 661 | let assert_c = vals c [ 0; 1; 3; 6; 10] in 662 | let assert_dc = assert_s_stub 0 in 663 | let assert_dhc = assert_s_stub 0 in 664 | let dyn () = 665 | let dc = S.fold ( + ) 2 x in 666 | let dhc = S.fold ( + ) 2 (high_e x) in 667 | assert_dc := vals dc [4; 7; 11]; 668 | assert_dhc := vals dhc [4; 7; 11] 669 | in 670 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in 671 | Gc.full_major (); 672 | List.iter send_x [1; 2; 3; 4]; 673 | List.iter empty [assert_c; !assert_dc; !assert_dhc ]; 674 | keep_eref create_dyn 675 | 676 | let test_merge () = 677 | let cons acc v = v :: acc in 678 | let w, set_w = S.create 0 in 679 | let x, set_x = S.create 1 in 680 | let y = S.map succ w in 681 | let z = S.map List.rev (S.merge cons [] [w; x; y]) in 682 | let assert_z = vals z [[0; 1; 1]; [1; 1; 2]; [1; 4; 2]; [2; 4; 3]] in 683 | let assert_dz = assert_s_stub [] in 684 | let assert_dhz = assert_s_stub [] in 685 | let dyn () = 686 | let dz = S.map List.rev (S.merge cons [] [w; x; y]) in 687 | let dhz = S.map List.rev (S.merge cons [] [(high_s w); x; y; S.const 2]) in 688 | assert_dz := vals dz [[1; 4; 2]; [2; 4; 3]]; 689 | assert_dhz := vals dhz [[1; 4; 2; 2]; [2; 4; 3; 2]] 690 | in 691 | let create_dyn = S.map (fun v -> if v = 4 then dyn ()) x in 692 | Gc.full_major (); 693 | set_w 1; set_x 4; set_w 2; set_w 2; 694 | List.iter empty [assert_z; !assert_dz; !assert_dhz]; 695 | keep_sref create_dyn 696 | 697 | let esswitch s es = (* Pre 1.0.0 S.switch *) 698 | S.switch (S.hold ~eq:( == ) s es) 699 | 700 | let test_switch () = 701 | let s, set_s = S.create 0 in 702 | let switch s = 703 | let map v = 704 | if v mod 3 = 0 && v <> 0 then Some (S.map (( * ) v) s) else None 705 | in 706 | S.fmap ~eq:( == ) map s s 707 | in 708 | let sw = S.switch (switch s) in 709 | let hsw = S.switch (switch (high_s s)) in 710 | let assert_sw = vals sw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in 711 | let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in 712 | let assert_dsw = assert_s_stub 0 in 713 | let assert_dhsw = assert_s_stub 0 in 714 | let dyn () = 715 | let dsw = S.switch (switch s) in 716 | let dhsw = S.switch (switch (high_s s)) in 717 | assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; 718 | assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; 719 | in 720 | let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in 721 | Gc.full_major (); 722 | List.iter set_s [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; 723 | List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; 724 | keep_sref create_dyn 725 | 726 | let test_esswitch () = 727 | let x, send_x = E.create () in 728 | let s = S.hold 0 x in 729 | let switch s = 730 | E.fmap (fun v -> if v mod 3 = 0 then Some (S.map (( * ) v) s) else None) x 731 | in 732 | let sw = esswitch s (switch s) in 733 | let hsw = esswitch s (switch (high_s s)) in 734 | let assert_sw = vals sw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in 735 | let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in 736 | let assert_dsw = assert_s_stub 0 in 737 | let assert_dhsw = assert_s_stub 0 in 738 | let dyn () = 739 | let dsw = esswitch s (switch s) in 740 | let dhsw = esswitch s (switch (high_s s)) in 741 | assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; 742 | assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; 743 | in 744 | let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in 745 | Gc.full_major (); 746 | List.iter send_x [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; 747 | List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; 748 | keep_eref create_dyn 749 | 750 | let test_switch_const () = 751 | let s, set_s = S.create 0 in 752 | let switch = S.map (fun x -> S.const x) s in 753 | let sw = S.switch switch in 754 | let assert_sw = vals sw [0; 1; 2; 3] in 755 | let assert_dsw = assert_s_stub 0 in 756 | let dyn () = 757 | let dsw = S.switch switch in 758 | assert_dsw := vals dsw [2; 3]; 759 | in 760 | let create_dyn = S.map (fun v -> if v = 2 then dyn ()) s in 761 | Gc.full_major (); 762 | List.iter set_s [0; 1; 2; 3]; 763 | List.iter empty [assert_sw; !assert_dsw ]; 764 | keep_sref create_dyn 765 | 766 | let test_esswitch_const () = 767 | let x, send_x = E.create () in 768 | let switch = E.map (fun x -> S.const x) x in 769 | let sw = esswitch (S.const 0) switch in 770 | let assert_sw = vals sw [0; 1; 2; 3] in 771 | let assert_dsw = assert_s_stub 0 in 772 | let dyn () = 773 | let dsw = esswitch (S.const 0) switch in 774 | assert_dsw := vals dsw [2; 3]; 775 | in 776 | let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in 777 | Gc.full_major (); 778 | List.iter send_x [0; 1; 2; 3]; 779 | List.iter empty [assert_sw; !assert_dsw ]; 780 | keep_eref create_dyn 781 | 782 | let test_switch1 () = (* dynamic creation depends on triggering prim. *) 783 | let x, set_x = S.create 0 in 784 | let dcount = ref 0 in 785 | let assert_d1 = assert_s_stub 0 in 786 | let assert_d2 = assert_s_stub 0 in 787 | let assert_d3 = assert_s_stub 0 in 788 | let dyn v = 789 | let d = S.map (fun x -> v * x) x in 790 | begin match !dcount with 791 | | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] 792 | | 1 -> assert_d2 := vals d [36; 42; 48; 54] 793 | | 2 -> assert_d3 := vals d [81] 794 | | _ -> assert false 795 | end; 796 | incr dcount; 797 | d 798 | in 799 | let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in 800 | let s = S.switch (S.fmap change x x) in 801 | let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in 802 | Gc.full_major (); 803 | List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; 804 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 805 | 806 | let test_esswitch1 () = 807 | let ex, send_x = E.create () in 808 | let x = S.hold 0 ex in 809 | let dcount = ref 0 in 810 | let assert_d1 = assert_s_stub 0 in 811 | let assert_d2 = assert_s_stub 0 in 812 | let assert_d3 = assert_s_stub 0 in 813 | let dyn v = 814 | let d = S.map (fun x -> v * x) x in 815 | begin match !dcount with 816 | | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] 817 | | 1 -> assert_d2 := vals d [36; 42; 48; 54] 818 | | 2 -> assert_d3 := vals d [81] 819 | | _ -> assert false 820 | end; 821 | incr dcount; 822 | d 823 | in 824 | let change x = if x mod 3 = 0 then Some (dyn x) else None in 825 | let s = esswitch x (E.fmap change (S.changes x)) in 826 | let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in 827 | Gc.full_major (); 828 | List.iter send_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; 829 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 830 | 831 | let test_switch2 () = (* test_switch1 + high rank. *) 832 | let x, set_x = S.create 0 in 833 | let high_x = high_s x in 834 | let dcount = ref 0 in 835 | let assert_d1 = assert_s_stub 0 in 836 | let assert_d2 = assert_s_stub 0 in 837 | let assert_d3 = assert_s_stub 0 in 838 | let dyn v = 839 | let d = S.map (fun x -> v * x) high_x in 840 | begin match !dcount with 841 | | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] 842 | | 1 -> assert_d2 := vals d [36; 42; 48; 54] 843 | | 2 -> assert_d3 := vals d [81] 844 | | _ -> assert false 845 | end; 846 | incr dcount; 847 | d 848 | in 849 | let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in 850 | let s = S.switch (S.fmap change x x) in 851 | let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in 852 | Gc.full_major (); 853 | List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; 854 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 855 | 856 | let test_esswitch2 () = (* test_esswitch1 + high rank. *) 857 | let ex, send_x = E.create () in 858 | let x = S.hold 0 ex in 859 | let high_x = high_s x in 860 | let dcount = ref 0 in 861 | let assert_d1 = assert_s_stub 0 in 862 | let assert_d2 = assert_s_stub 0 in 863 | let assert_d3 = assert_s_stub 0 in 864 | let dyn v = 865 | let d = S.map (fun x -> v * x) high_x in 866 | begin match !dcount with 867 | | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] 868 | | 1 -> assert_d2 := vals d [36; 42; 48; 54] 869 | | 2 -> assert_d3 := vals d [81] 870 | | _ -> assert false 871 | end; 872 | incr dcount; 873 | d 874 | in 875 | let change x = if x mod 3 = 0 then Some (dyn x) else None in 876 | let s = esswitch x (E.fmap change (S.changes x)) in 877 | let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in 878 | Gc.full_major (); 879 | List.iter send_x [1; 1; 2; 2; 3; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; 880 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 881 | 882 | let test_switch3 () = (* dynamic creation does not depend on triggering 883 | prim. *) 884 | let x, set_x = S.create 0 in 885 | let y, set_y = S.create 0 in 886 | let dcount = ref 0 in 887 | let assert_d1 = assert_s_stub 0 in 888 | let assert_d2 = assert_s_stub 0 in 889 | let assert_d3 = assert_s_stub 0 in 890 | let dyn v = 891 | let d = S.map (fun y -> v * y) y in 892 | begin match !dcount with 893 | | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] 894 | | 1 -> assert_d2 := vals d [12; 6; 12] 895 | | 2 -> assert_d3 := vals d [18] 896 | | _ -> assert false 897 | end; 898 | incr dcount; 899 | d 900 | in 901 | let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in 902 | let s = S.switch (S.fmap change y x) in 903 | let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in 904 | Gc.full_major (); 905 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; 906 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [4; 4; 5; 5; 6; 6]; 907 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; 908 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 909 | 910 | let test_esswitch3 () = (* dynamic creation does not depend on triggering 911 | prim. *) 912 | let ex, send_x = E.create () in 913 | let ey, send_y = E.create () in 914 | let x = S.hold 0 ex in 915 | let y = S.hold 0 ey in 916 | let dcount = ref 0 in 917 | let assert_d1 = assert_s_stub 0 in 918 | let assert_d2 = assert_s_stub 0 in 919 | let assert_d3 = assert_s_stub 0 in 920 | let dyn v = 921 | let d = S.map (fun y -> v * y) y in 922 | begin match !dcount with 923 | | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] 924 | | 1 -> assert_d2 := vals d [12; 6; 12] 925 | | 2 -> assert_d3 := vals d [18] 926 | | _ -> assert false 927 | end; 928 | incr dcount; 929 | d 930 | in 931 | let change x = if x mod 3 = 0 then Some (dyn x) else None in 932 | let s = esswitch y (E.fmap change (S.changes x)) in 933 | let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in 934 | Gc.full_major (); 935 | List.iter send_y [1; 1; 2; 2]; List.iter send_x [1; 1; 2; 2; 3; 3]; 936 | List.iter send_y [1; 1; 2; 2]; List.iter send_x [4; 4; 5; 5; 6; 6]; 937 | List.iter send_y [1; 1; 2; 2]; List.iter send_x [7; 7; 8; 8; 9; 9]; 938 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 939 | 940 | let test_switch4 () = (* test_switch3 + high rank. *) 941 | let x, set_x = S.create 0 in 942 | let y, set_y = S.create 0 in 943 | let dcount = ref 0 in 944 | let assert_d1 = assert_s_stub 0 in 945 | let assert_d2 = assert_s_stub 0 in 946 | let assert_d3 = assert_s_stub 0 in 947 | let dyn v = 948 | let d = S.map (fun y -> v * y) (high_s y) in 949 | begin match !dcount with 950 | | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] 951 | | 1 -> assert_d2 := vals d [12; 6; 12] 952 | | 2 -> assert_d3 := vals d [18] 953 | | _ -> assert false 954 | end; 955 | incr dcount; 956 | d 957 | in 958 | let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in 959 | let s = S.switch (S.fmap change y x) in 960 | let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in 961 | Gc.full_major (); 962 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; 963 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [4; 4; 5; 5; 6; 6]; 964 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; 965 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 966 | 967 | let test_esswitch4 () = (* test_esswitch3 + high rank. *) 968 | let ex, set_x = E.create () in 969 | let ey, set_y = E.create () in 970 | let x = S.hold 0 ex in 971 | let y = S.hold 0 ey in 972 | let dcount = ref 0 in 973 | let assert_d1 = assert_s_stub 0 in 974 | let assert_d2 = assert_s_stub 0 in 975 | let assert_d3 = assert_s_stub 0 in 976 | let dyn v = 977 | let d = S.map (fun y -> v * y) (high_s y) in 978 | begin match !dcount with 979 | | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] 980 | | 1 -> assert_d2 := vals d [12; 6; 12] 981 | | 2 -> assert_d3 := vals d [18] 982 | | _ -> assert false 983 | end; 984 | incr dcount; 985 | d 986 | in 987 | let change x = if x mod 3 = 0 then Some (dyn x) else None in 988 | let s = esswitch y (E.fmap change (S.changes x)) in 989 | let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in 990 | Gc.full_major (); 991 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; 992 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [4; 4; 5; 5; 6; 6]; 993 | List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; 994 | List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] 995 | 996 | let test_bind () = 997 | let e, set_e = E.create () in 998 | let a = S.hold 0 e in 999 | let b = S.hold 1 e in 1000 | let s, set_s = S.create true in 1001 | let next = function 1002 | | true -> b 1003 | | false -> a 1004 | in 1005 | let f = S.bind s next in 1006 | let assert_bind = vals f [1; 0; 3;] in 1007 | set_s false; 1008 | set_e 3; 1009 | set_s true; 1010 | List.iter empty [assert_bind] 1011 | 1012 | let test_dyn_bind () = (* i.e. dyn switch *) 1013 | let s1, set_s1 = S.create true in 1014 | let s2, set_s2 = S.create 1 in 1015 | let bind1 = function 1016 | | true -> 1017 | let bind2 = function 1018 | | true -> s2 1019 | | false -> S.const 2 1020 | in 1021 | S.bind s1 bind2 1022 | | false -> S.const 2 1023 | in 1024 | let s = S.bind s1 bind1 in 1025 | let assert_bind = vals s [1; 2; 1 ] in 1026 | set_s1 true; 1027 | set_s1 false; 1028 | set_s1 true; 1029 | List.iter empty [assert_bind] 1030 | 1031 | let test_dyn_bind2 () = (* i.e. dyn switch *) 1032 | let s1, set_s1 = S.create true in 1033 | let s2, set_s2 = S.create true in 1034 | let bind1 = function 1035 | | true -> 1036 | let bind2 = function 1037 | | true -> (S.map (fun _ -> 3) s1) 1038 | | false -> S.const 2 1039 | in 1040 | S.bind s2 bind2 1041 | | false -> S.const 2 1042 | in 1043 | let s = S.bind s1 bind1 in 1044 | let assert_bind = vals s [3; 2; 3 ] in 1045 | set_s1 true; 1046 | set_s1 false; 1047 | set_s1 true; 1048 | List.iter empty [assert_bind] 1049 | 1050 | let test_fix () = 1051 | let s, set_s = S.create 0 in 1052 | let history s = 1053 | let push v = function 1054 | | v' :: _ as l -> if v = v' then l else v :: l 1055 | | [] -> [ v ] 1056 | in 1057 | let define h = 1058 | let h' = S.l2 push s h in 1059 | h', (h', S.map (fun x -> x) h) 1060 | in 1061 | S.fix [] define 1062 | in 1063 | let h, hm = history s in 1064 | let assert_h = vals h [[0]; [1; 0;]; [2; 1; 0;]; [3; 2; 1; 0;]] in 1065 | let assert_hm = vals hm [[0]; [1; 0;]; [2; 1; 0]; [3; 2; 1; 0;]] in 1066 | let assert_dh = assert_s_stub [] in 1067 | let assert_dhm = assert_s_stub [] in 1068 | let assert_dhh = assert_s_stub [] in 1069 | let assert_dhhm = assert_s_stub [] in 1070 | let dyn () = 1071 | let dh, dhm = history s in 1072 | let dhh, dhhm = history (high_s s) in 1073 | assert_dh := vals dh [[1]; [2; 1]; [3; 2; 1]]; 1074 | assert_dhm := vals dhm [[]; [1]; [2; 1]; [3; 2; 1]]; 1075 | assert_dhh := vals dhh [[1]; [2; 1]; [3; 2; 1]]; 1076 | assert_dhhm := vals dhhm [[]; [1]; [2; 1]; [3; 2; 1]]; 1077 | in 1078 | let create_dyn = S.map (fun v -> if v = 1 then dyn ()) s in 1079 | Gc.full_major (); 1080 | List.iter set_s [0; 1; 1; 2; 3]; 1081 | List.iter empty [assert_h; assert_hm; !assert_dh; !assert_dhm; 1082 | !assert_dhh; !assert_dhhm]; 1083 | keep_sref create_dyn 1084 | 1085 | let test_fix' () = 1086 | let s, set_s = S.create 0 in 1087 | let f, set_f = S.create 3 in 1088 | let hs = high_s s in 1089 | let assert_cs = assert_s_stub 0 in 1090 | let assert_chs = assert_s_stub 0 in 1091 | let assert_cdhs = assert_s_stub 0 in 1092 | let assert_ss = assert_s_stub 0 in 1093 | let assert_shs = assert_s_stub 0 in 1094 | let assert_sdhs = assert_s_stub 0 in 1095 | let assert_fs = assert_s_stub 0 in 1096 | let assert_fhs = assert_s_stub 0 in 1097 | let assert_fdhs = assert_s_stub 0 in 1098 | let dyn () = 1099 | let cs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h s) in 1100 | let chs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h hs) in 1101 | let cdhs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h (high_s s)) in 1102 | let ss = S.fix 0 (fun h -> s, S.Int.( + ) h s) in 1103 | let shs = S.fix 0 (fun h -> s, S.Int.( + ) h hs) in 1104 | let sdhs = S.fix 0 (fun h -> s, S.Int.( + ) h (high_s s)) in 1105 | let fs = S.fix 0 (fun h -> f, S.Int.( + ) h s) in 1106 | let fhs = S.fix 0 (fun h -> f, S.Int.( + ) h hs) in 1107 | let fdhs = S.fix 0 (fun h -> f, S.Int.( + ) h (high_s s)) in 1108 | let cs_vals = [1; 3; 4; 5; ] in 1109 | assert_cs := vals cs cs_vals; 1110 | assert_chs := vals chs cs_vals; 1111 | assert_cdhs := vals cdhs cs_vals; 1112 | let ss_vals = [1; 2; 3; 4; 5; 6] in 1113 | assert_ss := vals ss ss_vals; 1114 | assert_shs := vals shs ss_vals; 1115 | assert_sdhs := vals sdhs ss_vals; 1116 | let fs_vals = [1; 4; 5; 6; 4 ] in 1117 | assert_fs := vals fs fs_vals; 1118 | assert_fhs := vals fhs fs_vals; 1119 | assert_fdhs := vals fdhs fs_vals; 1120 | in 1121 | let create_dyn = S.map (fun v -> if v = 1 then dyn ()) s in 1122 | Gc.full_major (); 1123 | List.iter set_s [0; 1; 1; 2; 3]; 1124 | List.iter set_f [1]; 1125 | List.iter empty [!assert_cs; !assert_chs; !assert_cdhs; 1126 | !assert_ss; !assert_shs; !assert_sdhs; 1127 | !assert_fs; !assert_fhs; !assert_fdhs]; 1128 | keep_sref create_dyn 1129 | 1130 | let test_lifters () = 1131 | let f1 a = 1 + a in 1132 | let f2 a0 a1 = a0 + a1 in 1133 | let f3 a0 a1 a2 = a0 + a1 + a2 in 1134 | let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in 1135 | let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in 1136 | let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in 1137 | let x, set_x = S.create 0 in 1138 | let x1 = S.l1 f1 x in 1139 | let x2 = S.l2 f2 x x1 in 1140 | let x3 = S.l3 f3 x x1 x2 in 1141 | let x4 = S.l4 f4 x x1 x2 x3 in 1142 | let x5 = S.l5 f5 x x1 x2 x3 x4 in 1143 | let x6 = S.l6 f6 x x1 x2 x3 x4 x5 in 1144 | let a_x1 = vals x1 [1; 2] in 1145 | let a_x2 = vals x2 [1; 3] in 1146 | let a_x3 = vals x3 [2; 6] in 1147 | let a_x4 = vals x4 [4; 12] in 1148 | let a_x5 = vals x5 [8; 24] in 1149 | let a_x6 = vals x6 [16; 48] in 1150 | let a_dx1 = assert_s_stub 0 in 1151 | let a_dx2 = assert_s_stub 0 in 1152 | let a_dx3 = assert_s_stub 0 in 1153 | let a_dx4 = assert_s_stub 0 in 1154 | let a_dx5 = assert_s_stub 0 in 1155 | let a_dx6 = assert_s_stub 0 in 1156 | let dyn () = 1157 | let dx1 = S.l1 f1 x in 1158 | let dx2 = S.l2 f2 x x1 in 1159 | let dx3 = S.l3 f3 x x1 x2 in 1160 | let dx4 = S.l4 f4 x x1 x2 x3 in 1161 | let dx5 = S.l5 f5 x x1 x2 x3 x4 in 1162 | let dx6 = S.l6 f6 x x1 x2 x3 x4 x5 in 1163 | a_dx1 := vals dx1 [2]; 1164 | a_dx2 := vals dx2 [3]; 1165 | a_dx3 := vals dx3 [6]; 1166 | a_dx4 := vals dx4 [12]; 1167 | a_dx5 := vals dx5 [24]; 1168 | a_dx6 := vals dx6 [48] 1169 | in 1170 | let create_dyn = S.map (fun v -> if v = 1 then dyn ()) x in 1171 | Gc.full_major (); 1172 | List.iter set_x [0; 1]; 1173 | List.iter empty [ a_x1; a_x2; a_x3; a_x4; a_x5; a_x6; !a_dx1; !a_dx2; !a_dx3; 1174 | !a_dx4; !a_dx5; !a_dx6 ]; 1175 | keep_sref create_dyn 1176 | 1177 | let test_option () = 1178 | let b0, set_b0 = S.create None in 1179 | let b1, set_b1 = S.create (Some 1) in 1180 | let b2 = S.const None in 1181 | let b3 = S.const (Some 3) in 1182 | let d, set_d = S.create 512 in 1183 | let dsome = S.Option.some d in 1184 | let s00 = S.Option.value ~default:(`Init (S.const 255)) b0 in 1185 | let s01 = S.Option.value ~default:(`Init (S.const 255)) b1 in 1186 | let s02 = S.Option.value ~default:(`Init (S.const 255)) b2 in 1187 | let s03 = S.Option.value ~default:(`Init (S.const 255)) b3 in 1188 | let s10 = S.Option.value ~default:(`Always (S.const 255)) b0 in 1189 | let s11 = S.Option.value ~default:(`Always (S.const 255)) b1 in 1190 | let s12 = S.Option.value ~default:(`Always (S.const 255)) b2 in 1191 | let s13 = S.Option.value ~default:(`Always (S.const 255)) b3 in 1192 | let s20 = S.Option.value ~default:(`Init d) b0 in 1193 | let s21 = S.Option.value ~default:(`Init d) b1 in 1194 | let s22 = S.Option.value ~default:(`Init d) b2 in 1195 | let s23 = S.Option.value ~default:(`Init d) b3 in 1196 | let s30 = S.Option.value ~default:(`Always d) b0 in 1197 | let s31 = S.Option.value ~default:(`Always d) b1 in 1198 | let s32 = S.Option.value ~default:(`Always d) b2 in 1199 | let s33 = S.Option.value ~default:(`Always d) b3 in 1200 | let a_dsome = vals dsome [ Some 512; Some 1024; Some 2048;] in 1201 | let a_s00 = vals s00 [255;3] in 1202 | let a_s01 = vals s01 [1;] in 1203 | let a_s02 = vals s02 [255;] in 1204 | let a_s03 = vals s03 [3;] in 1205 | let a_s10 = vals s10 [255;3;255] in 1206 | let a_s11 = vals s11 [1;255;] in 1207 | let a_s12 = vals s12 [255] in 1208 | let a_s13 = vals s13 [3] in 1209 | let a_s20 = vals s20 [512;3] in 1210 | let a_s21 = vals s21 [1;] in 1211 | let a_s22 = vals s22 [512] in 1212 | let a_s23 = vals s23 [3] in 1213 | let a_s30 = vals s30 [512;3;1024;2048] in 1214 | let a_s31 = vals s31 [1;512;1024;2048] in 1215 | let a_s32 = vals s32 [512;1024;2048] in 1216 | let a_s33 = vals s33 [3] in 1217 | set_b0 (Some 3); set_b1 None; set_d 1024; set_b0 None; set_d 2048; 1218 | empty a_dsome; 1219 | List.iter empty [ a_s00; a_s01; a_s02; a_s03; 1220 | a_s10; a_s11; a_s12; a_s13; 1221 | a_s20; a_s21; a_s22; a_s23; 1222 | a_s30; a_s31; a_s32; a_s33; ]; 1223 | () 1224 | 1225 | let test_bool () = 1226 | let s, set_s = S.create false in 1227 | let a_zedge = occs (S.Bool.(edge zero)) [] in 1228 | let a_zrise = occs (S.Bool.(rise zero)) [] in 1229 | let a_zfall = occs (S.Bool.(fall zero)) [] in 1230 | let a_sedge = occs (S.Bool.edge s) [true; false] in 1231 | let a_srise = occs (S.Bool.rise s) [()] in 1232 | let a_rfall = occs (S.Bool.fall s) [()] in 1233 | let a_flip_never = vals (S.Bool.flip false E.never) [false] in 1234 | let a_flip = vals (S.Bool.flip true (S.changes s)) [true; false; true] in 1235 | let dyn_flip = S.bind s (fun _ -> S.Bool.flip true (S.changes s)) in 1236 | let a_dyn_flip = vals dyn_flip [true] in 1237 | set_s false; set_s true; set_s true; set_s false; 1238 | List.iter empty [a_zedge; a_sedge; ]; 1239 | List.iter empty [a_zrise; a_zfall; a_srise; a_rfall ]; 1240 | List.iter empty [a_flip_never; a_flip; a_dyn_flip ]; 1241 | () 1242 | 1243 | let test_signals () = 1244 | test_no_leak (); 1245 | test_hold (); 1246 | test_app (); 1247 | test_map_filter_fmap (); 1248 | test_diff_changes (); 1249 | test_sample (); 1250 | test_on (); 1251 | test_dismiss (); 1252 | test_accum (); 1253 | test_fold (); 1254 | test_merge (); 1255 | test_switch (); 1256 | test_esswitch (); 1257 | test_switch_const (); 1258 | test_esswitch_const (); 1259 | test_switch_const (); 1260 | test_switch1 (); 1261 | test_esswitch1 (); 1262 | test_switch2 (); 1263 | test_esswitch2 (); 1264 | test_switch3 (); 1265 | test_esswitch3 (); 1266 | test_switch4 (); 1267 | test_esswitch4 (); 1268 | test_bind (); 1269 | test_dyn_bind (); 1270 | test_dyn_bind2 (); 1271 | test_fix (); 1272 | test_fix' (); 1273 | test_lifters (); 1274 | test_option (); 1275 | test_bool (); 1276 | () 1277 | 1278 | (* Test steps *) 1279 | 1280 | let test_executed_raise () = 1281 | let e, send = E.create () in 1282 | let s, set = S.create 4 in 1283 | let step = Step.create () in 1284 | Step.execute step; 1285 | (try send ~step 3; assert false with Invalid_argument _ -> ()); 1286 | (try set ~step 3; assert false with Invalid_argument _ -> ()); 1287 | (try Step.execute step; assert false with Invalid_argument _ -> ()); 1288 | () 1289 | 1290 | let test_already_scheduled_raise () = 1291 | let e, send = E.create () in 1292 | let s, set = S.create 4 in 1293 | let step = Step.create () in 1294 | let step2 = Step.create () in 1295 | send ~step 3; 1296 | (try send ~step 3; assert false with Invalid_argument _ -> ()); 1297 | (try send ~step:step2 4; assert false with Invalid_argument _ -> ()); 1298 | set ~step 5; 1299 | set ~step 5; (* doesn't raise because sig value is eq. *) 1300 | (try set ~step 6; assert false with Invalid_argument _ -> ()); 1301 | (try set ~step:step2 7; assert false with Invalid_argument _ -> ()); 1302 | () 1303 | 1304 | let test_simultaneous () = 1305 | let e1, send1 = E.create () in 1306 | let e2, send2 = E.create () in 1307 | let s1, set1 = S.create 99 in 1308 | let s2, set2 = S.create 98 in 1309 | let never = E.dismiss e1 e2 in 1310 | let assert_never = occs never [] in 1311 | let merge = E.merge (fun acc o -> o :: acc) [] [e1; e2] in 1312 | let assert_merge = occs merge [[2; 1]] in 1313 | let s1_value = S.sample (fun _ sv -> sv) e1 s1 in 1314 | let assert_s1_value = occs s1_value [ 3 ] in 1315 | let dismiss = S.dismiss e1 1 s1 in 1316 | let assert_dismiss = vals dismiss [ 99 ] in 1317 | let on = S.on (S.map (( = ) 3) s1) 0 s2 in 1318 | let assert_on_ = vals on [0; 4] in 1319 | let step = Step.create () in 1320 | send1 ~step 1; 1321 | send2 ~step 2; 1322 | set1 ~step 3; 1323 | set2 ~step 4; 1324 | Step.execute step; 1325 | empty assert_never; 1326 | empty assert_merge; 1327 | empty assert_s1_value; 1328 | empty assert_dismiss; 1329 | empty assert_on_; 1330 | () 1331 | 1332 | let test_multistep () = 1333 | let e, send = E.create () in 1334 | let s, set = S.create 0 in 1335 | let assert_e = occs e [1; 2] in 1336 | let assert_s = vals s [0; 1; 2] in 1337 | let step = Step.create () in 1338 | send ~step 1; 1339 | set ~step 1; 1340 | Step.execute step; 1341 | let step = Step.create () in 1342 | send ~step 2; 1343 | set ~step 2; 1344 | Step.execute step; 1345 | empty assert_e; 1346 | empty assert_s; 1347 | () 1348 | 1349 | let test_steps () = 1350 | test_executed_raise (); 1351 | test_already_scheduled_raise (); 1352 | test_simultaneous (); 1353 | test_multistep (); 1354 | () 1355 | 1356 | (* bug fixes *) 1357 | 1358 | let test_jake_heap_bug () = 1359 | Gc.full_major (); 1360 | let id x = x in 1361 | let a, set_a = S.create 0 in (* rank 0 *) 1362 | let _ = S.map (fun x -> if x = 2 then Gc.full_major ()) a in 1363 | let _ = 1364 | let a1 = S.map id a in 1365 | (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) 1366 | (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) 1367 | (S.l2 (fun x y -> (x + y)) a1 a) (* rank 2 *) 1368 | in 1369 | let _ = 1370 | (S.l2 (fun x y -> (x + y)) a a), (* rank 1 *) 1371 | (S.l2 (fun x y -> (x + y)) a a) (* rank 1 *) 1372 | in 1373 | let d = S.map id (S.map id (S.map (fun x -> x + 1) a)) in (* rank 3 *) 1374 | let h = S.l2 (fun x y -> x + y) a d in (* rank 4 *) 1375 | let a_h = vals h [ 1; 5 ] in 1376 | set_a 2; 1377 | empty a_h 1378 | 1379 | let test_sswitch_init_rank_bug () = 1380 | let enabled, set_enabled = S.create true in 1381 | (* let enabled = S.const true *) 1382 | let pos, set_pos = S.create () in 1383 | let down, send_down = E.create () in 1384 | let up, send_up = E.create () in 1385 | let hover enabled = match enabled with 1386 | | true -> S.map (fun a -> true) pos 1387 | | false -> S.Bool.zero 1388 | in 1389 | let used hover enabled = match enabled with 1390 | | true -> 1391 | let start = E.stamp (E.on hover down) true in 1392 | let stop = E.stamp up false in 1393 | let accum = E.select [ start; stop ] in 1394 | let s = S.hold false accum in 1395 | s 1396 | | false -> S.Bool.zero 1397 | in 1398 | let hover = S.bind enabled hover in 1399 | let used = S.switch (S.map ~eq:( == ) (used hover) enabled) in 1400 | let activates = S.changes used in 1401 | let activates' = (E.map (fun _ -> (fun _ -> ())) activates) in 1402 | let actuate = (E.app activates' up) in 1403 | let actuate_assert = occs actuate [()] in 1404 | send_down (); send_up (); empty actuate_assert 1405 | 1406 | let test_changes_end_of_step_add_bug () = 1407 | let s, set_s = S.create false in 1408 | let s1, set_s1 = S.create false in 1409 | let high_s1 = high_s s1 in 1410 | let e = S.changes s1 in 1411 | let assert_o = assert_e_stub () in 1412 | let bind = function 1413 | | true -> 1414 | let changing_rank = S.bind s @@ function 1415 | | true -> high_s1 1416 | | false -> s1 1417 | in 1418 | let o = E.l2 (fun _ _ -> ()) (S.changes changing_rank) e in 1419 | assert_o := occs o [ () ]; 1420 | S.const o 1421 | | false -> S.const E.never 1422 | in 1423 | let r = S.bind s bind in 1424 | set_s true; 1425 | set_s1 true; 1426 | List.iter empty [!assert_o;]; 1427 | keep_sref r 1428 | 1429 | let test_diff_end_of_step_add_bug () = 1430 | let s, set_s = S.create false in 1431 | let s1, set_s1 = S.create false in 1432 | let high_s1 = high_s s1 in 1433 | let e = S.changes s1 in 1434 | let assert_o = assert_e_stub () in 1435 | let bind = function 1436 | | true -> 1437 | let changing_rank = S.bind s @@ function 1438 | | true -> high_s1 1439 | | false -> s1 1440 | in 1441 | let o = E.l2 (fun _ _ -> ()) (S.diff (fun _ _ -> ()) changing_rank) e in 1442 | assert_o := occs o [ () ]; 1443 | S.const o 1444 | | false -> S.const E.never 1445 | in 1446 | let r = S.bind s bind in 1447 | set_s true; 1448 | set_s1 true; 1449 | List.iter empty [!assert_o;]; 1450 | keep_sref r 1451 | 1452 | let test_bool_rise_end_of_step_add_bug () = 1453 | let s, set_s = S.create false in 1454 | let s1, set_s1 = S.create false in 1455 | let high_s1 = high_s s1 in 1456 | let e = S.changes s1 in 1457 | let assert_o = assert_e_stub () in 1458 | let bind = function 1459 | | true -> 1460 | let changing_rank = S.bind s @@ function 1461 | | true -> high_s1 1462 | | false -> s1 1463 | in 1464 | let o = E.l2 (fun _ _ -> ()) (S.Bool.rise changing_rank) e in 1465 | assert_o := occs o [ () ]; 1466 | S.const o 1467 | | false -> S.const E.never 1468 | in 1469 | let r = S.bind s bind in 1470 | set_s true; 1471 | set_s1 true; 1472 | List.iter empty [!assert_o;]; 1473 | keep_sref r 1474 | 1475 | let test_misc () = 1476 | test_jake_heap_bug (); 1477 | test_sswitch_init_rank_bug (); 1478 | test_changes_end_of_step_add_bug (); 1479 | test_diff_end_of_step_add_bug (); 1480 | test_bool_rise_end_of_step_add_bug (); 1481 | () 1482 | 1483 | let main () = 1484 | test_events (); 1485 | test_signals (); 1486 | test_steps (); 1487 | test_misc (); 1488 | print_endline "All tests succeeded." 1489 | 1490 | let () = main () 1491 | 1492 | (*---------------------------------------------------------------------------- 1493 | Copyright (c) 2009 The react programmers 1494 | 1495 | Permission to use, copy, modify, and/or distribute this software for any 1496 | purpose with or without fee is hereby granted, provided that the above 1497 | copyright notice and this permission notice appear in all copies. 1498 | 1499 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1500 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1501 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1502 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1503 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1504 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1505 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1506 | ---------------------------------------------------------------------------*) 1507 | --------------------------------------------------------------------------------