diff -Nru react-0.9.4/CHANGES react-1.2.0/CHANGES --- react-0.9.4/CHANGES 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/CHANGES 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -v0.9.4 2012-08-05 Lausanne --------------------------- - -- OASIS 0.3.0 support. - - -v0.9.3 2012-03-17 La Forclaz (VS) ---------------------------------- - -- OASIS support. - - -v0.9.2 2010-04-25 Lausanne --------------------------- - -- Fix a bug in weak heap implementation (thanks to Jake Donham for reporting - and a discussion about the fix). - - -v0.9.1 2010-04-15 Paris ------------------------ - -- Added `E.retain` and `S.retain`. -- A few `List.map` where replaced by `List.rev_map`. -- Fixes to `breakout.ml` to make it work on vte based terminals. - - -v0.9.0 2009-01-19 Lausanne --------------------------- - -- First release. diff -Nru react-0.9.4/CHANGES.md react-1.2.0/CHANGES.md --- react-0.9.4/CHANGES.md 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/CHANGES.md 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,78 @@ + +v1.2.0 2014-08-24 Cambridge (UK) +-------------------------------- + +- Fix bug in dynamic creation of S.{diff,changes} (#8). +- Fix bug in dynamic creation of S.switch (#7). +- Add support for toplevel: automatically `open React` on `#require "react"`. +- Add `S.Bool.{flip,edge,fall,rise}`. + +v1.1.0 2014-04-27 La Forclaz (VS) +--------------------------------- + +- Fix `S.switch` rank's initialisation. +- Add `E.l{1,2,3,4,5,6}`, lifting combinators on events. +- Add `E.Option.{some,value}`. +- Add `S.{Float,Int}.{zero,one,minus_one}`. +- Add `S.Bool.{zero,one}`. +- Add `S.Option.{none,some,value}`. +- Add `{S,E}.on` equivalent to `{S,E}.when_`. +- Deprecate `{S,E}.when_` (syntax error prone). + +v1.0.1 2014-04-21 La Forclaz (VS) +--------------------------------- + +- Fix `S.bind`. +- Use package builder topkg for distribution. + +v1.0.0 2014-04-02 La Forclaz (VS) +--------------------------------- + +- OPAM friendly workflow and drop OASIS support. +- Add `S.bind`. + +The following changes are incompatible. + +- Add support for update steps, see the `React.Step` module. Allows to + specify simultaneous primitive signal updates and event occurences. + The functions returned by `{S,E}.create` now have an optional + `?step` argument; if unused the previous semantics is preserved. +- Add support for strong stops, can be used on platforms where weak + arrays are not to prevent leaks. The function `{E,S}.stop` now have + an optional `?strong` argument; if unused the previous semantics is + preserved. +- Change signature of `S.switch`. Any existing call `S.switch ~eq s es` can + be replaced by `S.(switch ~eq (hold ~eq:( == ) s es))`. + + +v0.9.4 2012-08-05 Lausanne +-------------------------- + +- OASIS 0.3.0 support. + + +v0.9.3 2012-03-17 La Forclaz (VS) +--------------------------------- + +- OASIS support. + + +v0.9.2 2010-04-25 Lausanne +-------------------------- + +- Fix a bug in weak heap implementation (thanks to Jake Donham for reporting + and a discussion about the fix). + + +v0.9.1 2010-04-15 Paris +----------------------- + +- Added `E.retain` and `S.retain`. +- A few `List.map` where replaced by `List.rev_map`. +- Fixes to `breakout.ml` to make it work on vte based terminals. + + +v0.9.0 2009-01-19 Lausanne +-------------------------- + +- First release. diff -Nru react-0.9.4/debian/changelog react-1.2.0/debian/changelog --- react-0.9.4/debian/changelog 2013-12-03 07:42:17.000000000 +0000 +++ react-1.2.0/debian/changelog 2015-11-05 15:30:48.000000000 +0000 @@ -1,3 +1,23 @@ +react (1.2.0-2build1) xenial; urgency=medium + + * No-change rebuild against ocaml 4.02. + + -- Łukasz 'sil2100' Zemczak Thu, 05 Nov 2015 09:30:48 -0600 + +react (1.2.0-2) unstable; urgency=medium + + * Bump debhelper compat level to 9 + * Bump Standards-Version to 3.9.6 + * Upload to unstable + + -- Stéphane Glondu Tue, 03 Nov 2015 16:21:30 +0100 + +react (1.2.0-1) experimental; urgency=medium + + * New upstream release + + -- Stéphane Glondu Thu, 29 Oct 2015 10:08:38 +0100 + react (0.9.4-3) unstable; urgency=low * Upload to unstable diff -Nru react-0.9.4/debian/compat react-1.2.0/debian/compat --- react-0.9.4/debian/compat 2013-07-26 19:50:58.000000000 +0000 +++ react-1.2.0/debian/compat 2015-11-03 15:22:41.000000000 +0000 @@ -1 +1 @@ -7 +9 diff -Nru react-0.9.4/debian/control react-1.2.0/debian/control --- react-0.9.4/debian/control 2013-07-26 19:51:34.000000000 +0000 +++ react-1.2.0/debian/control 2015-11-03 15:22:42.000000000 +0000 @@ -3,11 +3,12 @@ Maintainer: Debian OCaml Maintainers Uploaders: Stéphane Glondu Build-Depends: - debhelper (>= 7.0.50~), + debhelper (>= 9), dh-ocaml (>= 0.9), ocaml-findlib (>= 1.4), + opam, ocaml-nox (>= 4) -Standards-Version: 3.9.4 +Standards-Version: 3.9.6 Section: ocaml Homepage: http://erratique.ch/software/react Vcs-Browser: http://anonscm.debian.org/gitweb/?p=pkg-ocaml-maint/packages/react.git diff -Nru react-0.9.4/debian/libreact-ocaml-dev.docs react-1.2.0/debian/libreact-ocaml-dev.docs --- react-0.9.4/debian/libreact-ocaml-dev.docs 2013-07-26 19:50:58.000000000 +0000 +++ react-1.2.0/debian/libreact-ocaml-dev.docs 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -README diff -Nru react-0.9.4/debian/libreact-ocaml-dev.examples react-1.2.0/debian/libreact-ocaml-dev.examples --- react-0.9.4/debian/libreact-ocaml-dev.examples 2013-07-26 19:50:58.000000000 +0000 +++ react-1.2.0/debian/libreact-ocaml-dev.examples 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -test/*.ml diff -Nru react-0.9.4/debian/libreact-ocaml-dev.install.in react-1.2.0/debian/libreact-ocaml-dev.install.in --- react-0.9.4/debian/libreact-ocaml-dev.install.in 2013-07-26 19:50:58.000000000 +0000 +++ react-1.2.0/debian/libreact-ocaml-dev.install.in 2015-11-03 09:27:28.000000000 +0000 @@ -1,7 +1,10 @@ @OCamlStdlibDir@/react/react.mli @OCamlStdlibDir@/react/react.cmi + @OCamlStdlibDir@/react/react.cmti OPT: @OCamlStdlibDir@/react/react.cmx OPT: @OCamlStdlibDir@/react/react.cmxa OPT: @OCamlStdlibDir@/react/react.a + @OCamlStdlibDir@/react/react_top.* doc/*.html /usr/share/doc/libreact-ocaml-dev/html doc/*.css /usr/share/doc/libreact-ocaml-dev/html + usr/share/doc/react/* /usr/share/doc/libreact-ocaml-dev diff -Nru react-0.9.4/debian/rules react-1.2.0/debian/rules --- react-0.9.4/debian/rules 2013-07-26 19:50:58.000000000 +0000 +++ react-1.2.0/debian/rules 2015-11-03 15:22:41.000000000 +0000 @@ -5,37 +5,35 @@ include /usr/share/ocaml/ocamlvars.mk -OCAMLFIND_DESTDIR=$(DESTDIR)/$(OCAML_STDLIB_DIR) -export OCAMLFIND_DESTDIR +BUILD_ARGS := -%: - dh --with ocaml $@ +ifeq ($(OCAML_HAVE_OCAMLOPT),yes) + BUILD_ARGS += native=true +else + BUILD_ARGS += native=false +endif + +ifeq ($(OCAML_NATDYNLINK),yes) + BUILD_ARGS += native-dynlink=true +else + BUILD_ARGS += native-dynlink=false +endif -.PHONY: override_dh_auto_configure -override_dh_auto_configure: - ocaml setup.ml -configure --enable-tests +%: + dh $@ --with ocaml .PHONY: override_dh_auto_build override_dh_auto_build: - ocaml setup.ml -build - -.PHONY: override_dh_auto_test -override_dh_auto_test: - ocaml setup.ml -test + ocaml pkg/build.ml $(BUILD_ARGS) .PHONY: override_dh_auto_install override_dh_auto_install: - mkdir -p '$(OCAMLFIND_DESTDIR)' - ocaml setup.ml -install + opam-installer --prefix=debian/tmp --libdir=.$(OCAML_STDLIB_DIR) --docdir=usr/share/doc react.install .PHONY: override_dh_install override_dh_install: dh_install --fail-missing -.PHONY: override_dh_auto_clean -override_dh_auto_clean: - ocaml setup.ml -distclean - .PHONY: override_dh_compress override_dh_compress: dh_compress -X.ml diff -Nru react-0.9.4/doc/index_modules.html react-1.2.0/doc/index_modules.html --- react-0.9.4/doc/index_modules.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/index_modules.html 2014-08-23 23:03:35.000000000 +0000 @@ -38,6 +38,14 @@ Functor specializing the combinators for the given signal value type +
O +Option [React.S] + +Option [React.E] +
+Events with option occurences. +
+
P Pair [React.S] @@ -73,6 +81,11 @@ Specialization for booleans, integers and floats. +Step [React] +
+Update steps. +
+ \ No newline at end of file diff -Nru react-0.9.4/doc/index_types.html react-1.2.0/doc/index_types.html --- react-0.9.4/doc/index_types.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/index_types.html 2014-08-23 23:03:35.000000000 +0000 @@ -26,7 +26,17 @@ The type for signals of type 'a. +step [React] +
+The type for update steps. +
+
T +t [React.Step] +
+The type for update steps. +
+ t [React.S.EqType] t [React.S] diff -Nru react-0.9.4/doc/index_values.html react-1.2.0/doc/index_values.html --- react-0.9.4/doc/index_values.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/index_values.html 2014-08-23 23:03:35.000000000 +0000 @@ -94,7 +94,7 @@ app [React.S]
app sf s holds the value of sf applied - to the value of s, [app sf s]t + to the value of s, [app sf s]t = [sf]t [s]t.
@@ -110,6 +110,14 @@ atan2 [React.S.Float] +
B +bind [React.S.S] + +bind [React.S] +
+bind s sf is switch (map ~eq:( == ) sf s). +
+
C ceil [React.S.Float] @@ -120,7 +128,7 @@ changes [React.E]
-changes eq e is e's occurrences with occurences equal to +changes eq e is e's occurrences with occurences equal to the previous one dropped.
@@ -137,6 +145,11 @@ cosh [React.S.Float] +create [React.Step] +
+create () is a new update step. +
+ create [React.S.S] create [React.S] @@ -182,6 +195,11 @@
E +edge [React.S.Bool] +
+edge s is changes s. +
+ epsilon_float [React.S.Float] equal [React.S.EqType] @@ -198,9 +216,19 @@ equal e e' is true iff e and e' are equal. +execute [React.Step] +
+execute step executes the update step. +
+ exp [React.S.Float]
F +fall [React.S.Bool] +
+fall s is E.fmap (fun b -> if b then None else Some ()) (edge s). +
+ filter [React.S.S] filter [React.S] @@ -227,6 +255,12 @@ infinitesimal amount of time before. +flip [React.S.Bool] +
+flip b e is a signal whose boolean value flips each time + e occurs. +
+ float [React.S.Float] float_of_int [React.S.Float] @@ -266,7 +300,7 @@ hold [React.S]
-hold i e has the value of e's last occurrence or i if there +hold i e has the value of e's last occurrence or i if there wasn't any.
@@ -280,26 +314,38 @@ l1 [React.S] +l1 [React.E] + l2 [React.S.S] l2 [React.S] +l2 [React.E] + l3 [React.S.S] l3 [React.S] +l3 [React.E] + l4 [React.S.S] l4 [React.S] +l4 [React.E] + l5 [React.S.S] l5 [React.S] +l5 [React.E] + l6 [React.S.S] l6 [React.S] +l6 [React.E] + ldexp [React.S.Float] lnot [React.S.Int] @@ -330,19 +376,23 @@ merge [React.S]
merge f a sl merges the value of every signal in sl - using f and the accumulator a. + using f and the accumulator a.
merge [React.E]
merge f a el merges the simultaneous - occurrences of every event in el using f and the accumulator a. + occurrences of every event in el using f and the accumulator a.
min_float [React.S.Float] min_int [React.S.Int] +minus_one [React.S.Float] + +minus_one [React.S.Int] + mod_float [React.S.Float] modf [React.S.Float] @@ -357,14 +407,35 @@ A never occuring event. +none [React.S.Option] +
+none is S.const None. +
+ not [React.S.Bool]
O +on [React.S] +
+on c i s is the signal s whenever c is true. +
+ +on [React.E] +
+on c e is the occurrences of e when c is true. +
+ once [React.E]
once e is e with only its next occurence.
+one [React.S.Float] + +one [React.S.Int] + +one [React.S.Bool] +
P pair [React.S.Pair] @@ -383,6 +454,11 @@ returns the previously retained value. +rise [React.S.Bool] +
+rise s is E.fmap (fun b -> if b then Some () else None) (edge s). +
+
S sample [React.S]
@@ -400,6 +476,17 @@ snd [React.S.Pair] +some [React.S.Option] +
+some s is S.map ~eq (fun v -> Some v) None, where eq uses + s's equality function to test the Some v's equalities. +
+ +some [React.E.Option] +
+some e is map (fun v -> Some v) e. +
+ sqrt [React.S.Float] stamp [React.E] @@ -423,14 +510,12 @@ switch [React.S]
-switch s es is s until there is an - occurrence s' on es, s' is then used - until there is a new occurrence on es, etc.. +switch ss is the inner signal of ss.
switch [React.E]
-switch e ee is e's occurrences until there is an +switch e ee is e's occurrences until there is an occurrence e' on ee, the occurrences of e' are then used until there is a new occurrence on ee, etc..
@@ -462,24 +547,41 @@

V +value [React.S.Option] +
+value default s is s with only its Some v values. +
+ value [React.S]
value s is s's current value.
+value [React.E.Option] +
+value default e either silences None occurences if default is + unspecified or replaces them by the value of default at the occurence + time. +
+
W when_ [React.S.S] when_ [React.S]
-when_ c i s is the signal s whenever c is true. -
+ when_ [React.E]
-when_ c e is the occurrences of e when c is true. -
+ +
Z +zero [React.S.Float] + +zero [React.S.Int] + +zero [React.S.Bool] + \ No newline at end of file diff -Nru react-0.9.4/doc/React.E.html react-1.2.0/doc/React.E.html --- react-0.9.4/doc/React.E.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.E.html 2014-08-23 23:03:35.000000000 +0000 @@ -14,6 +14,8 @@ + + React.E @@ -21,30 +23,46 @@  Next

Module React.E

-
module E: sig .. end
Event combinators. + +
module E: sig .. end
+Event combinators.

Consult their semantics.
+


-

Primitive and basics


+

Primitive and basics


+ 
type 'a t = 'a React.event
-
+
The type for events with occurrences of type 'a.
-
val never : 'a React.event
+ +
val never : 'a React.event
A never occuring event. For all t, [never]t = None.
-
val create : unit -> 'a React.event * ('a -> unit)
-create () is a primitive event e and a send function. - send v generates an occurrence v of e at the time it is called - and triggers an update cycle. + +
val create : unit -> 'a React.event * (?step:React.step -> 'a -> unit)
+create () is a primitive event e and a send function. The + function send is such that: +
    +
  • send v generates an occurrence v of e at the time it is called + and triggers an update step.
    • +
  • send ~step v generates an occurence v of e on the step step + when step is executed.
    • +
  • send ~step v raises Invalid_argument if it was previously + called with a step and this step has not executed yet or if + the given step was already executed.
    • +
+

- Warning. send must not be executed inside an update cycle.
+ Warning. send must not be executed inside an update step.

-
val retain : 'a React.event -> (unit -> unit) -> [ `R of unit -> unit ]
+ +
val retain : 'a React.event -> (unit -> unit) -> [ `R of unit -> unit ]
retain e c keeps a reference to the closure c in e and returns the previously retained value. c will never be invoked. @@ -52,57 +70,69 @@ Raises. Invalid_argument on React.E.never.
-
val stop : 'a React.event -> unit
+ +
val stop : ?strong:bool -> 'a React.event -> unit
stop e stops e from occuring. It conceptually becomes - React.E.never and cannot be restarted. Allows to - disable effectful events. + React.E.never and cannot be restarted. Allows to + disable effectful events. +

+ + The strong argument should only be used on platforms + where weak arrays have a strong semantics (i.e. JavaScript). + See details.

- Note. If executed in an update cycle - the event may still occur in the cycle.
+ Note. If executed in an update step + the event may still occur in the step.

-
val equal : 'a React.event -> 'a React.event -> bool
+ +
val equal : 'a React.event -> 'a React.event -> bool
equal e e' is true iff e and e' are equal. If both events are different from React.E.never, physical equality is used.
-
val trace : ?iff:bool React.signal -> ('a -> unit) -> 'a React.event -> 'a React.event
+ +
val trace : ?iff:bool React.signal -> ('a -> unit) -> 'a React.event -> 'a React.event
trace iff tr e is e except tr is invoked with e's occurence when iff is true (defaults to S.const true). For all t where [e]t = Some v and [iff]t = true, tr is invoked with v.

-

Transforming and filtering


-
val once : 'a React.event -> 'a React.event
+

Transforming and filtering


+ +
val once : 'a React.event -> 'a React.event
once e is e with only its next occurence.
    -
  • [once e]t = Some v if [e]t = Some v and +
  • [once e]t = Some v if [e]t = Some v and [e]<t = None.
  • [once e]t = None otherwise.

-
val drop_once : 'a React.event -> 'a React.event
-drop_once e is e without its next occurrence. + +
val drop_once : 'a React.event -> 'a React.event
+drop_once e is e without its next occurrence.
    -
  • [drop_once e]t = Some v if [e]t = Some v and +
  • [drop_once e]t = Some v if [e]t = Some v and [e]<t = Some _.
  • [drop_once e]t = None otherwise.

-
val app : ('a -> 'b) React.event -> 'a React.event -> 'b React.event
+ +
val app : ('a -> 'b) React.event -> 'a React.event -> 'b React.event
app ef e occurs when both ef and e occur simultaneously. The value is ef's occurence applied to e's one.
    -
  • [app ef e]t = Some v' if [ef]t = Some f and +
  • [app ef e]t = Some v' if [ef]t = Some f and [e]t = Some v and f v = v'.
  • [app ef e]t = None otherwise.

-
val map : ('a -> 'b) -> 'a React.event -> 'b React.event
+ +
val map : ('a -> 'b) -> 'a React.event -> 'b React.event
map f e applies f to e's occurrences.
  • [map f e]t = Some (f v) if [e]t = Some v.
    • @@ -110,19 +140,22 @@

-
val stamp : 'b React.event -> 'a -> 'a React.event
+ +
val stamp : 'b React.event -> 'a -> 'a React.event
stamp e v is map (fun _ -> v) e.
-
val filter : ('a -> bool) -> 'a React.event -> 'a React.event
-filter p e are e's occurrences that satisfy p. + +
val filter : ('a -> bool) -> 'a React.event -> 'a React.event
+filter p e are e's occurrences that satisfy p.
    -
  • [filter p e]t = Some v if [e]t = Some v and - p v = true
    • +
  • [filter p e]t = Some v if [e]t = Some v and + p v = true
  • [filter p e]t = None otherwise.

-
val fmap : ('a -> 'b option) -> 'a React.event -> 'b React.event
+ +
val fmap : ('a -> 'b option) -> 'a React.event -> 'b React.event
fmap fm e are e's occurrences filtered and mapped by fm.
  • [fmap fm e]t = Some v if fm [e]t = Some v
    • @@ -130,7 +163,8 @@

-
val diff : ('a -> 'a -> 'b) -> 'a React.event -> 'b React.event
+ +
val diff : ('a -> 'a -> 'b) -> 'a React.event -> 'b React.event
diff f e occurs whenever e occurs except on the next occurence. Occurences are f v v' where v is e's current occurrence and v' the previous one. @@ -141,37 +175,45 @@
-
val changes : ?eq:('a -> 'a -> bool) -> 'a React.event -> 'a React.event
-changes eq e is e's occurrences with occurences equal to + +
val changes : ?eq:('a -> 'a -> bool) -> 'a React.event -> 'a React.event
+changes eq e is e's occurrences with occurences equal to the previous one dropped. Equality is tested with eq (defaults to structural equality).
  • [changes eq e]t = Some v if [e]t = Some v - and either [e]<t = None or [e]<t = Some v' and + and either [e]<t = None or [e]<t = Some v' and eq v v' = false.
  • [changes eq e]t = None otherwise.

-
val when_ : bool React.signal -> 'a React.event -> 'a React.event
-when_ c e is the occurrences of e when c is true. + +
val on : bool React.signal -> 'a React.event -> 'a React.event
+on c e is the occurrences of e when c is true.
    -
  • [when_ c e]t = Some v +
  • [on c e]t = Some v if [c]t = true and [e]t = Some v.
    • -
  • [when_ c e]t = None otherwise.
    • +
  • [on c e]t = None otherwise.

-
val dismiss : 'b React.event -> 'a React.event -> 'a React.event
-dismiss c e is the occurences of e except the ones when c occurs. + +
val when_ : bool React.signal -> 'a React.event -> 'a React.event
+Deprecated.Use React.E.on.
+
+ +
val dismiss : 'b React.event -> 'a React.event -> 'a React.event
+dismiss c e is the occurences of e except the ones when c occurs.
    -
  • [dimiss c e]t = Some v +
  • [dimiss c e]t = Some v if [c]t = None and [e]t = Some v.
  • [dimiss c e]t = None otherwise.

-
val until : 'a React.event -> 'b React.event -> 'b React.event
+ +
val until : 'a React.event -> 'b React.event -> 'b React.event
until c e is e's occurences until c occurs.
  • [until c e]t = Some v if [e]t = Some v and @@ -181,22 +223,24 @@

-

Accumulating


-
val accum : ('a -> 'a) React.event -> 'a -> 'a React.event
+

Accumulating


+ +
val accum : ('a -> 'a) React.event -> 'a -> 'a React.event
accum ef i accumulates a value, starting with i, using e's functional occurrences.
  • [accum ef i]t = Some (f i) if [ef]t = Some f and [ef]<t = None.
    • -
  • [accum ef i]t = Some (f acc) if [ef]t = Some f +
  • [accum ef i]t = Some (f acc) if [ef]t = Some f and [accum ef i]<t = Some acc.
  • [accum ef i] = None otherwise.

-
val fold : ('a -> 'b -> 'a) -> 'a -> 'b React.event -> 'a React.event
-fold f i e accumulates e's occurrences with f starting with i. + +
val fold : ('a -> 'b -> 'a) -> 'a -> 'b React.event -> 'a React.event
+fold f i e accumulates e's occurrences with f starting with i.
  • [fold f i e]t = Some (f i v) if [e]t = Some v and [e]<t = None.
    • @@ -207,39 +251,43 @@

-

Combining


-
val select : 'a React.event list -> 'a React.event
-select el is the occurrences of every event in el. +

Combining


+ +
val select : 'a React.event list -> 'a React.event
+select el is the occurrences of every event in el. If more than one event occurs simultaneously the leftmost is taken and the others are lost.
    -
  • [select el]t = [List.find (fun e -> [e]t +
  • [select el]t = [List.find (fun e -> [e]t <> None) el]t
  • [select el]t = None otherwise.

-
val merge : ('a -> 'b -> 'a) -> 'a -> 'b React.event list -> 'a React.event
+ +
val merge : ('a -> 'b -> 'a) -> 'a -> 'b React.event list -> 'a React.event
merge f a el merges the simultaneous - occurrences of every event in el using f and the accumulator a. + occurrences of every event in el using f and the accumulator a.

- [merge f a el]t - = List.fold_left f a (List.filter (fun o -> o <> None) - (List.map []t el)).
+ [merge f a el]t + = List.fold_left f a (List.filter (fun o -> o <> None) + (List.map []t el)).

-
val switch : 'a React.event -> 'a React.event React.event -> 'a React.event
-switch e ee is e's occurrences until there is an + +
val switch : 'a React.event -> 'a React.event React.event -> 'a React.event
+switch e ee is e's occurrences until there is an occurrence e' on ee, the occurrences of e' are then used - until there is a new occurrence on ee, etc.. + until there is a new occurrence on ee, etc..
  • [switch e ee]t = [e]t if [ee]<=t = None.
    • -
  • [switch e ee]t = [e']t if [ee]<=t - = Some e'.
    • +
  • [switch e ee]t = [e']t if [ee]<=t + = Some e'.

-
val fix : ('a React.event -> 'a React.event * 'b) -> 'b
+ +
val fix : ('a React.event -> 'a React.event * 'b) -> 'b
fix ef allows to refer to the value an event had an infinitesimal amount of time before.

@@ -252,10 +300,33 @@

  • [e]t = None if t = 0
  • [e]t = [e']t-dt otherwise
    • - +

    - Raises. Invalid_argument if e' is directly a delayed event (i.e. + Raises. Invalid_argument if e' is directly a delayed event (i.e. an event given to a fixing function).

    +
    +

    Lifting

    +

    + + Lifting combinators. For a given n the semantics is: +

      +
    • [ln f e1 ... en]t = Some (f v1 ... vn) if for all + i : [ei]t = Some vi.
      • +
    • [ln f e1 ... en]t = None otherwise.
      • +
    +
    + +
    val l1 : ('a -> 'b) -> 'a React.event -> 'b React.event
    +
    val l2 : ('a -> 'b -> 'c) -> 'a React.event -> 'b React.event -> 'c React.event
    +
    val l3 : ('a -> 'b -> 'c -> 'd) ->
           'a React.event -> 'b React.event -> 'c React.event -> 'd React.event
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e) ->
           'a React.event ->
           'b React.event -> 'c React.event -> 'd React.event -> 'e React.event
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
           'a React.event ->
           'b React.event ->
           'c React.event -> 'd React.event -> 'e React.event -> 'f React.event
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
           'a React.event ->
           'b React.event ->
           'c React.event ->
           'd React.event -> 'e React.event -> 'f React.event -> 'g React.event

    +

    Pervasives support


    + +
    module Option: sig .. end
    +Events with option occurences. +
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.E.Option.html react-1.2.0/doc/React.E.Option.html --- react-0.9.4/doc/React.E.Option.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/React.E.Option.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,40 @@ + + + + + + + + + + + +React.E.Option + + +
     Up + 
    +

    Module React.E.Option

    + +
    module Option: sig .. end
    +Events with option occurences.
    +
    +
    + +
    val some : 'a React.event -> 'a option React.event
    +some e is map (fun v -> Some v) e.
    +
    + +
    val value : ?default:'a React.signal -> 'a option React.event -> 'a React.event
    +value default e either silences None occurences if default is + unspecified or replaces them by the value of default at the occurence + time. +
      +
    • [value ~default e]t = v if [e]t = Some (Some v).
      • +
    • [value ?default:None e]t = None if [e]t = None.
      • +
    • [value ?default:(Some s) e]t = v + if [e]t = None and [s]t = v.
      • +
    +
    +
    + \ No newline at end of file diff -Nru react-0.9.4/doc/React.html react-1.2.0/doc/React.html --- react-0.9.4/doc/React.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.html 2014-08-23 23:03:35.000000000 +0000 @@ -16,11 +16,13 @@ - + + + React @@ -28,7 +30,9 @@
     Up  

    Module React

    -
    module React: sig .. end
    Declarative events and signals. + +
    module React: sig .. end
    +Declarative events and signals.

    React is a module for functional reactive programming (frp). It @@ -38,44 +42,59 @@ choose the concrete timeline.

    - Consult the semantics, the basics and - examples. Open the module to use it, this defines only two + Consult the semantics, the basics and + examples. Open the module to use it, this defines only two types and modules in your scope.

    - Release 0.9.4 - Daniel Bünzli <daniel.buenzli at erratique.ch>
    + Release 1.2.0 - Daniel Bünzli <daniel.buenzl i@erratique.ch>
    +


    -

    Interface


    +

    Interface


    + 
    type 'a event
    -
    +
    The type for events of type 'a.
    + 
    type 'a signal
    -
    +
    The type for signals of type 'a.
    + +
    type step
    +
    +The type for update steps.
    +
    + + 
    module E: sig .. end
    Event combinators.
    + 
    module S: sig .. end
    Signal combinators.
    + +
    module Step: sig .. end
    +Update steps. +

    -

    Semantics

     +

    Semantics

    - The following notations are used to give precise meaning to the - combinators. It is important to note that in these semantic + The following notations are used to give precise meaning to the + combinators. It is important to note that in these semantic descriptions the origin of time t = 0 is always fixed at the time at which the combinator creates the event or the signal and the semantics of the dependents is evaluated relative to this timeline.

    We use dt to denote an infinitesimal amount of time. -

    Events

    +

    Events

    An event is a value with discrete occurrences over time. @@ -93,26 +112,26 @@ event before (resp. before or at) t. More precisely :

    • [e]<t = [e]t' with t' the greatest t' < t - (resp. <=) such that + (resp. <=) such that [e]t' <> None.
    • [e]<t = None if there is no such t'.

    -

    Signals

    +

    Signals

    A signal is a value that varies continuously over time. In - contrast to events which occur at specific point + contrast to events which occur at specific point in time, a signal has a value at every point in time.

    The semantic function [] : 'a signal -> time -> 'a gives meaning to a signal s by mapping it to a function of time - [s] that returns its value at a given time. We write [s]t + [s] that returns its value at a given time. We write [s]t the evaluation of this semantic function at time t. -

    Equality

    +

    Equality

    Most signal combinators have an optional eq parameter that @@ -120,25 +139,27 @@ function used to detect changes in the value of the resulting signal. This function is needed for the efficient update of signals and to deal correctly with signals that perform - side effects. + side effects.

    Given an equality function on a type the combinators can be automatically specialized via a functor. -

    Continuity

    +

    + +

    Continuity

    Ultimately signal updates depend on - primitive updates. Thus a signal can + primitives updates. Thus a signal can only approximate a real continuous signal. The accuracy of the approximation depends on the variation rate of the real signal and the primitive's update frequency.

    -

    Basics

    +

    Basics

    -

    Primitive events and signals

    +

    Primitive events and signals

    React doesn't define primitive events and signals, they must be @@ -150,42 +171,91 @@ occurrence for the event at the time it is called. The following code creates a primitive integer event x and generates three occurrences with value 1, 2, 3. Those occurrences are printed - on stdout by the effectful event pr_x. open React;;
    + on stdout by the effectful event pr_x. 

    open React;;
    
 
    
 let x, send_x = E.create ()
    
 let pr_x = E.map print_int x
    
-let () = List.iter send_x [1; 2; 3]    
+let () = List.iter send_x [1; 2; 3]
    Primitive signals are created with React.S.create. This function returns a new signal and an update function that sets the signal's value at the time it is called. The following code creates an - integer signal x initially set to 1 and updates it three time with - values 2, 2, 3. The signal's values are printed on stdout by the + integer signal x initially set to 1 and updates it three time with + values 2, 2, 3. The signal's values are printed on stdout by the effectful signal pr_x. Note that only updates that change the signal's value are printed, hence the program prints 123, not 1223. - See the discussion on - side effects for more details. -open React;;
    + See the discussion on + side effects for more details. +

    + +

    open React;;
    
 
    
 let x, set_x = S.create 1
    
 let pr_x = S.map print_int x
    
-let () = List.iter set_x [2; 2; 3]    
-    The clock example shows how a realtime time 
+let () = List.iter set_x [2; 2; 3]
    + The clock example shows how a realtime time flow can be defined.

    -

    The update cycle and thread safety

    +

    Update steps

    +

    + + The React.E.create and React.S.create functions return update functions + used to generate primitive event occurences and set the value of + primitive signals. Upon invocation as in the preceding section + these functions immediatly create and invoke an update step. + The update step automatically updates events and signals that + transitively depend on the updated primitive. The dependents of a + signal are updated iff the signal's value changed according to its + equality function. +

    + + The update functions have an optional step argument. If they are + given a concrete step value created with React.Step.create, then it + updates the event or signal but doesn't update its dependencies. It + will only do so whenever step is executed with + React.Step.execute. This allows to make primitive event occurences and + signal changes simultaneous. See next section for an example. +

    + +

    Simultaneous events

    +

    + + Update steps are made under a + synchrony hypothesis : + the update step takes no time, it is instantenous. Two event occurrences + are simultaneous if they occur in the same update step. +

    + + In the code below w, x and y will always have simultaneous + occurrences. They may have simulatenous occurences with z + if send_w and send_z are used with the same update step. +

    + +

    let w, send_w = E.create ()
    
+let x = E.map succ w
    
+let y = E.map succ x
    
+let z, send_z = E.create ()
    
+
    
+let () =
    
+  let () = send_w 3 (* w x y occur simultaneously, z doesn't occur *) in
    
+  let step = Step.create () in
    
+  send_w ~step 3;
    
+  send_z ~step 4;
    
+  Step.execute step (* w x z y occur simultaneously *)
    
+

    - Primitives are the only mean to drive the reactive +

    The update step and thread safety

    +

    + + Primitives are the only mean to drive the reactive system and they are entirely under the control of the client. When - the client invokes a primitive's update function, React performs - an update cycle. The update cycle automatically updates events and - signals that transitively depend on the updated primitive. The - dependents of a signal are updated iff the signal's value changed - according to its equality function. + the client invokes a primitive's update function without the + step argument or when it invokes React.Step.execute on a step + value, React performs an update step.

    - To ensure correctness in the presence of threads, update cycles + To ensure correctness in the presence of threads, update steps must be executed in a critical section. Let uset(p) be the set of events and signals that need to be updated whenever the primitive p is updated. Updating two primitives p and p' @@ -193,57 +263,41 @@ disjoint. Otherwise the updates must be properly serialized.

    - Below updates to x and y must be serialized, but z can - be updated concurently to both x and y. -open React;;
    + Below, concurrent, updates to x and y must be serialized (or + performed on the same step if it makes sense semantically), but z + can be updated concurently to both x and y. +

    + +

    open React;;
    
 
    
 let x, set_x = S.create 0
    
 let y, send_y = E.create ()
    
 let z, set_z = S.create 0
    
 let max_xy = S.l2 (fun x y -> if x > y then x else y) x (S.hold 0 y)
    
-let succ_z = S.map succ z    
-    
    Simultaneous events
    
-
    
-
-    Update cycles are made under a 
-    synchrony hypothesis :
-    the update cycle takes no time, it is instantenous. 
+let succ_z = S.map succ z

    - Two event occurrences are simultaneous if they occur in the - same update cycle; in other words if there exists a primitive on - which they both depend. By definition a primitive doesn't depend - on any primitive it is therefore impossible for two primitive - events to occur simultaneously. -

    - - In the code below w, x and y will have simultaneous occurrences while - z will never have simultaneous occurrences with them. -let w, send_w = E.create ()
    -let x = E.map succ w
    -let y = E.map succ x
    -let z, send_z = E.create ()     -

    Side effects

    +

    Side effects

    Effectful events and signals perform their side effect - exactly once in each update cycle in which there + exactly once in each update step in which there is an update of at least one of the event or signal it depends on.

    - Remember that a signal updates in a cycle iff its - equality function determined that the signal - value changed. Signal initialization is unconditionally considered as - an update. + Remember that a signal updates in a step iff its + equality function determined that the signal + value changed. Signal initialization is unconditionally considered as + an update.

    It is important to keep references on effectful events and signals. Otherwise they may be reclaimed by the garbage collector. The following program prints only a 1. -let x, set_x = S.create 1
    +

    let x, set_x = S.create 1
    
 let () = ignore (S.map print_int x)
    
-let () = Gc.full_major (); List.iter set_x [2; 2; 3]    
-    
    Lifting
    
+let () = Gc.full_major (); List.iter set_x [2; 2; 3]
    +

    Lifting

    Lifting transforms a regular function to make it act on signals. @@ -252,30 +306,30 @@ but this involves the inefficient creation of n-1 intermediary closure signals. The fixed arity lifting functions are more efficient. For example : -let f x y = x mod y
    +

    let f x y = x mod y
    
 let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y (* inefficient *)
    
 let fl' x y = S.l2 f x y                            (* efficient *)
    
-    
+
    Besides, some of Pervasives's functions and operators are already lifted and availables in submodules of React.S. They can be be opened in specific scopes. For example if you are dealing with - float signals you can open React.S.Float. -open React 
    -open React.S.Float 
    + float signals you can open React.S.Float. +
    open React
    
+open React.S.Float
    
 
    
 let f t = sqrt t *. sin t (* f is defined on float signals *)
    
 ...
    
 open Pervasives (* back to pervasives floats *)
    
-    
+
    If you are using OCaml 3.12 or later you can also use the let open - construct -let open React.S.Float in 
    + construct +
    let open React.S.Float in
    
 let f t = sqrt t *. sin t in (* f is defined on float signals *)
    
 ...
    
-    
+

    -

    Mutual and self reference

    +

    Mutual and self reference

    Mutual and self reference among time varying values occurs naturally @@ -293,55 +347,100 @@ itself returns.

    - In the example below history s returns a signal whose value - is the history of s as a list. -let history ?(eq = ( = )) s = 
    -  let push v = function 
    -    | [] -> [ v ] 
    + In the example below history s returns a signal whose value + is the history of s as a list. +

    let history ?(eq = ( = )) s =
    
+  let push v = function
    
+    | [] -> [ v ]
    
     | v' :: _ as l when eq v v' -> l
    
-    | l -> v :: l  
    
+    | l -> v :: l
    
   in
    
-  let define h = 
    
-    let h' = S.l2 push s h in 
    
+  let define h =
    
+    let h' = S.l2 push s h in
    
     h', h'
    
   in
    
-  S.fix [] define    
+  S.fix [] define
    When a program has infinitesimally delayed values a - primitive may trigger more than one update - cycle. For example if a signal s is infinitesimally delayed, then - its update in a cycle c will trigger a new cycle c' at the end - of the cycle in which the delayed signal of s will have the value + primitive may trigger more than one update + step. For example if a signal s is infinitesimally delayed, then + its update in a step c will trigger a new step c' at the end + of the step in which the delayed signal of s will have the value s had in c. This means that the recursion occuring between a signal (or event) and its infinitesimally delayed counterpart must be well-founded otherwise this may trigger an infinite number - of update cycles, like in the following examples. -let start, send_start = E.create ()
    -let diverge = 
    -  let define e = 
    -    let e' = E.select [e; start] in 
    + of update steps, like in the following examples. +
    let start, send_start = E.create ()
    
+let diverge =
    
+  let define e =
    
+    let e' = E.select [e; start] in
    
     e', e'
    
   in
    
   E.fix define
    
-    
    
+
    
 let () = send_start ()        (* diverges *)
    
-  
    
+
    
 let diverge =                 (* diverges *)
    
-  let define s = 
    
+  let define s =
    
     let s' = S.Int.succ s in
    
     s', s'
    
   in
    
-  S.fix 0 define    
+  S.fix 0 define
    For technical reasons, delayed events and signals (those given to fixing functions) are not allowed to directly depend on each other. Fixed point combinators will raise Invalid_argument if such dependencies are created. This limitation can be - circumvented by mapping these values with the identity. + circumvented by mapping these values with the identity. +

    + +

    Strong stops

    +

    + + Strong stops should only be used on platforms where weak arrays have + a strong semantics (i.e. JavaScript). You can safely ignore that + section and the strong argument of React.E.stop and React.S.stop + if that's not the case. +

    + + Whenever React.E.stop and React.S.stop is called with ~strong:true on a + reactive value v, it is first stopped and then it walks over the + list prods of events and signals that it depends on and + unregisters itself from these ones as a dependent (something that is + normally automatically done when v is garbage collected since + dependents are stored in a weak array). Then for each element of + prod that has no dependents anymore and is not a primitive it + stops them aswell and recursively. +

    + + A stop call with ~strong:true is more involved. But it allows to + prevent memory leaks when used judiciously on the leaves of the + reactive system that are no longer used. +

    + + Warning. It should be noted that if direct references are kept + on an intermediate event or signal of the reactive system it may + suddenly stop updating if all its dependents were strongly stopped. In + the example below, e1 will never occur: +

    let e, e_send = E.create ()
    
+let e1 = E.map (fun x -> x + 1) e (* never occurs *)
    
+let () =
    
+  let e2 = E.map (fun x -> x + 1) e1 in
    
+  E.stop ~strong:true e2
    
+
    + This can be side stepped by making an artificial dependency to keep + the reference: +
    let e, e_send = E.create ()
    
+let e1 = E.map (fun x -> x + 1) e (* may still occur *)
    
+let e1_ref = E.map (fun x -> x) e1
    
+let () =
    
+  let e2 = E.map (fun x -> x + 1) e1 in
    
+  E.stop ~strong:true e2
    
+

    -

    Examples

    +

    Examples

    -

    Clock

    +

    Clock

    The following program defines a primitive event seconds holding @@ -350,21 +449,21 @@ along with an ANSI escape sequence to control the cursor position. -let pr_time t = 
    +

    let pr_time t =
    
   let tm = Unix.localtime t in
    
-  Printf.printf "\x1B[8D%02d:%02d:%02d%!" 
    
+  Printf.printf "\x1B[8D%02d:%02d:%02d%!"
    
     tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
    
 
    
 open React;;
    
 
    
-let seconds, run = 
    
+let seconds, run =
    
   let e, send = E.create () in
    
-  let run () = 
    
+  let run () =
    
     while true do send (Unix.gettimeofday ()); Unix.sleep 1 done
    
   in
    
   e, run
    
 
    
 let printer = E.map pr_time seconds
    
 
    
-let () = run ()
    
+let () = run ()

    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Bool.html react-1.2.0/doc/React.S.Bool.html --- react-0.9.4/doc/React.S.Bool.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Bool.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,5 +17,35 @@  Next

    Module React.S.Bool

    + 
    module Bool: sig .. end
    -
    val not : bool React.signal -> bool React.signal
    val (&&) : bool React.signal -> bool React.signal -> bool React.signal
    val (||) : bool React.signal -> bool React.signal -> bool React.signal
    \ No newline at end of file + +
    val zero : bool React.signal
    +
    val one : bool React.signal
    +
    val not : bool React.signal -> bool React.signal
    +
    val (&&) : bool React.signal -> bool React.signal -> bool React.signal
    +
    val (||) : bool React.signal -> bool React.signal -> bool React.signal
    +
    val edge : bool React.signal -> bool React.event
    +edge s is changes s.
    +
    + +
    val rise : bool React.signal -> unit React.event
    +rise s is E.fmap (fun b -> if b then Some () else None) (edge s).
    +
    + +
    val fall : bool React.signal -> unit React.event
    +fall s is E.fmap (fun b -> if b then None else Some ()) (edge s).
    +
    + +
    val flip : bool -> 'a React.event -> bool React.signal
    +flip b e is a signal whose boolean value flips each time + e occurs. b is the initial signal value. +
      +
    • [flip b e]0 = not b if [e]0 = Some _
      • +
    • [flip b e]t = b if [e]<=t = None
      • +
    • [flip b e]t = not [flip b e]t-dt + if [e]t = Some _
      • +
    +
    +
    + \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Compare.html react-1.2.0/doc/React.S.Compare.html --- react-0.9.4/doc/React.S.Compare.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Compare.html 2014-08-23 23:03:35.000000000 +0000 @@ -4,7 +4,7 @@ - + @@ -14,10 +14,20 @@ React.S.Compare -
    Previous +
    Previous  Up  Next

    Module React.S.Compare

    + 
    module Compare: sig .. end
    -
    val (=) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (<>) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (<) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (>) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (<=) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (>=) : 'a React.signal -> 'a React.signal -> bool React.signal
    val compare : 'a React.signal -> 'a React.signal -> int React.signal
    val (==) : 'a React.signal -> 'a React.signal -> bool React.signal
    val (!=) : 'a React.signal -> 'a React.signal -> bool React.signal
    \ No newline at end of file + +
    val (=) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (<>) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (<) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (>) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (<=) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (>=) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val compare : 'a React.signal -> 'a React.signal -> int React.signal
    +
    val (==) : 'a React.signal -> 'a React.signal -> bool React.signal
    +
    val (!=) : 'a React.signal -> 'a React.signal -> bool React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.EqType.html react-1.2.0/doc/React.S.EqType.html --- react-0.9.4/doc/React.S.EqType.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.EqType.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,8 +17,13 @@  Next

    Module type React.S.EqType

    -
    module type EqType = sig .. end
    Input signature of React.S.Make
    + +
    module type EqType = sig .. end
    +Input signature of React.S.Make
    +
    + 
    type 'a t
    + 
    val equal : 'a t -> 'a t -> bool
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Float.html react-1.2.0/doc/React.S.Float.html --- react-0.9.4/doc/React.S.Float.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Float.html 2014-08-23 23:03:35.000000000 +0000 @@ -19,5 +19,47 @@  Next

    Module React.S.Float

    + 
    module Float: sig .. end
    -
    val (~-.) : float React.signal -> float React.signal
    val (+.) : float React.signal -> float React.signal -> float React.signal
    val (-.) : float React.signal -> float React.signal -> float React.signal
    val ( *. ) : float React.signal -> float React.signal -> float React.signal
    val (/.) : float React.signal -> float React.signal -> float React.signal
    val ( ** ) : float React.signal -> float React.signal -> float React.signal
    val sqrt : float React.signal -> float React.signal
    val exp : float React.signal -> float React.signal
    val log : float React.signal -> float React.signal
    val log10 : float React.signal -> float React.signal
    val cos : float React.signal -> float React.signal
    val sin : float React.signal -> float React.signal
    val tan : float React.signal -> float React.signal
    val acos : float React.signal -> float React.signal
    val asin : float React.signal -> float React.signal
    val atan : float React.signal -> float React.signal
    val atan2 : float React.signal -> float React.signal -> float React.signal
    val cosh : float React.signal -> float React.signal
    val sinh : float React.signal -> float React.signal
    val tanh : float React.signal -> float React.signal
    val ceil : float React.signal -> float React.signal
    val floor : float React.signal -> float React.signal
    val abs_float : float React.signal -> float React.signal
    val mod_float : float React.signal -> float React.signal -> float React.signal
    val frexp : float React.signal -> (float * int) React.signal
    val ldexp : float React.signal -> int React.signal -> float React.signal
    val modf : float React.signal -> (float * float) React.signal
    val float : int React.signal -> float React.signal
    val float_of_int : int React.signal -> float React.signal
    val truncate : float React.signal -> int React.signal
    val int_of_float : float React.signal -> int React.signal
    val infinity : float React.signal
    val neg_infinity : float React.signal
    val nan : float React.signal
    val max_float : float React.signal
    val min_float : float React.signal
    val epsilon_float : float React.signal
    val classify_float : float React.signal -> Pervasives.fpclass React.signal
    \ No newline at end of file + +
    val zero : float React.signal
    +
    val one : float React.signal
    +
    val minus_one : float React.signal
    +
    val (~-.) : float React.signal -> float React.signal
    +
    val (+.) : float React.signal -> float React.signal -> float React.signal
    +
    val (-.) : float React.signal -> float React.signal -> float React.signal
    +
    val ( *. ) : float React.signal -> float React.signal -> float React.signal
    +
    val (/.) : float React.signal -> float React.signal -> float React.signal
    +
    val ( ** ) : float React.signal -> float React.signal -> float React.signal
    +
    val sqrt : float React.signal -> float React.signal
    +
    val exp : float React.signal -> float React.signal
    +
    val log : float React.signal -> float React.signal
    +
    val log10 : float React.signal -> float React.signal
    +
    val cos : float React.signal -> float React.signal
    +
    val sin : float React.signal -> float React.signal
    +
    val tan : float React.signal -> float React.signal
    +
    val acos : float React.signal -> float React.signal
    +
    val asin : float React.signal -> float React.signal
    +
    val atan : float React.signal -> float React.signal
    +
    val atan2 : float React.signal -> float React.signal -> float React.signal
    +
    val cosh : float React.signal -> float React.signal
    +
    val sinh : float React.signal -> float React.signal
    +
    val tanh : float React.signal -> float React.signal
    +
    val ceil : float React.signal -> float React.signal
    +
    val floor : float React.signal -> float React.signal
    +
    val abs_float : float React.signal -> float React.signal
    +
    val mod_float : float React.signal -> float React.signal -> float React.signal
    +
    val frexp : float React.signal -> (float * int) React.signal
    +
    val ldexp : float React.signal -> int React.signal -> float React.signal
    +
    val modf : float React.signal -> (float * float) React.signal
    +
    val float : int React.signal -> float React.signal
    +
    val float_of_int : int React.signal -> float React.signal
    +
    val truncate : float React.signal -> int React.signal
    +
    val int_of_float : float React.signal -> int React.signal
    +
    val infinity : float React.signal
    +
    val neg_infinity : float React.signal
    +
    val nan : float React.signal
    +
    val max_float : float React.signal
    +
    val min_float : float React.signal
    +
    val epsilon_float : float React.signal
    +
    val classify_float : float React.signal -> Pervasives.fpclass React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.html react-1.2.0/doc/React.S.html --- react-0.9.4/doc/React.S.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.html 2014-08-23 23:03:35.000000000 +0000 @@ -5,6 +5,7 @@ + @@ -22,41 +23,57 @@
    Previous  Up - 
    + Next +

    Module React.S

    -
    module S: sig .. end
    Signal combinators. + +
    module S: sig .. end
    +Signal combinators.

    Consult their semantics.
    +


    -

    Primitive and basics


    +

    Primitive and basics


    + 
    type 'a t = 'a React.signal
    -
    +
    The type for signals of type 'a.
    -
    val const : 'a -> 'a React.signal
    + +
    val const : 'a -> 'a React.signal
    const v is always v, [const v]t = v.
    -
    val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a React.signal * ('a -> unit)
    + +
    val create : ?eq:('a -> 'a -> bool) ->
           'a -> 'a React.signal * (?step:React.step -> 'a -> unit)
    create i is a primitive signal s set to i and a - set function. set v sets the signal's value to v at the - time it is called and triggers an update - cycle. -

    + set function. The function set is such that: +

      +
    • set v sets the signal's value to v at the time it is called and + triggers an update step.
      • +
    • set ~step v sets the signal's value to v at the time it is + called and updates it dependencies when step is + executed
      • +
    • set ~step v raises Invalid_argument if it was previously + called with a step and this step has not executed yet or if + the given step was already executed.
      • +
    - Warning. send must not be executed inside an update cycle.
    + Warning. set must not be executed inside an update step.
    -
    val value : 'a React.signal -> 'a
    -value s is s's current value. + +
    val value : 'a React.signal -> 'a
    +value s is s's current value.

    - Warning. If executed in an update - cycle may return a non up-to-date value or raise Failure if + Warning. If executed in an update + step may return a non up-to-date value or raise Failure if the signal is not yet initialized.

    -
    val retain : 'a React.signal -> (unit -> unit) -> [ `R of unit -> unit ]
    + +
    val retain : 'a React.signal -> (unit -> unit) -> [ `R of unit -> unit ]
    retain s c keeps a reference to the closure c in s and returns the previously retained value. c will never be invoked. @@ -64,22 +81,30 @@ Raises. Invalid_argument on constant signals.
    -
    val stop : 'a React.signal -> unit
    + +
    val stop : ?strong:bool -> 'a React.signal -> unit
    stop s, stops updating s. It conceptually becomes React.S.const with the signal's last value and cannot be restarted. Allows to disable effectful signals.

    - Note. If executed in an update cycle the signal may - still update in the cycle.
    + The strong argument should only be used on platforms + where weak arrays have a strong semantics (i.e. JavaScript). + See details. +

    + + Note. If executed in an update step the signal may + still update in the step.

    -
    val equal : ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a React.signal -> bool
    + +
    val equal : ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a React.signal -> bool
    equal s s' is true iff s and s' are equal. If both signals are React.S.constant eq is used between their value (defauts to structural equality). If both signals are not React.S.constant, physical equality is used.
    -
    val trace : ?iff:bool t -> ('a -> unit) -> 'a React.signal -> 'a React.signal
    + +
    val trace : ?iff:bool t -> ('a -> unit) -> 'a React.signal -> 'a React.signal
    trace iff tr s is s except tr is invoked with s's current value and on s changes when iff is true (defaults to S.const true). For all t where [s]t = v and (t = 0 @@ -87,9 +112,10 @@ [iff]t = true, tr is invoked with v.

    -

    From events


    -
    val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a React.event -> 'a React.signal
    -hold i e has the value of e's last occurrence or i if there +

    From events


    + +
    val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a React.event -> 'a React.signal
    +hold i e has the value of e's last occurrence or i if there wasn't any.
    • [hold i e]t = i if [e]<=t = None
      • @@ -98,19 +124,22 @@

    -

    Transforming and filtering


    -
    val app : ?eq:('b -> 'b -> bool) ->
           ('a -> 'b) React.signal -> 'a React.signal -> 'b React.signal
    +

    Transforming and filtering


    + +
    val app : ?eq:('b -> 'b -> bool) ->
           ('a -> 'b) React.signal -> 'a React.signal -> 'b React.signal
    app sf s holds the value of sf applied - to the value of s, [app sf s]t + to the value of s, [app sf s]t = [sf]t [s]t.
    -
    val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a React.signal -> 'b React.signal
    + +
    val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a React.signal -> 'b React.signal
    map f s is s transformed by f, [map f s]t = f [s]t.
    -
    val filter : ?eq:('a -> 'a -> bool) ->
           ('a -> bool) -> 'a -> 'a React.signal -> 'a React.signal
    + +
    val filter : ?eq:('a -> 'a -> bool) ->
           ('a -> bool) -> 'a -> 'a React.signal -> 'a React.signal
    filter f i s is s's values that satisfy p. If a value does not satisfy p it holds the last value that was satisfied or i if - there is none. + there is none.
    • [filter p s]t = [s]t if p [s]t = true.
    • [filter p s]t = [s]t' if p [s]t = false @@ -119,33 +148,37 @@

    -
    val fmap : ?eq:('b -> 'b -> bool) ->
           ('a -> 'b option) -> 'b -> 'a React.signal -> 'b React.signal
    + +
    val fmap : ?eq:('b -> 'b -> bool) ->
           ('a -> 'b option) -> 'b -> 'a React.signal -> 'b React.signal
    fmap fm i s is s filtered and mapped by fm.
    • [fmap fm i s]t = v if fm [s]t = Some v.
      • -
    • [fmap fm i s]t = [fmap fm i s]t' if fm - [s]t = None and t' is the greatest t' < t with fm +
    • [fmap fm i s]t = [fmap fm i s]t' if fm + [s]t = None and t' is the greatest t' < t with fm [s]t' <> None.
    • [fmap fm i s]t = i otherwise.

    -
    val diff : ('a -> 'a -> 'b) -> 'a React.signal -> 'b React.event
    + +
    val diff : ('a -> 'a -> 'b) -> 'a React.signal -> 'b React.event
    diff f s is an event with occurrences whenever s changes from v' to v and eq v v' is false (eq is the signal's equality function). The value of the occurrence is f v v'.
      -
    • [diff f s]t = Some d +
    • [diff f s]t = Some d if [s]t = v and [s]t-dt = v' and eq v v' = false and f v v' = d.
    • [diff f s]t = None otherwise.

    -
    val changes : 'a React.signal -> 'a React.event
    + +
    val changes : 'a React.signal -> 'a React.event
    changes s is diff (fun v _ -> v) s.
    -
    val sample : ('b -> 'a -> 'c) -> 'b React.event -> 'a React.signal -> 'c React.event
    + +
    val sample : ('b -> 'a -> 'c) -> 'b React.event -> 'a React.signal -> 'c React.event
    sample f e s samples s at e's occurrences.
    • [sample f e s]t = Some (f ev sv) if [e]t = Some ev @@ -154,19 +187,25 @@

    -
    val when_ : ?eq:('a -> 'a -> bool) ->
           bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
    -when_ c i s is the signal s whenever c is true. + +
    val on : ?eq:('a -> 'a -> bool) ->
           bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
    +on c i s is the signal s whenever c is true. When c is false it holds the last value s had when c was the last time true or i if it never was.
      -
    • [when_ c i s]t = [s]t if [c]t = true
      • -
    • [when_ c i s]t = [s]t' if [c]t = false +
    • [on c i s]t = [s]t if [c]t = true
      • +
    • [on c i s]t = [s]t' if [c]t = false where t' is the greatest t' < t with [c]t' = true.
      • -
    • [when_ c i s]t = i otherwise.
      • +
    • [on c i s]t = i otherwise.

    -
    val dismiss : ?eq:('a -> 'a -> bool) ->
           'b React.event -> 'a -> 'a React.signal -> 'a React.signal
    + +
    val when_ : ?eq:('a -> 'a -> bool) ->
           bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
    +Deprecated.Use React.S.on.
    +
    + +
    val dismiss : ?eq:('a -> 'a -> bool) ->
           'b React.event -> 'a -> 'a React.signal -> 'a React.signal
    dismiss c i s is the signal s except changes when c occurs are ignored. If c occurs initially i is used.
      @@ -174,40 +213,45 @@ where t' is the greatest t' <= t with [c]t' = None and [s]t'-dt <> [s]t'
    • [dismiss_ c i s]0 = v where v = i if - [c]0 = Some _ and v = [s]0 otherwise.
      • + [c]0 = Some _ and v = [s]0 otherwise.


    -

    Accumulating


    -
    val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) React.event -> 'a -> 'a React.signal
    +

    Accumulating


    + +
    val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) React.event -> 'a -> 'a React.signal
    accum e i is S.hold i (React.E.accum e i).
    -
    val fold : ?eq:('a -> 'a -> bool) ->
           ('a -> 'b -> 'a) -> 'a -> 'b React.event -> 'a React.signal
    + +
    val fold : ?eq:('a -> 'a -> bool) ->
           ('a -> 'b -> 'a) -> 'a -> 'b React.event -> 'a React.signal
    fold f i e is S.hold i (React.E.fold f i e).

    -

    Combining


    -
    val merge : ?eq:('a -> 'a -> bool) ->
           ('a -> 'b -> 'a) -> 'a -> 'b React.signal list -> 'a React.signal
    +

    Combining


    + +
    val merge : ?eq:('a -> 'a -> bool) ->
           ('a -> 'b -> 'a) -> 'a -> 'b React.signal list -> 'a React.signal
    merge f a sl merges the value of every signal in sl - using f and the accumulator a. + using f and the accumulator a.

    - [merge f a sl]t - = List.fold_left f a (List.map []t sl).
    + [merge f a sl]t + = List.fold_left f a (List.map []t sl).

    -
    val switch : ?eq:('a -> 'a -> bool) ->
           'a React.signal -> 'a React.signal React.event -> 'a React.signal
    -switch s es is s until there is an - occurrence s' on es, s' is then used - until there is a new occurrence on es, etc.. + +
    val switch : ?eq:('a -> 'a -> bool) -> 'a React.signal React.signal -> 'a React.signal
    +switch ss is the inner signal of ss.
      -
    • [switch s es]t = [s]t if [es]<=t = None.
      • -
    • [switch s es]t = [s']t if [es]<=t - = Some s'.
      • +
    • [switch ss]t = [[ss]t]t.

    -
    val fix : ?eq:('a -> 'a -> bool) ->
           'a -> ('a React.signal -> 'a React.signal * 'b) -> 'b
    + +
    val bind : ?eq:('b -> 'b -> bool) ->
           'a React.signal -> ('a -> 'b React.signal) -> 'b React.signal
    +bind s sf is switch (map ~eq:( == ) sf s).
    +
    + +
    val fix : ?eq:('a -> 'a -> bool) ->
           'a -> ('a React.signal -> 'a React.signal * 'b) -> 'b
    fix i sf allow to refer to the value a signal had an infinitesimal amount of time before.

    @@ -220,67 +264,83 @@

  • [s]t = i for t = 0.
  • [s]t = [s']t-dt otherwise.
    • - +

    - eq is the equality used by s. + eq is the equality used by s.

    - Raises. Invalid_argument if s' is directly a delayed signal (i.e. + Raises. Invalid_argument if s' is directly a delayed signal (i.e. a signal given to a fixing function).

    - Note. Regarding values depending on the result r of + Note. Regarding values depending on the result r of s', r = sf s the following two cases need to be distinguished :

      -
    • After sf s is applied, s' does not depend on - a value that is in a cycle and s has no dependents in a cycle (e.g - in the simple case where fix is applied outside a cycle). +
    • After sf s is applied, s' does not depend on + a value that is in a step and s has no dependents in a step (e.g + in the simple case where fix is applied outside a step).

      In that case if the initial value of s' differs from i, s and its dependents need to be updated and a special - update cycle will be triggered for this. Values + update step will be triggered for this. Values depending on the result r will be created only after this - special update cycle has finished (e.g. they won't see + special update step has finished (e.g. they won't see the i of s if r = s).

    • Otherwise, values depending on r will be created in the same - cycle as s and s' (e.g. they will see the i of s if r = s).
      • + step as s and s' (e.g. they will see the i of s if r = s).


    -

    Lifting

     +

    Lifting

    Lifting combinators. For a given n the semantics is :

    [ln f a1 ... an]t = f [a1]t ... [an]t
    -

    val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a React.signal -> 'b React.signal
    val l2 : ?eq:('c -> 'c -> bool) ->
           ('a -> 'b -> 'c) -> 'a React.signal -> 'b React.signal -> 'c React.signal
    val l3 : ?eq:('d -> 'd -> bool) ->
           ('a -> 'b -> 'c -> 'd) ->
           'a React.signal -> 'b React.signal -> 'c React.signal -> 'd React.signal
    val l4 : ?eq:('e -> 'e -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd React.signal -> 'e React.signal
    val l5 : ?eq:('f -> 'f -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e React.signal -> 'f React.signal
    val l6 : ?eq:('g -> 'g -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f React.signal -> 'g React.signal

    -The following modules lift some of Pervasives functions and + +
    val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a React.signal -> 'b React.signal
    +
    val l2 : ?eq:('c -> 'c -> bool) ->
           ('a -> 'b -> 'c) -> 'a React.signal -> 'b React.signal -> 'c React.signal
    +
    val l3 : ?eq:('d -> 'd -> bool) ->
           ('a -> 'b -> 'c -> 'd) ->
           'a React.signal -> 'b React.signal -> 'c React.signal -> 'd React.signal
    +
    val l4 : ?eq:('e -> 'e -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd React.signal -> 'e React.signal
    +
    val l5 : ?eq:('f -> 'f -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e React.signal -> 'f React.signal
    +
    val l6 : ?eq:('g -> 'g -> bool) ->
           ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f React.signal -> 'g React.signal

    +The following modules lift some of Pervasives functions and operators.
    -
    module Bool: sig .. end
    module Int: sig .. end
    module Float: sig .. end
    module Pair: sig .. end
    module Compare: sig .. end

    -

    Combinator specialization

     + +
    module Bool: sig .. end
    +
    module Int: sig .. end
    +
    module Float: sig .. end
    +
    module Pair: sig .. end
    +
    module Option: sig .. end
    +
    module Compare: sig .. end

    +

    Combinator specialization

    - Given an equality function equal and a type t, the functor - React.S.Make automatically applies the eq parameter of the combinators. - The outcome is combinators whose results are signals with + Given an equality function equal and a type t, the functor + React.S.Make automatically applies the eq parameter of the combinators. + The outcome is combinators whose results are signals with values in t.

    - Basic types are already specialized in the module React.S.Special, open + Basic types are already specialized in the module React.S.Special, open this module to use them.
    + 

    module type EqType = sig .. end
    Input signature of React.S.Make
    + 
    module type S = sig .. end
    Output signature of React.S.Make
    + 
    module Make: 
    functor (Eq : EqType) -> S  with type 'a v = 'a Eq.t
    Functor specializing the combinators for the given signal value type
    + 
    module Special: sig .. end
    Specialization for booleans, integers and floats.
    diff -Nru react-0.9.4/doc/React.S.Int.html react-1.2.0/doc/React.S.Int.html --- react-0.9.4/doc/React.S.Int.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Int.html 2014-08-23 23:03:35.000000000 +0000 @@ -19,5 +19,26 @@  Next

    Module React.S.Int

    + 
    module Int: sig .. end
    -
    val (~-) : int React.signal -> int React.signal
    val succ : int React.signal -> int React.signal
    val pred : int React.signal -> int React.signal
    val (+) : int React.signal -> int React.signal -> int React.signal
    val (-) : int React.signal -> int React.signal -> int React.signal
    val ( * ) : int React.signal -> int React.signal -> int React.signal
    val (mod) : int React.signal -> int React.signal -> int React.signal
    val abs : int React.signal -> int React.signal
    val max_int : int React.signal
    val min_int : int React.signal
    val (land) : int React.signal -> int React.signal -> int React.signal
    val (lor) : int React.signal -> int React.signal -> int React.signal
    val (lxor) : int React.signal -> int React.signal -> int React.signal
    val lnot : int React.signal -> int React.signal
    val (lsl) : int React.signal -> int React.signal -> int React.signal
    val (lsr) : int React.signal -> int React.signal -> int React.signal
    val (asr) : int React.signal -> int React.signal -> int React.signal
    \ No newline at end of file + +
    val zero : int React.signal
    +
    val one : int React.signal
    +
    val minus_one : int React.signal
    +
    val (~-) : int React.signal -> int React.signal
    +
    val succ : int React.signal -> int React.signal
    +
    val pred : int React.signal -> int React.signal
    +
    val (+) : int React.signal -> int React.signal -> int React.signal
    +
    val (-) : int React.signal -> int React.signal -> int React.signal
    +
    val ( * ) : int React.signal -> int React.signal -> int React.signal
    +
    val (mod) : int React.signal -> int React.signal -> int React.signal
    +
    val abs : int React.signal -> int React.signal
    +
    val max_int : int React.signal
    +
    val min_int : int React.signal
    +
    val (land) : int React.signal -> int React.signal -> int React.signal
    +
    val (lor) : int React.signal -> int React.signal -> int React.signal
    +
    val (lxor) : int React.signal -> int React.signal -> int React.signal
    +
    val lnot : int React.signal -> int React.signal
    +
    val (lsl) : int React.signal -> int React.signal -> int React.signal
    +
    val (lsr) : int React.signal -> int React.signal -> int React.signal
    +
    val (asr) : int React.signal -> int React.signal -> int React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Make.html react-1.2.0/doc/React.S.Make.html --- react-0.9.4/doc/React.S.Make.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Make.html 2014-08-23 23:03:35.000000000 +0000 @@ -19,7 +19,10 @@  Next

    Functor React.S.Make

    -
    module Make: 
    functor (Eq : EqType) -> S  with type 'a v = 'a Eq.t
    Functor specializing the combinators for the given signal value type
    + +
    module Make: 
    functor (Eq : EqType) -> S  with type 'a v = 'a Eq.t
    +Functor specializing the combinators for the given signal value type
    +
    @@ -35,6 +38,28 @@
    Parameters:
    + 
    type 'a v
    -
    val create : 'a v -> 'a v React.signal * ('a v -> unit)
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    val switch : 'a v React.signal ->
           'a v React.signal React.event -> 'a v React.signal
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file + +
    val create : 'a v ->
           'a v React.signal * (?step:React.step -> 'a v -> unit)
    +
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    +
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    +
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    +
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    +
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    +
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    +
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    +
    val switch : 'a v React.signal React.signal -> 'a v React.signal
    +
    val bind : 'b React.signal ->
           ('b -> 'a v React.signal) -> 'a v React.signal
    +
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    +
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    +
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Option.html react-1.2.0/doc/React.S.Option.html --- react-0.9.4/doc/React.S.Option.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/React.S.Option.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,54 @@ + + + + + + + + + + + + + +React.S.Option + + +
    Previous + Up + Next +
    +

    Module React.S.Option

    + +
    module Option: sig .. end
    + +
    val none : 'a option React.signal
    +none is S.const None.
    +
    + +
    val some : 'a React.signal -> 'a option React.signal
    +some s is S.map ~eq (fun v -> Some v) None, where eq uses + s's equality function to test the Some v's equalities.
    +
    + +
    val value : ?eq:('a -> 'a -> bool) ->
           default:[ `Always of 'a React.signal | `Init of 'a React.signal ] ->
           'a option React.signal -> 'a React.signal
    +value default s is s with only its Some v values. + Whenever s is None, if default is `Always dv then + the current value of dv is used instead. If default + is `Init dv the current value of dv is only used + if there's no value at creation time, otherwise the last + Some v value of s is used. +
      +
    • [value ~default s]t = v if [s]t = Some v
      • +
    • [value ~default:(`Always d) s]t = [d]t + if [s]t = None
      • +
    • [value ~default:(`Init d) s]0 = [d]0 + if [s]0 = None
      • +
    • [value ~default:(`Init d) s]t = + [value ~default:(`Init d) s]t' + if [s]t = None and t' is the greatest t' < t + with [s]t' <> None or 0 if there is no such t'.
      • +
    +
    +
    + \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Pair.html react-1.2.0/doc/React.S.Pair.html --- react-0.9.4/doc/React.S.Pair.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Pair.html 2014-08-23 23:03:35.000000000 +0000 @@ -5,7 +5,7 @@ - + @@ -16,8 +16,12 @@
    Previous  Up - Next + Next

    Module React.S.Pair

    + 
    module Pair: sig .. end
    -
    val pair : ?eq:('a * 'b -> 'a * 'b -> bool) ->
           'a React.signal -> 'b React.signal -> ('a * 'b) React.signal
    val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) React.signal -> 'a React.signal
    val snd : ?eq:('a -> 'a -> bool) -> ('b * 'a) React.signal -> 'a React.signal
    \ No newline at end of file + +
    val pair : ?eq:('a * 'b -> 'a * 'b -> bool) ->
           'a React.signal -> 'b React.signal -> ('a * 'b) React.signal
    +
    val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) React.signal -> 'a React.signal
    +
    val snd : ?eq:('a -> 'a -> bool) -> ('b * 'a) React.signal -> 'a React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.S.html react-1.2.0/doc/React.S.S.html --- react-0.9.4/doc/React.S.S.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.S.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,8 +17,33 @@  Up  

    Module type React.S.S

    -
    module type S = sig .. end
    Output signature of React.S.Make
    + +
    module type S = sig .. end
    +Output signature of React.S.Make
    +
    + 
    type 'a v
    -
    val create : 'a v -> 'a v React.signal * ('a v -> unit)
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    val switch : 'a v React.signal ->
           'a v React.signal React.event -> 'a v React.signal
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file + +
    val create : 'a v ->
           'a v React.signal * (?step:React.step -> 'a v -> unit)
    +
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    +
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    +
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    +
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    +
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    +
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    +
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    +
    val switch : 'a v React.signal React.signal -> 'a v React.signal
    +
    val bind : 'b React.signal ->
           ('b -> 'a v React.signal) -> 'a v React.signal
    +
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    +
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    +
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Special.html react-1.2.0/doc/React.S.Special.html --- react-0.9.4/doc/React.S.Special.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Special.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,17 +17,23 @@  Up  

    Module React.S.Special

    -
    module Special: sig .. end
    Specialization for booleans, integers and floats. + +
    module Special: sig .. end
    +Specialization for booleans, integers and floats.

    Open this module to use it.
    +

    + 
    module Sb: React.S.S  with type 'a v = bool
    Specialization for booleans.
    + 
    module Si: React.S.S  with type 'a v = int
    Specialization for integers.
    + 
    module Sf: React.S.S  with type 'a v = float
    Specialization for floats.
    diff -Nru react-0.9.4/doc/React.S.Special.Sb.html react-1.2.0/doc/React.S.Special.Sb.html --- react-0.9.4/doc/React.S.Special.Sb.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Special.Sb.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,8 +17,33 @@  Next

    Module React.S.Special.Sb

    -
    module Sb: React.S.S  with type 'a v = bool
    Specialization for booleans.
    + +
    module Sb: React.S.S  with type 'a v = bool
    +Specialization for booleans.
    +
    + 
    type 'a v
    -
    val create : 'a v -> 'a v React.signal * ('a v -> unit)
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    val switch : 'a v React.signal ->
           'a v React.signal React.event -> 'a v React.signal
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file + +
    val create : 'a v ->
           'a v React.signal * (?step:React.step -> 'a v -> unit)
    +
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    +
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    +
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    +
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    +
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    +
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    +
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    +
    val switch : 'a v React.signal React.signal -> 'a v React.signal
    +
    val bind : 'b React.signal ->
           ('b -> 'a v React.signal) -> 'a v React.signal
    +
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    +
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    +
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Special.Sf.html react-1.2.0/doc/React.S.Special.Sf.html --- react-0.9.4/doc/React.S.Special.Sf.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Special.Sf.html 2014-08-23 23:03:35.000000000 +0000 @@ -17,8 +17,33 @@  Up  

    Module React.S.Special.Sf

    -
    module Sf: React.S.S  with type 'a v = float
    Specialization for floats.
    + +
    module Sf: React.S.S  with type 'a v = float
    +Specialization for floats.
    +
    + 
    type 'a v
    -
    val create : 'a v -> 'a v React.signal * ('a v -> unit)
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    val switch : 'a v React.signal ->
           'a v React.signal React.event -> 'a v React.signal
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file + +
    val create : 'a v ->
           'a v React.signal * (?step:React.step -> 'a v -> unit)
    +
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    +
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    +
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    +
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    +
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    +
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    +
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    +
    val switch : 'a v React.signal React.signal -> 'a v React.signal
    +
    val bind : 'b React.signal ->
           ('b -> 'a v React.signal) -> 'a v React.signal
    +
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    +
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    +
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.S.Special.Si.html react-1.2.0/doc/React.S.Special.Si.html --- react-0.9.4/doc/React.S.Special.Si.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/React.S.Special.Si.html 2014-08-23 23:03:35.000000000 +0000 @@ -19,8 +19,33 @@  Next

    Module React.S.Special.Si

    -
    module Si: React.S.S  with type 'a v = int
    Specialization for integers.
    + +
    module Si: React.S.S  with type 'a v = int
    +Specialization for integers.
    +
    + 
    type 'a v
    -
    val create : 'a v -> 'a v React.signal * ('a v -> unit)
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    val switch : 'a v React.signal ->
           'a v React.signal React.event -> 'a v React.signal
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file + +
    val create : 'a v ->
           'a v React.signal * (?step:React.step -> 'a v -> unit)
    +
    val equal : 'a v React.signal -> 'a v React.signal -> bool
    +
    val hold : 'a v -> 'a v React.event -> 'a v React.signal
    +
    val app : ('a -> 'b v) React.signal ->
           'a React.signal -> 'b v React.signal
    +
    val map : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val filter : ('a v -> bool) ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val fmap : ('a -> 'b v option) ->
           'b v -> 'a React.signal -> 'b v React.signal
    +
    val when_ : bool React.signal ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val dismiss : 'b React.event ->
           'a v -> 'a v React.signal -> 'a v React.signal
    +
    val accum : ('a v -> 'a v) React.event ->
           'a v -> 'a v React.signal
    +
    val fold : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.event -> 'a v React.signal
    +
    val merge : ('a v -> 'b -> 'a v) ->
           'a v -> 'b React.signal list -> 'a v React.signal
    +
    val switch : 'a v React.signal React.signal -> 'a v React.signal
    +
    val bind : 'b React.signal ->
           ('b -> 'a v React.signal) -> 'a v React.signal
    +
    val fix : 'a v ->
           ('a v React.signal -> 'a v React.signal * 'b) -> 'b
    +
    val l1 : ('a -> 'b v) -> 'a React.signal -> 'b v React.signal
    +
    val l2 : ('a -> 'b -> 'c v) ->
           'a React.signal -> 'b React.signal -> 'c v React.signal
    +
    val l3 : ('a -> 'b -> 'c -> 'd v) ->
           'a React.signal ->
           'b React.signal -> 'c React.signal -> 'd v React.signal
    +
    val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal -> 'd React.signal -> 'e v React.signal
    +
    val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal -> 'e React.signal -> 'f v React.signal
    +
    val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) ->
           'a React.signal ->
           'b React.signal ->
           'c React.signal ->
           'd React.signal ->
           'e React.signal -> 'f React.signal -> 'g v React.signal
    \ No newline at end of file diff -Nru react-0.9.4/doc/React.Step.html react-1.2.0/doc/React.Step.html --- react-0.9.4/doc/React.Step.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/React.Step.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,55 @@ + + + + + + + + + + + + + +React.Step + + +
    Previous + Up + 
    +

    Module React.Step

    + +
    module Step: sig .. end
    +Update steps. +

    + + Update functions returned by React.S.create and React.E.create + implicitely create and execute update steps when used without + specifying their step argument. +

    + + Using explicit React.step values with these functions gives more control on + the time when the update step is perfomed and allows to perform + simultaneous primitive signal updates and event + occurences. See also the documentation about update steps and + simultaneous events.
    +

    +
    +
    +

    Steps


    + +
    type t = React.step
    +
    +The type for update steps.
    +
    + + +
    val create : unit -> React.step
    +create () is a new update step.
    +
    + +
    val execute : React.step -> unit
    +execute step executes the update step.
    +Raises Invalid_argument if step was already executed.
    +
    + \ No newline at end of file diff -Nru react-0.9.4/doc/style.css react-1.2.0/doc/style.css --- react-0.9.4/doc/style.css 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/doc/style.css 2014-08-23 23:03:34.000000000 +0000 @@ -4,50 +4,50 @@ html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, -form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td -{ margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; - font-weight: inherit; font-style:inherit; font-family:inherit; +form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td +{ margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; + font-weight: inherit; font-style:inherit; font-family:inherit; line-height: inherit; vertical-align: baseline; text-align:inherit; color:inherit; background: transparent; } table { border-collapse: collapse; border-spacing: 0; } -/* Basic page layout using the user's preferred font sizes */ +/* Basic page layout */ -body { font: normal 1em/1.375em helvetica, arial, sans-serif; text-align:left; - margin: 1.375em 10%; min-width: 40ex; max-width: 70ex; - color: black; background: transparent /* url(line-height-22.gif) */; } +body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; + margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; + color: black; background: white /* url(line-height-22.gif) */; } b { font-weight: bold } -em { font-style: italic } +em { font-style: italic } -tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; +tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; font-size: 1em; } pre code { font-size : inherit; } +.codepre { margin-bottom:1.375em /* after code example we introduce space. */ } -.superscript,.subscript +.superscript,.subscript { font-size : 0.813em; line-height:0; margin-left:0.4ex;} .superscript { vertical-align: super; } .subscript { vertical-align: sub; } /* ocamldoc markup workaround hacks */ + + hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br { display: none } /* annoying */ -code br { display: inline } /* because of the above span + br rule */ -pre + code { white-space:nowrap; /* in code examples we don't wrap. */ - line-height:1.375em; } /* and the line height is too large. */ -code + pre { margin-bottom:1.375em} /* after code example we introduce space. */ -center { text-align: left } -center + br + pre { margin-bottom:1.375em} /* Toplevel module description */ -div.info + br + code { display:block; margin-top: 1.375em} /* Records */ +div.info + br { display:block} + +.codepre br + br { display: none } +h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ /* Sections and document divisions */ /* .navbar { margin-bottom: -1.375em } */ h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ - margin-top:0.917em; padding-top:0.875em; + margin-top:0.917em; padding-top:0.875em; border-top-style:solid; border-width:1px; border-color:#AAA; } h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } @@ -63,7 +63,7 @@ .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ -ul, ol { margin-top:0.688em; padding-bottom:0.687em; +ul, ol { margin-top:0.688em; padding-bottom:0.687em; list-style-position:outside} ul + p, ol + p { margin-top: 0em } ul { list-style-type: square } @@ -74,7 +74,7 @@ ol > li { margin-left: 1.7em; } /* Links */ -a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } +a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } a:hover { text-decoration : underline } *:target {background-color: #FFFF99;} /* anchor highlight */ @@ -88,19 +88,11 @@ /* Functors */ -.paramstable { border-style : hidden ; padding-bottom:1.375em} +.paramstable { border-style : hidden ; padding-bottom:1.375em} .paramstable code { margin-left: 1ex; margin-right: 1ex } .sig_block {margin-left: 1em} +/* Images */ - - - - - - - - - - - +img { margin-top: 1.375em; display:block } +li img { margin-top: 0em; } diff -Nru react-0.9.4/doc/type_React.E.html react-1.2.0/doc/type_React.E.html --- react-0.9.4/doc/type_React.E.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.E.html 2014-08-23 23:03:35.000000000 +0000 @@ -12,9 +12,9 @@ sig
      type 'a t = 'a React.event
      val never : 'a React.event
    -  val create : unit -> 'a React.event * ('a -> unit)
    +  val create : unit -> 'a React.event * (?step:React.step -> 'a -> unit)
      val retain : 'a React.event -> (unit -> unit) -> [ `R of unit -> unit ]
    -  val stop : 'a React.event -> unit
    +  val stop : ?strong:bool -> 'a React.event -> unit
      val equal : 'a React.event -> 'a React.event -> bool
      val trace :
        ?iff:bool React.signal ->
    @@ -28,6 +28,7 @@   val fmap : ('a -> 'b option) -> 'a React.event -> 'b React.event
      val diff : ('a -> 'a -> 'b) -> 'a React.event -> 'b React.event
      val changes : ?eq:('a -> 'a -> bool) -> 'a React.event -> 'a React.event
    +  val on : bool React.signal -> 'a React.event -> 'a React.event
      val when_ : bool React.signal -> 'a React.event -> 'a React.event
      val dismiss : 'b React.event -> 'a React.event -> 'a React.event
      val until : 'a React.event -> 'b React.event -> 'b React.event
    @@ -37,4 +38,31 @@   val merge : ('a -> 'b -> 'a) -> 'a -> 'b React.event list -> 'a React.event
      val switch : 'a React.event -> 'a React.event React.event -> 'a React.event
      val fix : ('a React.event -> 'a React.event * 'b) -> 'b
    +  val l1 : ('a -> 'b) -> 'a React.event -> 'b React.event
    +  val l2 :
    +    ('a -> 'b -> 'c) -> 'a React.event -> 'b React.event -> 'c React.event
    +  val l3 :
    +    ('a -> 'b -> 'c -> 'd) ->
    +    'a React.event -> 'b React.event -> 'c React.event -> 'd React.event
    +  val l4 :
    +    ('a -> 'b -> 'c -> 'd -> 'e) ->
    +    'a React.event ->
    +    'b React.event -> 'c React.event -> 'd React.event -> 'e React.event
    +  val l5 :
    +    ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
    +    'a React.event ->
    +    'b React.event ->
    +    'c React.event -> 'd React.event -> 'e React.event -> 'f React.event
    +  val l6 :
    +    ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
    +    'a React.event ->
    +    'b React.event ->
    +    'c React.event ->
    +    'd React.event -> 'e React.event -> 'f React.event -> 'g React.event
    +  module Option :
    +    sig
    +      val some : 'a React.event -> 'a option React.event
    +      val value :
    +        ?default:'a React.signal -> 'a option React.event -> 'a React.event
    +    end
    end     \ No newline at end of file diff -Nru react-0.9.4/doc/type_React.E.Option.html react-1.2.0/doc/type_React.E.Option.html --- react-0.9.4/doc/type_React.E.Option.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/type_React.E.Option.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,16 @@ + + + + + + + + +React.E.Option + + +sig
    +  val some : 'a React.event -> 'a option React.event
    +  val value :
    +    ?default:'a React.signal -> 'a option React.event -> 'a React.event
    +end     \ No newline at end of file diff -Nru react-0.9.4/doc/type_React.html react-1.2.0/doc/type_React.html --- react-0.9.4/doc/type_React.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.html 2014-08-23 23:03:35.000000000 +0000 @@ -12,13 +12,14 @@ sig
      type 'a event
      type 'a signal
    +  type step
      module E :
        sig
          type 'a t = 'a React.event
          val never : 'a React.event
    -      val create : unit -> 'a React.event * ('a -> unit)
    +      val create : unit -> 'a React.event * (?step:React.step -> 'a -> unit)
          val retain : 'a React.event -> (unit -> unit) -> [ `R of unit -> unit ]
    -      val stop : 'a React.event -> unit
    +      val stop : ?strong:bool -> 'a React.event -> unit
          val equal : 'a React.event -> 'a React.event -> bool
          val trace :
            ?iff:bool React.signal ->
    @@ -33,6 +34,7 @@       val diff : ('a -> 'a -> 'b) -> 'a React.event -> 'b React.event
          val changes :
            ?eq:('a -> 'a -> bool) -> 'a React.event -> 'a React.event
    +      val on : bool React.signal -> 'a React.event -> 'a React.event
          val when_ : bool React.signal -> 'a React.event -> 'a React.event
          val dismiss : 'b React.event -> 'a React.event -> 'a React.event
          val until : 'a React.event -> 'b React.event -> 'b React.event
    @@ -44,18 +46,48 @@       val switch :
            'a React.event -> 'a React.event React.event -> 'a React.event
          val fix : ('a React.event -> 'a React.event * 'b) -> 'b
    +      val l1 : ('a -> 'b) -> 'a React.event -> 'b React.event
    +      val l2 :
    +        ('a -> 'b -> 'c) ->
    +        'a React.event -> 'b React.event -> 'c React.event
    +      val l3 :
    +        ('a -> 'b -> 'c -> 'd) ->
    +        'a React.event -> 'b React.event -> 'c React.event -> 'd React.event
    +      val l4 :
    +        ('a -> 'b -> 'c -> 'd -> 'e) ->
    +        'a React.event ->
    +        'b React.event -> 'c React.event -> 'd React.event -> 'e React.event
    +      val l5 :
    +        ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
    +        'a React.event ->
    +        'b React.event ->
    +        'c React.event -> 'd React.event -> 'e React.event -> 'f React.event
    +      val l6 :
    +        ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
    +        'a React.event ->
    +        'b React.event ->
    +        'c React.event ->
    +        'd React.event -> 'e React.event -> 'f React.event -> 'g React.event
    +      module Option :
    +        sig
    +          val some : 'a React.event -> 'a option React.event
    +          val value :
    +            ?default:'a React.signal ->
    +            'a option React.event -> 'a React.event
    +        end
        end
      module S :
        sig
          type 'a t = 'a React.signal
          val const : 'a -> 'a React.signal
          val create :
    -        ?eq:('a -> 'a -> bool) -> 'a -> 'a React.signal * ('a -> unit)
    +        ?eq:('a -> 'a -> bool) ->
    +        'a -> 'a React.signal * (?step:React.step -> 'a -> unit)
          val value : 'a React.signal -> 'a
          val retain :
            'a React.signal -> (unit -> unit) -> [ `R of unit -> unit ]
          val eq_fun : 'a React.signal -> ('a -> 'a -> bool) option
    -      val stop : 'a React.signal -> unit
    +      val stop : ?strong:bool -> 'a React.signal -> unit
          val equal :
            ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a React.signal -> bool
          val trace :
    @@ -80,6 +112,9 @@       val sample :
            ('b -> 'a -> 'c) ->
            'b React.event -> 'a React.signal -> 'c React.event
    +      val on :
    +        ?eq:('a -> 'a -> bool) ->
    +        bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
          val when_ :
            ?eq:('a -> 'a -> bool) ->
            bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
    @@ -97,7 +132,10 @@         ('a -> 'b -> 'a) -> 'a -> 'b React.signal list -> 'a React.signal
          val switch :
            ?eq:('a -> 'a -> bool) ->
    -        'a React.signal -> 'a React.signal React.event -> 'a React.signal
    +        'a React.signal React.signal -> 'a React.signal
    +      val bind :
    +        ?eq:('b -> 'b -> bool) ->
    +        'a React.signal -> ('a -> 'b React.signal) -> 'b React.signal
          val fix :
            ?eq:('a -> 'a -> bool) ->
            'a -> ('a React.signal -> 'a React.signal * 'b) -> 'b
    @@ -136,14 +174,23 @@         'e React.signal -> 'f React.signal -> 'g React.signal
          module Bool :
            sig
    +          val zero : bool React.signal
    +          val one : bool React.signal
              val not : bool React.signal -> bool React.signal
              val ( && ) :
                bool React.signal -> bool React.signal -> bool React.signal
              val ( || ) :
                bool React.signal -> bool React.signal -> bool React.signal
    +          val edge : bool React.signal -> bool React.event
    +          val rise : bool React.signal -> unit React.event
    +          val fall : bool React.signal -> unit React.event
    +          val flip : bool -> 'a React.event -> bool React.signal
            end
          module Int :
            sig
    +          val zero : int React.signal
    +          val one : int React.signal
    +          val minus_one : int React.signal
              val ( ~- ) : int React.signal -> int React.signal
              val succ : int React.signal -> int React.signal
              val pred : int React.signal -> int React.signal
    @@ -174,6 +221,9 @@         end
          module Float :
            sig
    +          val zero : float React.signal
    +          val one : float React.signal
    +          val minus_one : float React.signal
              val ( ~-. ) : float React.signal -> float React.signal
              val ( +. ) :
                float React.signal -> float React.signal -> float React.signal
    @@ -234,6 +284,15 @@             ?eq:('a -> 'a -> bool) ->
                ('b * 'a) React.signal -> 'a React.signal
            end
    +      module Option :
    +        sig
    +          val none : 'a option React.signal
    +          val some : 'a React.signal -> 'a option React.signal
    +          val value :
    +            ?eq:('a -> 'a -> bool) ->
    +            default:[ `Always of 'a React.signal | `Init of 'a React.signal ] ->
    +            'a option React.signal -> 'a React.signal
    +        end
          module Compare :
            sig
              val ( = ) : 'a React.signal -> 'a React.signal -> bool React.signal
    @@ -262,7 +321,8 @@           type 'a v
              val create :
                'a React.S.S.v ->
    -            'a React.S.S.v React.signal * ('a React.S.S.v -> unit)
    +            'a React.S.S.v React.signal *
    +            (?step:React.step -> 'a React.S.S.v -> unit)
              val equal :
                'a React.S.S.v React.signal ->
                'a React.S.S.v React.signal -> bool
    @@ -301,8 +361,11 @@             'a React.S.S.v ->
                'b React.signal list -> 'a React.S.S.v React.signal
              val switch :
    -            'a React.S.S.v React.signal ->
    -            'a React.S.S.v React.signal React.event ->
    +            'a React.S.S.v React.signal React.signal ->
    +            'a React.S.S.v React.signal
    +          val bind :
    +            'b React.signal ->
    +            ('b -> 'a React.S.S.v React.signal) ->
                'a React.S.S.v React.signal
              val fix :
                'a React.S.S.v ->
    @@ -341,7 +404,7 @@         functor (Eq : EqType) ->
              sig
                type 'a v = 'a Eq.t
    -            val create : 'a v -> 'a v signal * ('a v -> unit)
    +            val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
                val equal : 'a v signal -> 'a v signal -> bool
                val hold : 'a v -> 'a v event -> 'a v signal
                val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -356,7 +419,8 @@               ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
                val merge :
                  ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -            val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +            val switch : 'a v signal signal -> 'a v signal
    +            val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
                val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
                val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
                val l2 :
    @@ -382,7 +446,7 @@           module Sb :
                sig
                  type 'a v = bool
    -              val create : 'a v -> 'a v signal * ('a v -> unit)
    +              val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
                  val equal : 'a v signal -> 'a v signal -> bool
                  val hold : 'a v -> 'a v event -> 'a v signal
                  val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -398,7 +462,8 @@                 ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
                  val merge :
                    ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -              val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +              val switch : 'a v signal signal -> 'a v signal
    +              val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
                  val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
                  val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
                  val l2 :
    @@ -425,7 +490,7 @@           module Si :
                sig
                  type 'a v = int
    -              val create : 'a v -> 'a v signal * ('a v -> unit)
    +              val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
                  val equal : 'a v signal -> 'a v signal -> bool
                  val hold : 'a v -> 'a v event -> 'a v signal
                  val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -441,7 +506,8 @@                 ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
                  val merge :
                    ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -              val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +              val switch : 'a v signal signal -> 'a v signal
    +              val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
                  val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
                  val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
                  val l2 :
    @@ -468,7 +534,7 @@           module Sf :
                sig
                  type 'a v = float
    -              val create : 'a v -> 'a v signal * ('a v -> unit)
    +              val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
                  val equal : 'a v signal -> 'a v signal -> bool
                  val hold : 'a v -> 'a v event -> 'a v signal
                  val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -484,7 +550,8 @@                 ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
                  val merge :
                    ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -              val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +              val switch : 'a v signal signal -> 'a v signal
    +              val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
                  val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
                  val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
                  val l2 :
    @@ -510,4 +577,10 @@             end
            end
        end
    +  module Step :
    +    sig
    +      type t = React.step
    +      val create : unit -> React.step
    +      val execute : React.step -> unit
    +    end
    end     \ No newline at end of file diff -Nru react-0.9.4/doc/type_React.S.Bool.html react-1.2.0/doc/type_React.S.Bool.html --- react-0.9.4/doc/type_React.S.Bool.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Bool.html 2014-08-23 23:03:35.000000000 +0000 @@ -10,7 +10,13 @@ sig
    +  val zero : bool React.signal
    +  val one : bool React.signal
      val not : bool React.signal -> bool React.signal
      val ( && ) : bool React.signal -> bool React.signal -> bool React.signal
      val ( || ) : bool React.signal -> bool React.signal -> bool React.signal
    +  val edge : bool React.signal -> bool React.event
    +  val rise : bool React.signal -> unit React.event
    +  val fall : bool React.signal -> unit React.event
    +  val flip : bool -> 'a React.event -> bool React.signal
    end     \ No newline at end of file diff -Nru react-0.9.4/doc/type_React.S.Float.html react-1.2.0/doc/type_React.S.Float.html --- react-0.9.4/doc/type_React.S.Float.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Float.html 2014-08-23 23:03:35.000000000 +0000 @@ -10,6 +10,9 @@ sig
    +  val zero : float React.signal
    +  val one : float React.signal
    +  val minus_one : float React.signal
      val ( ~-. ) : float React.signal -> float React.signal
      val ( +. ) : float React.signal -> float React.signal -> float React.signal
      val ( -. ) : float React.signal -> float React.signal -> float React.signal
    diff -Nru react-0.9.4/doc/type_React.S.html react-1.2.0/doc/type_React.S.html --- react-0.9.4/doc/type_React.S.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.html 2014-08-23 23:03:35.000000000 +0000 @@ -12,11 +12,13 @@ sig
      type 'a t = 'a React.signal
      val const : 'a -> 'a React.signal
    -  val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a React.signal * ('a -> unit)
    +  val create :
    +    ?eq:('a -> 'a -> bool) ->
    +    'a -> 'a React.signal * (?step:React.step -> 'a -> unit)
      val value : 'a React.signal -> 'a
      val retain : 'a React.signal -> (unit -> unit) -> [ `R of unit -> unit ]
      val eq_fun : 'a React.signal -> ('a -> 'a -> bool) option
    -  val stop : 'a React.signal -> unit
    +  val stop : ?strong:bool -> 'a React.signal -> unit
      val equal :
        ?eq:('a -> 'a -> bool) -> 'a React.signal -> 'a React.signal -> bool
      val trace :
    @@ -39,6 +41,9 @@   val changes : 'a React.signal -> 'a React.event
      val sample :
        ('b -> 'a -> 'c) -> 'b React.event -> 'a React.signal -> 'c React.event
    +  val on :
    +    ?eq:('a -> 'a -> bool) ->
    +    bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
      val when_ :
        ?eq:('a -> 'a -> bool) ->
        bool React.signal -> 'a -> 'a React.signal -> 'a React.signal
    @@ -54,8 +59,10 @@     ?eq:('a -> 'a -> bool) ->
        ('a -> 'b -> 'a) -> 'a -> 'b React.signal list -> 'a React.signal
      val switch :
    -    ?eq:('a -> 'a -> bool) ->
    -    'a React.signal -> 'a React.signal React.event -> 'a React.signal
    +    ?eq:('a -> 'a -> bool) -> 'a React.signal React.signal -> 'a React.signal
    +  val bind :
    +    ?eq:('b -> 'b -> bool) ->
    +    'a React.signal -> ('a -> 'b React.signal) -> 'b React.signal
      val fix :
        ?eq:('a -> 'a -> bool) ->
        'a -> ('a React.signal -> 'a React.signal * 'b) -> 'b
    @@ -89,14 +96,23 @@     'd React.signal -> 'e React.signal -> 'f React.signal -> 'g React.signal
      module Bool :
        sig
    +      val zero : bool React.signal
    +      val one : bool React.signal
          val not : bool React.signal -> bool React.signal
          val ( && ) :
            bool React.signal -> bool React.signal -> bool React.signal
          val ( || ) :
            bool React.signal -> bool React.signal -> bool React.signal
    +      val edge : bool React.signal -> bool React.event
    +      val rise : bool React.signal -> unit React.event
    +      val fall : bool React.signal -> unit React.event
    +      val flip : bool -> 'a React.event -> bool React.signal
        end
      module Int :
        sig
    +      val zero : int React.signal
    +      val one : int React.signal
    +      val minus_one : int React.signal
          val ( ~- ) : int React.signal -> int React.signal
          val succ : int React.signal -> int React.signal
          val pred : int React.signal -> int React.signal
    @@ -117,6 +133,9 @@     end
      module Float :
        sig
    +      val zero : float React.signal
    +      val one : float React.signal
    +      val minus_one : float React.signal
          val ( ~-. ) : float React.signal -> float React.signal
          val ( +. ) :
            float React.signal -> float React.signal -> float React.signal
    @@ -175,6 +194,15 @@       val snd :
            ?eq:('a -> 'a -> bool) -> ('b * 'a) React.signal -> 'a React.signal
        end
    +  module Option :
    +    sig
    +      val none : 'a option React.signal
    +      val some : 'a React.signal -> 'a option React.signal
    +      val value :
    +        ?eq:('a -> 'a -> bool) ->
    +        default:[ `Always of 'a React.signal | `Init of 'a React.signal ] ->
    +        'a option React.signal -> 'a React.signal
    +    end
      module Compare :
        sig
          val ( = ) : 'a React.signal -> 'a React.signal -> bool React.signal
    @@ -197,7 +225,8 @@       type 'a v
          val create :
            'a React.S.S.v ->
    -        'a React.S.S.v React.signal * ('a React.S.S.v -> unit)
    +        'a React.S.S.v React.signal *
    +        (?step:React.step -> 'a React.S.S.v -> unit)
          val equal :
            'a React.S.S.v React.signal -> 'a React.S.S.v React.signal -> bool
          val hold :
    @@ -234,9 +263,11 @@         ('a React.S.S.v -> 'b -> 'a React.S.S.v) ->
            'a React.S.S.v -> 'b React.signal list -> 'a React.S.S.v React.signal
          val switch :
    -        'a React.S.S.v React.signal ->
    -        'a React.S.S.v React.signal React.event ->
    +        'a React.S.S.v React.signal React.signal ->
            'a React.S.S.v React.signal
    +      val bind :
    +        'b React.signal ->
    +        ('b -> 'a React.S.S.v React.signal) -> 'a React.S.S.v React.signal
          val fix :
            'a React.S.S.v ->
            ('a React.S.S.v React.signal -> 'a React.S.S.v React.signal * 'b) ->
    @@ -274,7 +305,7 @@     functor (Eq : EqType) ->
          sig
            type 'a v = 'a Eq.t
    -        val create : 'a v -> 'a v signal * ('a v -> unit)
    +        val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
            val equal : 'a v signal -> 'a v signal -> bool
            val hold : 'a v -> 'a v event -> 'a v signal
            val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -287,7 +318,8 @@         val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
            val merge :
              ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -        val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +        val switch : 'a v signal signal -> 'a v signal
    +        val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
            val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
            val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
            val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    @@ -312,7 +344,7 @@       module Sb :
            sig
              type 'a v = bool
    -          val create : 'a v -> 'a v signal * ('a v -> unit)
    +          val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
              val equal : 'a v signal -> 'a v signal -> bool
              val hold : 'a v -> 'a v event -> 'a v signal
              val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -325,7 +357,8 @@           val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
              val merge :
                ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -          val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +          val switch : 'a v signal signal -> 'a v signal
    +          val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
              val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
              val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
              val l2 :
    @@ -349,7 +382,7 @@       module Si :
            sig
              type 'a v = int
    -          val create : 'a v -> 'a v signal * ('a v -> unit)
    +          val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
              val equal : 'a v signal -> 'a v signal -> bool
              val hold : 'a v -> 'a v event -> 'a v signal
              val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -362,7 +395,8 @@           val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
              val merge :
                ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -          val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +          val switch : 'a v signal signal -> 'a v signal
    +          val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
              val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
              val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
              val l2 :
    @@ -386,7 +420,7 @@       module Sf :
            sig
              type 'a v = float
    -          val create : 'a v -> 'a v signal * ('a v -> unit)
    +          val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
              val equal : 'a v signal -> 'a v signal -> bool
              val hold : 'a v -> 'a v event -> 'a v signal
              val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -399,7 +433,8 @@           val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
              val merge :
                ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -          val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +          val switch : 'a v signal signal -> 'a v signal
    +          val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
              val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
              val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
              val l2 :
    diff -Nru react-0.9.4/doc/type_React.S.Int.html react-1.2.0/doc/type_React.S.Int.html --- react-0.9.4/doc/type_React.S.Int.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Int.html 2014-08-23 23:03:35.000000000 +0000 @@ -10,6 +10,9 @@ sig
    +  val zero : int React.signal
    +  val one : int React.signal
    +  val minus_one : int React.signal
      val ( ~- ) : int React.signal -> int React.signal
      val succ : int React.signal -> int React.signal
      val pred : int React.signal -> int React.signal
    diff -Nru react-0.9.4/doc/type_React.S.Make.html react-1.2.0/doc/type_React.S.Make.html --- react-0.9.4/doc/type_React.S.Make.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Make.html 2014-08-23 23:03:35.000000000 +0000 @@ -12,7 +12,7 @@ functor (Eq : EqType) ->
      sig
        type 'a v = 'a Eq.t
    -    val create : 'a v -> 'a v signal * ('a v -> unit)
    +    val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
        val equal : 'a v signal -> 'a v signal -> bool
        val hold : 'a v -> 'a v event -> 'a v signal
        val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -24,7 +24,8 @@     val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal
        val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
        val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -    val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +    val switch : 'a v signal signal -> 'a v signal
    +    val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
        val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
        val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
        val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    diff -Nru react-0.9.4/doc/type_React.S.Option.html react-1.2.0/doc/type_React.S.Option.html --- react-0.9.4/doc/type_React.S.Option.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Option.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,19 @@ + + + + + + + + +React.S.Option + + +sig
    +  val none : 'a option React.signal
    +  val some : 'a React.signal -> 'a option React.signal
    +  val value :
    +    ?eq:('a -> 'a -> bool) ->
    +    default:[ `Always of 'a React.signal | `Init of 'a React.signal ] ->
    +    'a option React.signal -> 'a React.signal
    +end     \ No newline at end of file diff -Nru react-0.9.4/doc/type_React.S.S.html react-1.2.0/doc/type_React.S.S.html --- react-0.9.4/doc/type_React.S.S.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.S.html 2014-08-23 23:03:35.000000000 +0000 @@ -12,7 +12,9 @@ sig
      type 'a v
      val create :
    -    'a React.S.S.v -> 'a React.S.S.v React.signal * ('a React.S.S.v -> unit)
    +    'a React.S.S.v ->
    +    'a React.S.S.v React.signal *
    +    (?step:React.step -> 'a React.S.S.v -> unit)
      val equal :
        'a React.S.S.v React.signal -> 'a React.S.S.v React.signal -> bool
      val hold :
    @@ -48,8 +50,10 @@     ('a React.S.S.v -> 'b -> 'a React.S.S.v) ->
        'a React.S.S.v -> 'b React.signal list -> 'a React.S.S.v React.signal
      val switch :
    -    'a React.S.S.v React.signal ->
    -    'a React.S.S.v React.signal React.event -> 'a React.S.S.v React.signal
    +    'a React.S.S.v React.signal React.signal -> 'a React.S.S.v React.signal
    +  val bind :
    +    'b React.signal ->
    +    ('b -> 'a React.S.S.v React.signal) -> 'a React.S.S.v React.signal
      val fix :
        'a React.S.S.v ->
        ('a React.S.S.v React.signal -> 'a React.S.S.v React.signal * 'b) -> 'b
    diff -Nru react-0.9.4/doc/type_React.S.Special.html react-1.2.0/doc/type_React.S.Special.html --- react-0.9.4/doc/type_React.S.Special.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Special.html 2014-08-23 23:03:35.000000000 +0000 @@ -13,7 +13,7 @@   module Sb :
        sig
          type 'a v = bool
    -      val create : 'a v -> 'a v signal * ('a v -> unit)
    +      val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
          val equal : 'a v signal -> 'a v signal -> bool
          val hold : 'a v -> 'a v event -> 'a v signal
          val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -26,7 +26,8 @@       val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
          val merge :
            ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -      val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +      val switch : 'a v signal signal -> 'a v signal
    +      val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
          val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
          val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
          val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    @@ -49,7 +50,7 @@   module Si :
        sig
          type 'a v = int
    -      val create : 'a v -> 'a v signal * ('a v -> unit)
    +      val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
          val equal : 'a v signal -> 'a v signal -> bool
          val hold : 'a v -> 'a v event -> 'a v signal
          val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -62,7 +63,8 @@       val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
          val merge :
            ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -      val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +      val switch : 'a v signal signal -> 'a v signal
    +      val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
          val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
          val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
          val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    @@ -85,7 +87,7 @@   module Sf :
        sig
          type 'a v = float
    -      val create : 'a v -> 'a v signal * ('a v -> unit)
    +      val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
          val equal : 'a v signal -> 'a v signal -> bool
          val hold : 'a v -> 'a v event -> 'a v signal
          val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -98,7 +100,8 @@       val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
          val merge :
            ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -      val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +      val switch : 'a v signal signal -> 'a v signal
    +      val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
          val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
          val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
          val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    diff -Nru react-0.9.4/doc/type_React.S.Special.Sb.html react-1.2.0/doc/type_React.S.Special.Sb.html --- react-0.9.4/doc/type_React.S.Special.Sb.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Special.Sb.html 2014-08-23 23:03:35.000000000 +0000 @@ -11,7 +11,7 @@ sig
      type 'a v = bool
    -  val create : 'a v -> 'a v signal * ('a v -> unit)
    +  val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
      val equal : 'a v signal -> 'a v signal -> bool
      val hold : 'a v -> 'a v event -> 'a v signal
      val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -23,7 +23,8 @@   val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal
      val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
      val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -  val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +  val switch : 'a v signal signal -> 'a v signal
    +  val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
      val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
      val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
      val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    diff -Nru react-0.9.4/doc/type_React.S.Special.Sf.html react-1.2.0/doc/type_React.S.Special.Sf.html --- react-0.9.4/doc/type_React.S.Special.Sf.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Special.Sf.html 2014-08-23 23:03:35.000000000 +0000 @@ -11,7 +11,7 @@ sig
      type 'a v = float
    -  val create : 'a v -> 'a v signal * ('a v -> unit)
    +  val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
      val equal : 'a v signal -> 'a v signal -> bool
      val hold : 'a v -> 'a v event -> 'a v signal
      val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -23,7 +23,8 @@   val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal
      val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
      val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -  val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +  val switch : 'a v signal signal -> 'a v signal
    +  val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
      val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
      val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
      val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    diff -Nru react-0.9.4/doc/type_React.S.Special.Si.html react-1.2.0/doc/type_React.S.Special.Si.html --- react-0.9.4/doc/type_React.S.Special.Si.html 2012-08-05 13:51:04.000000000 +0000 +++ react-1.2.0/doc/type_React.S.Special.Si.html 2014-08-23 23:03:35.000000000 +0000 @@ -11,7 +11,7 @@ sig
      type 'a v = int
    -  val create : 'a v -> 'a v signal * ('a v -> unit)
    +  val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit)
      val equal : 'a v signal -> 'a v signal -> bool
      val hold : 'a v -> 'a v event -> 'a v signal
      val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal
    @@ -23,7 +23,8 @@   val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal
      val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal
      val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal
    -  val switch : 'a v signal -> 'a v signal event -> 'a v signal
    +  val switch : 'a v signal signal -> 'a v signal
    +  val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal
      val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b
      val l1 : ('a -> 'b v) -> 'a signal -> 'b v signal
      val l2 : ('a -> 'b -> 'c v) -> 'a signal -> 'b signal -> 'c v signal
    diff -Nru react-0.9.4/doc/type_React.Step.html react-1.2.0/doc/type_React.Step.html --- react-0.9.4/doc/type_React.Step.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/doc/type_React.Step.html 2014-08-23 23:03:35.000000000 +0000 @@ -0,0 +1,16 @@ + + + + + + + + +React.Step + + +sig
    +  type t = React.step
    +  val create : unit -> React.step
    +  val execute : React.step -> unit
    +end     \ No newline at end of file diff -Nru react-0.9.4/myocamlbuild.ml react-1.2.0/myocamlbuild.ml --- react-0.9.4/myocamlbuild.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/myocamlbuild.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,491 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 283ec2005876064ba21c41d9e688a027) *) -module OASISGettext = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISGettext.ml" - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISExpr = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISExpr.ml" - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - - -# 117 "myocamlbuild.ml" -module BaseEnvLight = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseEnvLight.ml" - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 215 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - let split s ch = - let x = - ref [] - in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x - - let split_nl s = split s '\n' - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* this lists all supported packages *) - let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") - - (* this is supposed to list available syntaxes, but I don't know how to do it. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - (* ocamlfind command *) - let ocamlfind x = S[A"ocamlfind"; x] - - let dispatch = - function - | Before_options -> - (* by using Before_options one let command line options have an higher priority *) - (* on the contrary using After_options will guarantee to have the higher priority *) - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) - - | _ -> - () - -end - -module MyOCamlbuildBase = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - type dir = string - type file = string - type name = string - type tag = string - -# 56 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" - - type t = - { - lib_ocaml: (name * dir list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - let nm_libstubs nm = - nm^"_stubs" - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [] -> - ocaml_lib nm - | nm, dir :: tl -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = - BaseEnvLight.var_choose cond_specs env - in - flag tags & spec) - t.flags - | _ -> - () - - let dispatch_default t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch; - ] - -end - - -# 476 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = [("react", ["src"])]; - lib_c = []; - flags = []; - includes = [("test", ["src"])]; - } - ;; - -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; - -# 490 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff -Nru react-0.9.4/_oasis react-1.2.0/_oasis --- react-0.9.4/_oasis 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/_oasis 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -OASISFormat: 0.3 -Name: react -Version: 0.9.4 -Synopsis: Declarative events and signals for OCaml -Authors: Daniel Bünzli -Copyrights: (c) 2009-2012 Daniel C. Bünzli -License: BSD3 -Homepage: http://erratique.ch/software/react -Description: - React is an OCaml module for functional reactive programming (FRP). It - provides support to program with time varying values : declarative - events and signals. React doesn't define any primitive event or - signal, it lets the client chooses the concrete timeline. - . - React is made of a single, independent, module and distributed under - the BSD3 license. - -OCamlVersion: >= 3.11.0 -Plugins: META (0.3) -BuildTools:ocamlbuild - -Library react - Path: src - Modules: React - -Executable clock - Path: test - MainIs: clock.ml - BuildDepends: unix, react - CompiledObject: Best - Install: false - -Executable breakout - Path: test - MainIs: breakout.ml - BuildDepends: unix, react - CompiledObject: Best - Install: false - -Executable test - Path: test - MainIs: test.ml - CompiledObject: Best - BuildDepends: react - Install: false - -Test test - Command: $test - -Document api - Title: React's documentation and API reference - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - XOCamlbuildLibraries: react - XOCamlbuildPath: doc - -Document distribution - Title: "React's README and CHANGES files" - DataFiles: README CHANGES - -Document samples - Title: "React's sample code" - DataFiles: test/*.ml - -SourceRepository head - Type: git - Location: git://erratique.ch/repos/react.git - Browser: http://erratique.ch/repos/react diff -Nru react-0.9.4/.ocamlinit react-1.2.0/.ocamlinit --- react-0.9.4/.ocamlinit 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/.ocamlinit 2014-08-23 23:03:34.000000000 +0000 @@ -1,2 +1,2 @@ #directory "_build/src" -#load "react.cmo" +#load "react.cmo" \ No newline at end of file diff -Nru react-0.9.4/opam react-1.2.0/opam --- react-0.9.4/opam 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/opam 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,17 @@ +opam-version: "1" +maintainer: "Daniel Bünzli " +homepage: "http://erratique.ch/software/react" +authors: ["Daniel Bünzli "] +doc: "http://erratique.ch/software/react/doc/React" +dev-repo: "http://erratique.ch/repos/react.git" +bug-reports: "https://github.com/dbuenzli/react/issues" +tags: [ "reactive" "declarative" "signal" "event" "frp" "org:erratique" ] +license: "BSD3" +depends: ["ocamlfind"] +ocaml-version: [>= "3.11.0"] +build: +[ + [ "ocaml" "pkg/git.ml" ] + [ "ocaml" "pkg/build.ml" "native=%{ocaml-native}%" + "native-dynlink=%{ocaml-native-dynlink}%" ] +] \ No newline at end of file diff -Nru react-0.9.4/pkg/build.ml react-1.2.0/pkg/build.ml --- react-0.9.4/pkg/build.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/build.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,16 @@ +#!/usr/bin/env ocaml +#directory "pkg";; +#use "topkg.ml";; + +let () = + Pkg.describe "react" ~builder:`OCamlbuild [ + Pkg.lib "pkg/META"; + Pkg.lib ~exts:Exts.module_library "src/react"; + Pkg.lib ~exts:Exts.library "src/react_top"; + Pkg.doc "README.md"; + Pkg.doc "CHANGES.md"; + Pkg.doc "test/breakout.ml"; + Pkg.doc "test/clock.ml"; ] + + + diff -Nru react-0.9.4/pkg/config.ml react-1.2.0/pkg/config.ml --- react-0.9.4/pkg/config.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/config.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,11 @@ +#!/usr/bin/env ocaml +#directory "pkg" +#use "topkg-ext.ml" + +module Config = struct + include Config_default + let vars = + [ "NAME", "react"; + "VERSION", Git.describe ~chop_v:true "master"; + "MAINTAINER", "Daniel Bünzli " ] +end diff -Nru react-0.9.4/pkg/git.ml react-1.2.0/pkg/git.ml --- react-0.9.4/pkg/git.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/git.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,14 @@ +#!/usr/bin/env ocaml +#directory "pkg" +#use "config.ml" + +(* This is only for git checkout builds, it can be ignored + for distribution builds. *) + +let () = + if Dir.exists ".git" then begin + Vars.subst ~skip:Config.subst_skip ~vars:Config.vars ~dir:"." + >>& fun () -> Cmd.exec_hook Config.git_hook + >>& fun () -> () + end + diff -Nru react-0.9.4/pkg/META react-1.2.0/pkg/META --- react-0.9.4/pkg/META 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/META 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,22 @@ +version = "1.2.0" +description = "Declarative events and signals for OCaml" +archive(byte) = "react.cma" +archive(byte, plugin) = "react.cma" +archive(byte, toploop) += "react_top.cma" +archive(native) = "react.cmxa" +archive(native, plugin) = "react.cmxs" +archive(native, toploop) += "react_top.cmxs" +exists_if = "react.cma" + +package "top" ( + description = "Toplevel support for React" + version = "1.2.0" + requires = "compiler-libs.toplevel" + archive(byte) = "react_top.cma" + archive(byte, plugin) = "react_top.cma" + archive(native) = "react_top.cmxa" + archive(native, plugin) = "react_top.cmxs" + exists_if = "react_top.cma" +) + + diff -Nru react-0.9.4/pkg/topkg-ext.ml react-1.2.0/pkg/topkg-ext.ml --- react-0.9.4/pkg/topkg-ext.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/topkg-ext.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,272 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + react release 1.2.0 + ---------------------------------------------------------------------------*) + +let ( >>= ) v f = match v with `Ok v -> f v | `Error _ as e -> e +let ( >>& ) v f = match v with +| `Ok v -> f v | `Error e -> Printf.eprintf "%s: %s\n%!" Sys.argv.(0) e; exit 1 + +type 'a result = [ `Ok of 'a | `Error of string ] + +(** Working with files *) +module File : sig + val exists : string -> bool + (** [exists file] is [true] if [file] exists. *) + + val read : string -> string result + (** [read file] is [file]'s contents. *) + + val write : string -> string -> unit result + (** [write file content] writes [contents] to [file]. *) + + val write_subst : string -> (string * string) list -> string -> unit result + (** [write_subst file vars content] writes [contents] to [file] + substituting variables of the form [%%ID%%] by their definition. + The [ID]'s are [List.map fst vars] and their definition content + is found with [List.assoc]. *) + + val delete : ?maybe:bool -> string -> unit result + (** [delete maybe file] deletes file [file]. If [maybe] is [true] (defaults + to false) no error is reported if the file doesn't exist. *) + + val temp : unit -> string result + (** [temp ()] creates a temporary file and returns its name. The file + is destroyed at the end of program execution. *) +end = struct + let exists = Sys.file_exists + let read file = try + let ic = open_in file in + let len = in_channel_length ic in + let s = String.create len in + really_input ic s 0 len; close_in ic; `Ok s + with Sys_error e -> `Error e + + let write f s = try + let oc = open_out f in + output_string oc s; close_out oc; `Ok () + with Sys_error e -> `Error e + + let write_subst f vars s = try + let oc = open_out f in + let start = ref 0 in + let last = ref 0 in + let len = String.length s in + while (!last < len - 4) do + if not (s.[!last] = '%' && s.[!last + 1] = '%') then incr last else + begin + let start_subst = !last in + let last_id = ref (!last + 2) in + let stop = ref false in + while (!last_id < len - 1 && not !stop) do + if not (s.[!last_id] = '%' && s.[!last_id + 1] = '%') then begin + if s.[!last_id] <> ' ' then (incr last_id) else + (stop := true; last := !last_id) + end else begin + let id_start = start_subst + 2 in + let id = String.sub s (id_start) (!last_id - id_start) in + try + let subst = List.assoc id vars in + output oc s !start (start_subst - !start); + output_string oc subst; + stop := true; + start := !last_id + 2; + last := !last_id + 2; + with Not_found -> + stop := true; + last := !last_id + end + done + end + done; + output oc s !start (len - !start); close_out oc; `Ok () + with Sys_error e -> `Error e + + let delete ?(maybe = false) file = try + if maybe && not (exists file) then `Ok () else + `Ok (Sys.remove file) + with Sys_error e -> `Error e + + let temp () = try + let f = Filename.temp_file (Filename.basename Sys.argv.(0)) "topkg" in + at_exit (fun () -> ignore (delete f)); `Ok f + with Sys_error e -> `Error e +end + +(** Working with directories. *) +module Dir : sig + val exists : string -> bool + (** [exists dir] is [true] if directory [dir] exists. *) + + val change_cwd : string -> unit result + (** [change_cwd dir] changes the current working directory to [dir]. *) + + val fold_files_rec : ?skip:string list -> (string -> 'a -> 'a result) -> + 'a -> string list -> 'a result + (** [fold_files_rec skip f acc paths] folds [f] over the files + found in [paths]. Files and directories whose suffix matches an + element of [skip] are skipped. *) +end = struct + let exists dir = Sys.file_exists dir && Sys.is_directory dir + let change_cwd dir = try `Ok (Sys.chdir dir) with Sys_error e -> `Error e + let fold_files_rec ?(skip = []) f acc paths = + let is_dir d = try Sys.is_directory d with Sys_error _ -> false in + let readdir d = try Array.to_list (Sys.readdir d) with Sys_error _ -> [] in + let keep p = not (List.exists (fun s -> Filename.check_suffix p s) skip) in + let process acc file = match acc with + | `Error _ as e -> e + | `Ok acc -> f file acc + in + let rec aux f acc = function + | (d :: ds) :: up -> + let paths = List.rev_map (Filename.concat d) (readdir d) in + let paths = List.find_all keep paths in + let dirs, files = List.partition is_dir paths in + begin match List.fold_left process acc files with + | `Error _ as e -> e + | `Ok _ as acc -> aux f acc (dirs :: ds :: up) + end + | [] :: [] -> acc + | [] :: up -> aux f acc up + | _ -> assert false + in + let paths = List.find_all keep paths in + let dirs, files = List.partition is_dir paths in + let acc = List.fold_left process (`Ok acc) files in + aux f acc (dirs :: []) +end + +(** Command invocation. *) +module Cmd : sig + val exec : string -> unit result + (** [exec cmd] executes [cmd]. *) + + val exec_hook : string option -> unit result + (** [exec_hook args] is [exec ("ocaml " ^ "args")] if [args] is some. *) + + val read : string -> string result + (** [read cmd] executes [cmd] and returns the contents of its stdout. *) +end = struct + let exec cmd = + let code = Sys.command cmd in + if code = 0 then `Ok () else + `Error (Printf.sprintf "invocation `%s' exited with %d" cmd code) + + let exec_hook args = match args with + | None -> `Ok () + | Some args -> exec (Printf.sprintf "ocaml %s" args) + + let read cmd = + File.temp () >>= fun file -> + exec (Printf.sprintf "%s > %s" cmd file) >>= fun () -> + File.read file >>= fun v -> + `Ok v +end + +(** Variable substitution. *) +module Vars : sig + val subst : skip:string list -> vars:(string * string) list -> + dir:string -> unit result + (** [subst skip vars dir] substitutes [vars] in all files + in [dir] except those that are [skip]ped (see {!Dir.fold_files_rec}). *) + + val get : string -> (string * string) list -> string result + (** [get v] lookup variable [v] in [vars]. Returns an error if [v] is + absent or if it is the empty string. *) + +end = struct + let subst ~skip ~vars ~dir = + let subst f () = + File.read f >>= fun contents -> + File.write_subst f vars contents >>= fun () -> `Ok () + in + Dir.fold_files_rec ~skip subst () [dir] + + let get v vars = + let v = try List.assoc v vars with Not_found -> "" in + if v <> "" then `Ok v else + `Error (Printf.sprintf "empty or undefined variable %s in Config.vars" v) +end + +(** Git invocations. *) +module Git : sig + val describe : ?chop_v:bool -> string -> string + (** [describe chop_v branch] invokes [git describe branch]. If [chop_v] + is [true] (defaults to [false]) an initial ['v'] in the result + is chopped. *) +end = struct + let describe ?(chop_v = false) branch = + if not (Dir.exists ".git") then "not-a-git-checkout" else + Cmd.read (Printf.sprintf "git describe %s" branch) >>& fun d -> + let len = String.length d in + if chop_v && len > 0 && d.[0] = 'v' then String.sub d 1 (len - 2) else + String.sub d 0 (len - 1) (* remove \n *) +end + +(** Default configuration. *) +module Config_default : sig + val subst_skip : string list + (** [subst_skip] is a list of suffixes that are automatically + skipped during variable substitution. *) + + val vars : (string * string) list + (** [vars] is the list of variables to substitute, empty. *) + + val git_hook : string option + (** [git_start_hook] is an ocaml script to invoke before a git package + build, after variable substitution occured. *) + + val distrib_remove : string list + (** [distrib_remove] is a list of files to remove before making + the distributino tarball. *) + + val distrib_hook : string option + (** [distrib_hook] is an ocaml script to invoke before trying + to build the distribution. *) + + val www_demos : string list + (** [www_demos] is a list of build targets that represent single page + js_of_ocaml demo. *) +end = struct + let subst_skip = [".git"; ".png"; ".jpeg"; ".otf"; ".ttf"; ".pdf" ] + let vars = [] + let git_hook = None + let distrib_remove = [".git"; ".gitignore"; "build"] + let distrib_hook = None + let www_demos = [] +end + + +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) diff -Nru react-0.9.4/pkg/topkg.ml react-1.2.0/pkg/topkg.ml --- react-0.9.4/pkg/topkg.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/pkg/topkg.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,303 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + react release 1.2.0 + ---------------------------------------------------------------------------*) + +(* Public api *) + +(** Build environment access *) +module type Env = sig + val bool : string -> bool + (** [bool key] declares [key] as being a boolean key in the environment. + Specifing key=(true|false) on the command line becomes mandatory. *) + + val native : bool + (** [native] is [bool "native"]. *) + + val native_dynlink : bool + (** [native_dylink] is [bool "native-dynlink"] *) +end + +(** Exts defines sets of file extensions. *) +module type Exts = sig + val interface : string list + (** [interface] is [[".mli"; ".cmi"; ".cmti"]] *) + + val interface_opt : string list + (** [interface_opt] is [".cmx" :: interface] *) + + val library : string list + (** [library] is [[".cma"; ".cmxa"; ".cmxs"; ".a"]] *) + + val module_library : string list + (** [module_library] is [(interface_opt @ library)]. *) +end + +(** Package description. *) +module type Pkg = sig + type builder = [ `OCamlbuild | `Other of string * string ] + (** The type for build tools. Either [`OCamlbuild] or an + [`Other (tool, bdir)] tool [tool] that generates its build artefacts + in [bdir]. *) + + type moves + (** The type for install moves. *) + + type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves + (** The type for field install functions. A call + [field cond exts dst path] generates install moves as follows: + {ul + {- If [cond] is [false] (defaults to [true]), no move is generated.} + {- If [exts] is present, generates a move for each path in + the list [List.map (fun e -> path ^ e) exts].} + {- If [dst] is present this path is used as the move destination + (allows to install in subdirectories). If absent [dst] is + [Filename.basename path].} *) + + val lib : field + val bin : ?auto:bool -> field + (** If [auto] is true (defaults to false) generates + [path ^ ".native"] if {!Env.native} is [true] and + [path ^ ".byte"] if {!Env.native} is [false]. *) + val sbin : ?auto:bool -> field (** See {!bin}. *) + val toplevel : field + val share : field + val share_root : field + val etc : field + val doc : field + val misc : field + val stublibs : field + val man : field + val describe : string -> builder:builder -> moves list -> unit + (** [describe name builder moves] describes a package named [name] with + builder [builder] and install moves [moves]. *) +end + +(* Implementation *) + +module Topkg : sig + val cmd : [`Build | `Explain | `Help ] + val env : (string * bool) list + val err_parse : string -> 'a + val err_mdef : string -> 'a + val err_miss : string -> 'a + val err_file : string -> string -> 'a + val warn_unused : string -> unit +end = struct + + (* Parses the command line. The actual cmd execution occurs in the call + to Pkg.describe. *) + + let err fmt = + let k _ = exit 1 in + Format.kfprintf k Format.err_formatter ("%s: " ^^ fmt ^^ "@.") Sys.argv.(0) + + let err_parse a = err "argument `%s' is not of the form key=(true|false)" a + let err_mdef a = err "bool `%s' is defined more than once" a + let err_miss a = err "argument `%s=(true|false)' is missing" a + let err_file f e = err "%s: %s" f e + let warn_unused k = + Format.eprintf "%s: warning: environment key `%s` unused.@." Sys.argv.(0) k + + let cmd, env = + let rec parse_env acc = function (* not t.r. *) + | arg :: args -> + begin try + (* String.cut ... *) + let len = String.length arg in + let eq = String.index arg '=' in + let bool = bool_of_string (String.sub arg (eq + 1) (len - eq - 1)) in + let key = String.sub arg 0 eq in + if key = "" then raise Exit else + try ignore (List.assoc key acc); err_mdef key with + | Not_found -> parse_env ((key, bool) :: acc) args + with + | Invalid_argument _ | Not_found | Exit -> err_parse arg + end + | [] -> acc + in + match List.tl (Array.to_list Sys.argv) with + | "explain" :: args -> `Explain, parse_env [] args + | ("help" | "-h" | "--help" | "-help") :: args -> `Help, parse_env [] args + | args -> `Build, parse_env [] args +end + +module Env : sig + include Env + val get : unit -> (string * bool) list +end = struct + let env = ref [] + let get () = !env + let add_bool key b = env := (key, b) :: !env + let bool key = + let b = try List.assoc key Topkg.env with + | Not_found -> if Topkg.cmd = `Build then Topkg.err_miss key else true + in + add_bool key b; b + + let native = bool "native" + let native_dynlink = bool "native-dynlink" +end + +module Exts : Exts = struct + let interface = [".mli"; ".cmi"; ".cmti"] + let interface_opt = ".cmx" :: interface + let library = [".cma"; ".cmxa"; ".cmxs"; ".a"] + let module_library = (interface_opt @ library) +end + +module Pkg : Pkg = struct + type builder = [ `OCamlbuild | `Other of string * string ] + type moves = (string * (string * string)) list + type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves + + let str = Printf.sprintf + let warn_unused () = + let keys = List.map fst Topkg.env in + let keys_used = List.map fst (Env.get ()) in + let unused = List.find_all (fun k -> not (List.mem k keys_used)) keys in + List.iter Topkg.warn_unused unused + + let has_suffix = Filename.check_suffix + let build_strings ?(exec_sep = " ") btool bdir mvs = + let no_build = [ ".cmti"; ".cmt" ] in + let install = Buffer.create 1871 in + let exec = Buffer.create 1871 in + let rec add_mvs current = function + | (field, (src, dst)) :: mvs when field = current -> + if List.exists (has_suffix src) no_build then + Buffer.add_string install (str "\n \"?%s/%s\" {\"%s\"}" bdir src dst) + else begin + Buffer.add_string exec (str "%s%s" exec_sep src); + Buffer.add_string install (str "\n \"%s/%s\" {\"%s\"}" bdir src dst); + end; + add_mvs current mvs + | (((field, _) :: _) as mvs) -> + if current <> "" (* first *) then Buffer.add_string install " ]\n"; + Buffer.add_string install (str "%s: [" field); + add_mvs field mvs + | [] -> () + in + Buffer.add_string exec btool; + add_mvs "" mvs; + Buffer.add_string install " ]\n"; + Buffer.contents install, Buffer.contents exec + + let pr = Format.printf + let pr_explanation btool bdir pkg mvs = + let env = Env.get () in + let install, exec = build_strings ~exec_sep:" \\\n " btool bdir mvs in + pr "@["; + pr "Package name: %s@," pkg; + pr "Build tool: %s@," btool; + pr "Build directory: %s@," bdir; + pr "Environment:@, "; + List.iter (fun (k,v) -> pr "%s=%b@, " k v) (List.sort compare env); + pr "@,Build invocation:@,"; + pr " %s@,@," exec; + pr "Install file:@,"; + pr "%s@," install; + pr "@]"; + () + + let pr_help () = + pr "Usage example:@\n %s" Sys.argv.(0); + List.iter (fun (k,v) -> pr " %s=%b" k v) (List.sort compare (Env.get ())); + pr "@." + + let build btool bdir pkg mvs = + let install, exec = build_strings btool bdir mvs in + let e = Sys.command exec in + if e <> 0 then exit e else + let install_file = pkg ^ ".install" in + try + let oc = open_out install_file in + output_string oc install; flush oc; close_out oc + with Sys_error e -> Topkg.err_file install_file e + + let mvs ?(drop_exts = []) field ?(cond = true) ?(exts = []) ?dst src = + if not cond then [] else + let mv src dst = (field, (src, dst)) in + let expand exts s d = List.map (fun e -> mv (s ^ e) (d ^ e)) exts in + let dst = match dst with None -> Filename.basename src | Some dst -> dst in + let files = if exts = [] then [mv src dst] else expand exts src dst in + let keep (_, (src, _)) = not (List.exists (has_suffix src) drop_exts) in + List.find_all keep files + + let lib = + let drop_exts = + if Env.native && not Env.native_dynlink then [ ".cmxs" ] else + if not Env.native then [ ".a"; ".cmx"; ".cmxa"; ".cmxs" ] else [] + in + mvs ~drop_exts "lib" + + let share = mvs "share" + let share_root = mvs "share_root" + let etc = mvs "etc" + let toplevel = mvs "toplevel" + let doc = mvs "doc" + let misc = mvs "misc" + let stublibs = mvs "stublibs" + let man = mvs "man" + + let bin_drops = if not Env.native then [ ".native" ] else [] + let bin_mvs field ?(auto = false) ?cond ?exts ?dst src = + let src, dst = + if not auto then src, dst else + let dst = match dst with + | None -> Some (Filename.basename src) + | Some _ as dst -> dst + in + let src = if Env.native then src ^ ".native" else src ^ ".byte" in + src, dst + in + mvs ~drop_exts:bin_drops field ?cond ?dst src + + let bin = bin_mvs "bin" + let sbin = bin_mvs "sbin" + + let describe pkg ~builder mvs = + let mvs = List.sort compare (List.flatten mvs) in + let btool, bdir = match builder with + | `OCamlbuild -> "ocamlbuild -use-ocamlfind -classic-display", "_build" + | `Other (btool, bdir) -> btool, bdir + in + match Topkg.cmd with + | `Explain -> pr_explanation btool bdir pkg mvs + | `Help -> pr_help () + | `Build -> warn_unused (); build btool bdir pkg mvs +end + +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) diff -Nru react-0.9.4/README react-1.2.0/README --- react-0.9.4/README 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -------------------------------------------------------------------------------- -React - Declarative events and signals for OCaml - Release 0.9.4 -------------------------------------------------------------------------------- - -React is an OCaml module for functional reactive programming (FRP). It -provides support to program with time varying values : declarative -events and signals. React doesn't define any primitive event or -signal, it lets the client chooses the concrete timeline. - -React is made of a single, independent, module and distributed under -the BSD3 license. - -Home page: http://erratique.ch/software/react -Contact: Daniel Bünzli - - -Installation ------------- - -To install React you need at least : - - OCaml >= 3.11.0 - -If you have `findlib`, it can be installed by typing : - - ocaml setup.ml -configure - ocaml setup.ml -build - ocaml setup.ml -install - -If you don't, `react.mli` and `react.ml` contain everything, the -code, the documentation and the license. Install the dependencies and -use the sources the way you want. For example if you use `ocamlbuild` -you can issue the following commands from the root directory of your -project : - - ln -s /path/to/react-0.9.4/src react - echo " : include" >> _tags - - -Documentation -------------- - -The documentation and API reference is automatically generated by -`ocamldoc` from `react.mli`. For you convenience you can find a -generated version in the `doc` directory of the distribution. - - -Sample programs ---------------- - -Sample programs are located in the `test` directory of the -distribution. They can be built with : - - ocamlbuild test/tests.otarget - -The resulting binaries are in `_build/test` : - -- `test.native` tests the library, nothing should fail. -- `clock.native` is a command line program using ANSI escape sequences - and the Unix module to print the current local time. -- `breakout.native` is a command line program using ANSI escape sequences - and the Unix module to implement a simple breakout game. diff -Nru react-0.9.4/README.md react-1.2.0/README.md --- react-0.9.4/README.md 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/README.md 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,53 @@ +React — Declarative events and signals for OCaml +------------------------------------------------------------------------------- +Release 1.2.0 + +React is an OCaml module for functional reactive programming (FRP). It +provides support to program with time varying values : declarative +events and signals. React doesn't define any primitive event or +signal, it lets the client chooses the concrete timeline. + +React is made of a single, independent, module and distributed under +the BSD3 license. + +Home page: http://erratique.ch/software/react +Contact: Daniel Bünzli `` + + +## Installation + +React can be installed with `opam`: + + opam install react + +If you don't use `opam` consult the [`opam`](opam) file for build +instructions. + + +## Documentation + +The documentation and API reference is automatically generated by +`ocamldoc` from the interfaces. It can be consulted [online][3] +and there is a generated version in the `doc` directory of the +distribution. + +[3]: http://erratique.ch/software/react/doc/React + + +## Sample programs + +If you installed React with `opam` sample programs are located in +the directory `opam config var react:doc`. + +In the distribution sample programs are located in the `test` +directory of the distribution. They can be built with: + + ocamlbuild -use-ocamlfind test/tests.otarget + +The resulting binaries are in `_build/test`. + +- `test.native` tests the library, nothing should fail. +- `clock.native` is a command line program using ANSI escape sequences + and the Unix module to print the current local time. +- `breakout.native` is a command line program using ANSI escape sequences + and the Unix module to implement a simple breakout game. diff -Nru react-0.9.4/setup.ml react-1.2.0/setup.ml --- react-0.9.4/setup.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/setup.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,6073 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.3.0 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 80aa4c9fa91e67754a0644227176230f) *) -(* - Regenerated by OASIS v0.3.0 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISGettext.ml" - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISContext = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISContext.ml" - - open OASISGettext - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - type t = - { - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - let quiet = - {!default with quiet = true} - - - let args () = - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - (s_ " Run quietly"); - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - (s_ " Display information message"); - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - (s_ " Output debug message")] -end - -module OASISString = struct -# 1 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISString.ml" - - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf - -end - -module OASISUtils = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISUtils.ml" - - open OASISGettext - - module MapString = Map.Make(String) - - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc - - module SetString = Set.Make(String) - - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst - - let set_string_of_list = - set_string_add_list - SetString.empty - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - String.lowercase buf - end - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - let failwithf fmt = Printf.ksprintf failwith fmt - -end - -module PropList = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/PropList.ml" - - open OASISGettext - - type name = string - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - module Data = - struct - - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - -# 71 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/PropList.ml" - end - - module Schema = - struct - - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - module Field = - struct - - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - - end - - module FieldRO = - struct - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - - end -end - -module OASISMessage = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISMessage.ml" - - - open OASISGettext - open OASISContext - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISVersion.ml" - - open OASISGettext - - - - type s = string - - type t = string - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - let string_of_version t = t - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - let version_0_3_or_after t = - comparator_apply t (VGreaterEqual (string_of_version "0.3")) - -end - -module OASISLicense = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISLicense.ml" - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - type license = string - - type license_exception = string - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - -end - -module OASISExpr = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISExpr.ml" - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - -module OASISTypes = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISTypes.ml" - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - type findlib_name = string - type findlib_full = string - - type compiled_object = - | Byte - | Native - | Best - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - type 'a plugin = 'a * name * OASISVersion.t option - - type all_plugin = plugin_kind plugin - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - -# 102 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISTypes.ml" - - type 'a conditional = 'a OASISExpr.choices - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - type section = - | Library of common_section * build_section * library - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - -end - -module OASISUnixPath = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISUnixPath.ml" - - type unix_filename = string - type unix_dirname = string - - type host_filename = string - type host_dirname = string - - let current_dir_name = "." - - let parent_dir_name = ".." - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) - -end - -module OASISHostPath = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISHostPath.ml" - - - open Filename - - module Unix = OASISUnixPath - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISSection.ml" - - open OASISTypes - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - let section_common sct = - snd (section_kind_common sct) - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - -end - -module OASISBuildSection = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISBuildSection.ml" - -end - -module OASISExecutable = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISExecutable.ml" - - open OASISTypes - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - -end - -module OASISLibrary = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISLibrary.ml" - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - library * - group_t list) - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists (cs, bs, lib) modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module source_file_exists (cs, bs, lib) modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with - | `Sources (base_fn, _) -> - [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - lst - in - List.map - (fun nm -> - List.map - (fun base_fn -> base_fn ^"."^ext) - (find_module nm)) - lst - in - - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - (not lib.lib_pack) && (* Do not install .cmx packed submodules *) - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - type data = common_section * build_section * library - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children : tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, lib) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - -end - -module OASISFlag = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISFlag.ml" - -end - -module OASISPackage = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISPackage.ml" - -end - -module OASISSourceRepository = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISSourceRepository.ml" - -end - -module OASISTest = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISTest.ml" - -end - -module OASISDocument = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISDocument.ml" - -end - -module OASISExec = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISExec.ml" - - open OASISGettext - open OASISUtils - open OASISMessage - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/oasis/OASISFileUtil.ml" - - open OASISGettext - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a,b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a,b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p,e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find - (if case_sensitive then - file_exists_case - else - Sys.file_exists) - alternatives - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - let q = Filename.quote - (**/**) - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2142 "setup.ml" -module BaseEnvLight = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseEnvLight.ml" - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 2240 "setup.ml" -module BaseContext = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseContext.ml" - - open OASISContext - - let args = args - - let default = default - -end - -module BaseMessage = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseMessage.ml" - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - let debug fmt = debug ~ctxt:!default fmt - - let info fmt = info ~ctxt:!default fmt - - let warning fmt = warning ~ctxt:!default fmt - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseEnv.ml" - - open OASISGettext - open OASISUtils - open PropList - - module MapString = BaseEnvLight.MapString - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - let schema = - Schema.create "environment" - - (* Environment data *) - let env = - Data.create () - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - let var_ignore (e : unit -> string) = - () - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - let default_filename = - BaseEnvLight.default_filename - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name,value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseArgExt.ml" - - open OASISUtils - open OASISGettext - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseCheck.ml" - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - let prog prg = - prog_best prg [prg] - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - let ocamlfind = - prog "ocamlfind" - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseOCamlcConfig.ml" - - - open BaseEnv - open OASISUtils - open OASISGettext - - module SMap = Map.Make(String) - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseStandardVar.ml" - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - let var_cond = ref [] - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - (**/**) - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - let c = BaseOCamlcConfig.var_define - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - (* TODO: Check standard variable presence at runtime *) - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - let flexlink = - BaseCheck.prog "flexlink" - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s : string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s : string = - ocamlc () - in - "false") - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" -> ".exe" - | _ -> "") - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseFileAB.ml" - - open BaseEnv - open OASISGettext - open BaseMessage - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseLog.ml" - - open OASISUtils - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseBuilt.ml" - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BDoc (* Document *) - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BDoc -> "doc")^ - "_"^nm - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseCustom.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseDynVar.ml" - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseTest.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let (failed, n) = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISVersion.version_0_3_or_after pkg.oasis_version && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseDoc.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISVersion.version_0_3_or_after pkg.oasis_version && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/base/BaseSetup.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - type std_args_fun = - package -> string array -> unit - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t [||]; - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - let reinstall t args = - uninstall t args; - install t args - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - let version t _ = - print_endline t.oasis_version - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> "_oasis" - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - -end - - -# 4480 "setup.ml" -module InternalConfigurePlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = - let _s : string = - var () - in - () - in - - let errors = - ref SetString.empty - in - - let buff = - Buffer.create 13 - in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - -end - -module InternalInstallPlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/internal/InternalInstallPlugin.ml" - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISLibrary - open OASISGettext - open OASISUtils - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - let install_file_ev = - "install-file" - - let install_dir_ev = - "install-dir" - - let install_findlib_ev = - "install-findlib" - - let win32_max_command_line_length = 8000 - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the flag \ - '-add' of ocamlfind because the command line is too \ - long. This flag is only available for findlib 1.3.2. \ - Please upgrade findlib from %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let (_, bs, _) = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let (cs, bs, exec) = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let (cs, doc) = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev;])) - -end - - -# 5233 "setup.ml" -module OCamlbuildCommon = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" - - (** Functions common to OCamlbuild build and doc plugin - *) - - open OASISGettext - open BaseEnv - open BaseStandardVar - - let ocamlbuild_clean_ev = - "ocamlbuild-clean" - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - -end - -module OCamlbuildPlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISUtils - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - let cond_targets_hook = - ref (fun lst -> lst) - - let build pkg argv = - - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cma" fn - || ends_with ".cmxs" fn - || ends_with ".cmxa" fn - || ends_with (ext_lib ()) fn - || ends_with (ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (f_ "No one of expected built files %s exists") - (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - let cond_targets = - (* Run the hook *) - !cond_targets_hook cond_targets - in - - (* Run a list of target... *) - run_ocamlbuild - (List.flatten - (List.map snd cond_targets)) - argv; - (* ... and register events *) - List.iter - check_and_register - (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - -end - -module OCamlbuildDocPlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - let doc_build path pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild [index_html] argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - let doc_clean t pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - -end - - -# 5558 "setup.ml" -module NonePlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/none/NonePlugin.ml" - - (** Plugin to handle "none" generation - @author Sylvain Le Gall - *) - - open OASISGettext - open OASISUtils - - let not_implemented str _ _ = - failwithf (f_ "No implementation for %s") str - - let section_not_implemented str pkg _ _ extra_args = - not_implemented str pkg extra_args - -end - - -# 5578 "setup.ml" -module CustomPlugin = struct -# 21 "/Users/dbuenzli/.odb/install-oasis/oasis-0.3.0/src/plugins/custom/CustomPlugin.ml" - - (** Generate custom configure/build/doc/test/install system - @author - *) - - open BaseEnv - open OASISGettext - open OASISTypes - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - let run = BaseCustom.run - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - -end - - -# 5714 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build; - test = - [ - ("test", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - doc = - [ - ("api", OCamlbuildDocPlugin.doc_build "doc"); - ("distribution", - NonePlugin.not_implemented "doc of section distribution"); - ("samples", NonePlugin.not_implemented "doc of section samples") - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("test", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - clean_doc = [("api", OCamlbuildDocPlugin.doc_clean "doc")]; - distclean = []; - distclean_test = - [ - ("test", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = Some (OASISVersion.VGreaterEqual "3.11.0"); - findlib_version = None; - name = "react"; - version = "0.9.4"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD3"; - excption = None; - version = OASISLicense.NoVersion; - }); - license_file = None; - copyrights = ["(c) 2009-2012 Daniel C. Bünzli"]; - maintainers = []; - authors = ["Daniel Bünzli "]; - homepage = Some "http://erratique.ch/software/react"; - synopsis = "Declarative events and signals for OCaml"; - description = - Some - "React is an OCaml module for functional reactive programming (FRP). It\nprovides support to program with time varying values : declarative\nevents and signals. React doesn't define any primitive event or\nsignal, it lets the client chooses the concrete timeline.\n\nReact is made of a single, independent, module and distributed under\nthe BSD3 license."; - categories = []; - conf_type = (`Configure, "internal", Some "0.3"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - build_type = (`Build, "ocamlbuild", Some "0.3"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - install_type = (`Install, "internal", Some "0.3"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - files_ab = []; - sections = - [ - Library - ({ - cs_name = "react"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["React"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = []; - }); - Executable - ({ - cs_name = "clock"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("unix", None); - InternalLibrary "react" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "clock.ml"; }); - Executable - ({ - cs_name = "breakout"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("unix", None); - InternalLibrary "react" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "breakout.ml"; }); - Executable - ({ - cs_name = "test"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "react"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "test.ml"; }); - Test - ({ - cs_name = "test"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - test_type = (`Test, "custom", Some "0.3"); - test_command = [(OASISExpr.EBool true, ("$test", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", true) - ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); - Doc - ({ - cs_name = "api"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "React's documentation and API reference"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); - Doc - ({ - cs_name = "distribution"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "none", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "\"React's README and CHANGES files\""; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = [("README CHANGES", None)]; - doc_build_tools = [ExternalTool "ocamlbuild"]; - }); - Doc - ({ - cs_name = "samples"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "none", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "\"React's sample code\""; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = [("test/*.ml", None)]; - doc_build_tools = [ExternalTool "ocamlbuild"]; - }); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - src_repo_type = Git; - src_repo_location = - "git://erratique.ch/repos/react.git"; - src_repo_browser = - Some "http://erratique.ch/repos/react"; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None; - }) - ]; - plugins = [(`Extra, "META", Some "0.3")]; - schema_data = PropList.Data.create (); - plugin_data = []; - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.3.0"; - oasis_digest = Some "RH\127\015tPX68\002\025"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false; - };; - -let setup () = BaseSetup.setup setup_t;; - -# 6072 "setup.ml" -(* OASIS_STOP *) -let () = setup ();; diff -Nru react-0.9.4/src/META react-1.2.0/src/META --- react-0.9.4/src/META 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/src/META 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d8fbd39ff38100842999af9571ea8121) -version = "0.9.4" -description = "Declarative events and signals for OCaml" -archive(byte) = "react.cma" -archive(byte, plugin) = "react.cma" -archive(native) = "react.cmxa" -archive(native, plugin) = "react.cmxs" -exists_if = "react.cma" -# OASIS_STOP - diff -Nru react-0.9.4/src/react.ml react-1.2.0/src/react.ml --- react-0.9.4/src/react.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/src/react.ml 2014-08-23 23:03:34.000000000 +0000 @@ -1,7 +1,7 @@ (*--------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli. All rights reserved. + Copyright (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. - react release 0.9.4 + react release 1.2.0 ---------------------------------------------------------------------------*) let err_max_rank = "maximal rank exceeded" @@ -9,10 +9,13 @@ let err_fix = "trying to fix a delayed value" let err_retain_never = "E.never cannot retain a closure" let err_retain_cst_sig = "constant signals cannot retain a closure" +let err_step_executed = "step already executed" +let err_event_scheduled = "event already scheduled on a step" +let err_signal_scheduled = "signal already scheduled on a step" -module Wa = struct +module Wa = struct type 'a t = { mutable arr : 'a Weak.t; mutable len : int } - (* The type for resizeable weak arrays. + (* The type for resizeable weak arrays. For now the arrays only grow. We could try to compact and downsize the array in scan_add if a threshold of empty slots is @@ -20,11 +23,19 @@ let create size = { arr = Weak.create size; len = 0 } let length a = a.len + let is_empty a = + try + for i = 0 to a.len - 1 do + if Weak.check a.arr i then raise Exit; + done; + true + with Exit -> false + let clear a = a.arr <- Weak.create 0; a.len <- 0 let get a i = Weak.get a.arr i let set a i = Weak.set a.arr i - let swap a i i' = - let v = Weak.get a.arr i' in + let swap a i i' = + let v = Weak.get a.arr i' in Weak.blit a.arr i a.arr i' 1; (* blit prevents i from becoming live. *) Weak.set a.arr i v @@ -32,52 +43,52 @@ let arr' = Weak.create (2 * (a.len + 1)) in Weak.blit a.arr 0 arr' 0 a.len; a.arr <- arr' - + let add a v = (* adds v at the end of a. *) if a.len = Weak.length a.arr then grow a; Weak.set a.arr a.len (Some v); a.len <- a.len + 1 - + let scan_add a v = (* adds v to a, tries to find an empty slot, O(a.len). *) try for i = 0 to a.len - 1 do - match Weak.get a.arr i with - | None -> Weak.set a.arr i (Some v); raise Exit | Some _ -> () + match Weak.get a.arr i with + | None -> Weak.set a.arr i (Some v); raise Exit | Some _ -> () done; add a v with Exit -> () let rem_last a = let l = a.len - 1 in (a.len <- l; Weak.set a.arr l None) let rem a v = (* removes v from a, uses physical equality, O(a.len). *) - try - for i = 0 to a.len - 1 do - match Weak.get a.arr i with - | Some v' when v == v' -> Weak.set a.arr i None; raise Exit - | _ -> () + try + for i = 0 to a.len - 1 do + match Weak.get a.arr i with + | Some v' when v == v' -> Weak.set a.arr i None; raise Exit + | _ -> () done with Exit -> () - + let iter f a = - for i = 0 to a.len - 1 do - match Weak.get a.arr i with Some v -> f v | None -> () - done - - let fold f acc a = - let acc = ref acc in for i = 0 to a.len - 1 do - match Weak.get a.arr i with Some v -> acc := f !acc v | None -> () + match Weak.get a.arr i with Some v -> f v | None -> () + done + + let fold f acc a = + let acc = ref acc in + for i = 0 to a.len - 1 do + match Weak.get a.arr i with Some v -> acc := f !acc v | None -> () done; !acc end -type node = - { mutable rank : int; (* its rank (height) in the dataflow graph. *) - mutable stamp : cycle; (* last cycle in which it was scheduled. *) - mutable retain : unit -> unit; (* retained by the node, NEVER invoked. *) - mutable producers : unit -> node list; (* nodes on which it depends. *) - mutable update : cycle -> unit; (* update closure. *) - deps : node Wa.t } (* weak references to dependent nodes. *) -(* The type for nodes. +type node = + { mutable rank : int; (* its rank (height) in the dataflow graph. *) + mutable stamp : step; (* last step in which it was scheduled. *) + mutable retain : unit -> unit; (* retained by the node, NEVER invoked. *) + mutable producers : unit -> node list; (* nodes on which it depends. *) + mutable update : step -> unit; (* update closure. *) + deps : node Wa.t } (* weak references to dependent nodes. *) +(* The type for nodes. Each event and (non-constant) signal has an associated node. The fields producers and update keep, in their closure environment, @@ -89,45 +100,48 @@ (needed for recursive definitions). These nodes all have a rank of Node.delayed_rank and depend only on the node they delay. Since they have the highest rank possible they are updated only at the - end of the cycle and treated specially at that point (see - Cycle.execute). *) + end of the step and treated specially at that point (see + Step.execute). *) + +and step = + { mutable over : bool; (* true when the step is over. *) + mutable heap : heap; (* min-heap of nodes sorted by rank. *) + mutable eops : (unit -> unit) list; (* end of step operations. *) + mutable cops : (unit -> unit) list } (* cleanup step operations. *) +(* The type for update steps. -and cycle = - { mutable over : bool; (* true when the cycle is over. *) - mutable heap : heap; (* min-heap of nodes sorted by rank. *) - mutable eops : (unit -> unit) list; (* end of cycle operations. *) - mutable cops : (unit -> unit) list } (* cleanup cycle operations. *) -(* The type for update cycles. + Note for historical reasons we use the variable names [c] and [c'] + in the code for representing update steps. - There are four successive phases in the execution of a cycle c (see - Cycle.execute). + There are four successive phases in the execution of a step c (see + Step.execute). 1. Nodes are updated in topological order until c.heap is empty or we reach a delayed node. - 2. End of cycle operations are executed. This may add new + 2. End of step operations are executed. This may add new dependencies (see S.diff and S.changes) and clear the occurence - of delayed events from a previous cycle (but used in this - cycle). + of delayed events from a previous step (but used in this + step). - 3. If there are delayed nodes in c.heap, we create a new cycle + 3. If there are delayed nodes in c.heap, we create a new step c'. Each delayed node is updated and its dependents are put in - c'.heap. For delayed events, an end of cycle operation is added + c'.heap. For delayed events, an end of step operation is added in c' to clear the occurence at step 2 of c'. Delayed nodes are - updated in any order as a delayed node updating in a cycle - cannot depend on a delayed node updating in the same cycle. + updated in any order as a delayed node updating in a step + cannot depend on a delayed node updating in the same step. - 4. Cleanup operations are executed. This clears the event occurences of + 4. Cleanup operations are executed. This clears the event occurences of non-delayed event that occured in c. - After this, if a cycle c' was created in 3. the cycle gets executed. *) + After this, if a step c' was created in 3. the step gets executed. *) and heap = node Wa.t -(* The type for heaps. +(* The type for heaps. Weak min-heaps of nodes sorted according to their rank. Classic imperative implementation with a twist to accomodate the fact - that nodes may disappear. + that nodes may disappear. The heap property we maintain is that for any node its descendents (vs. children) are either of no smaller rank or they are None. None @@ -140,34 +154,34 @@ parent of smaller rank), the property can however be reestablished by percolating down from that point. *) -type 'a emut = - { ev : 'a option ref; (* during cycles, holds a potential occurence. *) - enode : node; } (* associated node. *) +type 'a emut = + { ev : 'a option ref; (* during steps, holds a potential occurence. *) + enode : node; } (* associated node. *) type 'a event = Never | Emut of 'a emut (* The type for events. An event is either the never occuring event Never or a mutable - Emut. A mutable m has some value in m.v iff a cycle is being - executed and m has an occurence in the cycle. m's dependents are + Emut. A mutable m has some value in m.v iff a step is being + executed and m has an occurence in the step. m's dependents are scheduled for update iff m has a value in m.v. - Mutables that occur in a cycle are set back to None when the cycle - terminates with an cleanup cycle operation (see eupdate and - Cycle.execute). To avoid a weak reference on m in the cleanup + Mutables that occur in a step are set back to None when the step + terminates with an cleanup step operation (see eupdate and + Step.execute). To avoid a weak reference on m in the cleanup operation, the field m.v is a field on a reference instead of a mutable field. A new node n can be made dependent on a an event mutable m during a - cycle. But when n is added to m's dependents, m may already have + step. But when n is added to m's dependents, m may already have updated and scheduled its dependents. In that case n also need to - be scheduled (see E.add_dep). If m only occurs later in the cycle, + be scheduled (see E.add_dep). If m only occurs later in the step, the n will be scheduled as usual with the others. *) -type 'a smut = - { mutable sv : 'a option; (* signal value (None only temporary). *) - mutable eq : 'a -> 'a -> bool; (* to detect signal value changes. *) - mutable snode : node } (* associated node. *) +type 'a smut = + { mutable sv : 'a option; (* signal value (None only temporary). *) + eq : 'a -> 'a -> bool; (* to detect signal value changes. *) + snode : node } (* associated node. *) type 'a signal = Const of 'a | Smut of 'a smut (* The type for signals. @@ -175,17 +189,17 @@ A signal is either a constant signal Const or a mutable Smut. A mutable m has a value in m.v iff m.v initialized. m's dependents are scheduled for update iff m is initialized and m.v changed - according to m.eq in the cycle. + according to m.eq in the step. Signal initialization occurs as follows. If we have an init. value we set the signal's value to this value and then : - 1. If the creation occurs outside a cycle, the signal's update - function is invoked with Cycle.nil. This may overwrite the + 1. If the creation occurs outside a step, the signal's update + function is invoked with Step.nil. This may overwrite the init. value, but no dependent will see this change as there cannot be any at that time. - 2. If the creation occurs inside a cycle, the signal is scheduled + 2. If the creation occurs inside a step, the signal is scheduled for update. Here again this may overwrite the init. value. If the new value is equal to the init. value this will not schedule the signals' dependents. However this is not a problem since @@ -197,28 +211,28 @@ update function must unconditionaly write a concrete value for the signal. - To find out whether the creation occurs in a cycle we walk back the + To find out whether the creation occurs in a step we walk back the signal's producers recursively looking for a node stamp with an - unfinished cycle (see Cycle.find_unfinished). This is not in favor + unfinished step (see Step.find_unfinished). This is not in favor of static signal creation but this is the price we have to pay for not having global data structures. A new node n can be made dependent on a signal mutable m during a - cycle. In contrast to events (see above) nothing special has to be + step. In contrast to events (see above) nothing special has to be done. Here's the rationale : 1. If n is the node of a new event then either the event cannot - happen in the same cycle and thus the depency addition occurs at - the end of the cycle (S.diff, S.changes) or the event cares only + happen in the same step and thus the depency addition occurs at + the end of the step (S.diff, S.changes) or the event cares only about having an up to date value if some other event occurs - (S.sample, E.when_) in the same cycle and the rank of n ensures + (S.sample, E.on) in the same step and the rank of n ensures this. 2. If n is the node of a new signal then n cares only about having m's up to date values whenever n will initialize and the rank of n ensures this. *) -module H = struct +module H = struct let size = Wa.length let els h = Wa.fold (fun acc e -> e :: acc) [] h (* no particular order. *) let compare_down h i i' = match Wa.get h i, Wa.get h i' with @@ -226,11 +240,11 @@ | Some _, None -> 1 (* None is smaller than anything. *) | None, Some _ -> -1 (* None is smaller than anything. *) | None, None -> 0 - + let rec down h i = let last = size h - 1 in let start = 2 * i in - let l = start + 1 in (* left child index. *) + let l = start + 1 in (* left child index. *) let r = start + 2 in (* right child index. *) if l > last then () (* no child, stop *) else let child = (* index of smallest child. *) @@ -243,34 +257,37 @@ if i = 0 then (if last_none then down h 0) else let p = (i - 1) / 2 in (* parent index. *) match Wa.get h i, Wa.get h p with - | Some n, Some n' -> - if compare n.rank n'.rank < 0 then (Wa.swap h i p; aux h p false) else - (if last_none then down h i) - | Some _, None -> - Wa.swap h i p; aux h p true - | None, _ -> () + | Some n, Some n' -> + if compare n.rank n'.rank < 0 then (Wa.swap h i p; aux h p false) else + (if last_none then down h i) + | Some _, None -> + Wa.swap h i p; aux h p true + | None, _ -> () in aux h i false - + let rebuild h = for i = (size h - 2) / 2 downto 0 do down h i done let add h n = Wa.add h n; up h (size h - 1) - let rec take h = + let rec take h = let s = size h in if s = 0 then None else let v = Wa.get h 0 in - if s > 1 then - (Wa.set h 0 (Wa.get h (s - 1)); Wa.rem_last h; down h 0) - else - Wa.rem_last h; + begin + if s > 1 + then (Wa.set h 0 (Wa.get h (s - 1)); Wa.rem_last h; down h 0) + else Wa.rem_last h + end; match v with None -> take h | v -> v end -let delayed_rank = max_int +let delayed_rank = max_int -module Cycle = struct (* Update cycles. *) +module Step = struct (* Update steps. *) + type t = step let nil = { over = true; heap = Wa.create 0; eops = []; cops = []} - let create n = - let h = Wa.create (3 * Wa.length n.deps) in + + let create () = + let h = Wa.create 11 in { over = false; heap = h; eops = []; cops = []} let add c n = if n.stamp == c then () else (n.stamp <- c; H.add c.heap n) @@ -278,37 +295,40 @@ let add_eop c op = c.eops <- op :: c.eops let add_cop c op = c.cops <- op :: c.cops let allow_reschedule n = n.stamp <- nil - let rebuild c = H.rebuild c.heap + let rebuild c = H.rebuild c.heap - let rec execute c = - let eops c = List.iter (fun op -> op ()) c.eops; c.eops <- [] in + let rec execute c = + let eops c = List.iter (fun op -> op ()) c.eops; c.eops <- [] in let cops c = List.iter (fun op -> op ()) c.cops; c.cops <- [] in let finish c = c.over <- true; c.heap <- Wa.create 0 in let rec update c = match H.take c.heap with - | Some n when n.rank <> delayed_rank -> n.update c; update c - | Some n -> - let c' = create n in - eops c; List.iter (fun n -> n.update c') (n :: H.els c.heap); cops c; - finish c; - execute c' + | Some n when n.rank <> delayed_rank -> n.update c; update c + | Some n -> + let c' = create () in + eops c; List.iter (fun n -> n.update c') (n :: H.els c.heap); cops c; + finish c; + execute c' | None -> eops c; cops c; finish c in update c - let find_unfinished nl = (* find unfinished cycle in recursive producers. *) + let execute c = if c.over then invalid_arg err_step_executed else execute c + + + let find_unfinished nl = (* find unfinished step in recursive producers. *) let rec aux next = function (* zig-zag breadth-first search. *) - | [] -> if next = [] then nil else aux [] next - | [] :: todo -> aux next todo - | nl :: todo -> find next todo nl + | [] -> if next = [] then nil else aux [] next + | [] :: todo -> aux next todo + | nl :: todo -> find next todo nl and find next todo = function - | [] -> aux next todo - | n :: nl -> - if not n.stamp.over then n.stamp else - find (n.producers () :: next) todo nl + | [] -> aux next todo + | n :: nl -> + if not n.stamp.over then n.stamp else + find (n.producers () :: next) todo nl in aux [] [ nl ] end - + module Node = struct let delayed_rank = delayed_rank let min_rank = min_int @@ -316,25 +336,51 @@ let nop _ = () let no_producers () = [] - let create r = - { rank = r; stamp = Cycle.nil; update = nop; retain = nop; + let create r = + { rank = r; stamp = Step.nil; update = nop; retain = nop; producers = no_producers; deps = Wa.create 0 } - let bind n p u = n.producers <- p; n.update <- u - let stop n = n.producers <- no_producers; n.update <- nop; Wa.clear n.deps let rem_dep n n' = Wa.rem n.deps n' let add_dep n n' = Wa.scan_add n.deps n' + let has_dep n = not (Wa.is_empty n.deps) let deps n = Wa.fold (fun acc d -> d :: acc) [] n.deps + + let bind n p u = n.producers <- p; n.update <- u + let stop ?(strong = false) n = + if not strong then begin + n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; + end else begin + let rec loop next to_rem = function + | [] -> + begin match next with + | (to_rem, prods) :: next -> loop next to_rem prods + | [] -> () + end + | n :: todo -> + rem_dep n to_rem; (* N.B. rem_dep could be combined with has_dep *) + if n.rank = min_rank (* is a primitive *) || has_dep n + then loop next to_rem todo else + begin + let prods = n.producers () in + n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; + loop ((n, prods) :: next) to_rem todo + end + in + let producers = n.producers () in + n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; + loop [] n producers + end + let set_rank n r = n.rank <- r let rmin = create min_rank let rmax n n' = if n.rank > n'.rank then n else n' - let rsucc n = + let rsucc n = if n.rank = delayed_rank then min_rank else if n.rank < max_rank then n.rank + 1 else invalid_arg err_max_rank - let rsucc2 n n' = - let r = rsucc n in - let r' = rsucc n' in + let rsucc2 n n' = + let r = rsucc n in + let r' = rsucc n' in if r > r' then r else r' (* Rank updates currently only increases ranks. If this is problematic @@ -343,20 +389,20 @@ loop and blow the ranks). *) let update_rank n r = (* returns true iff n's rank increased. *) let rec aux = function - | [] -> () - | n :: todo -> - let update todo d = - if n.rank < d.rank || n.rank = delayed_rank then todo else - (d.rank <- rsucc n; d :: todo) - in - aux (Wa.fold update todo n.deps) + | [] -> () + | n :: todo -> + let update todo d = + if n.rank < d.rank || n.rank = delayed_rank then todo else + (d.rank <- rsucc n; d :: todo) + in + aux (Wa.fold update todo n.deps) in if r > n.rank then (n.rank <- r; aux [ n ]; true) else false end (* Shortcuts *) -let rsucc = Node.rsucc +let rsucc = Node.rsucc let rsucc2 = Node.rsucc2 let rmax = Node.rmax @@ -366,54 +412,60 @@ let emut rank = { ev = ref None; enode = Node.create rank } let event m p u = Node.bind m.enode p u; Emut m let eupdate v m c = - let clear v () = v := None in + let clear v () = v := None in m.ev := Some v; - Cycle.add_cop c (clear m.ev); - Cycle.add_deps c m.enode + Step.add_cop c (clear m.ev); + Step.add_deps c m.enode (* Signal value, creation and update *) -let sval m = match m.sv with Some v -> v | None -> assert false +let sval m = match m.sv with Some v -> v | None -> assert false let smut rank eq = { sv = None; eq = eq; snode = Node.create rank } -let signal ?i m p u = +let signal ?i m p u = Node.bind m.snode p u; begin match i with Some _ as v -> m.sv <- v | None -> () end; - begin match Cycle.find_unfinished (m.snode.producers ()) with - | c when c == Cycle.nil -> m.snode.update Cycle.nil - | c -> Cycle.add c m.snode + begin match Step.find_unfinished (m.snode.producers ()) with + | c when c == Step.nil -> m.snode.update Step.nil + | c -> Step.add c m.snode end; Smut m -let supdate v m c = match m.sv with +let supdate v m c = match m.sv with | Some v' when (m.eq v v') -> () -| Some _ -> m.sv <- Some v; if c != Cycle.nil then Cycle.add_deps c m.snode +| Some _ -> m.sv <- Some v; if c != Step.nil then Step.add_deps c m.snode | None -> m.sv <- Some v (* init. without init value. *) module E = struct type 'a t = 'a event - let add_dep m n = + let add_dep m n = Node.add_dep m.enode n; - if !(m.ev) <> None then Cycle.add m.enode.stamp n + if !(m.ev) <> None then Step.add m.enode.stamp n - let send m v = (* starts an update cycle. *) - let c = Cycle.create m.enode in - m.enode.stamp <- c; - eupdate v m c; - Cycle.execute c + let send m ?step v = match step with (* sends an event occurence. *) + | Some c -> + if c.over then invalid_arg err_step_executed else + if not m.enode.stamp.over then invalid_arg err_event_scheduled else + m.enode.stamp <- c; + eupdate v m c + | None -> + let c = Step.create () in + m.enode.stamp <- c; + eupdate v m c; + Step.execute c (* Basics *) let never = Never - let create () = + let create () = let m = emut Node.min_rank in Emut m, send m - - let retain e c = match e with - | Never -> invalid_arg err_retain_never + + let retain e c = match e with + | Never -> invalid_arg err_retain_never | Emut m -> let c' = m.enode.retain in (m.enode.retain <- c); (`R c') - let stop = function Never -> () | Emut m -> Node.stop m.enode + let stop ?strong = function Never -> () | Emut m -> Node.stop ?strong m.enode let equal e e' = match e, e' with | Never, Never -> true | Never, _ | _, Never -> false @@ -422,566 +474,729 @@ let trace ?(iff = Const true) t e = match iff with | Const false -> e | Const true -> - begin match e with - | Never -> e + begin match e with + | Never -> e | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = let v = eval m in t v; eupdate v m' c in - add_dep m m'.enode; - event m' p u + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = let v = eval m in t v; eupdate v m' c in + add_dep m m'.enode; + event m' p u end | Smut mc -> match e with | Never -> Never | Emut m -> - let m' = emut (rsucc2 mc.snode m.enode) in - let rec p () = [mc.snode; m.enode] - and u c = match !(m.ev) with - | None -> () (* mc updated. *) - | Some v -> if (sval mc) then t v; eupdate v m' c - in - Node.add_dep mc.snode m'.enode; - add_dep m m'.enode; - event m' p u + let m' = emut (rsucc2 mc.snode m.enode) in + let rec p () = [mc.snode; m.enode] + and u c = match !(m.ev) with + | None -> () (* mc updated. *) + | Some v -> if (sval mc) then t v; eupdate v m' c + in + Node.add_dep mc.snode m'.enode; + add_dep m m'.enode; + event m' p u (* Transforming and filtering *) let once = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = - Node.rem_dep m.enode m'.enode; - eupdate (eval m) m' c; - Node.stop m'.enode - in - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = + Node.rem_dep m.enode m'.enode; + eupdate (eval m) m' c; + Node.stop m'.enode + in + add_dep m m'.enode; + event m' p u let drop_once = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = (* first update. *) - let u' c = eupdate (eval m) m' c in (* subsequent updates. *) - Node.bind m'.enode p u' - in - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = (* first update. *) + let u' c = eupdate (eval m) m' c in (* subsequent updates. *) + Node.bind m'.enode p u' + in + add_dep m m'.enode; + event m' p u let app ef = function - | Never -> Never - | Emut m -> match ef with - | Never -> Never + | Never -> Never + | Emut m -> + match ef with + | Never -> Never | Emut mf -> - let m' = emut (rsucc2 m.enode mf.enode) in - let rec p () = [ m.enode; mf.enode ] - and u c = match !(mf.ev), !(m.ev) with - | None, _ | _, None -> () - | Some f, Some v -> eupdate (f v) m' c - in - add_dep m m'.enode; - add_dep mf m'.enode; - event m' p u + let m' = emut (rsucc2 m.enode mf.enode) in + let rec p () = [ m.enode; mf.enode ] + and u c = match !(mf.ev), !(m.ev) with + | None, _ | _, None -> () + | Some f, Some v -> eupdate (f v) m' c + in + add_dep m m'.enode; + add_dep mf m'.enode; + event m' p u let map f = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = eupdate (f (eval m)) m' c in - add_dep m m'.enode; - event m' p u - + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = eupdate (f (eval m)) m' c in + add_dep m m'.enode; + event m' p u + let stamp e v = match e with - | Never -> Never - | Emut m -> + | Never -> Never + | Emut m -> let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] - and u c = eupdate v m' c in + and u c = eupdate v m' c in add_dep m m'.enode; event m' p u - + let filter pred = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = let v = eval m in if pred v then eupdate v m' c else () in - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = let v = eval m in if pred v then eupdate v m' c else () in + add_dep m m'.enode; + event m' p u let fmap fm = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = match fm (eval m) with Some v -> eupdate v m' c | None -> () - in - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let rec p () = [ m.enode ] + and u c = match fm (eval m) with Some v -> eupdate v m' c | None -> () + in + add_dep m m'.enode; + event m' p u let diff d = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let last = ref None in - let rec p () = [ m.enode ] - and u c = - let v = eval m in - match !last with - | None -> last := Some v - | Some v' -> last := Some v; eupdate (d v v') m' c - in - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let last = ref None in + let rec p () = [ m.enode ] + and u c = + let v = eval m in + match !last with + | None -> last := Some v + | Some v' -> last := Some v; eupdate (d v v') m' c + in + add_dep m m'.enode; + event m' p u let changes ?(eq = ( = )) = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let last = ref None in - let rec p () = [ m.enode ] - and u c = - let v = eval m in - match !last with - | None -> last := Some v; eupdate v m' c - | Some v' -> last := Some v; if eq v v' then () else eupdate v m' c - in - add_dep m m'.enode; - event m' p u - - let when_ c = function - | Never -> Never - | Emut m as e -> - match c with - | Const true -> e - | Const false -> Never - | Smut mc -> - let m' = emut (rsucc2 m.enode mc.snode) in - let rec p () = [ m.enode; mc.snode ] - and u c = match !(m.ev) with - | None -> () (* mc updated. *) - | Some _ -> if (sval mc) then eupdate (eval m) m' c else () - in - add_dep m m'.enode; - Node.add_dep mc.snode m'.enode; - event m' p u - - let dismiss c = function - | Never -> Never - | Emut m as e -> - match c with - | Never -> e - | Emut mc -> - let m' = emut (rsucc2 mc.enode m.enode) in - let rec p () = [ mc.enode; m.enode ] - and u c = match !(mc.ev) with - | Some _ -> () - | None -> eupdate (eval m) m' c - in - add_dep mc m'.enode; - add_dep m m'.enode; - event m' p u + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let last = ref None in + let rec p () = [ m.enode ] + and u c = + let v = eval m in + match !last with + | None -> last := Some v; eupdate v m' c + | Some v' -> last := Some v; if eq v v' then () else eupdate v m' c + in + add_dep m m'.enode; + event m' p u + + let on c = function + | Never -> Never + | Emut m as e -> + match c with + | Const true -> e + | Const false -> Never + | Smut mc -> + let m' = emut (rsucc2 m.enode mc.snode) in + let rec p () = [ m.enode; mc.snode ] + and u c = match !(m.ev) with + | None -> () (* mc updated. *) + | Some _ -> if (sval mc) then eupdate (eval m) m' c else () + in + add_dep m m'.enode; + Node.add_dep mc.snode m'.enode; + event m' p u + + let when_ = on + + let dismiss c = function + | Never -> Never + | Emut m as e -> + match c with + | Never -> e + | Emut mc -> + let m' = emut (rsucc2 mc.enode m.enode) in + let rec p () = [ mc.enode; m.enode ] + and u c = match !(mc.ev) with + | Some _ -> () + | None -> eupdate (eval m) m' c + in + add_dep mc m'.enode; + add_dep m m'.enode; + event m' p u let until c = function - | Never -> Never - | Emut m as e -> - match c with - | Never -> e - | Emut mc -> - let m' = emut (rsucc2 m.enode mc.enode) in - let rec p () = [ m.enode; mc.enode] in - let u c = match !(mc.ev) with - | None -> eupdate (eval m) m' c - | Some _ -> - Node.rem_dep m.enode m'.enode; - Node.rem_dep mc.enode m'.enode; - Node.stop m'.enode - in - add_dep m m'.enode; - add_dep mc m'.enode; - event m' p u - + | Never -> Never + | Emut m as e -> + match c with + | Never -> e + | Emut mc -> + let m' = emut (rsucc2 m.enode mc.enode) in + let rec p () = [ m.enode; mc.enode] in + let u c = match !(mc.ev) with + | None -> eupdate (eval m) m' c + | Some _ -> + Node.rem_dep m.enode m'.enode; + Node.rem_dep mc.enode m'.enode; + Node.stop m'.enode + in + add_dep m m'.enode; + add_dep mc m'.enode; + event m' p u + (* Accumulating *) let accum ef i = match ef with | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in + | Emut m -> + let m' = emut (rsucc m.enode) in let acc = ref i in - let rec p () = [ m.enode ] + let rec p () = [ m.enode ] and u c = acc := (eval m) !acc; eupdate !acc m' c in add_dep m m'.enode; event m' p u - - let fold f i = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in - let acc = ref i in - let rec p () = [ m.enode ] - and u c = acc := f !acc (eval m); eupdate !acc m' c in - add_dep m m'.enode; - event m' p u - + + let fold f i = function + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in + let acc = ref i in + let rec p () = [ m.enode ] + and u c = acc := f !acc (eval m); eupdate !acc m' c in + add_dep m m'.enode; + event m' p u + (* Combining *) - + let occurs m = !(m.ev) <> None - let find_muts_and_next_rank el = + let find_muts_and_next_rank el = let rec aux acc max = function - | [] -> List.rev acc, rsucc max - | (Emut m) :: l -> aux (m :: acc) (rmax max m.enode) l - | Never :: l -> aux acc max l + | [] -> List.rev acc, rsucc max + | (Emut m) :: l -> aux (m :: acc) (rmax max m.enode) l + | Never :: l -> aux acc max l in - aux [] Node.rmin el - + aux [] Node.rmin el + let select el = let emuts, r = find_muts_and_next_rank el in let m' = emut r in let rec p () = List.rev_map (fun m -> m.enode) emuts and u c = try eupdate (eval (List.find occurs emuts)) m' c with - | Not_found -> assert false + | Not_found -> assert false in List.iter (fun m -> add_dep m m'.enode) emuts; event m' p u - + let merge f a el = let rec fold f acc = function - | m :: l when occurs m -> fold f (f acc (eval m)) l - | m :: l -> fold f acc l - | [] -> acc + | m :: l when occurs m -> fold f (f acc (eval m)) l + | m :: l -> fold f acc l + | [] -> acc in - let emuts, r = find_muts_and_next_rank el in + let emuts, r = find_muts_and_next_rank el in let m' = emut r in - let rec p () = List.rev_map (fun m -> m.enode) emuts + let rec p () = List.rev_map (fun m -> m.enode) emuts and u c = eupdate (fold f a emuts) m' c in List.iter (fun m -> add_dep m m'.enode) emuts; event m' p u - + let switch e = function - | Never -> e - | Emut ms -> - let r = match e with - | Emut m -> rsucc2 m.enode ms.enode | Never -> rsucc ms.enode - in - let m' = emut r in - let src = ref e in (* current event source. *) - let rec p () = match !src with - | Emut m -> [ m.enode; ms.enode ] | Never -> [ ms.enode ] - and u c = match !(ms.ev) with - | None -> (match !src with (* only src occurs. *) - | Emut m -> eupdate (eval m) m' c | Never -> assert false) - | Some e -> - begin match !src with - | Emut m -> Node.rem_dep m.enode m'.enode | Never -> () - end; - src := e; - match e with - | Never -> ignore (Node.update_rank m'.enode (rsucc ms.enode)) - | Emut m -> - Node.add_dep m.enode m'.enode; - if Node.update_rank m'.enode (rsucc2 m.enode ms.enode) then - begin - (* Rank increased because of m. Thus m may stil - update and we may be rescheduled. If it happens - we'll be in the other branch without any harm - but some redundant computation. *) - Cycle.allow_reschedule m'.enode; - Cycle.rebuild c; - end - else - (* No rank increase, m already updated if needed. *) - (match !(m.ev) with Some v -> eupdate v m' c | None -> ()) - in - (match e with Emut m -> add_dep m m'.enode | Never -> ()); - add_dep ms m'.enode; - event m' p u + | Never -> e + | Emut ms -> + let r = match e with + | Emut m -> rsucc2 m.enode ms.enode | Never -> rsucc ms.enode + in + let m' = emut r in + let src = ref e in (* current event source. *) + let rec p () = match !src with + | Emut m -> [ m.enode; ms.enode ] | Never -> [ ms.enode ] + and u c = match !(ms.ev) with + | None -> (match !src with (* only src occurs. *) + | Emut m -> eupdate (eval m) m' c | Never -> assert false) + | Some e -> + begin match !src with + | Emut m -> Node.rem_dep m.enode m'.enode | Never -> () + end; + src := e; + match e with + | Never -> ignore (Node.update_rank m'.enode (rsucc ms.enode)) + | Emut m -> + Node.add_dep m.enode m'.enode; + if Node.update_rank m'.enode (rsucc2 m.enode ms.enode) then + begin + (* Rank increased because of m. Thus m may stil + update and we may be rescheduled. If it happens + we'll be in the other branch without any harm + but some redundant computation. *) + Step.allow_reschedule m'.enode; + Step.rebuild c; + end + else + (* No rank increase, m already updated if needed. *) + (match !(m.ev) with Some v -> eupdate v m' c | None -> ()) + in + (match e with Emut m -> add_dep m m'.enode | Never -> ()); + add_dep ms m'.enode; + event m' p u - let fix f = + let fix f = let m = emut Node.delayed_rank in let e = event m (fun () -> []) (fun _ -> assert false) in match f e with | Never, r -> r - | Emut m', r -> - if m'.enode.rank = Node.delayed_rank then invalid_arg err_fix; - let rec p () = [ (* avoid cyclic dep. *) ] - and u c = (* N.B. c is the next cycle. *) - let clear v () = v := None in - m.ev := Some (eval m'); - Cycle.add_eop c (clear m.ev); (* vs. add_cop for regular events. *) - Cycle.add_deps c m.enode - in - Node.bind m.enode p u; - add_dep m' m.enode; - r + | Emut m', r -> + if m'.enode.rank = Node.delayed_rank then invalid_arg err_fix; + let rec p () = [ (* avoid cyclic dep. *) ] + and u c = (* N.B. c is the next step. *) + let clear v () = v := None in + m.ev := Some (eval m'); + Step.add_eop c (clear m.ev); (* vs. add_cop for regular events. *) + Step.add_deps c m.enode + in + Node.bind m.enode p u; + add_dep m' m.enode; + r + + (* Lifting *) + + let l1 = map + let l2 f e0 e1 = match e0, e1 with + | Never, _ -> Never + | _, Never -> Never + | Emut m0, Emut m1 -> + let r = rsucc2 m0.enode m1.enode in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode ] in + let u c = match !(m0.ev), !(m1.ev) with + | None, _ + | _, None -> () + | Some v0, Some v1 -> eupdate (f v0 v1) m' c + in + add_dep m0 m'.enode; + add_dep m1 m'.enode; + event m' p u + + let l3 f e0 e1 e2 = match e0, e1, e2 with + | Never, _, _ -> Never + | _, Never, _ -> Never + | _, _, Never -> Never + | Emut m0, Emut m1, Emut m2 -> + let r = rsucc (rmax (rmax m0.enode m1.enode) m2.enode) in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev) with + | None, _, _ + | _, None, _ + | _, _, None -> () + | Some v0, Some v1, Some v2 -> eupdate (f v0 v1 v2) m' c + in + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + event m' p u + + + let l4 f e0 e1 e2 e3 = match e0, e1, e2, e3 with + | Never, _, _, _ -> Never + | _, Never, _, _ -> Never + | _, _, Never, _ -> Never + | _, _, _, Never -> Never + | Emut m0, Emut m1, Emut m2, Emut m3 -> + let r = rsucc (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev) with + | None, _, _, _ + | _, None, _, _ + | _, _, None, _ + | _, _, _, None -> () + | Some v0, Some v1, Some v2, Some v3 -> eupdate (f v0 v1 v2 v3) m' c + in + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; + event m' p u + + let l5 f e0 e1 e2 e3 e4 = match e0, e1, e2, e3, e4 with + | Never, _, _, _, _ -> Never + | _, Never, _, _, _ -> Never + | _, _, Never, _, _ -> Never + | _, _, _, Never, _ -> Never + | _, _, _, _, Never -> Never + | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4 -> + let r = + rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) + m4.enode) + in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev) with + | None, _, _, _, _ + | _, None, _, _, _ + | _, _, None, _, _ + | _, _, _, None, _ + | _, _, _, _, None -> () + | Some v0, Some v1, Some v2, Some v3, Some v4 -> + eupdate (f v0 v1 v2 v3 v4) m' c + in + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; + add_dep m4 m'.enode; + event m' p u + + let l6 f e0 e1 e2 e3 e4 e5 = match e0, e1, e2, e3, e4, e5 with + | Never, _, _, _, _, _ -> Never + | _, Never, _, _, _, _ -> Never + | _, _, Never, _, _, _ -> Never + | _, _, _, Never, _, _ -> Never + | _, _, _, _, Never, _ -> Never + | _, _, _, _, _, Never -> Never + | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4, Emut m5 -> + let r = + rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) + (rmax m4.enode m5.enode)) + in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode; + m5.enode; ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev), + !(m5.ev) with + | None, _, _, _, _, _ + | _, None, _, _, _, _ + | _, _, None, _, _, _ + | _, _, _, None, _, _ + | _, _, _, _, None, _ + | _, _, _, _, _, None -> () + | Some v0, Some v1, Some v2, Some v3, Some v4, Some v5 -> + eupdate (f v0 v1 v2 v3 v4 v5) m' c + in + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; + add_dep m4 m'.enode; + add_dep m5 m'.enode; + event m' p u + + (* Pervasives support *) + + module Option = struct + let some e = map (fun v -> Some v) e + let value ?default e = match default with + | None -> fmap (fun v -> v) e + | Some (Const dv) -> map (function None -> dv | Some v -> v) e + | Some (Smut ms) -> + match e with + | Never -> Never + | Emut m -> + let m' = emut (rsucc2 m.enode ms.snode) in + let rec p () = [ m.enode; ms.snode ] + and u c = match !(m.ev) with + | None -> () (* ms updated. *) + | Some None -> eupdate (sval ms) m' c + | Some Some v -> eupdate v m' c + in + add_dep m m'.enode; + Node.add_dep ms.snode m'.enode; + event m' p u + end end - + module S = struct type 'a t = 'a signal - - let set_sval v m c = m.sv <- Some v; Cycle.add_deps c m.snode - let set m v = (* starts an update cycle. *) + + let set_sval v m c = m.sv <- Some v; Step.add_deps c m.snode + let set m ?step v = (* starts an update step. *) if m.eq (sval m) v then () else - let c = Cycle.create m.snode in - m.snode.stamp <- c; - m.sv <- Some v; - Cycle.add_deps c m.snode; - Cycle.execute c + match step with + | Some c -> + if c.over then invalid_arg err_step_executed else + if not m.snode.stamp.over then invalid_arg err_signal_scheduled else + m.snode.stamp <- c; + m.sv <- Some v; + Step.add_deps c m.snode + | None -> + let c = Step.create () in + m.snode.stamp <- c; + m.sv <- Some v; + Step.add_deps c m.snode; + Step.execute c + + let end_of_step_add_dep ?(post_add_op = fun () -> ()) ~stop_if_stopped m m' = + (* In some combinators, when the semantics of event m' is such + that it should not occur in the (potential) step it is created, + we add the dependency [m'] to signal [m] only via an end of + step operation to avoid being scheduled in the step. *) + match Step.find_unfinished (m.snode.producers ()) with + | c when c == Step.nil -> + Node.add_dep m.snode m'.enode; + post_add_op (); + | c -> + let add_dep () = + if m.snode.update == Node.nop then + (* m stopped in step *) + (if stop_if_stopped then Node.stop m'.enode) + else + begin + ignore (Node.update_rank m'.enode (rsucc m.snode)); + Node.add_dep m.snode m'.enode; + post_add_op (); + end + in + Step.add_eop c add_dep (* Basics *) let const v = Const v - let create ?(eq = ( = )) v = + let create ?(eq = ( = )) v = let m = smut Node.min_rank eq in m.sv <- Some v; Smut m, set m - let retain s c = match s with + let retain s c = match s with | Const _ -> invalid_arg err_retain_cst_sig | Smut m -> let c' = m.snode.retain in m.snode.retain <- c; (`R c') let eq_fun = function Const _ -> None | Smut m -> Some m.eq - let value = function - | Const v | Smut { sv = Some v } -> v - | Smut { sv = None } -> failwith err_sig_undef - - let stop = function Const _ -> () | Smut m -> Node.stop m.snode + let value = function + | Const v | Smut { sv = Some v } -> v + | Smut { sv = None } -> failwith err_sig_undef + + let stop ?strong = + function Const _ -> () | Smut m -> Node.stop ?strong m.snode + let equal ?(eq = ( = )) s s' = match s, s' with | Const v, Const v' -> eq v v' | Const _, _ | _, Const _ -> false | Smut m, Smut m' -> m == m' - + let trace ?(iff = const true) t s = match iff with | Const false -> s - | Const true -> - begin match s with + | Const true -> + begin match s with | Const v -> t v; s - | Smut m -> - let m' = smut (rsucc m.snode) m.eq in - let rec p () = [ m.snode ] in - let u c = let v = sval m in t v; supdate v m' c in - Node.add_dep m.snode m'.snode; - signal m' p u + | Smut m -> + let m' = smut (rsucc m.snode) m.eq in + let rec p () = [ m.snode ] in + let u c = let v = sval m in t v; supdate v m' c in + Node.add_dep m.snode m'.snode; + signal m' p u end - | Smut mc -> - match s with - | Const v -> - let m' = smut (rsucc mc.snode) ( = ) (* we don't care about eq *) in - let rec p () = [ mc.snode ] - and u c = - if (sval mc) then t v; - Node.rem_dep mc.snode m'.snode; - Node.stop m'.snode; - in - Node.add_dep mc.snode m'.snode; - signal ~i:v m' p u + | Smut mc -> + match s with + | Const v -> + let m' = smut (rsucc mc.snode) ( = ) (* we don't care about eq *) in + let rec p () = [ mc.snode ] + and u c = + if (sval mc) then t v; + Node.rem_dep mc.snode m'.snode; + Node.stop m'.snode; + in + Node.add_dep mc.snode m'.snode; + signal ~i:v m' p u | Smut m -> - let m' = smut (rsucc2 mc.snode m.snode) m.eq in - let rec p () = [ mc.snode; m.snode ] - and u c = - let v = sval m in - match m'.sv with - | Some v' when m'.eq v v' -> () (* mc updated. *) - | _ -> if (sval mc) then t v; supdate v m' c (* init or diff. *) - in - Node.add_dep mc.snode m'.snode; - Node.add_dep m.snode m'.snode; - signal m' p u + let m' = smut (rsucc2 mc.snode m.snode) m.eq in + let rec p () = [ mc.snode; m.snode ] + and u c = + let v = sval m in + match m'.sv with + | Some v' when m'.eq v v' -> () (* mc updated. *) + | _ -> if (sval mc) then t v; supdate v m' c (* init or diff. *) + in + Node.add_dep mc.snode m'.snode; + Node.add_dep m.snode m'.snode; + signal m' p u (* From events *) let hold ?(eq = ( = )) i = function - | Never -> Const i - | Emut m -> - let m' = smut (rsucc m.enode) eq in - let rec p () = [ m.enode ] - and u c = match !(m.ev) with - | None -> () (* init. only. *) - | Some v -> supdate v m' c - in - E.add_dep m m'.snode; - signal ~i m' p u - + | Never -> Const i + | Emut m -> + let m' = smut (rsucc m.enode) eq in + let rec p () = [ m.enode ] + and u c = match !(m.ev) with + | None -> () (* init. only. *) + | Some v -> supdate v m' c + in + E.add_dep m m'.snode; + signal ~i m' p u + (* Filtering and transforming *) let map ?(eq = ( = )) f = function - | Const v -> Const (f v) - | Smut m -> - let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] - and u c = supdate (f (sval m)) m' c in - Node.add_dep m.snode m'.snode; - signal m' p u - + | Const v -> Const (f v) + | Smut m -> + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] + and u c = supdate (f (sval m)) m' c in + Node.add_dep m.snode m'.snode; + signal m' p u + let app ?(eq = ( = )) sf sv = match sf, sv with - | Smut mf, Smut mv -> - let m' = smut (rsucc2 mf.snode mv.snode) eq in - let rec p () = [ mf.snode; mv.snode ] + | Smut mf, Smut mv -> + let m' = smut (rsucc2 mf.snode mv.snode) eq in + let rec p () = [ mf.snode; mv.snode ] and u c = supdate ((sval mf) (sval mv)) m' c in Node.add_dep mf.snode m'.snode; Node.add_dep mv.snode m'.snode; signal m' p u | Const f, Const v -> Const (f v) | Const f, sv -> map ~eq f sv - | Smut mf, Const v -> - let m' = smut (rsucc mf.snode) eq in + | Smut mf, Const v -> + let m' = smut (rsucc mf.snode) eq in let rec p () = [ mf.snode ] - and u c = supdate ((sval mf) v) m' c in + and u c = supdate ((sval mf) v) m' c in Node.add_dep mf.snode m'.snode; signal m' p u let filter ?(eq = ( = )) pred i = function - | Const v as s -> if pred v then s else Const i - | Smut m -> - let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] - and u c = let v = sval m in if pred v then supdate v m' c else () in - Node.add_dep m.snode m'.snode; - signal ~i m' p u - + | Const v as s -> if pred v then s else Const i + | Smut m -> + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] + and u c = let v = sval m in if pred v then supdate v m' c else () in + Node.add_dep m.snode m'.snode; + signal ~i m' p u + let fmap ?(eq = ( = )) fm i = function - | Const v -> (match fm v with Some v' -> Const v' | None -> Const i) - | Smut m -> - let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] - and u c = match fm (sval m) with Some v -> supdate v m' c | None -> () - in - Node.add_dep m.snode m'.snode; - signal ~i m' p u - + | Const v -> (match fm v with Some v' -> Const v' | None -> Const i) + | Smut m -> + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] + and u c = match fm (sval m) with Some v -> supdate v m' c | None -> () + in + Node.add_dep m.snode m'.snode; + signal ~i m' p u + let diff d = function - | Const _ -> Never - | Smut m -> - let m' = emut (rsucc m.snode) in - let last = ref None in - let rec p () = [ m.snode ] - and u c = - let v = sval m in - match !last with - | Some v' -> last := Some v; eupdate (d v v') m' c - | None -> assert false - in - begin match Cycle.find_unfinished (m.snode.producers ()) with - | c when c == Cycle.nil -> - Node.add_dep m.snode m'.enode; last := Some (sval m) - | c -> (* In a cycle, m' cannot occur in that cycle (cf. semantics). - Dep. added at the end of cycle to avoid being scheduled. *) - let setup () = - if m.snode.update == Node.nop then - () (* m stopped in cycle *) - else - (Node.add_dep m.snode m'.enode; last := Some (sval m)) - in - Cycle.add_eop c setup - end; - event m' p u + | Const _ -> Never + | Smut m -> + let m' = emut (rsucc m.snode) in + let last = ref None in + let rec p () = [ m.snode ] + and u c = + let v = sval m in + match !last with + | Some v' -> last := Some v; eupdate (d v v') m' c + | None -> assert false + in + let post_add_op () = last := Some (sval m) in + end_of_step_add_dep ~post_add_op ~stop_if_stopped:true m m'; + event m' p u let changes = function - | Const _ -> Never - | Smut m -> - let m' = emut (rsucc m.snode) in - let rec p () = [ m.snode ] - and u c = eupdate (sval m) m' c in - begin match Cycle.find_unfinished (m.snode.producers ()) with - | c when c == Cycle.nil -> Node.add_dep m.snode m'.enode - | c -> (* In a cycle, m' cannot occur in that cycle (cf. semantics). - Dep. added at the end of cycle to avoid being scheduled. *) - let setup () = - if m.snode.update == Node.nop then - () (* m stopped in cycle *) - else - (Node.add_dep m.snode m'.enode) - in - Cycle.add_eop c setup - end; - event m' p u + | Const _ -> Never + | Smut m -> + let m' = emut (rsucc m.snode) in + let rec p () = [ m.snode ] + and u c = eupdate (sval m) m' c in + end_of_step_add_dep ~stop_if_stopped:true m m'; + event m' p u let sample f e = function - | Const v -> E.map (fun ev -> f ev v) e - | Smut ms -> - match e with - | Never -> Never - | Emut me -> - let m' = emut (rsucc2 me.enode ms.snode) in - let rec p () = [ me.enode; ms.snode ] - and u c = match !(me.ev) with - | None -> () (* ms updated *) - | Some v -> eupdate (f v (sval ms)) m' c - in - E.add_dep me m'.enode; - Node.add_dep ms.snode m'.enode; - event m' p u + | Const v -> E.map (fun ev -> f ev v) e + | Smut ms -> + match e with + | Never -> Never + | Emut me -> + let m' = emut (rsucc2 me.enode ms.snode) in + let rec p () = [ me.enode; ms.snode ] + and u c = match !(me.ev) with + | None -> () (* ms updated *) + | Some v -> eupdate (f v (sval ms)) m' c + in + E.add_dep me m'.enode; + Node.add_dep ms.snode m'.enode; + event m' p u - let when_ ?(eq = ( = )) c i s = match c with + let on ?(eq = ( = )) c i s = match c with | Const true -> s - | Const false -> Const i - | Smut mc -> + | Const false -> Const i + | Smut mc -> match s with | Const v -> - let m' = smut (rsucc mc.snode) eq in - let rec p () = [ mc.snode ] - and u c = if (sval mc) then supdate v m' c else () in - Node.add_dep mc.snode m'.snode; - signal ~i m' p u - | Smut ms -> - let m' = smut (rsucc2 mc.snode ms.snode) eq in - let rec p () = [ mc.snode; ms.snode ] - and u c = if (sval mc) then supdate (sval ms) m' c else () in - Node.add_dep mc.snode m'.snode; - Node.add_dep ms.snode m'.snode; - signal ~i m' p u + let m' = smut (rsucc mc.snode) eq in + let rec p () = [ mc.snode ] + and u c = if (sval mc) then supdate v m' c else () in + Node.add_dep mc.snode m'.snode; + signal ~i m' p u + | Smut ms -> + let m' = smut (rsucc2 mc.snode ms.snode) eq in + let rec p () = [ mc.snode; ms.snode ] + and u c = if (sval mc) then supdate (sval ms) m' c else () in + Node.add_dep mc.snode m'.snode; + Node.add_dep ms.snode m'.snode; + signal ~i m' p u + + let when_ = on - let dismiss ?(eq = ( = )) c i s = match c with + let dismiss ?(eq = ( = )) c i s = match c with | Never -> s - | Emut mc -> + | Emut mc -> match s with - | Const v -> - let m' = smut (rsucc mc.enode) eq in - let rec p () = [ mc.enode ] - and u c = match !(mc.ev) with - | Some _ -> () | None -> supdate v m' c - in - Node.add_dep mc.enode m'.snode; - signal ~i m' p u + | Const v -> + let m' = smut (rsucc mc.enode) eq in + let rec p () = [ mc.enode ] + and u c = match !(mc.ev) with + | Some _ -> () | None -> supdate v m' c + in + Node.add_dep mc.enode m'.snode; + signal ~i m' p u | Smut ms -> - let m' = smut (rsucc2 mc.enode ms.snode) eq in - let rec p () = [ mc.enode; ms.snode ] - and u c = match !(mc.ev) with - | Some _ -> () | None -> supdate (sval ms) m' c - in - Node.add_dep mc.enode m'.snode; - Node.add_dep ms.snode m'.snode; - signal ~i m' p u - + let m' = smut (rsucc2 mc.enode ms.snode) eq in + let rec p () = [ mc.enode; ms.snode ] + and u c = match !(mc.ev) with + | Some _ -> () | None -> supdate (sval ms) m' c + in + Node.add_dep mc.enode m'.snode; + Node.add_dep ms.snode m'.snode; + signal ~i m' p u + (* Accumulating *) let accum ?(eq = ( = )) ef i = match ef with | Never -> Const i - | Emut m -> - let m' = smut (rsucc m.enode) eq in - let rec p () = [ m.enode ] + | Emut m -> + let m' = smut (rsucc m.enode) eq in + let rec p () = [ m.enode ] and u c = match !(m.ev) with | None -> () (* init only. *) - | Some v -> supdate (v (sval m')) m' c + | Some v -> supdate (v (sval m')) m' c in E.add_dep m m'.snode; signal ~i m' p u - let fold ?(eq = ( = )) f i = function - | Never -> Const i - | Emut m -> - let m' = smut (rsucc m.enode) eq in - let rec p () = [ m.enode ] - and u c = match !(m.ev) with - | None -> () (* init only. *) - | Some v -> supdate (f (sval m') v) m' c in - E.add_dep m m'.snode; - signal ~i m' p u + let fold ?(eq = ( = )) f i = function + | Never -> Const i + | Emut m -> + let m' = smut (rsucc m.enode) eq in + let rec p () = [ m.enode ] + and u c = match !(m.ev) with + | None -> () (* init only. *) + | Some v -> supdate (f (sval m') v) m' c in + E.add_dep m m'.snode; + signal ~i m' p u (* Combining *) @@ -995,108 +1210,126 @@ let dep = function Const _ -> ()| Smut m -> Node.add_dep m.snode m'.snode in List.iter dep sl; signal m' p u - - let switch ?(eq = ( = )) s = function - | Never -> s - | Emut ms -> - let r = match s with - | Smut m -> rsucc2 ms.enode m.snode | Const v -> rsucc ms.enode - in - let m' = smut r eq in - let src = ref s in (* current signal source. *) - let rec p () = match !src with - | Smut m -> [ m.snode; ms.enode] | Const _ -> [ ms.enode ] - and u c = match !(ms.ev) with - | None -> (match !src with (* src supdated. *) - | Smut m -> supdate (sval m) m' c | Const _ -> () (* init only. *)) - | Some s -> - begin match !src with - | Smut m -> Node.rem_dep m.snode m'.snode | Const _ -> () - end; - src := s; - match s with - | Const v -> - ignore (Node.update_rank m'.snode (rsucc ms.enode)); - supdate v m' c - | Smut m -> - Node.add_dep m.snode m'.snode; - if Node.update_rank m'.snode (rsucc2 m.snode ms.enode) then - begin - (* Rank increased because of m. Thus m may still - update and we need to reschedule. Next time we - will be in the other branch. *) - Cycle.allow_reschedule m'.snode; - Cycle.rebuild c; - Cycle.add c m'.snode - end - else - (* No rank increase. m already updated if needed. - No need to reschedule and rebuild the queue. *) - supdate (sval m) m' c - in - E.add_dep ms m'.snode; - match s with - | Const i -> signal ~i m' p u - | Smut m -> Node.add_dep m.snode m'.snode; signal m' p u - let fix ?(eq = ( = )) i f = - let update_delayed n p u nl = + let switch ?(eq = ( = )) = function + | Const s -> s + | Smut mss -> + let dummy = smut Node.min_rank eq in + let src = ref (Smut dummy) in (* dummy is overwritten by sig. init *) + let m' = smut (rsucc mss.snode) eq in + let rec p () = match !src with + | Smut m -> [ mss.snode; m.snode] | Const _ -> [ mss.snode ] + and u c = + if (sval mss) == !src then (* ss didn't change, !src did *) + begin match !src with + | Smut m -> supdate (sval m) m' c + | Const _ -> () (* init only. *) + end + else (* ss changed *) + begin + begin match !src with + | Smut m -> Node.rem_dep m.snode m'.snode + | Const _ -> () + end; + let new_src = sval mss in + src := new_src; + match new_src with + | Const v -> + ignore (Node.update_rank m'.snode (rsucc mss.snode)); + supdate v m' c + | Smut m -> + Node.add_dep m.snode m'.snode; + if c == Step.nil then + begin + ignore (Node.update_rank m'.snode + (rsucc2 m.snode mss.snode)); + (* Check if the init src is in a step. *) + match Step.find_unfinished [m.snode] with + | c when c == Step.nil -> supdate (sval m) m' c + | c -> Step.add c m'.snode + end + else + if Node.update_rank m'.snode (rsucc2 m.snode mss.snode) then + begin + (* Rank increased because of m. Thus m may still + update and we need to reschedule. Next time we + will be in the other branch. *) + Step.allow_reschedule m'.snode; + Step.rebuild c; + Step.add c m'.snode + end + else + (* No rank increase. m already updated if needed, no need + to reschedule and rebuild the queue. *) + supdate (sval m) m' c + end + in + Node.add_dep mss.snode m'.snode; + (* We add a dep to dummy to avoid a long scan of Wa.rem when we remove + the dep in the [u] function during static init. *) + Node.add_dep dummy.snode m'.snode; + signal m' p u + + let bind ?eq s sf = switch ?eq (map ~eq:( == ) sf s) + + let fix ?(eq = ( = )) i f = + let update_delayed n p u nl = Node.bind n p u; - match Cycle.find_unfinished nl with - | c when c == Cycle.nil -> - (* no pertinent occuring cycle, create a cycle for update. *) - let c = Cycle.create n in - n.update c; - Cycle.execute c - | c -> Cycle.add c n + match Step.find_unfinished nl with + | c when c == Step.nil -> + (* no pertinent occuring step, create a step for update. *) + let c = Step.create () in + n.update c; + Step.execute c + | c -> Step.add c n in let m = smut Node.delayed_rank eq in let s = signal ~i m (fun () -> []) (fun _ -> ()) in match f s with - | Const v, r -> - let rec p () = [] - and u c = supdate v m c in - update_delayed m.snode p u (Node.deps m.snode); - r - | Smut m', r -> - if m'.snode.rank = Node.delayed_rank then invalid_arg err_fix; - let rec p () = [ (* avoid cyclic dep. *) ] - and u c = supdate (sval m') m c in (* N.B. c is the next cycle. *) - Node.add_dep m'.snode m.snode; - update_delayed m.snode p u (m'.snode :: Node.deps m.snode); - r + | Const v, r -> + let rec p () = [] + and u c = supdate v m c in + update_delayed m.snode p u (Node.deps m.snode); + r + | Smut m', r -> + if m'.snode.rank = Node.delayed_rank then invalid_arg err_fix; + let rec p () = [ (* avoid cyclic dep. *) ] + and u c = supdate (sval m') m c in (* N.B. c is the next step. *) + Node.add_dep m'.snode m.snode; + update_delayed m.snode p u (m'.snode :: Node.deps m.snode); + r (* Lifting *) - + let l1 = map let l2 ?(eq = ( = )) f s s' = match s, s' with - | Smut m0, Smut m1 -> - let m' = smut (rsucc2 m0.snode m1.snode) eq in + | Smut m0, Smut m1 -> + let m' = smut (rsucc2 m0.snode m1.snode) eq in let rec p () = [ m0.snode; m1.snode ] - and u c = supdate (f (sval m0) (sval m1)) m' c in + and u c = supdate (f (sval m0) (sval m1)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; signal m' p u - | Const v, Const v' -> Const (f v v') - | Const v, Smut m -> + | Const v, Const v' -> Const (f v v') + | Const v, Smut m -> let m' = smut (rsucc m.snode) eq in let rec p () = [ m.snode ] - and u c = supdate (f v (sval m)) m' c in + and u c = supdate (f v (sval m)) m' c in Node.add_dep m.snode m'.snode; signal m' p u - | Smut m, Const v -> + | Smut m, Const v -> let m' = smut (rsucc m.snode) eq in let rec p () = [ m.snode ] - and u c = supdate (f (sval m) v) m' c in + and u c = supdate (f (sval m) v) m' c in Node.add_dep m.snode m'.snode; signal m' p u - + let l3 ?(eq = ( = )) f s0 s1 s2 = match s0, s1, s2 with - | Smut m0, Smut m1, Smut m2 -> + | Smut m0, Smut m1, Smut m2 -> let r = rsucc (rmax (rmax m0.snode m1.snode) m2.snode) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode ] - and u c = supdate (f (sval m0) (sval m1) (sval m2)) m' c in + and u c = supdate (f (sval m0) (sval m1) (sval m2)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; @@ -1104,32 +1337,32 @@ | Const v0, Const v1, Const v2 -> Const (f v0 v1 v2) | s0, s1, s2 -> app ~eq (l2 ~eq:( == ) f s0 s1) s2 - let l4 ?(eq = ( = )) f s0 s1 s2 s3 = match s0, s1, s2, s3 with - | Smut m0, Smut m1, Smut m2, Smut m3 -> + let l4 ?(eq = ( = )) f s0 s1 s2 s3 = match s0, s1, s2, s3 with + | Smut m0, Smut m1, Smut m2, Smut m3 -> let r = rsucc (rmax (rmax m0.snode m1.snode) (rmax m2.snode m3.snode)) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode ] - and u c = supdate (f (sval m0) (sval m1) (sval m2) (sval m3)) m' c in + and u c = supdate (f (sval m0) (sval m1) (sval m2) (sval m3)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; Node.add_dep m3.snode m'.snode; signal m' p u | Const v0, Const v1, Const v2, Const v3 -> Const (f v0 v1 v2 v3) - | s0, s1, s2, s3 -> app ~eq (l3 ~eq:( == ) f s0 s1 s2) s3 + | s0, s1, s2, s3 -> app ~eq (l3 ~eq:( == ) f s0 s1 s2) s3 - let l5 ?(eq = ( = )) f s0 s1 s2 s3 s4 = match s0, s1, s2, s3, s4 with - | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4 -> + let l5 ?(eq = ( = )) f s0 s1 s2 s3 s4 = match s0, s1, s2, s3, s4 with + | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4 -> let m = rmax in - let r = rsucc (m (m m0.snode m1.snode) - (m m2.snode (m m3.snode m4.snode))) + let r = rsucc (m (m m0.snode m1.snode) + (m m2.snode (m m3.snode m4.snode))) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode ] - and u c = - let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) in - supdate v m' c - in + and u c = + let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) in + supdate v m' c + in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; @@ -1137,21 +1370,21 @@ Node.add_dep m4.snode m'.snode; signal m' p u | Const v0, Const v1, Const v2, Const v3, Const v4 -> Const (f v0 v1 v2 v3 v4) - | s0, s1, s2, s3, s4 -> app ~eq (l4 ~eq:( == ) f s0 s1 s2 s3) s4 + | s0, s1, s2, s3, s4 -> app ~eq (l4 ~eq:( == ) f s0 s1 s2 s3) s4 - let l6 ?(eq = ( = )) f s0 s1 s2 s3 s4 s5 = match s0, s1, s2, s3, s4, s5 with - | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4, Smut m5 -> + let l6 ?(eq = ( = )) f s0 s1 s2 s3 s4 s5 = match s0, s1, s2, s3, s4, s5 with + | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4, Smut m5 -> let m = rmax in - let m = m (m m0.snode (m m1.snode m2.snode)) - (m m3.snode (m m4.snode m5.snode)) + let m = m (m m0.snode (m m1.snode m2.snode)) + (m m3.snode (m m4.snode m5.snode)) in let m' = smut (rsucc m) eq in - let rec p () = - [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode; m5.snode ] - and u c = - let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) (sval m5) in - supdate v m' c - in + let rec p () = + [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode; m5.snode ] + and u c = + let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) (sval m5) in + supdate v m' c + in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; @@ -1159,22 +1392,56 @@ Node.add_dep m4.snode m'.snode; Node.add_dep m5.snode m'.snode; signal m' p u - | Const v0, Const v1, Const v2, Const v3, Const v4, Const v5-> + | Const v0, Const v1, Const v2, Const v3, Const v4, Const v5-> Const (f v0 v1 v2 v3 v4 v5) - | s0, s1, s2, s3, s4, s5 -> app ~eq (l5 ~eq:( == ) f s0 s1 s2 s3 s4) s5 - + | s0, s1, s2, s3, s4, s5 -> app ~eq (l5 ~eq:( == ) f s0 s1 s2 s3 s4) s5 + module Bool = struct - let eq : bool -> bool -> bool = ( = ) + let one = Const true + let zero = Const false + let eq : bool -> bool -> bool = ( = ) let not s = l1 ~eq not s - let ( && ) s s' = l2 ~eq ( && ) s s' + let ( && ) s s' = l2 ~eq ( && ) s s' let ( || ) s s' = l2 ~eq ( || ) s s' + + let edge s = changes s + let edge_detect edge = function + | Const _ -> Never + | Smut m -> + let m' = emut (rsucc m.snode) in + let rec p () = [ m.snode ] + and u c = if (sval m) = edge then eupdate () m' c in + end_of_step_add_dep ~stop_if_stopped:true m m'; + event m' p u + + let rise s = edge_detect true s + let fall s = edge_detect false s + let flip b = function + | Never -> Const b + | Emut m -> + let m' = smut (rsucc m.enode) ( = ) in + let rec p () = [ m.enode ] + and u c = supdate (Pervasives.not (sval m')) m' c in + E.add_dep m m'.snode; + (* can't use [signal] here because of semantics. *) + Node.bind m'.snode p u; + m'.sv <- Some b; + begin match Step.find_unfinished [m.enode] with + | c when c == Step.nil -> () + | c -> Step.add c m'.snode + end; + Smut m' + end module Int = struct + let zero = Const 0 + let one = Const 1 + let minus_one = Const (-1) let eq : int -> int -> bool = ( = ) let ( ~- ) s = l1 ~eq ( ~- ) s let succ s = l1 ~eq succ s - let pred s = l1 ~eq pred s + let pred s = l1 ~eq pred s let ( + ) s s' = l2 ~eq ( + ) s s' let ( - ) s s' = l2 ~eq ( - ) s s' let ( * ) s s' = l2 ~eq ( * ) s s' @@ -1192,6 +1459,9 @@ end module Float = struct + let zero = Const 0. + let one = Const 1. + let minus_one = Const (-1.) let eq : float -> float -> bool = ( = ) let ( ~-. ) s = l1 ~eq ( ~-. ) s let ( +. ) s s' = l2 ~eq ( +. ) s s' @@ -1227,7 +1497,7 @@ let infinity = const infinity let neg_infinity = const neg_infinity let nan = const nan - let max_float = const max_float + let max_float = const max_float let min_float = const min_float let epsilon_float = const epsilon_float let classify_float s = l1 ~eq:( = ) classify_float s @@ -1239,8 +1509,87 @@ let snd ?eq s = l1 ?eq snd s end - module Compare = struct - let eq = Bool.eq + module Option = struct + let none = Const None + let some s = + let eq = match eq_fun s with + | None -> None + | Some eq -> + let eq v v' = match v, v' with + | Some v, Some v' -> eq v v' + | _ -> assert false + in + Some eq + in + map ?eq (fun v -> Some v) s + + let value ?(eq = ( = )) ~default s = match s with + | Const (Some v) -> Const v + | Const None -> + let d = match default with `Init d -> d | `Always d -> d in + begin match d with + | Const d -> Const d + | Smut md -> + match Step.find_unfinished [md.snode] with + | c when c == Step.nil -> Const (sval md) + | c -> + let m' = smut (rsucc md.snode) eq in + let rec p () = [ md.snode ] + and u c = + Node.rem_dep md.snode m'.snode; + supdate (sval md) m' c; + Node.stop m'.snode + in + Node.add_dep md.snode m'.snode; + signal m' p u + end + | Smut m -> + match default with + | `Init (Const d) -> fmap ~eq (fun v -> v) d s + | `Always (Const d) -> map ~eq (function None -> d | Some v -> v) s + | `Init (Smut md) -> + begin match Step.find_unfinished [md.snode] with + | c when c == Step.nil -> + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] + and u c = match sval m with + | Some v -> supdate v m' c | None -> () + in + Node.add_dep m.snode m'.snode; + signal ~i:(sval md) m' p u + | c -> + let m' = smut (rsucc2 m.snode md.snode) eq in + let rec p () = [ m.snode ] in (* subsequent updates *) + let u c = match sval m with + | Some v -> supdate v m' c | None -> () + in + let rec p_first () = [ m.snode; md.snode ] in (* first update *) + let u_first c = + Node.rem_dep md.snode m'.snode; + begin match sval m with + | None -> supdate (sval md) m' c + | Some v -> supdate v m' c + end; + Node.bind m'.snode p u + in + Node.add_dep m.snode m'.snode; + Node.add_dep md.snode m'.snode; + signal m' p_first u_first + end + | `Always (Smut md) -> + let m' = smut (rsucc2 m.snode md.snode) eq in + let rec p () = [ m.snode; md.snode ] in + let u c = match sval m with + | Some v -> supdate v m' c + | None -> supdate (sval md) m' c + in + Node.add_dep m.snode m'.snode; + Node.add_dep md.snode m'.snode; + signal m' p u + end + + module Compare = struct + let eq = Bool.eq let ( = ) s s' = l2 ~eq ( = ) s s' let ( <> ) s s' = l2 ~eq ( <> ) s s' let ( < ) s s' = l2 ~eq ( < ) s s' @@ -1250,48 +1599,49 @@ let compare s s' = l2 ~eq:Int.eq compare s s' let ( == ) s s' = l2 ~eq ( == ) s s' let ( != ) s s' = l2 ~eq ( != ) s s' - end + end (* Combinator specialization *) module type EqType = sig - type 'a t - val equal : 'a t -> 'a t -> bool + type 'a t + val equal : 'a t -> 'a t -> bool end - + module type S = sig - type 'a v - val create : 'a v -> 'a v signal * ('a v -> unit) + type 'a v + val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) val equal : 'a v signal -> 'a v signal -> bool val hold : 'a v -> 'a v event -> 'a v signal val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal val map : ('a -> 'b v) -> 'a signal -> 'b v signal - val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal + val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal - val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal + val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal - val switch : 'a v signal -> 'a v signal event -> 'a v signal + val switch : 'a v signal signal -> 'a v signal + val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) - val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) - val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 'c signal - -> 'd v signal) - val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) - val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f v signal) - val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g v signal) + val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) + val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 'c signal + -> 'd v signal) + val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f v signal) + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g v signal) end module Make (Eq : EqType) = struct type 'a v = 'a Eq.t - let eq = Eq.equal + let eq = Eq.equal let create v = create ~eq v let equal s s' = equal ~eq s s' let hold v e = hold ~eq v e @@ -1300,20 +1650,21 @@ let filter pred i = filter ~eq pred i let fmap fm i = fmap ~eq fm i let when_ c i s = when_ ~eq c i s - let dismiss c s = dismiss ~eq c s + let dismiss c s = dismiss ~eq c s let accum ef i = accum ~eq ef i let fold f i = fold ~eq f i let merge f a sl = merge ~eq f a sl let switch s = switch ~eq s + let bind s sf = bind ~eq s sf let fix f = fix ~eq f - let l1 = map + let l1 = map let l2 f s s' = l2 ~eq f s s' let l3 f s0 s1 s2 = l3 ~eq f s0 s1 s2 let l4 f s0 s1 s2 s3 = l4 ~eq f s0 s1 s2 s3 let l5 f s0 s1 s2 s3 s4 = l5 ~eq f s0 s1 s2 s3 s4 let l6 f s0 s1 s2 s3 s4 s5 = l6 ~eq f s0 s1 s2 s3 s4 s5 end - + module Special = struct module Sb = Make (struct type 'a t = bool let equal = Bool.eq end) module Si = Make (struct type 'a t = int let equal = Int.eq end) @@ -1322,13 +1673,13 @@ end (*--------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli + Copyright (c) 2009 Daniel C. Bünzli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff -Nru react-0.9.4/src/react.mli react-1.2.0/src/react.mli --- react-0.9.4/src/react.mli 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/src/react.mli 2014-08-23 23:03:34.000000000 +0000 @@ -1,23 +1,23 @@ (*--------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli. All rights reserved. + Copyright (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. - react release 0.9.4 + react release 1.2.0 ---------------------------------------------------------------------------*) (** Declarative events and signals. React is a module for functional reactive programming (frp). It provides support to program with time varying values : declarative - {{:React.E.html}events} and {{:React.S.html}signals}. React + {{!E}events} and {{!S}signals}. React doesn't define any primitive event or signal, this lets the client choose the concrete timeline. - Consult the {{:#sem}semantics}, the {{:#basics}basics} and - {{:#ex}examples}. Open the module to use it, this defines only two + Consult the {{!sem}semantics}, the {{!basics}basics} and + {{!ex}examples}. Open the module to use it, this defines only two types and modules in your scope. - {e Release 0.9.4 - Daniel Bünzli } *) - + {e Release 1.2.0 - Daniel Bünzli } *) + (** {1 Interface} *) type 'a event @@ -26,9 +26,12 @@ type 'a signal (** The type for signals of type ['a]. *) -(** Event combinators. +type step +(** The type for update steps. *) + +(** Event combinators. - Consult their {{:React.html#evsem}semantics.} *) + Consult their {{!evsem}semantics.} *) module E : sig (** {1:prim Primitive and basics} *) @@ -38,12 +41,19 @@ val never : 'a event (** A never occuring event. For all t, \[[never]\]{_t} [= None]. *) - val create : unit -> 'a event * ('a -> unit) - (** [create ()] is a primitive event [e] and a [send] function. - [send v] generates an occurrence [v] of [e] at the time it is called - and triggers an {{:React.html#update}update cycle}. + val create : unit -> 'a event * (?step:step -> 'a -> unit) + (** [create ()] is a primitive event [e] and a [send] function. The + function [send] is such that: + {ul + {- [send v] generates an occurrence [v] of [e] at the time it is called + and triggers an {{!steps}update step}.} + {- [send ~step v] generates an occurence [v] of [e] on the step [step] + when [step] is {{!Step.execute}executed}.} + {- [send ~step v] raises [Invalid_argument] if it was previously + called with a step and this step has not executed yet or if + the given [step] was already executed.}} - {b Warning.} [send] must not be executed inside an update cycle. *) + {b Warning.} [send] must not be executed inside an update step. *) val retain : 'a event -> (unit -> unit) -> [ `R of (unit -> unit) ] (** [retain e c] keeps a reference to the closure [c] in [e] and @@ -52,13 +62,17 @@ {b Raises.} [Invalid_argument] on {!E.never}. *) - val stop : 'a event -> unit + val stop : ?strong:bool -> 'a event -> unit (** [stop e] stops [e] from occuring. It conceptually becomes - {!never} and cannot be restarted. Allows to - disable {{:React.html#sideeffects}effectful} events. + {!never} and cannot be restarted. Allows to + disable {{!sideeffects}effectful} events. - {b Note.} If executed in an {{:React.html#update}update cycle} - the event may still occur in the cycle. *) + The [strong] argument should only be used on platforms + where weak arrays have a strong semantics (i.e. JavaScript). + See {{!strongstop}details}. + + {b Note.} If executed in an {{!steps}update step} + the event may still occur in the step. *) val equal : 'a event -> 'a event -> bool (** [equal e e'] is [true] iff [e] and [e'] are equal. If both events are @@ -75,23 +89,23 @@ val once : 'a event -> 'a event (** [once e] is [e] with only its next occurence. {ul - {- \[[once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + {- \[[once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[e]\]{_ 'a event - (** [drop_once e] is [e] without its next occurrence. + (** [drop_once e] is [e] without its next occurrence. {ul - {- \[[drop_once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + {- \[[drop_once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[e]\]{_ 'b) event -> 'a event -> 'b event (** [app ef e] occurs when both [ef] and [e] occur - {{:React.html#simultaneity}simultaneously}. + {{!simultaneity}simultaneously}. The value is [ef]'s occurence applied to [e]'s one. - {ul - {- \[[app ef e]\]{_t} [= Some v'] if \[[ef]\]{_t} [= Some f] and + {ul + {- \[[app ef e]\]{_t} [= Some v'] if \[[ef]\]{_t} [= Some f] and \[[e]\]{_t} [= Some v] and [f v = v'].} {- \[[app ef e]\]{_t} [= None] otherwise.}} *) @@ -105,10 +119,10 @@ (** [stamp e v] is [map (fun _ -> v) e]. *) val filter : ('a -> bool) -> 'a event -> 'a event - (** [filter p e] are [e]'s occurrences that satisfy [p]. + (** [filter p e] are [e]'s occurrences that satisfy [p]. {ul - {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and - [p v = true]} + {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + [p v = true]} {- \[[filter p e]\]{_t} [= None] otherwise.}} *) val fmap : ('a -> 'b option) -> 'a event -> 'b event @@ -117,7 +131,7 @@ {- \[[fmap fm e]\]{_t} [= Some v] if [fm] \[[e]\]{_t} [= Some v]} {- \[[fmap fm e]\]{_t} [= None] otherwise.}} *) - val diff : ('a -> 'a -> 'b) -> 'a event -> 'b event + val diff : ('a -> 'a -> 'b) -> 'a event -> 'b event (** [diff f e] occurs whenever [e] occurs except on the next occurence. Occurences are [f v v'] where [v] is [e]'s current occurrence and [v'] the previous one. @@ -127,53 +141,55 @@ {- \[[diff f e]\]{_t} [= None] otherwise.}} *) val changes : ?eq:('a -> 'a -> bool) -> 'a event -> 'a event - (** [changes eq e] is [e]'s occurrences with occurences equal to + (** [changes eq e] is [e]'s occurrences with occurences equal to the previous one dropped. Equality is tested with [eq] (defaults to structural equality). {ul {- \[[changes eq e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] - and either \[[e]\]{_ 'a event -> 'a event - (** [when_ c e] is the occurrences of [e] when [c] is [true]. - {ul - {- \[[when_ c e]\]{_t} [= Some v] + val on : bool signal -> 'a event -> 'a event + (** [on c e] is the occurrences of [e] when [c] is [true]. + {ul + {- \[[on c e]\]{_t} [= Some v] if \[[c]\]{_t} [= true] and \[[e]\]{_t} [= Some v].} - {- \[[when_ c e]\]{_t} [= None] otherwise.}} *) + {- \[[on c e]\]{_t} [= None] otherwise.}} *) + val when_ : bool signal -> 'a event -> 'a event + (** @deprecated Use {!on}. *) - val dismiss : 'b event -> 'a event -> 'a event - (** [dismiss c e] is the occurences of [e] except the ones when [c] occurs. + val dismiss : 'b event -> 'a event -> 'a event + (** [dismiss c e] is the occurences of [e] except the ones when [c] occurs. {ul - {- \[[dimiss c e]\]{_t} [= Some v] + {- \[[dimiss c e]\]{_t} [= Some v] if \[[c]\]{_t} [= None] and \[[e]\]{_t} [= Some v].} {- \[[dimiss c e]\]{_t} [= None] otherwise.}} *) val until : 'a event -> 'b event -> 'b event (** [until c e] is [e]'s occurences until [c] occurs. - {ul + {ul {- \[[until c e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[c]\]{_<=t} [= None]} {- \[[until c e]\]{_t} [= None] otherwise.}} *) (** {1:accum Accumulating} *) - val accum : ('a -> 'a) event -> 'a -> 'a event + val accum : ('a -> 'a) event -> 'a -> 'a event (** [accum ef i] accumulates a value, starting with [i], using [e]'s functional occurrences. - {ul + {ul {- \[[accum ef i]\]{_t} [= Some (f i)] if \[[ef]\]{_t} [= Some f] and \[[ef]\]{_ 'b -> 'a) -> 'a -> 'b event -> 'a event - (** [fold f i e] accumulates [e]'s occurrences with [f] starting with [i]. - {ul + (** [fold f i e] accumulates [e]'s occurrences with [f] starting with [i]. + {ul {- \[[fold f i e]\]{_t} [= Some (f i v)] if \[[e]\]{_t} [= Some v] and \[[e]\]{_ 'a event - (** [select el] is the occurrences of every event in [el]. - If more than one event occurs {{:React.html#simultaneity}simultaneously} + (** [select el] is the occurrences of every event in [el]. + If more than one event occurs {{!simultaneity}simultaneously} the leftmost is taken and the others are lost. {ul - {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} + {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} [<> None) el]\]{_t}}. {- \[[select el]\]{_ t} [= None] otherwise.}} *) val merge : ('a -> 'b -> 'a) -> 'a -> 'b event list -> 'a event - (** [merge f a el] merges the {{:React.html#simultaneity}simultaneous} - occurrences of every event in [el] using [f] and the accumulator [a]. - - \[[merge f a el]\]{_ t} - [= List.fold_left f a (List.filter (fun o -> o <> None) - (List.map] \[\]{_t}[ el))]. *) + (** [merge f a el] merges the {{!simultaneity}simultaneous} + occurrences of every event in [el] using [f] and the accumulator [a]. + + \[[merge f a el]\]{_ t} + [= List.fold_left f a (List.filter (fun o -> o <> None) + (List.map] \[\]{_t}[ el))]. *) - val switch : 'a event -> 'a event event -> 'a event - (** [switch e ee] is [e]'s occurrences until there is an + val switch : 'a event -> 'a event event -> 'a event + (** [switch e ee] is [e]'s occurrences until there is an occurrence [e'] on [ee], the occurrences of [e'] are then used - until there is a new occurrence on [ee], etc.. + until there is a new occurrence on [ee], etc.. {ul {- \[[switch e ee]\]{_ t} [=] \[[e]\]{_t} if \[[ee]\]{_<=t} [= None].} - {- \[[switch e ee]\]{_ t} [=] \[[e']\]{_t} if \[[ee]\]{_<=t} - [= Some e'].}} *) + {- \[[switch e ee]\]{_ t} [=] \[[e']\]{_t} if \[[ee]\]{_<=t} + [= Some e'].}} *) val fix : ('a event -> 'a event * 'b) -> 'b (** [fix ef] allows to refer to the value an event had an @@ -218,15 +234,52 @@ is such that : {ul {- \[[e]\]{_ t} [=] [None] if t = 0 } - {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} + {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} - {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. + {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. an event given to a fixing function). *) + + (** {1 Lifting} + + Lifting combinators. For a given [n] the semantics is: + {ul + {- \[[ln f e1 ... en]\]{_t} [= Some (f v1 ... vn)] if for all + i : \[[ei]\]{_t} [= Some vi].} + {- \[[ln f e1 ... en]\]{_t} [= None] otherwise.}} *) + + val l1 : ('a -> 'b) -> 'a event -> 'b event + val l2 : ('a -> 'b -> 'c) -> 'a event -> 'b event -> 'c event + val l3 : ('a -> 'b -> 'c -> 'd) -> 'a event -> 'b event -> 'c event -> + 'd event + val l4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a event -> 'b event -> 'c event -> + 'd event -> 'e event + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a event -> 'b event -> + 'c event -> 'd event -> 'e event -> 'f event + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a event -> 'b event -> + 'c event -> 'd event -> 'e event -> 'f event -> 'g event + + (** {1 Pervasives support} *) + + (** Events with option occurences. *) + module Option : sig + val some : 'a event -> 'a option event + (** [some e] is [map (fun v -> Some v) e]. *) + + val value : ?default:'a signal -> 'a option event -> 'a event + (** [value default e] either silences [None] occurences if [default] is + unspecified or replaces them by the value of [default] at the occurence + time. + {ul + {- \[[value ~default e]\]{_t}[ = v] if \[[e]\]{_t} [= Some (Some v)].} + {- \[[value ?default:None e]\]{_t}[ = None] if \[[e]\]{_t} = [None].} + {- \[[value ?default:(Some s) e]\]{_t}[ = v] + if \[[e]\]{_t} = [None] and \[[s]\]{_t} [= v].}} *) + end end -(** Signal combinators. +(** Signal combinators. - Consult their {{:React.html#sigsem}semantics.} *) + Consult their {{!sigsem}semantics.} *) module S : sig (** {1:prim Primitive and basics} *) @@ -236,19 +289,26 @@ val const : 'a -> 'a signal (** [const v] is always [v], \[[const v]\]{_t} [= v]. *) - val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a signal * ('a -> unit) + val create : ?eq:('a -> 'a -> bool) -> 'a -> + 'a signal * (?step:step -> 'a -> unit) (** [create i] is a primitive signal [s] set to [i] and a - [set] function. [set v] sets the signal's value to [v] at the - time it is called and triggers an {{:React.html#update}update - cycle}. - - {b Warning.} [send] must not be executed inside an update cycle. *) + [set] function. The function [set] is such that: + {ul + {- [set v] sets the signal's value to [v] at the time it is called and + triggers an {{!steps}update step}.} + {- [set ~step v] sets the signal's value to [v] at the time it is + called and updates it dependencies when [step] is + {{!Step.execute}executed}} + {- [set ~step v] raises [Invalid_argument] if it was previously + called with a step and this step has not executed yet or if + the given [step] was already executed.}} + {b Warning.} [set] must not be executed inside an update step. *) val value : 'a signal -> 'a - (** [value s] is [s]'s current value. + (** [value s] is [s]'s current value. - {b Warning.} If executed in an {{:React.html#update}update - cycle} may return a non up-to-date value or raise [Failure] if + {b Warning.} If executed in an {{!steps}update + step} may return a non up-to-date value or raise [Failure] if the signal is not yet initialized. *) val retain : 'a signal -> (unit -> unit) -> [ `R of (unit -> unit) ] @@ -262,13 +322,17 @@ val eq_fun : 'a signal -> ('a -> 'a -> bool) option (**/**) - val stop : 'a signal -> unit + val stop : ?strong:bool -> 'a signal -> unit (** [stop s], stops updating [s]. It conceptually becomes {!const} with the signal's last value and cannot be restarted. Allows to - disable {{:React.html#sideeffects}effectful} signals. + disable {{!sideeffects}effectful} signals. - {b Note.} If executed in an update cycle the signal may - still update in the cycle. *) + The [strong] argument should only be used on platforms + where weak arrays have a strong semantics (i.e. JavaScript). + See {{!strongstop}details}. + + {b Note.} If executed in an update step the signal may + still update in the step. *) val equal : ?eq:('a -> 'a -> bool) -> 'a signal -> 'a signal -> bool (** [equal s s'] is [true] iff [s] and [s'] are equal. If both @@ -286,43 +350,42 @@ (** {1 From events} *) val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a event -> 'a signal - (** [hold i e] has the value of [e]'s last occurrence or [i] if there + (** [hold i e] has the value of [e]'s last occurrence or [i] if there wasn't any. - {ul + {ul {- \[[hold i e]\]{_t} [= i] if \[[e]\]{_<=t} [= None]} {- \[[hold i e]\]{_t} [= v] if \[[e]\]{_<=t} [= Some v]}} *) - (** {1:tr Transforming and filtering} *) - val app : ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> + val app : ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> 'b signal (** [app sf s] holds the value of [sf] applied - to the value of [s], \[[app sf s]\]{_t} + to the value of [s], \[[app sf s]\]{_t} [=] \[[sf]\]{_t} \[[s]\]{_t}. *) val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a signal -> 'b signal (** [map f s] is [s] transformed by [f], \[[map f s]\]{_t} = [f] \[[s]\]{_t}. *) - val filter : ?eq:('a -> 'a -> bool) -> ('a -> bool) -> 'a -> 'a signal -> - 'a signal + val filter : ?eq:('a -> 'a -> bool) -> ('a -> bool) -> 'a -> 'a signal -> + 'a signal (** [filter f i s] is [s]'s values that satisfy [p]. If a value does not satisfy [p] it holds the last value that was satisfied or [i] if - there is none. + there is none. {ul {- \[[filter p s]\]{_t} [=] \[[s]\]{_t} if [p] \[[s]\]{_t}[ = true].} {- \[[filter p s]\]{_t} [=] \[[s]\]{_t'} if [p] \[[s]\]{_t}[ = false] and t' is the greatest t' < t with [p] \[[s]\]{_t'}[ = true].} {- \[[filter p e]\]{_t} [= i] otherwise.}} *) - val fmap : ?eq:('b -> 'b -> bool) -> ('a -> 'b option) -> 'b -> 'a signal -> - 'b signal + val fmap : ?eq:('b -> 'b -> bool) -> ('a -> 'b option) -> 'b -> 'a signal -> + 'b signal (** [fmap fm i s] is [s] filtered and mapped by [fm]. {ul {- \[[fmap fm i s]\]{_t} [=] v if [fm] \[[s]\]{_t}[ = Some v].} - {- \[[fmap fm i s]\]{_t} [=] \[[fmap fm i s]\]{_t'} if [fm] - \[[s]\]{_t} [= None] and t' is the greatest t' < t with [fm] + {- \[[fmap fm i s]\]{_t} [=] \[[fmap fm i s]\]{_t'} if [fm] + \[[s]\]{_t} [= None] and t' is the greatest t' < t with [fm] \[[s]\]{_t'} [<> None].} {- \[[fmap fm i s]\]{_t} [= i] otherwise.}} *) @@ -331,7 +394,7 @@ [v'] to [v] and [eq v v'] is [false] ([eq] is the signal's equality function). The value of the occurrence is [f v v']. {ul - {- \[[diff f s]\]{_t} [= Some d] + {- \[[diff f s]\]{_t} [= Some d] if \[[s]\]{_t} [= v] and \[[s]\]{_t-dt} [= v'] and [eq v v' = false] and [f v v' = d].} {- \[[diff f s]\]{_t} [= None] otherwise.}} *) @@ -341,25 +404,28 @@ val sample : ('b -> 'a -> 'c) -> 'b event -> 'a signal -> 'c event (** [sample f e s] samples [s] at [e]'s occurrences. - {ul + {ul {- \[[sample f e s]\]{_t} [= Some (f ev sv)] if \[[e]\]{_t} [= Some ev] and \[[s]\]{_t} [= sv].} - {- \[[sample e s]\]{_t} [= None] otherwise.}} *) + {- \[[sample e s]\]{_t} [= None] otherwise.}} *) - val when_ : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> + val on : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> 'a signal - (** [when_ c i s] is the signal [s] whenever [c] is [true]. + (** [on c i s] is the signal [s] whenever [c] is [true]. When [c] is [false] it holds the last value [s] had when [c] was the last time [true] or [i] if it never was. {ul - {- \[[when_ c i s]\]{_t} [=] \[[s]\]{_t} if \[[c]\]{_t} [= true]} - {- \[[when_ c i s]\]{_t} [=] \[[s]\]{_t'} if \[[c]\]{_t} [= false] + {- \[[on c i s]\]{_t} [=] \[[s]\]{_t} if \[[c]\]{_t} [= true]} + {- \[[on c i s]\]{_t} [=] \[[s]\]{_t'} if \[[c]\]{_t} [= false] where t' is the greatest t' < t with \[[c]\]{_t'} [= true].} - {- \[[when_ c i s]\]{_t} [=] [i] otherwise.}} *) - + {- \[[on c i s]\]{_t} [=] [i] otherwise.}} *) + + val when_ : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> + 'a signal + (** @deprecated Use {!on}. *) - val dismiss : ?eq:('a -> 'a -> bool) -> 'b event -> 'a -> 'a signal -> - 'a signal + val dismiss : ?eq:('a -> 'a -> bool) -> 'b event -> 'a -> 'a signal -> + 'a signal (** [dismiss c i s] is the signal [s] except changes when [c] occurs are ignored. If [c] occurs initially [i] is used. {ul @@ -367,14 +433,14 @@ where t' is the greatest t' <= t with \[[c]\]{_t'} [= None] and \[[s]\]{_t'-dt} [<>] \[[s]\]{_t'}} {- \[[dismiss_ c i s]\]{_0} [=] [v] where [v = i] if - \[[c]\]{_0} [= Some _] and [v =] \[[s]\]{_0} otherwise.}} *) + \[[c]\]{_0} [= Some _] and [v =] \[[s]\]{_0} otherwise.}} *) (** {1:acc Accumulating} *) - val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) event -> 'a -> 'a signal + val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) event -> 'a -> 'a signal (** [accum e i] is [S.hold i (]{!E.accum}[ e i)]. *) - val fold : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b event -> + val fold : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b event -> 'a signal (** [fold f i e] is [S.hold i (]{!E.fold}[ f i e)]. *) @@ -383,20 +449,19 @@ val merge : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b signal list -> 'a signal (** [merge f a sl] merges the value of every signal in [sl] - using [f] and the accumulator [a]. - - \[[merge f a sl]\]{_ t} - [= List.fold_left f a (List.map] \[\]{_t}[ sl)]. *) + using [f] and the accumulator [a]. - val switch : ?eq:('a -> 'a -> bool) -> 'a signal -> 'a signal event -> - 'a signal - (** [switch s es] is [s] until there is an - occurrence [s'] on [es], [s'] is then used - until there is a new occurrence on [es], etc.. - {ul - {- \[[switch s es]\]{_ t} [=] \[[s]\]{_t} if \[[es]\]{_<=t} [= None].} - {- \[[switch s es]\]{_ t} [=] \[[s']\]{_t} if \[[es]\]{_<=t} - [= Some s'].}} *) + \[[merge f a sl]\]{_ t} + [= List.fold_left f a (List.map] \[\]{_t}[ sl)]. *) + + val switch : ?eq:('a -> 'a -> bool) -> 'a signal signal -> 'a signal + (** [switch ss] is the inner signal of [ss]. + {ul + {- \[[switch ss]\]{_ t} [=] \[\[[ss]\]{_t}\]{_t}.}} *) + + val bind : ?eq:('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> + 'b signal + (** [bind s sf] is [switch (map ~eq:( == ) sf s)]. *) val fix : ?eq:('a -> 'a -> bool) -> 'a -> ('a signal -> 'a signal * 'b) -> 'b (** [fix i sf] allow to refer to the value a signal had an @@ -408,63 +473,87 @@ is such that : {ul {- \[[s]\]{_ t} [=] [i] for t = 0. } - {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} + {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} - [eq] is the equality used by [s]. + [eq] is the equality used by [s]. - {b Raises.} [Invalid_argument] if [s'] is directly a delayed signal (i.e. + {b Raises.} [Invalid_argument] if [s'] is directly a delayed signal (i.e. a signal given to a fixing function). - {b Note.} Regarding values depending on the result [r] of + {b Note.} Regarding values depending on the result [r] of [s', r = sf s] the following two cases need to be distinguished : {ul - {- After [sf s] is applied, [s'] does not depend on - a value that is in a cycle and [s] has no dependents in a cycle (e.g - in the simple case where [fix] is applied outside a cycle). + {- After [sf s] is applied, [s'] does not depend on + a value that is in a step and [s] has no dependents in a step (e.g + in the simple case where [fix] is applied outside a step). In that case if the initial value of [s'] differs from [i], [s] and its dependents need to be updated and a special - update cycle will be triggered for this. Values + update step will be triggered for this. Values depending on the result [r] will be created only after this - special update cycle has finished (e.g. they won't see + special update step has finished (e.g. they won't see the [i] of [s] if [r = s]).} {- Otherwise, values depending on [r] will be created in the same - cycle as [s] and [s'] (e.g. they will see the [i] of [s] if [r = s]).}} + step as [s] and [s'] (e.g. they will see the [i] of [s] if [r = s]).}} *) - (** {1:lifting Lifting} + (** {1:lifting Lifting} Lifting combinators. For a given [n] the semantics is : \[[ln f a1] ... [an]\]{_t} = f \[[a1]\]{_t} ... \[[an]\]{_t} *) val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> ('a signal -> 'b signal) - val l2 : ?eq:('c -> 'c -> bool) -> - ('a -> 'b -> 'c) -> ('a signal -> 'b signal -> 'c signal) - val l3 : ?eq:('d -> 'd -> bool) -> - ('a -> 'b -> 'c -> 'd) -> ('a signal -> 'b signal -> 'c signal -> 'd signal) - val l4 : ?eq:('e -> 'e -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) - val l5 : ?eq:('f -> 'f -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal) - val l6 : ?eq:('g -> 'g -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g signal) + val l2 : ?eq:('c -> 'c -> bool) -> + ('a -> 'b -> 'c) -> ('a signal -> 'b signal -> 'c signal) + val l3 : ?eq:('d -> 'd -> bool) -> + ('a -> 'b -> 'c -> 'd) -> ('a signal -> 'b signal -> 'c signal -> 'd signal) + val l4 : ?eq:('e -> 'e -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) + val l5 : ?eq:('f -> 'f -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal) + val l6 : ?eq:('g -> 'g -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g signal) - (** The following modules lift some of [Pervasives] functions and + (** The following modules lift some of [Pervasives] functions and operators. *) module Bool : sig + val zero : bool signal + val one : bool signal val not : bool signal -> bool signal val ( && ) : bool signal -> bool signal -> bool signal val ( || ) : bool signal -> bool signal -> bool signal + + val edge : bool signal -> bool event + (** [edge s] is [changes s]. *) + + val rise : bool signal -> unit event + (** [rise s] is [E.fmap (fun b -> if b then Some () else None) (edge s)].*) + + val fall : bool signal -> unit event + (** [fall s] is [E.fmap (fun b -> if b then None else Some ()) (edge s)].*) + + val flip : bool -> 'a event -> bool signal + (** [flip b e] is a signal whose boolean value flips each time + [e] occurs. [b] is the initial signal value. + {ul + {- \[[flip b e]\]{_0} [= not b] if \[[e]\]{_0} [= Some _]} + {- \[[flip b e]\]{_t} [= b] if \[[e]\]{_<=t} [= None]} + {- \[[flip b e]\]{_t} [=] [not] \[[flip b e]\]{_t-dt} + if \[[e]\]{_t} [= Some _]}} +*) end - + module Int : sig + val zero : int signal + val one : int signal + val minus_one : int signal val ( ~- ) : int signal -> int signal val succ : int signal -> int signal val pred : int signal -> int signal @@ -485,6 +574,9 @@ end module Float : sig + val zero : float signal + val one : float signal + val minus_one : float signal val ( ~-. ) : float signal -> float signal val ( +. ) : float signal -> float signal -> float signal val ( -. ) : float signal -> float signal -> float signal @@ -524,14 +616,43 @@ val epsilon_float : float signal val classify_float : float signal -> fpclass signal end - + module Pair : sig - val pair : ?eq:(('a * 'b) -> ('a * 'b) -> bool)-> + val pair : ?eq:(('a * 'b) -> ('a * 'b) -> bool)-> 'a signal -> 'b signal -> ('a * 'b) signal val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) signal -> 'a signal val snd : ?eq:('a -> 'a -> bool) -> ('b * 'a) signal -> 'a signal end + module Option : sig + val none : 'a option signal + (** [none] is [S.const None]. *) + + val some : 'a signal -> 'a option signal + (** [some s] is [S.map ~eq (fun v -> Some v) None], where [eq] uses + [s]'s equality function to test the [Some v]'s equalities. *) + + val value : ?eq:('a -> 'a -> bool) -> + default:[`Init of 'a signal | `Always of 'a signal ] -> + 'a option signal -> 'a signal + (** [value default s] is [s] with only its [Some v] values. + Whenever [s] is [None], if [default] is [`Always dv] then + the current value of [dv] is used instead. If [default] + is [`Init dv] the current value of [dv] is only used + if there's no value at creation time, otherwise the last + [Some v] value of [s] is used. + {ul + {- \[[value ~default s]\]{_t} [= v] if \[[s]\]{_t} [= Some v]} + {- \[[value ~default:(`Always d) s]\]{_t} [=] \[[d]\]{_t} + if \[[s]\]{_t} [= None]} + {- \[[value ~default:(`Init d) s]\]{_0} [=] \[[d]\]{_0} + if \[[s]\]{_0} [= None]} + {- \[[value ~default:(`Init d) s]\]{_t} [=] + \[[value ~default:(`Init d) s]\]{_t'} + if \[[s]\]{_t} [= None] and t' is the greatest t' < t + with \[[s]\]{_t'} [<> None] or 0 if there is no such [t'].}} *) + end + module Compare : sig val ( = ) : 'a signal -> 'a signal -> bool signal val ( <> ) : 'a signal -> 'a signal -> bool signal @@ -546,60 +667,61 @@ (** {1:special Combinator specialization} - Given an equality function [equal] and a type [t], the functor - {!Make} automatically applies the [eq] parameter of the combinators. - The outcome is combinators whose {e results} are signals with + Given an equality function [equal] and a type [t], the functor + {!Make} automatically applies the [eq] parameter of the combinators. + The outcome is combinators whose {e results} are signals with values in [t]. - Basic types are already specialized in the module {!Special}, open + Basic types are already specialized in the module {!Special}, open this module to use them. *) (** Input signature of {!S.Make} *) module type EqType = sig - type 'a t - val equal : 'a t -> 'a t -> bool + type 'a t + val equal : 'a t -> 'a t -> bool end - (** Output signature of {!S.Make} *) + (** Output signature of {!S.Make} *) module type S = sig - type 'a v - val create : 'a v -> 'a v signal * ('a v -> unit) + type 'a v + val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) val equal : 'a v signal -> 'a v signal -> bool val hold : 'a v -> 'a v event -> 'a v signal val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal val map : ('a -> 'b v) -> 'a signal -> 'b v signal - val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal + val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal - val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal + val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal - val switch : 'a v signal -> 'a v signal event -> 'a v signal + val switch : 'a v signal signal -> 'a v signal + val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) - val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) - val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> - 'c signal -> 'd v signal) - val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) - val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f v signal) - val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g v signal) + val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) + val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> + 'c signal -> 'd v signal) + val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f v signal) + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g v signal) end (** Functor specializing the combinators for the given signal value type *) module Make (Eq : EqType) : S with type 'a v = 'a Eq.t - (** Specialization for booleans, integers and floats. + (** Specialization for booleans, integers and floats. Open this module to use it. *) module Special : sig - + (** Specialization for booleans. *) module Sb : S with type 'a v = bool @@ -611,16 +733,43 @@ end end -(** {1:sem Semantics} +(** Update steps. + + Update functions returned by {!S.create} and {!E.create} + implicitely create and execute update steps when used without + specifying their [step] argument. + + Using explicit {!step} values with these functions gives more control on + the time when the update step is perfomed and allows to perform + simultaneous {{!primitives}primitive} signal updates and event + occurences. See also the documentation about {{!steps}update steps} and + {{!simultaneity}simultaneous events}. *) +module Step : sig + + (** {1 Steps} *) + + type t = step + (** The type for update steps. *) + + val create : unit -> step + (** [create ()] is a new update step. *) - The following notations are used to give precise meaning to the - combinators. It is important to note that in these semantic + val execute : step -> unit + (** [execute step] executes the update step. + + @raise Invalid_argument if [step] was already executed. *) +end + +(** {1:sem Semantics} + + The following notations are used to give precise meaning to the + combinators. It is important to note that in these semantic descriptions the origin of time t = 0 is {e always} fixed at the time at which the combinator creates the event or the signal and the semantics of the dependents is evaluated relative to this timeline. - + We use dt to denote an infinitesimal amount of time. - {2:evsem Events} + {2:evsem Events} An event is a value with discrete occurrences over time. @@ -635,35 +784,36 @@ event before (resp. before or at) [t]. More precisely : {ul {- \[[e]\]{_ None].} {- \[[e]\]{_ time -> 'a] gives meaning to a signal [s] by mapping it to a function of time - \[[s]\] that returns its value at a given time. We write \[[s]\]{_t} + \[[s]\] that returns its value at a given time. We write \[[s]\]{_t} the evaluation of this {e semantic} function at time t. - {3:sigeq Equality} + {3:sigeq Equality} Most signal combinators have an optional [eq] parameter that defaults to structural equality. [eq] specifies the equality function used to detect changes in the value of the resulting signal. This function is needed for the efficient update of signals and to deal correctly with signals that perform - {{:#sideeffects}side effects}. + {{!sideeffects}side effects}. Given an equality function on a type the combinators can be automatically - {{:React.S.html#special}specialized} via a functor. + {{!S.special}specialized} via a functor. + {3:sigcont Continuity} Ultimately signal updates depend on - {{:#primitives}primitive} updates. Thus a signal can + {{!primitives}primitives} updates. Thus a signal can only approximate a real continuous signal. The accuracy of the approximation depends on the variation rate of the real signal and the primitive's update frequency. @@ -688,39 +838,82 @@ Primitive signals are created with {!S.create}. This function returns a new signal and an update function that sets the signal's value at the time it is called. The following code creates an - integer signal [x] initially set to [1] and updates it three time with - values [2], [2], [3]. The signal's values are printed on stdout by the + integer signal [x] initially set to [1] and updates it three time with + values [2], [2], [3]. The signal's values are printed on stdout by the effectful signal [pr_x]. Note that only updates that change the signal's value are printed, hence the program prints [123], not [1223]. - See the discussion on - {{:#sideeffects}side effects} for more details. + See the discussion on + {{!sideeffects}side effects} for more details. + {[open React;; let x, set_x = S.create 1 let pr_x = S.map print_int x let () = List.iter set_x [2; 2; 3]]} - The {{:#clock}clock} example shows how a realtime time + The {{!clock}clock} example shows how a realtime time flow can be defined. - {2:update The update cycle and thread safety} + {2:steps Update steps} + + The {!E.create} and {!S.create} functions return update functions + used to generate primitive event occurences and set the value of + primitive signals. Upon invocation as in the preceding section + these functions immediatly create and invoke an update step. + The {e update step} automatically updates events and signals that + transitively depend on the updated primitive. The dependents of a + signal are updated iff the signal's value changed according to its + {{!sigeq}equality function}. + + The update functions have an optional [step] argument. If they are + given a concrete [step] value created with {!Step.create}, then it + updates the event or signal but doesn't update its dependencies. It + will only do so whenever [step] is executed with + {!Step.execute}. This allows to make primitive event occurences and + signal changes simultaneous. See next section for an example. + + {2:simultaneity Simultaneous events} + + {{!steps}Update steps} are made under a + {{:http://dx.doi.org/10.1016/0167-6423(92)90005-V}synchrony hypothesis} : + the update step takes no time, it is instantenous. Two event occurrences + are {e simultaneous} if they occur in the same update step. + + In the code below [w], [x] and [y] will always have simultaneous + occurrences. They {e may} have simulatenous occurences with [z] + if [send_w] and [send_z] are used with the same update step. + +{[let w, send_w = E.create () +let x = E.map succ w +let y = E.map succ x +let z, send_z = E.create () + +let () = + let () = send_w 3 (* w x y occur simultaneously, z doesn't occur *) in + let step = Step.create () in + send_w ~step 3; + send_z ~step 4; + Step.execute step (* w x z y occur simultaneously *) +]} + + {2:update The update step and thread safety} - {{:#primitives}Primitives} are the only mean to drive the reactive + {{!primitives}Primitives} are the only mean to drive the reactive system and they are entirely under the control of the client. When - the client invokes a primitive's update function, React performs - an update cycle. The update cycle automatically updates events and - signals that transitively depend on the updated primitive. The - dependents of a signal are updated iff the signal's value changed - according to its {{:#sigeq}equality function}. + the client invokes a primitive's update function without the + [step] argument or when it invokes {!Step.execute} on a [step] + value, React performs an update step. - To ensure correctness in the presence of threads, update cycles + To ensure correctness in the presence of threads, update steps must be executed in a critical section. Let uset([p]) be the set of events and signals that need to be updated whenever the primitive [p] is updated. Updating two primitives [p] and [p'] concurrently is only allowed if uset([p]) and uset([p']) are disjoint. Otherwise the updates must be properly serialized. - Below updates to [x] and [y] must be serialized, but z can - be updated concurently to both [x] and [y]. + Below, concurrent, updates to [x] and [y] must be serialized (or + performed on the same step if it makes sense semantically), but z + can be updated concurently to both [x] and [y]. + {[open React;; let x, set_x = S.create 0 @@ -728,35 +921,17 @@ let z, set_z = S.create 0 let max_xy = S.l2 (fun x y -> if x > y then x else y) x (S.hold 0 y) let succ_z = S.map succ z]} - {2:simultaneity Simultaneous events} - - {{:#update}Update cycles} are made under a - {{:http://dx.doi.org/10.1016/0167-6423(92)90005-V}synchrony hypothesis} : - the update cycle takes no time, it is instantenous. - - Two event occurrences are {e simultaneous} if they occur in the - same update cycle; in other words if there exists a primitive on - which they both depend. By definition a primitive doesn't depend - on any primitive it is therefore impossible for two primitive - events to occur simultaneously. - - In the code below [w], [x] and [y] will have simultaneous occurrences while - [z] will never have simultaneous occurrences with them. -{[let w, send_w = E.create () -let x = E.map succ w -let y = E.map succ x -let z, send_z = E.create ()]} {2:sideeffects Side effects} Effectful events and signals perform their side effect - exactly {e once} in each {{:#update}update cycle} in which there + exactly {e once} in each {{!steps}update step} in which there is an update of at least one of the event or signal it depends on. - Remember that a signal updates in a cycle iff its - {{:#sigeq}equality function} determined that the signal - value changed. Signal initialization is unconditionally considered as - an update. + Remember that a signal updates in a step iff its + {{!sigeq}equality function} determined that the signal + value changed. Signal initialization is unconditionally considered as + an update. It is important to keep references on effectful events and signals. Otherwise they may be reclaimed by the garbage collector. @@ -770,7 +945,7 @@ The combinators {!S.const} and {!S.app} allow to lift functions of arbitrary arity n, but this involves the inefficient creation of n-1 intermediary - closure signals. The fixed arity {{:React.S.html#lifting}lifting + closure signals. The fixed arity {{!S.lifting}lifting functions} are more efficient. For example : {[let f x y = x mod y let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y (* inefficient *) @@ -779,17 +954,17 @@ Besides, some of [Pervasives]'s functions and operators are already lifted and availables in submodules of {!S}. They can be be opened in specific scopes. For example if you are dealing with - float signals you can open {!S.Float}. -{[open React -open React.S.Float + float signals you can open {!S.Float}. +{[open React +open React.S.Float let f t = sqrt t *. sin t (* f is defined on float signals *) ... open Pervasives (* back to pervasives floats *) ]} If you are using OCaml 3.12 or later you can also use the [let open] - construct -{[let open React.S.Float in + construct +{[let open React.S.Float in let f t = sqrt t *. sin t in (* f is defined on float signals *) ... ]} @@ -809,40 +984,40 @@ as argument the infinitesimally delayed event or signal that [f] itself returns. - In the example below [history s] returns a signal whose value - is the history of [s] as a list. -{[let history ?(eq = ( = )) s = - let push v = function - | [] -> [ v ] + In the example below [history s] returns a signal whose value + is the history of [s] as a list. +{[let history ?(eq = ( = )) s = + let push v = function + | [] -> [ v ] | v' :: _ as l when eq v v' -> l - | l -> v :: l + | l -> v :: l in - let define h = - let h' = S.l2 push s h in + let define h = + let h' = S.l2 push s h in h', h' in S.fix [] define]} When a program has infinitesimally delayed values a - {{:#primitives}primitive} may trigger more than one update - cycle. For example if a signal [s] is infinitesimally delayed, then - its update in a cycle [c] will trigger a new cycle [c'] at the end - of the cycle in which the delayed signal of [s] will have the value + {{!primitives}primitive} may trigger more than one update + step. For example if a signal [s] is infinitesimally delayed, then + its update in a step [c] will trigger a new step [c'] at the end + of the step in which the delayed signal of [s] will have the value [s] had in [c]. This means that the recursion occuring between a signal (or event) and its infinitesimally delayed counterpart must be well-founded otherwise this may trigger an infinite number - of update cycles, like in the following examples. + of update steps, like in the following examples. {[let start, send_start = E.create () -let diverge = - let define e = - let e' = E.select [e; start] in +let diverge = + let define e = + let e' = E.select [e; start] in e', e' in E.fix define - + let () = send_start () (* diverges *) - + let diverge = (* diverges *) - let define s = + let define s = let s' = S.Int.succ s in s', s' in @@ -851,9 +1026,49 @@ fixing functions) are not allowed to directly depend on each other. Fixed point combinators will raise [Invalid_argument] if such dependencies are created. This limitation can be - circumvented by mapping these values with the identity. + circumvented by mapping these values with the identity. - {1:ex Examples} + {2:strongstop Strong stops} + + Strong stops should only be used on platforms where weak arrays have + a strong semantics (i.e. JavaScript). You can safely ignore that + section and the [strong] argument of {!E.stop} and {!S.stop} + if that's not the case. + + Whenever {!E.stop} and {!S.stop} is called with [~strong:true] on a + reactive value [v], it is first stopped and then it walks over the + list [prods] of events and signals that it depends on and + unregisters itself from these ones as a dependent (something that is + normally automatically done when [v] is garbage collected since + dependents are stored in a weak array). Then for each element of + [prod] that has no dependents anymore and is not a primitive it + stops them aswell and recursively. + + A stop call with [~strong:true] is more involved. But it allows to + prevent memory leaks when used judiciously on the leaves of the + reactive system that are no longer used. + + {b Warning.} It should be noted that if direct references are kept + on an intermediate event or signal of the reactive system it may + suddenly stop updating if all its dependents were strongly stopped. In + the example below, [e1] will {e never} occur: +{[let e, e_send = E.create () +let e1 = E.map (fun x -> x + 1) e (* never occurs *) +let () = + let e2 = E.map (fun x -> x + 1) e1 in + E.stop ~strong:true e2 +]} + This can be side stepped by making an artificial dependency to keep + the reference: +{[let e, e_send = E.create () +let e1 = E.map (fun x -> x + 1) e (* may still occur *) +let e1_ref = E.map (fun x -> x) e1 +let () = + let e2 = E.map (fun x -> x + 1) e1 in + E.stop ~strong:true e2 +]} + + {1:ex Examples} {2:clock Clock} @@ -863,16 +1078,16 @@ along with an {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm}ANSI escape sequence} to control the cursor position. -{[let pr_time t = +{[let pr_time t = let tm = Unix.localtime t in - Printf.printf "\x1B[8D%02d:%02d:%02d%!" + Printf.printf "\x1B[8D%02d:%02d:%02d%!" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec open React;; -let seconds, run = +let seconds, run = let e, send = E.create () in - let run () = + let run () = while true do send (Unix.gettimeofday ()); Unix.sleep 1 done in e, run @@ -883,13 +1098,13 @@ *) (*--------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli + Copyright (c) 2009 Daniel C. Bünzli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff -Nru react-0.9.4/src/react.mllib react-1.2.0/src/react.mllib --- react-0.9.4/src/react.mllib 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/src/react.mllib 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 50ce2da63bea6a618e7578fa50690040) -React -# OASIS_STOP diff -Nru react-0.9.4/src/react_top.ml react-1.2.0/src/react_top.ml --- react-0.9.4/src/react_top.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/src/react_top.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,48 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + react release 1.2.0 + ---------------------------------------------------------------------------*) + +let exec s = + let l = Lexing.from_string s in + let ph = !Toploop.parse_toplevel_phrase l in + assert(Toploop.execute_phrase false Format.err_formatter ph) + +let setup () = + exec "open React;;" + +let () = setup () + +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) diff -Nru react-0.9.4/_tags react-1.2.0/_tags --- react-0.9.4/_tags 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/_tags 2014-08-23 23:03:34.000000000 +0000 @@ -1,28 +1,11 @@ -# OASIS_START -# DO NOT EDIT (digest: 3c0d04860d57a46187f9c6a24d463425) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library react -"src/react.cmxs": use_react -# Executable clock -: use_react -: pkg_unix -# Executable breakout -: use_react -: pkg_unix -: pkg_unix -# Executable test -: use_react -: use_react -# OASIS_STOP +<**/*.{ml,mli}> : bin_annot, annot + + : include + : package(compiler-libs.toplevel) + + : include + : use_unix + : use_unix + : package(js_of_ocaml), \ + package(js_of_ocaml.syntax), \ + syntax(camlp4o) \ No newline at end of file diff -Nru react-0.9.4/test/breakout.ml react-1.2.0/test/breakout.ml --- react-0.9.4/test/breakout.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/test/breakout.ml 2014-08-23 23:03:34.000000000 +0000 @@ -1,5 +1,5 @@ (*--------------------------------------------------------------------------- - Copyright (c) (c) 2009-2012 Daniel C. Bünzli. All rights reserved. + Copyright (c) (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. ---------------------------------------------------------------------------*) @@ -13,15 +13,15 @@ val e : (Format.formatter -> 'a -> unit) -> string -> 'a event -> 'a event val s : (Format.formatter -> 'a -> unit) -> string -> 'a signal -> 'a signal end = struct - let init () = - let t = Unix.gettimeofday () in - let tm = Unix.localtime t in + let init () = + let t = Unix.gettimeofday () in + let tm = Unix.localtime t in Format.eprintf "\x1B[2J\x1B[H\x1B[7m@[>> %04d-%02d-%02d %02d:%02d:%02d <<@]\x1B[0m@." (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - let value pp name v = Format.eprintf "@[%s =@ %a@]@." name pp v + let value pp name v = Format.eprintf "@[%s =@ %a@]@." name pp v let e pp name e = E.trace (value pp name) e let s pp name s = S.trace (value pp name) s end @@ -31,24 +31,24 @@ val v : float -> float -> t val o : t val ex : t - val ey : t + val ey : t val x : t -> float - val y : t -> float + val y : t -> float val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val smul : float -> t -> t - val dot : t -> t -> float + val dot : t -> t -> float val to_ints : t -> int * int val print : Format.formatter -> t -> unit end = struct type t = { x : float; y : float } let v x y = { x = x; y = y } - let o = v 0. 0. - let ex = v 1. 0. + let o = v 0. 0. + let ex = v 1. 0. let ey = v 0. 1. - let x p = p.x - let y p = p.y + let x p = p.x + let y p = p.y let add p p' = v (p.x +. p'.x) (p.y +. p'.y) let sub p p' = v (p.x -. p'.x) (p.y -. p'.y) let neg p = v (-. p.x) (-. p.y) @@ -67,15 +67,15 @@ val xmin : t -> float val xmax : t -> float val ymin : t -> float - val ymax : t -> float + val ymax : t -> float val print : Format.formatter -> t -> unit -end = struct +end = struct type t = V2.t * V2.t - let create o size = o, size - let empty = V2.o, V2.o + let create o size = o, size + let empty = V2.o, V2.o let o (o, s) = o let size (_, s) = s - let xmin (o, _) = V2.x o + let xmin (o, _) = V2.x o let xmax (o, s) = V2.x o +. V2.x s let ymin (o, _) = V2.y o let ymax (o, s) = V2.y o +. V2.y s @@ -90,13 +90,13 @@ val text : ?center:bool -> ?color:int -> V2.t -> string -> unit val rect : ?color:int -> Rect.t -> unit val beep : unit -> unit -end = struct +end = struct let pr = Printf.printf let frame = Rect.create (V2.v 1. 1.) (V2.v 80. 24.) let clear () = pr "\x1B[47m\x1B[2J" let flush () = pr "%!" let reset () = clear (); pr "\x1Bc"; flush () - let init () = + let init () = pr "\x1B[H\x1B[7l\x1B[?25l"; clear (); flush (); at_exit (reset) @@ -104,7 +104,7 @@ let x, y = V2.to_ints pos in let x = if center then x - (String.length str) / 2 else x in pr ("\x1B[%d;%df\x1B[47;%dm%s") y x color str - + let rect ?(color = 40) r = let (x, y) = V2.to_ints (Rect.o r) in let (w, h) = V2.to_ints (Rect.size r) in @@ -133,14 +133,14 @@ Sys.set_signal Sys.sigint (Sys.Signal_handle quit); Sys.set_signal Sys.sigfpe (Sys.Signal_handle quit) - let time, send_time = E.create () - let key, send_key = E.create () + let time, send_time = E.create () + let key, send_key = E.create () let gather () = (* updates primitive events. *) let c = " " in - let i = Unix.stdin in + let i = Unix.stdin in let input_char i = ignore (Unix.read i c 0 1); c.[0] in let dt = 0.1 in - while true do + while true do if Unix.select [i] [] [] dt = ([i], [], []) then send_key (input_char i); send_time (Unix.gettimeofday ()); done @@ -157,48 +157,49 @@ val collisions : t -> unit event val outcome : t -> [> `Game_over of int ] event end = struct - type t = { walls : Rect.t; - ball : Rect.t signal; - paddle : Rect.t signal; - bricks : Rect.t list signal; - brick_count : int signal; - collisions : unit event } + type t = + { walls : Rect.t; + ball : Rect.t signal; + paddle : Rect.t signal; + bricks : Rect.t list signal; + brick_count : int signal; + collisions : unit event } (* Collisions *) - let ctime c r d n = Some (n, (r -. c) /. d) + let ctime c r d n = Some (n, (r -. c) /. d) let cmin c r d n = if r <= c && d < 0. then ctime c r d n else None let cmax c r d n = if r >= c && d > 0. then ctime c r d n else None - let cinter cmin cmax rmin rmax d n = match d with + let cinter cmin cmax rmin rmax d n = match d with | d when d < 0. -> if rmax -. d < cmin then None else (* moving apart. *) - if rmin -. d >= cmax then - if rmin <= cmax then ctime cmax rmin d n else None + if rmin -. d >= cmax then + if rmin <= cmax then ctime cmax rmin d n else None else Some (V2.o, 0.) (* initially overlapping. *) | d when d > 0. -> if rmin -. d > cmax then None else (* moving apart. *) - if rmax -. d <= cmin then - if rmax >= cmin then ctime cmin rmax d (V2.neg n) else None + if rmax -. d <= cmin then + if rmax >= cmin then ctime cmin rmax d (V2.neg n) else None else Some (V2.o, 0.) (* initially overlapping. *) | _ (* d = 0. *) -> - if cmax < rmin || rmax < cmin then None else Some (V2.o, 0.) + if cmax < rmin || rmax < cmin then None else Some (V2.o, 0.) let crect c r d = (* r last moved by d relatively to c. *) - let inter min max c r d n = cinter (min c) (max c) (min r) (max r) d n in + let inter min max c r d n = cinter (min c) (max c) (min r) (max r) d n in match inter Rect.xmin Rect.xmax c r (V2.x d) V2.ex with - | None -> None - | Some (_, t as x) -> - match inter Rect.ymin Rect.ymax c r (V2.y d) V2.ey with - | None -> None - | Some (_, t' as y) -> - let _, t as c = if t > t' then x else y in - if t = 0. then None else Some c + | None -> None + | Some (_, t as x) -> + match inter Rect.ymin Rect.ymax c r (V2.y d) V2.ey with + | None -> None + | Some (_, t' as y) -> + let _, t as c = if t > t' then x else y in + if t = 0. then None else Some c (* Game objects *) - + let moving_rect pos size = S.map (fun pos -> Rect.create pos size) pos - let ball walls dt collisions = + let ball walls dt collisions = let size = V2.v 2. 1. in let x0 = 0.5 *. (Rect.xmax walls -. V2.x size) in let p0 = V2.v x0 (0.5 *. Rect.ymax walls) in @@ -208,55 +209,55 @@ let speed = 18. +. Random.float 2. in V2.v (speed *. sin angle) (speed *. cos angle) in - let v = + let v = let bounce (n, _) v = V2.sub v (V2.smul (2. *. V2.dot n v) n) in - S.accum (E.map bounce collisions) v0 + S.accum (E.map bounce collisions) v0 in let dp = S.sample (fun dt v -> V2.smul dt v) dt v in - let p = + let p = let pos p0 = S.fold V2.add p0 dp in let adjust (_, pc) = pos pc in (* visually sufficient. *) - S.switch (pos p0) (E.map adjust collisions) + S.switch (S.hold ~eq:( == ) (pos p0) (E.map adjust collisions)) in moving_rect p size, dp - - let walls walls (ball, dp) = - let left = Rect.xmin walls in + + let walls walls (ball, dp) = + let left = Rect.xmin walls in let right = Rect.xmax walls in let top = Rect.ymin walls in - let collisions = + let collisions = let collide dp ball = - let c = match cmin left (Rect.xmin ball) (V2.x dp) V2.ex with - | Some _ as c -> c - | None -> - match cmax right (Rect.xmax ball) (V2.x dp) (V2.neg V2.ex) with - | Some _ as c -> c - | None -> cmin top (Rect.ymin ball) (V2.y dp) V2.ey - in - match c with - | None -> None - | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) + let c = match cmin left (Rect.xmin ball) (V2.x dp) V2.ex with + | Some _ as c -> c + | None -> + match cmax right (Rect.xmax ball) (V2.x dp) (V2.neg V2.ex) with + | Some _ as c -> c + | None -> cmin top (Rect.ymin ball) (V2.y dp) V2.ey + in + match c with + | None -> None + | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) in - E.fmap (fun x -> x) (S.sample collide dp ball) + E.fmap (fun x -> x) (S.sample collide dp ball) in walls, collisions let paddle walls moves (ball, dp) = - let speed = 4. in + let speed = 4. in let size = V2.v 9. 1. in - let xmin = Rect.xmin walls in - let xmax = Rect.xmax walls -. (V2.x size) in + let xmin = Rect.xmin walls in + let xmax = Rect.xmax walls -. (V2.x size) in let p0 = V2.v (0.5 *. xmax) (Rect.ymax walls -. 2.) in - let control p = function - | `Left -> - let x' = V2.x p -. speed in - if x' < xmin then V2.v xmin (V2.y p) else V2.v x' (V2.y p) - | `Right -> - let x' = V2.x p +. speed in - if x' > xmax then V2.v xmax (V2.y p) else V2.v x' (V2.y p) + let control p = function + | `Left -> + let x' = V2.x p -. speed in + if x' < xmin then V2.v xmin (V2.y p) else V2.v x' (V2.y p) + | `Right -> + let x' = V2.x p +. speed in + if x' > xmax then V2.v xmax (V2.y p) else V2.v x' (V2.y p) in - let paddle = moving_rect (S.fold control p0 moves) size in - let collisions = + let paddle = moving_rect (S.fold control p0 moves) size in + let collisions = let collide dp (ball, paddle) = match crect paddle ball dp with | None -> None | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) @@ -264,39 +265,39 @@ E.fmap (fun x -> x) (S.sample collide dp (S.Pair.pair ball paddle)) in paddle, collisions - + let bricks walls (ball, dp) = - let bricks0 = + let bricks0 = let size = Rect.size walls in - let w = V2.x size in + let w = V2.x size in let h = (V2.y size) /. 4. in (* use 1/4 for bricks. *) let bw, bh = (w /. 8.), h /. 3. in let x_count = truncate (w /. bw) in let y_count = truncate (h /. bh) in let acc = ref [] in - for x = 0 to x_count - 1 do - for y = 0 to y_count - 1 do + for x = 0 to x_count - 1 do + for y = 0 to y_count - 1 do let x = Rect.xmin walls +. (float x) *. bw in let y = Rect.ymin walls +. 2. *. bh +. (float y) *. bh in acc := Rect.create (V2.v x y) (V2.v bw bh) :: !acc - done + done done; !acc in let define bricks = - let cresult = - let collide dp (ball, bricks) = - let rec aux c acc bricks ball dp = match bricks with - | [] -> c, List.rev acc - | b :: bricks' -> match crect b ball dp with - | None -> aux c (b :: acc) bricks' ball dp - | c -> aux c acc bricks' ball dp - in - match aux None [] bricks ball dp with - | None, bl -> None, bl - | Some (n, t), bl -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)),bl - in - S.sample collide dp (S.Pair.pair ball bricks) + let cresult = + let collide dp (ball, bricks) = + let rec aux c acc bricks ball dp = match bricks with + | [] -> c, List.rev acc + | b :: bricks' -> match crect b ball dp with + | None -> aux c (b :: acc) bricks' ball dp + | c -> aux c acc bricks' ball dp + in + match aux None [] bricks ball dp with + | None, bl -> None, bl + | Some (n, t), bl -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)),bl + in + S.sample collide dp (S.Pair.pair ball bricks) in let collisions = E.fmap (fun (c, _) -> c) cresult in let bricks_e = E.map (fun (_, bl) -> fun _ -> bl) cresult in @@ -304,59 +305,59 @@ bricks', (bricks', collisions) in S.fix bricks0 define - - (* Game data structure, links game objects *) - - let create w dt moves = - let define collisions = + + (* Game data structure, links game objects *) + + let create w dt moves = + let define collisions = let ball = ball w dt collisions in - let walls, wcollisions = walls w ball in - let paddle, pcollisions = paddle w moves ball in + let walls, wcollisions = walls w ball in + let paddle, pcollisions = paddle w moves ball in let bricks, bcollisions = bricks w ball in let collisions' = E.select [pcollisions; wcollisions; bcollisions] in - let g = - { walls = walls; - ball = S.dismiss collisions' Rect.empty (fst ball); - paddle = paddle; - bricks = bricks; - brick_count = S.map List.length bricks; - collisions = E.stamp collisions' () } + let g = + { walls = walls; + ball = S.dismiss collisions' Rect.empty (fst ball); + paddle = paddle; + bricks = bricks; + brick_count = S.map List.length bricks; + collisions = E.stamp collisions' () } in collisions', g in E.fix define - - let walls g = g.walls + + let walls g = g.walls let ball g = g.ball let paddle g = g.paddle let bricks g = g.bricks let brick_count g = g.brick_count let collisions g = g.collisions let outcome g = (* game outcome logic. *) - let no_bricks = S.map (fun l -> l = 0) g.brick_count in + let no_bricks = S.map (fun l -> l = 0) g.brick_count in let miss = S.map (fun b -> Rect.ymax b >= Rect.ymax g.walls) g.ball in let game_over = S.changes (S.Bool.( || ) no_bricks miss) in S.sample (fun _ l -> `Game_over l) game_over g.brick_count end -module Render = struct - let str = Printf.sprintf +module Render = struct + let str = Printf.sprintf let str_bricks count = if count = 1 then "1 brick" else str "%d bricks" count let intro title_color = (* draws the splash screen. *) let x = 0.5 *. Rect.xmax Draw.frame in - let y = 0.5 *. Rect.ymax Draw.frame in + let y = 0.5 *. Rect.ymax Draw.frame in Draw.clear (); Draw.text ~color:title_color (V2.v x (y -. 2.)) "BREAKOUT"; - Draw.text ~color:30 (V2.v x y) + Draw.text ~color:30 (V2.v x y) "Hit 'a' and 'd' to move the paddle, 'q' to quit"; Draw.text ~color:31 (V2.v x (y +. 2.)) "Hit spacebar to start the game"; Draw.flush () let game_init m = (* draws game init message. *) - let x = 0.5 *. Rect.xmax Draw.frame in - let y = 0.5 *. Rect.ymax Draw.frame in - Draw.text ~color:31 (V2.v x (y +. 2.)) m; + let x = 0.5 *. Rect.xmax Draw.frame in + let y = 0.5 *. Rect.ymax Draw.frame in + Draw.text ~color:31 (V2.v x (y +. 2.)) m; Draw.flush () let game ball paddle bricks bcount = (* draws the game state. *) @@ -369,9 +370,9 @@ Draw.flush () let game_over outcome = (* draws the game over screen. *) - let x = 0.5 *. Rect.xmax Draw.frame in + let x = 0.5 *. Rect.xmax Draw.frame in let y = 0.5 *. Rect.ymax Draw.frame in - let outcome_msg = + let outcome_msg = if outcome = 0 then "Congratulations, no bricks left" else str "%s left, you can do better" (str_bricks outcome) in @@ -391,7 +392,7 @@ let wait_until ?stop e = match stop with | Some s -> E.map (fun v -> s (); v) (E.once e) | None -> E.once e - + let intro () = let color_swap = E.stamp Input.time (fun c -> if c = 31 then 34 else 31) in let output = S.l1 Render.intro (S.accum color_swap 34) in @@ -402,58 +403,58 @@ let run = S.hold false (E.once (E.stamp (key ' ') true)) in let moves = let move = function 'a' -> Some `Left | 'd' -> Some `Right | _ -> None in - E.when_ run (E.fmap move Input.key) + E.on run (E.fmap move Input.key) in - let dt = E.when_ run (E.diff ( -. ) Input.time) in + let dt = E.on run (E.diff ( -. ) Input.time) in let g = Game.create Draw.frame dt moves in - let outcome = Game.outcome g in + let outcome = Game.outcome g in let sound = E.map Draw.beep (Game.collisions g) in let output = S.l4 Render.game (Game.ball g) (Game.paddle g) (Game.bricks g) - (Game.brick_count g) + (Game.brick_count g) in let stop () = E.stop sound; S.stop output in Render.game_init "Hit spacebar to start the game"; wait_until (E.select [quit (); outcome]) ~stop - let game_over outcome = - Render.game_over outcome; + let game_over outcome = + Render.game_over outcome; wait_until (E.select [quit (); new_game ()]) - let init () = - let define ui = - let display ui = - Gc.full_major (); (* cleanup game objects. *) - match ui with - | `Intro -> intro () - | `Game -> game () - | `Game_over outcome -> game_over outcome - | `Quit -> exit 0 + let init () = + let define ui = + let display ui = + Gc.full_major (); (* cleanup game objects. *) + match ui with + | `Intro -> intro () + | `Game -> game () + | `Game_over outcome -> game_over outcome + | `Quit -> exit 0 in let ui' = E.switch (display `Intro) (E.map display ui) in ui', ui' in - E.stamp (E.fix define) () + E.stamp (E.fix define) () end -let main () = +let main () = Random.self_init (); Log.init (); Draw.init (); Input.init (); - let ui = Ui.init () in + let ui = Ui.init () in Input.gather (); ui let ui = main () (* keep a ref. to avoid g.c. *) (*---------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli + Copyright (c) 2009 Daniel C. Bünzli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff -Nru react-0.9.4/test/clock.ml react-1.2.0/test/clock.ml --- react-0.9.4/test/clock.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/test/clock.ml 2014-08-23 23:03:34.000000000 +0000 @@ -1,14 +1,14 @@ -(* This code is in the public domain. +(* This code is in the public domain. Prints a clock with the current local time in the terminal. *) - -let pr_time t = + +let pr_time t = let tm = Unix.localtime t in - Printf.printf "\x1B[8D%02d:%02d:%02d%!" + Printf.printf "\x1B[8D%02d:%02d:%02d%!" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec open React;; -let seconds, run = +let seconds, run = let e, send = E.create () in let run () = while true do send (Unix.gettimeofday ()); Unix.sleep 1 done in e, run diff -Nru react-0.9.4/test/js_test.html react-1.2.0/test/js_test.html --- react-0.9.4/test/js_test.html 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/test/js_test.html 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,22 @@ + + + + + + + + + React strong stops + + + +

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

    +

    Steps: 0

    + + diff -Nru react-0.9.4/test/js_test.ml react-1.2.0/test/js_test.ml --- react-0.9.4/test/js_test.ml 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/test/js_test.ml 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,49 @@ +(* Test for ~strong stop *) + +open React + +let strong = true + +(* Artificially increase memory usage *) +let high_e e = + let id e = E.map (fun v -> v) e in + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ + e + +let counter_ui = + let none () = assert false in + let el = Dom_html.window ## document ## getElementById (Js.string "count") in + Js.Opt.get el none + +let count = ref 0 +let incr_counter () = + incr count; + counter_ui ## innerHTML <- Js.string (string_of_int !count) + +let tick, send_tick = E.create () + +let rec loop () = + let ev = E.map (fun () -> incr_counter ()) (high_e tick) in + send_tick (); + E.stop ~strong ev; + ignore (Dom_html.window ## setTimeout (Js.wrap_callback loop, 1.)) + + +let main _ = loop (); Js._false + +let () = Dom_html.window ## onload <- Dom_html.handler main diff -Nru react-0.9.4/test/test.ml react-1.2.0/test/test.ml --- react-0.9.4/test/test.ml 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/test/test.ml 2014-08-23 23:03:34.000000000 +0000 @@ -1,28 +1,28 @@ (*--------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli. All rights reserved. + Copyright (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. ---------------------------------------------------------------------------*) (* Tests for react's combinators. - Compile with -g to get a precise backtrace to the error. + Compile with -g to get a precise backtrace to the error. Note that the testing mechanism itself (cf. occs and vals) needs a correct implementation; particulary w.r.t. updates with side effects. *) open React;; -let pp_list ppv pp l = - Format.fprintf pp "@[["; +let pp_list ppv pp l = + Format.fprintf pp "@[["; List.iter (fun v -> Format.fprintf pp "%a;@ " ppv v) l; Format.fprintf pp "]@]" -let pr_value pp name v = Format.printf "@[%s =@ %a@]@." name pp v +let pr_value pp name v = Format.printf "@[%s =@ %a@]@." name pp v let e_pr ?iff pp name e = E.trace ?iff (pr_value pp name) e let s_pr ?iff pp name s = S.trace ?iff (pr_value pp name) s - + (* Tests the event e has occurences occs. *) -let occs ?(eq = ( = )) e occs = - let occs = ref occs in +let occs ?(eq = ( = )) e occs = + let occs = ref occs in let assert_occ o = match !occs with | o' :: occs' when eq o' o -> occs := occs' | _ -> assert false @@ -30,10 +30,10 @@ E.map assert_occ e, occs (* Tests the signal s goes through vals. *) -let vals ?(eq = ( = )) s vals = - let vals = ref vals in +let vals ?(eq = ( = )) s vals = + let vals = ref vals in let assert_val v = match !vals with - | v' :: vals' when eq v' v -> vals := vals' + | v' :: vals' when eq v' v -> vals := vals' | _ -> assert false in S.map assert_val s, vals @@ -46,42 +46,42 @@ let assert_s_stub v = ref (vals (S.const v) [v]) (* To keep references for the g.c. (warning also stops the given nodes) *) -let keep_eref e = E.stop e -let keep_sref s = S.stop s +let keep_eref e = E.stop e +let keep_sref s = S.stop s (* To artificially raise the rank of events and signals *) -let high_e e = +let high_e e = let id e = E.map (fun v -> v) e in (id (id (id (id (id (id (id (id e)))))))) -let high_s s = +let high_s s = let id s = S.map (fun v -> v) s in (id (id (id (id (id (id (id (id s)))))))) (* Event tests *) -let test_no_leak () = - let x, send_x = E.create () in +let test_no_leak () = + let x, send_x = E.create () in let count = ref 0 in - let w = - let w = Weak.create 1 in - let e = E.map (fun x -> incr count) x in + let w = + let w = Weak.create 1 in + let e = E.map (fun x -> incr count) x in Weak.set w 0 (Some e); w in List.iter send_x [0; 1; 2]; - Gc.full_major (); + Gc.full_major (); List.iter send_x [3; 4; 5]; (match Weak.get w 0 with None -> () | Some _ -> assert false); if !count > 3 then assert false else () -let test_once_drop_once () = - let w, send_w = E.create () in - let x = E.once w in - let y = E.drop_once w in - let assert_x = occs x [0] in +let test_once_drop_once () = + let w, send_w = E.create () in + let x = E.once w in + let y = E.drop_once w in + let assert_x = occs x [0] in let assert_y = occs y [1; 2; 3] in let assert_dx = assert_e_stub () in let assert_dy = assert_e_stub () in - let dyn () = + let dyn () = let dx = E.once w in let dy = E.drop_once w in assert_dx := occs dx [1]; @@ -93,42 +93,42 @@ List.iter empty [assert_x; assert_y; !assert_dx; !assert_dy]; keep_eref create_dyn -let test_app () = - let f x y = x + y in +let test_app () = + let f x y = x + y in let w, send_w = E.create () in let x = E.map (fun w -> f w) w in let y = E.drop_once w in - let z = E.app x y in + let z = E.app x y in let assert_z = occs z [ 2; 4; 6 ] in let assert_dz = assert_e_stub () in - let dyn () = - let dx = E.drop_once (E.map (fun w -> f w) w) in - let dz = E.app dx y in + let dyn () = + let dx = E.drop_once (E.map (fun w -> f w) w) in + let dz = E.app dx y in assert_dz := occs dz [ 4; 6 ]; in - let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in + let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in Gc.full_major (); List.iter send_w [0; 1; 2; 3]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_map_stamp_filter_fmap () = - let v, send_v = E.create () in +let test_map_stamp_filter_fmap () = + let v, send_v = E.create () in let w = E.map (fun s -> "z:" ^ s) v in - let x = E.stamp v "bla" in + let x = E.stamp v "bla" in let y = E.filter (fun s -> String.length s = 5) v in let z = E.fmap (fun s -> if s = "blu" then Some "hip" else None) v in let assert_w = occs w ["z:didap"; "z:dip"; "z:didop"; "z:blu"] in let assert_x = occs x ["bla"; "bla"; "bla"; "bla"] in let assert_y = occs y ["didap"; "didop"] in - let assert_z = occs z ["hip"] in + let assert_z = occs z ["hip"] in let assert_dw = assert_e_stub () in let assert_dx = assert_e_stub () in let assert_dy = assert_e_stub () in let assert_dz = assert_e_stub () in - let dyn () = + let dyn () = let dw = E.map (fun s -> String.length s) v in - let dx = E.stamp v 4 in + let dx = E.stamp v 4 in let dy = E.filter (fun s -> String.length s = 5) v in let dz = E.fmap (fun s -> if s = "didap" then Some "ha" else None) v in let _ = E.map (fun _ -> assert false) (E.fmap (fun _ -> None) x) in @@ -137,7 +137,7 @@ assert_dy := occs dy ["didap"; "didop"]; assert_dz := occs dz ["ha"]; in - let create_dyn = E.map (fun v -> if v = "didap" then dyn ()) v in + let create_dyn = E.map (fun v -> if v = "didap" then dyn ()) v in Gc.full_major (); List.iter send_v ["didap"; "dip"; "didop"; "blu"]; List.iter empty [assert_w; assert_x; assert_y; assert_z]; @@ -145,17 +145,17 @@ List.iter empty [!assert_dy; !assert_dz]; keep_eref create_dyn -let test_diff_changes () = - let x, send_x = E.create () in - let y = E.diff ( - ) x in - let z = E.changes x in - let assert_y = occs y [ 0; 1; 1; 0] in +let test_diff_changes () = + let x, send_x = E.create () in + let y = E.diff ( - ) x in + let z = E.changes x in + let assert_y = occs y [ 0; 1; 1; 0] in let assert_z = occs z [ 1; 2; 3] in let assert_dy = assert_e_stub () in let assert_dz = assert_e_stub () in - let dyn () = - let dy = E.diff ( - ) x in - let dz = E.changes z in + let dyn () = + let dy = E.diff ( - ) x in + let dz = E.changes z in assert_dy := occs dy [1; 0]; assert_dz := occs dz [2; 3]; in @@ -165,34 +165,34 @@ List.iter empty [assert_y; assert_z; !assert_dy; !assert_dz]; keep_eref create_dyn -let test_dismiss () = - let x, send_x = E.create () in - let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in - let z = E.dismiss y x in +let test_dismiss () = + let x, send_x = E.create () in + let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in + let z = E.dismiss y x in let assert_z = occs z [1; 3; 5] in - let assert_dz = assert_e_stub () in - let dyn () = - let dz = E.dismiss y x in + let assert_dz = assert_e_stub () in + let dyn () = + let dz = E.dismiss y x in assert_dz := occs dz [3; 5]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3; 4; 5]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_when () = - let e, send_e = E.create () in - let s = S.hold 0 e in +let test_on () = + let e, send_e = E.create () in + let s = S.hold 0 e in let c = S.map (fun x -> x mod 2 = 0) s in - let w = E.when_ c e in + let w = E.on c e in let ovals = [2; 4; 4; 6; 4] in let assert_w = occs w ovals in let assert_dw = assert_e_stub () in let assert_dhw = assert_e_stub () in - let dyn () = - let dw = E.when_ c e in - let dhw = E.when_ (high_s c) (high_e e) in + let dyn () = + let dw = E.on c e in + let dhw = E.on (high_s c) (high_e e) in assert_dw := occs dw ovals; assert_dhw := occs dhw ovals in @@ -202,31 +202,31 @@ List.iter empty [assert_w; !assert_dw; !assert_dhw ]; keep_eref create_dyn -let test_until () = - let x, send_x = E.create () in - let stop = E.filter (fun v -> v = 3) x in +let test_until () = + let x, send_x = E.create () in + let stop = E.filter (fun v -> v = 3) x in let e = E.until stop x in let assert_e = occs e [1; 2] in let assert_de = assert_e_stub () in let assert_de' = assert_e_stub () in - let dyn () = + let dyn () = let de = E.until stop x in let de' = E.until (E.filter (fun v -> v = 5) x) x in assert_de := occs de []; assert_de' := occs de' [3; 4] in let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); List.iter send_x [1; 2; 3; 4; 5]; List.iter empty [assert_e; !assert_de; !assert_de']; keep_eref create_dyn -let test_accum () = - let f, send_f = E.create () in - let a = E.accum f 0 in +let test_accum () = + let f, send_f = E.create () in + let a = E.accum f 0 in let assert_a = occs a [2; -1; -2] in - let assert_da = assert_e_stub () in - let dyn () = + let assert_da = assert_e_stub () in + let dyn () = let da = E.accum f 0 in assert_da := occs da [1; 2]; in @@ -234,70 +234,70 @@ let count = ref 0 in E.map (fun _ -> incr count; if !count = 2 then dyn ()) f in - Gc.full_major (); + Gc.full_major (); List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; List.iter empty [assert_a; !assert_da]; keep_eref create_dyn - + let test_fold () = - let x, send_x = E.create () in - let c = E.fold ( + ) 0 x in + let x, send_x = E.create () in + let c = E.fold ( + ) 0 x in let assert_c = occs c [1; 3; 6; 10] in - let assert_dc = assert_e_stub () in - let dyn () = + let assert_dc = assert_e_stub () in + let dyn () = let dc = E.fold ( + ) 0 x in - assert_dc := occs dc [2; 5; 9]; + assert_dc := occs dc [2; 5; 9]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in - Gc.full_major (); + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + Gc.full_major (); List.iter send_x [1; 2; 3; 4]; List.iter empty [assert_c; !assert_dc]; keep_eref create_dyn -let test_select () = - let w, send_w = E.create () in - let x, send_x = E.create () in +let test_select () = + let w, send_w = E.create () in + let x, send_x = E.create () in let y = E.map succ w in let z = E.map succ y in - let tw = E.map (fun v -> `Int v) w in - let tx = E.map (fun v -> `Bool v) x in + let tw = E.map (fun v -> `Int v) w in + let tx = E.map (fun v -> `Bool v) x in let t = E.select [tw; tx] in let sy = E.select [y; z] in (* always y. *) let sz = E.select [z; y] in (* always z. *) - let assert_t = occs t [ `Int 0; `Bool false; `Int 1; `Int 2; `Int 3 ] in + let assert_t = occs t [ `Int 0; `Bool false; `Int 1; `Int 2; `Int 3 ] in let assert_sy = occs sy [1; 2; 3; 4] in let assert_sz = occs sz [2; 3; 4; 5] in let assert_d = assert_e_stub () in - let dyn () = - let d = E.select [y; w; z] in + let dyn () = + let d = E.select [y; w; z] in assert_d := occs d [3; 4] in let create_dyn = E.map (fun v -> if v = 2 then dyn ()) w in - Gc.full_major (); + Gc.full_major (); send_w 0; send_x false; List.iter send_w [1; 2; 3;]; empty assert_t; List.iter empty [assert_sy; assert_sz; !assert_d]; keep_eref create_dyn - -let test_merge () = + +let test_merge () = let w, send_w = E.create () in - let x, send_x = E.create () in + let x, send_x = E.create () in let y = E.map succ w in let z = E.merge (fun acc v -> v :: acc) [] [w; x; y] in let assert_z = occs z [[2; 1]; [4]; [3; 2]] in let assert_dz = assert_e_stub () in - let dyn () = + let dyn () = let dz = E.merge (fun acc v -> v :: acc) [] [y; x; w] in - assert_dz := occs dz [[4]; [2; 3]] + assert_dz := occs dz [[4]; [2; 3]] in let create_dyn = E.map (fun v -> if v = 4 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); send_w 1; send_x 4; send_w 2; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_switch () = +let test_switch () = let x, send_x = E.create () in - let switch e = + let switch e = E.fmap (fun v -> if v mod 3 = 0 then Some (E.map (( * ) v) e) else None) x in let s = E.switch x (switch x) in @@ -306,23 +306,23 @@ let assert_hs = occs hs [1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_ds = assert_e_stub () in let assert_dhs = assert_e_stub () in - let dyn () = + let dyn () = let ds = E.switch x (switch x) in let dhs = E.switch x (switch (high_e x)) in assert_ds := occs ds [9; 12; 15; 36; 42; 48; 81]; assert_ds := occs dhs [9; 12; 15; 36; 42; 48; 81] in let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); List.iter send_x [1; 2; 3; 4; 5; 6; 7; 8; 9]; List.iter empty [assert_s; assert_hs; !assert_ds; !assert_dhs]; keep_eref create_dyn -let test_fix () = - let x, send_x = E.create () in +let test_fix () = + let x, send_x = E.create () in let c1 () = E.stamp x `C2 in let c2 () = E.stamp x `C1 in - let loop result = + let loop result = let switch = function `C1 -> c1 () | `C2 -> c2 () in let switcher = E.switch (c1 ()) (E.map switch result) in switcher, switcher @@ -330,23 +330,80 @@ let l = E.fix loop in let assert_l = occs l [`C2; `C1; `C2] in let assert_dl = assert_e_stub () in - let dyn () = - let dl = E.fix loop in + let dyn () = + let dl = E.fix loop in assert_dl := occs dl [`C2; `C1]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in Gc.full_major (); List.iter send_x [1; 2; 3]; List.iter empty [assert_l; !assert_dl]; keep_eref create_dyn -let test_events () = +let test_lifts () = + let x1, send_x1 = E.create () in + let x2, send_x2 = E.create () in + let x3, send_x3 = E.create () in + let x4, send_x4 = E.create () in + let x5, send_x5 = E.create () in + let x6, send_x6 = E.create () in + let f1 a = 1 + a in + let f2 a0 a1 = a0 + a1 in + let f3 a0 a1 a2 = a0 + a1 + a2 in + let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in + let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in + let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in + let v1 = E.l1 f1 x1 in + let v2 = E.l2 f2 x1 x2 in + let v3 = E.l3 f3 x1 x2 x3 in + let v4 = E.l4 f4 x1 x2 x3 x4 in + let v5 = E.l5 f5 x1 x2 x3 x4 x5 in + let v6 = E.l6 f6 x1 x2 x3 x4 x5 x6 in + let a_v1 = occs v1 [2; 2; 2; 2; 2; 2;] in + let a_v2 = occs v2 [ 3; 3; 3; 3; 3;] in + let a_v3 = occs v3 [ 6; 6; 6; 6;] in + let a_v4 = occs v4 [ 10;10;10;] in + let a_v5 = occs v5 [ 15;15;] in + let a_v6 = occs v6 [ 21;] in + let with_step f = + let s = Step.create () in + f s; Step.execute s + in + let s1 s = send_x1 ~step:s 1 in + let s2 s = s1 s; send_x2 ~step:s 2 in + let s3 s = s2 s; send_x3 ~step:s 3 in + let s4 s = s3 s; send_x4 ~step:s 4 in + let s5 s = s4 s; send_x5 ~step:s 5 in + let s6 s = s5 s; send_x6 ~step:s 6 in + with_step s1; with_step s2; with_step s3; + with_step s4; with_step s5; with_step s6; + List.iter empty [ a_v1; a_v2; a_v3; a_v4; a_v5; a_v6;]; + () + +let test_option () = + let x, send_x = E.create () in + let s, set_s = S.create 4 in + let some = E.Option.some (S.changes s) in + let e0 = E.Option.value x in + let e1 = E.Option.value ~default:(S.const 2) x in + let e2 = E.Option.value ~default:s x in + let assert_some = occs some [ Some 42;] in + let assert_e0 = occs e0 [1; 5; ] in + let assert_e1 = occs e1 [1; 2; 5; 2] in + let assert_e2 = occs e2 [1; 4; 5; 42] in + send_x (Some 1); send_x None; set_s 42; + send_x (Some 5); send_x None; + empty assert_some; + List.iter empty [ assert_e0; assert_e1; assert_e2]; + () + +let test_events () = test_no_leak (); test_once_drop_once (); test_app (); test_map_stamp_filter_fmap (); test_diff_changes (); - test_when (); + test_on (); test_dismiss (); test_until (); test_accum (); @@ -354,35 +411,38 @@ test_select (); test_merge (); test_switch (); - test_fix () + test_fix (); + test_lifts (); + test_option (); + () (* Signal tests *) -let test_no_leak () = - let x, set_x = S.create 0 in +let test_no_leak () = + let x, set_x = S.create 0 in let count = ref 0 in - let w = - let w = Weak.create 1 in - let e = S.map (fun x -> incr count) x in + let w = + let w = Weak.create 1 in + let e = S.map (fun x -> incr count) x in Weak.set w 0 (Some e); w in List.iter set_x [ 0; 1; 2]; - Gc.full_major (); + Gc.full_major (); List.iter set_x [ 3; 4; 5]; (match Weak.get w 0 with None -> () | Some _ -> assert false); if !count > 3 then assert false else () -let test_hold () = +let test_hold () = let e, send_e = E.create () in let e', send_e' = E.create () in let he = high_e e in - let s = S.hold 1 e in + let s = S.hold 1 e in let assert_s = vals s [1; 2; 3; 4] in let assert_ds = assert_s_stub 0 in let assert_dhs = assert_s_stub 0 in - let assert_ds' = assert_s_stub 0 in - let dyn () = + let assert_ds' = assert_s_stub 0 in + let dyn () = let ds = S.hold 42 e in (* init value unused. *) let dhs = S.hold 44 he in (* init value unused. *) let ds' = S.hold 128 e' in (* init value used. *) @@ -395,20 +455,20 @@ List.iter send_e [ 1; 1; 1; 1; 2; 2; 2; 3; 3; 3]; List.iter send_e' [2; 4]; List.iter send_e [4; 4; 4]; - List.iter empty [assert_s; !assert_ds; !assert_dhs; !assert_ds']; + List.iter empty [assert_s; !assert_ds; !assert_dhs; !assert_ds']; keep_sref create_dyn -let test_app () = - let f x y = x + y in - let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y in +let test_app () = + let f x y = x + y in + let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y in let x, set_x = S.create 0 in let y, set_y = S.create 0 in - let z = fl x y in + let z = fl x y in let assert_z = vals z [ 0; 1; 3; 4 ] in let assert_dz = assert_s_stub 0 in let assert_dhz = assert_s_stub 0 in - let dyn () = - let dz = fl x y in + let dyn () = + let dz = fl x y in let dhz = fl (high_s x) (high_s y) in assert_dz := vals dz [3; 4]; assert_dhz := vals dhz [3; 4]; @@ -419,13 +479,13 @@ List.iter empty [assert_z; !assert_dz; !assert_dhz]; keep_sref create_dyn -let test_map_filter_fmap () = - let even x = x mod 2 = 0 in +let test_map_filter_fmap () = + let even x = x mod 2 = 0 in let odd x = x mod 2 <> 0 in let meven x = if even x then Some (x * 2) else None in let modd x = if odd x then Some (x * 2) else None in let double x = 2 * x in - let x, set_x = S.create 1 in + let x, set_x = S.create 1 in let x2 = S.map double x in let fe = S.filter even 56 x in let fo = S.filter odd 56 x in @@ -438,7 +498,7 @@ let assert_fmo = vals fmo [ 2; 6; 10;] in let assert_dx2 = assert_s_stub 0 in let assert_dhx2 = assert_s_stub 0 in - let assert_dfe = assert_s_stub 0 in + let assert_dfe = assert_s_stub 0 in let assert_dhfe = assert_s_stub 0 in let assert_dfo = assert_s_stub 0 in let assert_dhfo = assert_s_stub 0 in @@ -447,7 +507,7 @@ let assert_dfmo = assert_s_stub 0 in let assert_dhfmo = assert_s_stub 0 in let dyn () = - let dx2 = S.map double x in + let dx2 = S.map double x in let dhx2 = S.map double (high_s x) in let dfe = S.filter even 56 x in let dhfe = S.filter even 56 (high_s x) in @@ -471,26 +531,26 @@ in let create_dyn = S.map (fun v -> if v = 3 then dyn ()) x in Gc.full_major (); - List.iter set_x [ 1; 2; 3; 4; 4; 5; 5]; + List.iter set_x [ 1; 2; 3; 4; 4; 5; 5]; List.iter empty [assert_x2; assert_fe; assert_fo; assert_fme; - assert_fmo; !assert_dx2; !assert_dhx2; !assert_dfe; - !assert_dhfe; !assert_dfo ; !assert_dhfo; !assert_dfme ; - !assert_dhfme ; !assert_dfmo ; !assert_dhfmo ]; + assert_fmo; !assert_dx2; !assert_dhx2; !assert_dfe; + !assert_dhfe; !assert_dfo ; !assert_dhfo; !assert_dfme ; + !assert_dhfme ; !assert_dfmo ; !assert_dhfmo ]; keep_sref create_dyn -let test_diff_changes () = +let test_diff_changes () = let e, send_e = E.create () in let s = S.hold 1 e in - let d = S.diff (fun x y -> x - y) s in + let d = S.diff (fun x y -> x - y) s in let c = S.changes s in let assert_dd = assert_e_stub () in let assert_dhd = assert_e_stub () in let assert_dc = assert_e_stub () in let assert_dhc = assert_e_stub () in - let dyn () = - let dd = S.diff (fun x y -> x - y) s in - let dhd = S.diff (fun x y -> x - y) (high_s s) in + let dyn () = + let dd = S.diff (fun x y -> x - y) s in + let dhd = S.diff (fun x y -> x - y) (high_s s) in let dc = S.changes s in let dhc = S.changes (high_s s) in assert_dd := occs dd [1]; @@ -502,22 +562,22 @@ let assert_d = occs d [2; 1] in let assert_c = occs c [3; 4] in Gc.full_major (); - List.iter send_e [1; 1; 3; 3; 4; 4]; + List.iter send_e [1; 1; 3; 3; 4; 4]; List.iter empty [assert_d; assert_c; !assert_dd; !assert_dhd; !assert_dc; - !assert_dhc]; + !assert_dhc]; keep_sref create_dyn -let test_sample () = +let test_sample () = let pair v v' = v, v' in - let e, send_e = E.create () in - let sampler () = E.filter (fun x -> x mod 2 = 0) e in - let s = S.hold 0 e in + let e, send_e = E.create () in + let sampler () = E.filter (fun x -> x mod 2 = 0) e in + let s = S.hold 0 e in let sam = S.sample pair (sampler ()) s in let ovals = [ (2, 2); (2, 2); (4, 4); (4, 4)] in let assert_sam = occs sam ovals in let assert_dsam = assert_e_stub () in let assert_dhsam = assert_e_stub () in - let dyn () = + let dyn () = let dsam = S.sample pair (sampler ()) s in let dhsam = S.sample pair (high_e (sampler ())) (high_s s) in assert_dsam := occs dsam ovals; @@ -529,23 +589,23 @@ List.iter empty [assert_sam; !assert_dsam; !assert_dhsam]; keep_sref create_dyn -let test_when () = - let s, set_s = S.create 0 in - let ce = S.map (fun x -> x mod 2 = 0) s in +let test_on () = + let s, set_s = S.create 0 in + let ce = S.map (fun x -> x mod 2 = 0) s in let co = S.map (fun x -> x mod 2 <> 0) s in - let se = S.when_ ce 42 s in - let so = S.when_ co 56 s in + let se = S.on ce 42 s in + let so = S.on co 56 s in let assert_se = vals se [ 0; 2; 4; 6; 4 ] in let assert_so = vals so [ 56; 1; 3; 1; 3 ] in let assert_dse = assert_s_stub 0 in let assert_dhse = assert_s_stub 0 in let assert_dso = assert_s_stub 0 in let assert_dhso = assert_s_stub 0 in - let dyn () = - let dse = S.when_ ce 42 s in - let dhse = S.when_ ce 42 (high_s s) in - let dso = S.when_ co 56 s in - let dhso = S.when_ co 56 (high_s s) in + let dyn () = + let dse = S.on ce 42 s in + let dhse = S.on ce 42 (high_s s) in + let dso = S.on co 56 s in + let dhso = S.on co 56 (high_s s) in assert_dse := vals dse [6; 4]; assert_dhse := vals dhse [6; 4]; assert_dso := vals dso [56; 1; 3]; @@ -555,55 +615,55 @@ Gc.full_major (); List.iter set_s [ 1; 3; 1; 2; 4; 4; 6; 1; 3; 4 ]; List.iter empty [assert_se; assert_so; !assert_dse; !assert_dhse; - !assert_dso; !assert_dhso]; + !assert_dso; !assert_dhso]; keep_sref create_dyn -let test_dismiss () = - let x, send_x = E.create () in - let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in - let z = S.dismiss y 4 (S.hold 44 x) in +let test_dismiss () = + let x, send_x = E.create () in + let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in + let z = S.dismiss y 4 (S.hold 44 x) in let assert_z = vals z [44; 1; 3; 5] in - let assert_dz = assert_s_stub 0 in - let dyn () = - let dz = S.dismiss y 4 (S.hold 44 x) in + let assert_dz = assert_s_stub 0 in + let dyn () = + let dz = S.dismiss y 4 (S.hold 44 x) in assert_dz := vals dz [4; 3; 5]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3; 4; 5]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_accum () = - let f, send_f = E.create () in - let a = S.accum f 0 in +let test_accum () = + let f, send_f = E.create () in + let a = S.accum f 0 in let assert_a = vals a [ 0; 2; -1; -2] in - let assert_da = assert_s_stub 0 in - let assert_dha = assert_s_stub 0 in - let dyn () = + let assert_da = assert_s_stub 0 in + let assert_dha = assert_s_stub 0 in + let dyn () = let da = S.accum f 3 in - let dha = S.accum (high_e f) 3 in + let dha = S.accum (high_e f) 3 in assert_da := vals da [-2; -4]; assert_dha := vals dha [-2; -4] in let create_dyn = - let count = ref 0 in + let count = ref 0 in E.map (fun _ -> incr count; if !count = 2 then dyn()) f in Gc.full_major (); List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; List.iter empty [assert_a; !assert_da; !assert_dha]; keep_eref create_dyn - -let test_fold () = - let x, send_x = E.create () in - let c = S.fold ( + ) 0 x in - let assert_c = vals c [ 0; 1; 3; 6; 10] in + +let test_fold () = + let x, send_x = E.create () in + let c = S.fold ( + ) 0 x in + let assert_c = vals c [ 0; 1; 3; 6; 10] in let assert_dc = assert_s_stub 0 in let assert_dhc = assert_s_stub 0 in - let dyn () = - let dc = S.fold ( + ) 2 x in - let dhc = S.fold ( + ) 2 (high_e x) in + let dyn () = + let dc = S.fold ( + ) 2 x in + let dhc = S.fold ( + ) 2 (high_e x) in assert_dc := vals dc [4; 7; 11]; assert_dhc := vals dhc [4; 7; 11] in @@ -611,18 +671,18 @@ Gc.full_major (); List.iter send_x [1; 2; 3; 4]; List.iter empty [assert_c; !assert_dc; !assert_dhc ]; - keep_eref create_dyn + keep_eref create_dyn -let test_merge () = +let test_merge () = let cons acc v = v :: acc in let w, set_w = S.create 0 in - let x, set_x = S.create 1 in + let x, set_x = S.create 1 in let y = S.map succ w in let z = S.map List.rev (S.merge cons [] [w; x; y]) in let assert_z = vals z [[0; 1; 1]; [1; 1; 2]; [1; 4; 2]; [2; 4; 3]] in let assert_dz = assert_s_stub [] in let assert_dhz = assert_s_stub [] in - let dyn () = + let dyn () = let dz = S.map List.rev (S.merge cons [] [w; x; y]) in let dhz = S.map List.rev (S.merge cons [] [(high_s w); x; y; S.const 2]) in assert_dz := vals dz [[1; 4; 2]; [2; 4; 3]]; @@ -634,119 +694,242 @@ List.iter empty [assert_z; !assert_dz; !assert_dhz]; keep_sref create_dyn +let esswitch s es = (* Pre 1.0.0 S.switch *) + S.switch (S.hold ~eq:( == ) s es) + let test_switch () = - let x, send_x = E.create () in + let s, set_s = S.create 0 in + let switch s = + let map v = + if v mod 3 = 0 && v <> 0 then Some (S.map (( * ) v) s) else None + in + S.fmap ~eq:( == ) map s s + in + let sw = S.switch (switch s) in + let hsw = S.switch (switch (high_s s)) in + let assert_sw = vals sw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in + let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in + let assert_dsw = assert_s_stub 0 in + let assert_dhsw = assert_s_stub 0 in + let dyn () = + let dsw = S.switch (switch s) in + let dhsw = S.switch (switch (high_s s)) in + assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; + assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; + in + let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in + Gc.full_major (); + List.iter set_s [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; + List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; + keep_sref create_dyn + +let test_esswitch () = + let x, send_x = E.create () in let s = S.hold 0 x in - let switch s = + let switch s = E.fmap (fun v -> if v mod 3 = 0 then Some (S.map (( * ) v) s) else None) x in - let sw = S.switch s (switch s) in - let hsw = S.switch s (switch (high_s s)) in + let sw = esswitch s (switch s) in + let hsw = esswitch s (switch (high_s s)) in let assert_sw = vals sw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_dsw = assert_s_stub 0 in let assert_dhsw = assert_s_stub 0 in - let dyn () = - let dsw = S.switch s (switch s) in - let dhsw = S.switch s (switch (high_s s)) in + let dyn () = + let dsw = esswitch s (switch s) in + let dhsw = esswitch s (switch (high_s s)) in assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; in - let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in Gc.full_major (); List.iter send_x [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; - List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw]; + List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; keep_eref create_dyn -let test_switch_const () = - let x, send_x = E.create () in +let test_switch_const () = + let s, set_s = S.create 0 in + let switch = S.map (fun x -> S.const x) s in + let sw = S.switch switch in + let assert_sw = vals sw [0; 1; 2; 3] in + let assert_dsw = assert_s_stub 0 in + let dyn () = + let dsw = S.switch switch in + assert_dsw := vals dsw [2; 3]; + in + let create_dyn = S.map (fun v -> if v = 2 then dyn ()) s in + Gc.full_major (); + List.iter set_s [0; 1; 2; 3]; + List.iter empty [assert_sw; !assert_dsw ]; + keep_sref create_dyn + +let test_esswitch_const () = + let x, send_x = E.create () in let switch = E.map (fun x -> S.const x) x in - let sw = S.switch (S.const 0) switch in + let sw = esswitch (S.const 0) switch in let assert_sw = vals sw [0; 1; 2; 3] in - let assert_dsw = assert_s_stub 0 in - let dyn () = - let dsw = S.switch (S.const 0) switch in + let assert_dsw = assert_s_stub 0 in + let dyn () = + let dsw = esswitch (S.const 0) switch in assert_dsw := vals dsw [2; 3]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3]; List.iter empty [assert_sw; !assert_dsw ]; keep_eref create_dyn - -let test_switch1 () = (* dynamic creation depends on triggering prim. *) + +let test_switch1 () = (* dynamic creation depends on triggering prim. *) + let x, set_x = S.create 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = + let d = S.map (fun x -> v * x) x in + begin match !dcount with + | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] + | 1 -> assert_d2 := vals d [36; 42; 48; 54] + | 2 -> assert_d3 := vals d [81] + | _ -> assert false + end; + incr dcount; + d + in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change x x) in + let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in + Gc.full_major (); + List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; + List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] + +let test_esswitch1 () = let ex, send_x = E.create () in let x = S.hold 0 ex in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = S.switch x (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch x (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter send_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] let test_switch2 () = (* test_switch1 + high rank. *) + let x, set_x = S.create 0 in + let high_x = high_s x in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = + let d = S.map (fun x -> v * x) high_x in + begin match !dcount with + | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] + | 1 -> assert_d2 := vals d [36; 42; 48; 54] + | 2 -> assert_d3 := vals d [81] + | _ -> assert false + end; + incr dcount; + d + in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change x x) in + let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in + Gc.full_major (); + List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; + List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] + +let test_esswitch2 () = (* test_esswitch1 + high rank. *) let ex, send_x = E.create () in - let x = S.hold 0 ex in + let x = S.hold 0 ex in let high_x = high_s x in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) high_x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = S.switch x (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch x (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter send_x [1; 1; 2; 2; 3; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] -let test_switch3 () = (* dynamic creation does not depend on triggering prim. *) - let ex, send_x = E.create () in +let test_switch3 () = (* dynamic creation does not depend on triggering + prim. *) + let x, set_x = S.create 0 in + let y, set_y = S.create 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = + let d = S.map (fun y -> v * y) y in + begin match !dcount with + | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] + | 1 -> assert_d2 := vals d [12; 6; 12] + | 2 -> assert_d3 := vals d [18] + | _ -> assert false + end; + incr dcount; + d + in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change y x) in + let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in + Gc.full_major (); + List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; + List.iter set_y [1; 1; 2; 2]; List.iter set_x [4; 4; 5; 5; 6; 6]; + List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; + List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] + +let test_esswitch3 () = (* dynamic creation does not depend on triggering + prim. *) + let ex, send_x = E.create () in let ey, send_y = E.create () in let x = S.hold 0 ex in let y = S.hold 0 ey in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in let assert_d2 = assert_s_stub 0 in let assert_d3 = assert_s_stub 0 in - let dyn v = + let dyn v = let d = S.map (fun y -> v * y) y in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = S.switch y (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch y (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); List.iter send_y [1; 1; 2; 2]; List.iter send_x [1; 1; 2; 2; 3; 3]; @@ -755,27 +938,54 @@ List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] let test_switch4 () = (* test_switch3 + high rank. *) - let ex, set_x = E.create () in + let x, set_x = S.create 0 in + let y, set_y = S.create 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = + let d = S.map (fun y -> v * y) (high_s y) in + begin match !dcount with + | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] + | 1 -> assert_d2 := vals d [12; 6; 12] + | 2 -> assert_d3 := vals d [18] + | _ -> assert false + end; + incr dcount; + d + in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change y x) in + let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in + Gc.full_major (); + List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; + List.iter set_y [1; 1; 2; 2]; List.iter set_x [4; 4; 5; 5; 6; 6]; + List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; + List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] + +let test_esswitch4 () = (* test_esswitch3 + high rank. *) + let ex, set_x = E.create () in let ey, set_y = E.create () in let x = S.hold 0 ex in let y = S.hold 0 ey in - let dcount = ref 0 in + let dcount = ref 0 in let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun y -> v * y) (high_s y) in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = S.switch y (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch y (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); List.iter set_y [1; 1; 2; 2]; List.iter set_x [1; 1; 2; 2; 3; 3]; @@ -783,69 +993,123 @@ List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] +let test_bind () = + let e, set_e = E.create () in + let a = S.hold 0 e in + let b = S.hold 1 e in + let s, set_s = S.create true in + let next = function + | true -> b + | false -> a + in + let f = S.bind s next in + let assert_bind = vals f [1; 0; 3;] in + set_s false; + set_e 3; + set_s true; + List.iter empty [assert_bind] + +let test_dyn_bind () = (* i.e. dyn switch *) + let s1, set_s1 = S.create true in + let s2, set_s2 = S.create 1 in + let bind1 = function + | true -> + let bind2 = function + | true -> s2 + | false -> S.const 2 + in + S.bind s1 bind2 + | false -> S.const 2 + in + let s = S.bind s1 bind1 in + let assert_bind = vals s [1; 2; 1 ] in + set_s1 true; + set_s1 false; + set_s1 true; + List.iter empty [assert_bind] + +let test_dyn_bind2 () = (* i.e. dyn switch *) + let s1, set_s1 = S.create true in + let s2, set_s2 = S.create true in + let bind1 = function + | true -> + let bind2 = function + | true -> (S.map (fun _ -> 3) s1) + | false -> S.const 2 + in + S.bind s2 bind2 + | false -> S.const 2 + in + let s = S.bind s1 bind1 in + let assert_bind = vals s [3; 2; 3 ] in + set_s1 true; + set_s1 false; + set_s1 true; + List.iter empty [assert_bind] + let test_fix () = let s, set_s = S.create 0 in - let history s = - let push v = function - | v' :: _ as l -> if v = v' then l else v :: l + let history s = + let push v = function + | v' :: _ as l -> if v = v' then l else v :: l | [] -> [ v ] in - let define h = - let h' = S.l2 push s h in + let define h = + let h' = S.l2 push s h in h', (h', S.map (fun x -> x) h) in - S.fix [] define + S.fix [] define in - let h, hm = history s in + let h, hm = history s in let assert_h = vals h [[0]; [1; 0;]; [2; 1; 0;]; [3; 2; 1; 0;]] in let assert_hm = vals hm [[0]; [1; 0;]; [2; 1; 0]; [3; 2; 1; 0;]] in - let assert_dh = assert_s_stub [] in - let assert_dhm = assert_s_stub [] in - let assert_dhh = assert_s_stub [] in - let assert_dhhm = assert_s_stub [] in + let assert_dh = assert_s_stub [] in + let assert_dhm = assert_s_stub [] in + let assert_dhh = assert_s_stub [] in + let assert_dhhm = assert_s_stub [] in let dyn () = - let dh, dhm = history s in + let dh, dhm = history s in let dhh, dhhm = history (high_s s) in assert_dh := vals dh [[1]; [2; 1]; [3; 2; 1]]; - assert_dhm := vals dhm [[]; [1]; [2; 1]; [3; 2; 1]]; + assert_dhm := vals dhm [[]; [1]; [2; 1]; [3; 2; 1]]; assert_dhh := vals dhh [[1]; [2; 1]; [3; 2; 1]]; assert_dhhm := vals dhhm [[]; [1]; [2; 1]; [3; 2; 1]]; in let create_dyn = S.map (fun v -> if v = 1 then dyn ()) s in Gc.full_major (); List.iter set_s [0; 1; 1; 2; 3]; - List.iter empty [assert_h; assert_hm; !assert_dh; !assert_dhm; - !assert_dhh; !assert_dhhm]; + List.iter empty [assert_h; assert_hm; !assert_dh; !assert_dhm; + !assert_dhh; !assert_dhhm]; keep_sref create_dyn -let test_fix' () = +let test_fix' () = let s, set_s = S.create 0 in let f, set_f = S.create 3 in let hs = high_s s in - let assert_cs = assert_s_stub 0 in - let assert_chs = assert_s_stub 0 in - let assert_cdhs = assert_s_stub 0 in - let assert_ss = assert_s_stub 0 in - let assert_shs = assert_s_stub 0 in - let assert_sdhs = assert_s_stub 0 in - let assert_fs = assert_s_stub 0 in - let assert_fhs = assert_s_stub 0 in - let assert_fdhs = assert_s_stub 0 in - let dyn () = + let assert_cs = assert_s_stub 0 in + let assert_chs = assert_s_stub 0 in + let assert_cdhs = assert_s_stub 0 in + let assert_ss = assert_s_stub 0 in + let assert_shs = assert_s_stub 0 in + let assert_sdhs = assert_s_stub 0 in + let assert_fs = assert_s_stub 0 in + let assert_fhs = assert_s_stub 0 in + let assert_fdhs = assert_s_stub 0 in + let dyn () = let cs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h s) in - let chs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h hs) in + let chs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h hs) in let cdhs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h (high_s s)) in let ss = S.fix 0 (fun h -> s, S.Int.( + ) h s) in - let shs = S.fix 0 (fun h -> s, S.Int.( + ) h hs) in + let shs = S.fix 0 (fun h -> s, S.Int.( + ) h hs) in let sdhs = S.fix 0 (fun h -> s, S.Int.( + ) h (high_s s)) in let fs = S.fix 0 (fun h -> f, S.Int.( + ) h s) in - let fhs = S.fix 0 (fun h -> f, S.Int.( + ) h hs) in + let fhs = S.fix 0 (fun h -> f, S.Int.( + ) h hs) in let fdhs = S.fix 0 (fun h -> f, S.Int.( + ) h (high_s s)) in let cs_vals = [1; 3; 4; 5; ] in assert_cs := vals cs cs_vals; assert_chs := vals chs cs_vals; assert_cdhs := vals cdhs cs_vals; - let ss_vals = [1; 2; 3; 4; 5; 6] in + let ss_vals = [1; 2; 3; 4; 5; 6] in assert_ss := vals ss ss_vals; assert_shs := vals shs ss_vals; assert_sdhs := vals sdhs ss_vals; @@ -859,25 +1123,25 @@ List.iter set_s [0; 1; 1; 2; 3]; List.iter set_f [1]; List.iter empty [!assert_cs; !assert_chs; !assert_cdhs; - !assert_ss; !assert_shs; !assert_sdhs; + !assert_ss; !assert_shs; !assert_sdhs; !assert_fs; !assert_fhs; !assert_fdhs]; keep_sref create_dyn -let test_lifters () = - let f1 a = 1 + a in - let f2 a0 a1 = a0 + a1 in - let f3 a0 a1 a2 = a0 + a1 + a2 in - let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in - let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in - let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in - let x, set_x = S.create 0 in +let test_lifters () = + let f1 a = 1 + a in + let f2 a0 a1 = a0 + a1 in + let f3 a0 a1 a2 = a0 + a1 + a2 in + let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in + let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in + let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in + let x, set_x = S.create 0 in let x1 = S.l1 f1 x in let x2 = S.l2 f2 x x1 in - let x3 = S.l3 f3 x x1 x2 in - let x4 = S.l4 f4 x x1 x2 x3 in - let x5 = S.l5 f5 x x1 x2 x3 x4 in - let x6 = S.l6 f6 x x1 x2 x3 x4 x5 in - let a_x1 = vals x1 [1; 2] in + let x3 = S.l3 f3 x x1 x2 in + let x4 = S.l4 f4 x x1 x2 x3 in + let x5 = S.l5 f5 x x1 x2 x3 x4 in + let x6 = S.l6 f6 x x1 x2 x3 x4 x5 in + let a_x1 = vals x1 [1; 2] in let a_x2 = vals x2 [1; 3] in let a_x3 = vals x3 [2; 6] in let a_x4 = vals x4 [4; 12] in @@ -892,8 +1156,8 @@ let dyn () = let dx1 = S.l1 f1 x in let dx2 = S.l2 f2 x x1 in - let dx3 = S.l3 f3 x x1 x2 in - let dx4 = S.l4 f4 x x1 x2 x3 in + let dx3 = S.l3 f3 x x1 x2 in + let dx4 = S.l4 f4 x x1 x2 x3 in let dx5 = S.l5 f5 x x1 x2 x3 x4 in let dx6 = S.l6 f6 x x1 x2 x3 x4 x5 in a_dx1 := vals dx1 [2]; @@ -903,34 +1167,190 @@ a_dx5 := vals dx5 [24]; a_dx6 := vals dx6 [48] in - let create_dyn = S.map (fun v -> if v = 1 then dyn ()) x in + let create_dyn = S.map (fun v -> if v = 1 then dyn ()) x in Gc.full_major (); List.iter set_x [0; 1]; - List.iter empty [ a_x1; a_x2; a_x3; a_x4; a_x5; a_x6; !a_dx1; !a_dx2; !a_dx3; - !a_dx4; !a_dx5; !a_dx6 ]; + List.iter empty [ a_x1; a_x2; a_x3; a_x4; a_x5; a_x6; !a_dx1; !a_dx2; !a_dx3; + !a_dx4; !a_dx5; !a_dx6 ]; keep_sref create_dyn -let test_signals () = +let test_option () = + let b0, set_b0 = S.create None in + let b1, set_b1 = S.create (Some 1) in + let b2 = S.const None in + let b3 = S.const (Some 3) in + let d, set_d = S.create 512 in + let dsome = S.Option.some d in + let s00 = S.Option.value ~default:(`Init (S.const 255)) b0 in + let s01 = S.Option.value ~default:(`Init (S.const 255)) b1 in + let s02 = S.Option.value ~default:(`Init (S.const 255)) b2 in + let s03 = S.Option.value ~default:(`Init (S.const 255)) b3 in + let s10 = S.Option.value ~default:(`Always (S.const 255)) b0 in + let s11 = S.Option.value ~default:(`Always (S.const 255)) b1 in + let s12 = S.Option.value ~default:(`Always (S.const 255)) b2 in + let s13 = S.Option.value ~default:(`Always (S.const 255)) b3 in + let s20 = S.Option.value ~default:(`Init d) b0 in + let s21 = S.Option.value ~default:(`Init d) b1 in + let s22 = S.Option.value ~default:(`Init d) b2 in + let s23 = S.Option.value ~default:(`Init d) b3 in + let s30 = S.Option.value ~default:(`Always d) b0 in + let s31 = S.Option.value ~default:(`Always d) b1 in + let s32 = S.Option.value ~default:(`Always d) b2 in + let s33 = S.Option.value ~default:(`Always d) b3 in + let a_dsome = vals dsome [ Some 512; Some 1024; Some 2048;] in + let a_s00 = vals s00 [255;3] in + let a_s01 = vals s01 [1;] in + let a_s02 = vals s02 [255;] in + let a_s03 = vals s03 [3;] in + let a_s10 = vals s10 [255;3;255] in + let a_s11 = vals s11 [1;255;] in + let a_s12 = vals s12 [255] in + let a_s13 = vals s13 [3] in + let a_s20 = vals s20 [512;3] in + let a_s21 = vals s21 [1;] in + let a_s22 = vals s22 [512] in + let a_s23 = vals s23 [3] in + let a_s30 = vals s30 [512;3;1024;2048] in + let a_s31 = vals s31 [1;512;1024;2048] in + let a_s32 = vals s32 [512] in + let a_s33 = vals s33 [3] in + set_b0 (Some 3); set_b1 None; set_d 1024; set_b0 None; set_d 2048; + empty a_dsome; + List.iter empty [ a_s00; a_s01; a_s02; a_s03; + a_s10; a_s11; a_s12; a_s13; + a_s20; a_s21; a_s22; a_s23; + a_s30; a_s31; a_s32; a_s33; ]; + () + +let test_bool () = + let s, set_s = S.create false in + let a_zedge = occs (S.Bool.(edge zero)) [] in + let a_zrise = occs (S.Bool.(rise zero)) [] in + let a_zfall = occs (S.Bool.(fall zero)) [] in + let a_sedge = occs (S.Bool.edge s) [true; false] in + let a_srise = occs (S.Bool.rise s) [()] in + let a_rfall = occs (S.Bool.fall s) [()] in + let a_flip_never = vals (S.Bool.flip false E.never) [false] in + let a_flip = vals (S.Bool.flip true (S.changes s)) [true; false; true] in + let dyn_flip = S.bind s (fun _ -> S.Bool.flip true (S.changes s)) in + let a_dyn_flip = vals dyn_flip [true; false] in + set_s false; set_s true; set_s true; set_s false; + List.iter empty [a_zedge; a_sedge; ]; + List.iter empty [a_zrise; a_zfall; a_srise; a_rfall ]; + List.iter empty [a_flip_never; a_flip; a_dyn_flip ]; + () + +let test_signals () = test_no_leak (); test_hold (); test_app (); test_map_filter_fmap (); test_diff_changes (); test_sample (); - test_when (); + test_on (); test_dismiss (); test_accum (); test_fold (); test_merge (); test_switch (); + test_esswitch (); + test_switch_const (); + test_esswitch_const (); test_switch_const (); test_switch1 (); + test_esswitch1 (); test_switch2 (); - test_switch3 (); + test_esswitch2 (); + test_switch3 (); + test_esswitch3 (); test_switch4 (); + test_esswitch4 (); + test_bind (); + test_dyn_bind (); + test_dyn_bind2 (); test_fix (); test_fix' (); test_lifters (); + test_option (); + test_bool (); + () + +(* Test steps *) + +let test_executed_raise () = + let e, send = E.create () in + let s, set = S.create 4 in + let step = Step.create () in + Step.execute step; + (try send ~step 3; assert false with Invalid_argument _ -> ()); + (try set ~step 3; assert false with Invalid_argument _ -> ()); + (try Step.execute step; assert false with Invalid_argument _ -> ()); + () + +let test_already_scheduled_raise () = + let e, send = E.create () in + let s, set = S.create 4 in + let step = Step.create () in + let step2 = Step.create () in + send ~step 3; + (try send ~step 3; assert false with Invalid_argument _ -> ()); + (try send ~step:step2 4; assert false with Invalid_argument _ -> ()); + set ~step 5; + set ~step 5; (* doesn't raise because sig value is eq. *) + (try set ~step 6; assert false with Invalid_argument _ -> ()); + (try set ~step:step2 7; assert false with Invalid_argument _ -> ()); + () + +let test_simultaneous () = + let e1, send1 = E.create () in + let e2, send2 = E.create () in + let s1, set1 = S.create 99 in + let s2, set2 = S.create 98 in + let never = E.dismiss e1 e2 in + let assert_never = occs never [] in + let merge = E.merge (fun acc o -> o :: acc) [] [e1; e2] in + let assert_merge = occs merge [[2; 1]] in + let s1_value = S.sample (fun _ sv -> sv) e1 s1 in + let assert_s1_value = occs s1_value [ 3 ] in + let dismiss = S.dismiss e1 1 s1 in + let assert_dismiss = vals dismiss [ 99 ] in + let on = S.on (S.map (( = ) 3) s1) 0 s2 in + let assert_on_ = vals on [0; 4] in + let step = Step.create () in + send1 ~step 1; + send2 ~step 2; + set1 ~step 3; + set2 ~step 4; + Step.execute step; + empty assert_never; + empty assert_merge; + empty assert_s1_value; + empty assert_dismiss; + empty assert_on_; + () + +let test_multistep () = + let e, send = E.create () in + let s, set = S.create 0 in + let assert_e = occs e [1; 2] in + let assert_s = vals s [0; 1; 2] in + let step = Step.create () in + send ~step 1; + set ~step 1; + Step.execute step; + let step = Step.create () in + send ~step 2; + set ~step 2; + Step.execute step; + empty assert_e; + empty assert_s; + () + +let test_steps () = + test_executed_raise (); + test_already_scheduled_raise (); + test_simultaneous (); + test_multistep (); () (* bug fixes *) @@ -940,41 +1360,143 @@ let id x = x in let a, set_a = S.create 0 in (* rank 0 *) let _ = S.map (fun x -> if x = 2 then Gc.full_major ()) a in - let _ = - let a1 = S.map id a in + let _ = + let a1 = S.map id a in (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) (S.l2 (fun x y -> (x + y)) a1 a) (* rank 2 *) in - let _ = + let _ = (S.l2 (fun x y -> (x + y)) a a), (* rank 1 *) (S.l2 (fun x y -> (x + y)) a a) (* rank 1 *) in - let d = S.map id (S.map id (S.map (fun x -> x + 1) a)) in (* rank 3 *) + let d = S.map id (S.map id (S.map (fun x -> x + 1) a)) in (* rank 3 *) let h = S.l2 (fun x y -> x + y) a d in (* rank 4 *) - let a_h = vals h [ 1; 5 ] in + let a_h = vals h [ 1; 5 ] in set_a 2; empty a_h +let test_sswitch_init_rank_bug () = + let enabled, set_enabled = S.create true in +(* let enabled = S.const true *) + let pos, set_pos = S.create () in + let down, send_down = E.create () in + let up, send_up = E.create () in + let hover enabled = match enabled with + | true -> S.map (fun a -> true) pos + | false -> S.Bool.zero + in + let used hover enabled = match enabled with + | true -> + let start = E.stamp (E.on hover down) true in + let stop = E.stamp up false in + let accum = E.select [ start; stop ] in + let s = S.hold false accum in + s + | false -> S.Bool.zero + in + let hover = S.bind enabled hover in + let used = S.switch (S.map ~eq:( == ) (used hover) enabled) in + let activates = S.changes used in + let activates' = (E.map (fun _ -> (fun _ -> ())) activates) in + let actuate = (E.app activates' up) in + let actuate_assert = occs actuate [()] in + send_down (); send_up (); empty actuate_assert + +let test_changes_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.changes changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_diff_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.diff (fun _ _ -> ()) changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_bool_rise_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.Bool.rise changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_misc () = + test_jake_heap_bug (); + test_sswitch_init_rank_bug (); + test_changes_end_of_step_add_bug (); + test_diff_end_of_step_add_bug (); + test_bool_rise_end_of_step_add_bug (); + () -let test_misc () = test_jake_heap_bug () - -let main () = +let main () = test_events (); test_signals (); + test_steps (); test_misc (); print_endline "All tests succeeded." let () = main () (*---------------------------------------------------------------------------- - Copyright (c) 2009-2012 Daniel C. Bünzli + Copyright (c) 2009 Daniel C. Bünzli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. @@ -999,6 +1521,3 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---------------------------------------------------------------------------*) - - - diff -Nru react-0.9.4/test/tests.itarget react-1.2.0/test/tests.itarget --- react-0.9.4/test/tests.itarget 2012-08-05 13:50:48.000000000 +0000 +++ react-1.2.0/test/tests.itarget 2014-08-23 23:03:34.000000000 +0000 @@ -1,3 +1,3 @@ test.native clock.native -breakout.native +breakout.native \ No newline at end of file diff -Nru react-0.9.4/TODO.md react-1.2.0/TODO.md --- react-0.9.4/TODO.md 1970-01-01 00:00:00.000000000 +0000 +++ react-1.2.0/TODO.md 2014-08-23 23:03:34.000000000 +0000 @@ -0,0 +1,52 @@ + +# Exceptions + +* Make steps resistant to exceptions ? There's more than one solution here + one is to discard the step and unschedule all nodes. Another would be + to catch them an trap them like in Fut. + + +# New event combinators + +* E.merge but only on simultanous occs ? +* Review Bool.flip init. +* S.Bool.edge,rise,fall plural ? +* E.Bool.flip + +# Signal init. + +Instead of having bare values why not always have signals ? +This would undermine the temptation of using S.value. + +# Stopped nodes + +Stopped nodes could be detected and considered as constant by +smart constructors. + +# Multisample + +Current combinators are not good for sampling multiple signals, +which is generally useful in conjunction with accum. TODO +maybe not in fact see list selector. Just compute the as a signal. +But maybe not always natural ? + + +# Recursive defs + +Investigate the case when dynamics can replace signals with constants +one which could make a direct dep on the delay noded (and hence +raise). Doesn't seem possible but I suspect I saw this once. + +# New signal combinators. + +To avoid uses of S.value we need better ways to access a +signal's current value and inject it in an efficient +way in the graph. + +```ocaml +S.freeze : 'a signal -> 'a signal +(** [freeze s]_{t} = [s]_{t'} where t' is freeze's creation time. *) +``` + +See if we can return a const and if what happens when used with +bind and/or provide an alternative S.bind for bootstraping.